Compiler/syntax analyzer: Difference between revisions

m
m (→‎{{header|Wren}}: Minor tidy)
 
(12 intermediate revisions by 4 users not shown)
Line 21:
[https://en.wikipedia.org/wiki/Extended_Backus%E2%80%93Naur_Form Extended Backus-Naur Form (EBNF)]:
 
<syntaxhighlight lang="ebnf">
<lang EBNF>
stmt_list = {stmt} ;
 
Line 47:
| '(' expr ')'
| ('+' | '-' | '!') primary
;</langsyntaxhighlight>
 
The resulting AST should be formulated as a Binary Tree.
Line 68:
|-
| style="vertical-align:top" |
<langsyntaxhighlight lang="c">count = 1;
while (count < 10) {
print("count is: ", count, "\n");
count = count + 1;
}</langsyntaxhighlight>
 
| style="vertical-align:top" |
Line 280:
[https://en.wikipedia.org/wiki/Recursive_descent_parser Recursive Descent] for statement parsing. The AST is also built:
 
<langsyntaxhighlight lang="python">def expr(p)
if tok is "("
x = paren_expr()
Line 364:
t = make_node(Sequence, t, stmt())
until tok is end-of-file
return t</langsyntaxhighlight>
 
;Once the AST is built, it should be output in a [[Flatten_a_list|flattened format.]] This can be as simple as the following:
 
<langsyntaxhighlight lang="python">def prt_ast(t)
if t == NULL
print(";\n")
Line 378:
print("\n")
prt_ast(t.left)
prt_ast(t.right)</langsyntaxhighlight>
 
;If the AST is correctly built, loading it into a subsequent program should be as simple as:
 
<langsyntaxhighlight lang="python">def load_ast()
line = readline()
# Each line has at least one token
Line 402:
left = load_ast()
right = load_ast()
return make_node(node_type, left, right)</langsyntaxhighlight>
 
Finally, the AST can also be tested by running it against one of the AST Interpreter [[Compiler/AST_interpreter|solutions]].
Line 415:
|-
| style="vertical-align:top" |
<langsyntaxhighlight lang="c">/*
Simple prime number generator
*/
Line 434:
}
}
print("Total primes found: ", count, "\n");</langsyntaxhighlight>
 
| style="vertical-align:top" |
Line 654:
 
=={{header|ALGOL W}}==
<syntaxhighlight lang ="algolw">begin % syntax analyser %
begin % syntax analyser %
% parse tree nodes %
record node( integer type
Line 952 ⟶ 953:
while begin
if tkType = tString then begin
stmtNode := opNode( nSequence, stmtNode, opNode( nPrts, operandNode( nString, tkIntegerValue ), null ) );
, stmtNode
, opNode( nPrts, operandNode( nString, tkIntegerValue ), null )
);
readToken
end
Line 981 ⟶ 985:
reference(node) listNode;
listNode := null;
while tkType not = terminator and tkType not = tEnd_of_input do listNode := opNode( nSequence, listNode, parseStatement );
and tkType not = tEnd_of_input do listNode := opNode( nSequence, listNode, parseStatement );
listNode
end parseStatementList ;
 
% sets a node code and name %
nIdentifier := 1; ndName( nIdentifier ) := "Identifier"; nString := 2; ndName( nString ) := "String";
procedure setNode ( integer result nd; integer value ndCode; string(14) value name ) ;
nInteger := 3; ndName( nInteger ) := "Integer"; nSequence := 4; ndName( nSequence ) := "Sequence";
nIf begin nd := 5ndCode; ndName( nIf ndCode ) := "If"; nPrtc := 6; ndName( nPrtc ) :=name "Prtc"end;
 
nPrts := 7; ndName( nPrts ) := "Prts"; nPrti := 8; ndName( nPrti ) := "Prti";
setNode( nIdentifier, 1, "Identifier" ); setNode( nString, 2, "String" );
nWhile := 9; ndName( nWhile ) := "While"; nAssign := 10; ndName( nAssign ) := "Assign";
nNegate := 11; ndNamesetNode( nNegatenInteger, ) :=3, "NegateInteger"; ); nNotsetNode( nSequence, 4, "Sequence" := 12); ndNamesetNode( nNotnIf, 5, "If" ) := "Not";
nMultiplysetNode( nPrtc, := 13; ndName( nMultiply6, "Prtc" ) := "Multiply"); setNode( nPrts, nDivide :=7, "Prts" 14; ndName( nDivide ) := "Divide";
nMod := 15; ndNamesetNode( nModnPrti, ) :=8, "ModPrti"; ); nAddsetNode( nWhile, := 16; ndName( nAdd9, "While" ) := "Add";
nSubtractsetNode( nAssign, := 17; ndName( nSubtract10, "Assign" ) := "Subtract"; setNode( nNegate, nLess 11, "Negate" := 18); ndNamesetNode( nLess nNot, 12, "Not" ) := "Less";
nLessEqualsetNode( nMultiply, 13, :="Multiply" 19; ndName( nLessEqual ); setNode( nDivide, ) :=14, "LessEqualDivide" ; nGreater := 20); ndNamesetNode( nGreaternMod, ) :=15, "GreaterMod" );
nGreaterEqualsetNode( nAdd, := 21; ndName( nGreaterEqual ) :=16, "GreaterEqualAdd"; nEqual := 22; ndName( nEqual ); setNode( nSubtract, ) :=17, "EqualSubtract" );
nNotEqual := 23; ndNamesetNode( nNotEqualnLess, ) :=18, "NotEqualLess"; nAnd := 24); ndNamesetNode( nAnd nLessEqual, 19, "LessEqual" ) := "And";
nOr := 25; ndNamesetNode( nOr nGreater, 20, "Greater" ) := "Or";
setNode( nGreaterEqual, 21, "GreaterEqual" ); setNode( nEqual, 22, "Equal" );
setNode( nNotEqual, 23, "NotEqual" ); setNode( nAnd, 24, "And" ); setNode( nOr, 25, "Or" );
tOp_multiply := 1; tkName( tOp_multiply ) := "Op_multiply"; tkPrec( tOp_multiply ) := 5;
tOp_divide := 2; tkName( tOp_divide ) := "Op_divide"; tkPrec( tOp_divide ) := 5;
Line 1,033 ⟶ 1,040:
tkNode( tOp_multiply ) := nMultiply; tkNode( tOp_divide ) := nDivide; tkNode( tOp_mod ) := nMod;
tkNode( tOp_add ) := nAdd; tkNode( tOp_subtract ) := nSubtract; tkNode( tOp_less ) := nLess;
tkNode( tOp_lessequal ) := nLessEqual; tkNode( tOp_greater ) := nGreater; tkNode( tOp_greaterequal ) := nGreaterEqual;
tkNode( tOp_greaterequal ) := nGreaterEqual;
tkNode( tOp_equal ) := nEqual; tkNode( tOp_notequal ) := nNotEqual; tkNode( tOp_not ) := nNot;
tkNode( tOp_and ) := nAnd; tkNode( tOp_or ) := nOr;
Line 1,041 ⟶ 1,049:
readToken;
writeNode( parseStatementList( tEnd_of_input ) )
end.</lang>
</syntaxhighlight>
{{out}}
Output from parsing the Prime Numbers example program.
Line 1,144 ⟶ 1,153:
=={{header|ATS}}==
 
<langsyntaxhighlight ATSlang="ats">(********************************************************************)
(* Usage: parse [INPUTFILE [OUTPUTFILE]]
If INPUTFILE or OUTPUTFILE is "-" or missing, then standard input
Line 2,074 ⟶ 2,083:
end
 
(********************************************************************)</langsyntaxhighlight>
 
 
Line 2,177 ⟶ 2,186:
=={{header|AWK}}==
Tested with gawk 4.1.1 and mawk 1.3.4.
<syntaxhighlight lang="awk">
<lang AWK>
function Token_assign(tk, attr, attr_array, n, i) {
n=split(attr, attr_array)
Line 2,473 ⟶ 2,482:
prt_ast(t)
}
</syntaxhighlight>
</lang>
 
{{out|case=count}}
Line 2,514 ⟶ 2,523:
=={{header|C}}==
Tested with gcc 4.81 and later, compiles warning free with -Wall -Wextra
<langsyntaxhighlight Clang="c">#include <stdio.h>
#include <stdlib.h>
#include <string.h>
Line 2,854 ⟶ 2,863:
init_io(&dest_fp, stdout, "wb", argc > 2 ? argv[2] : "");
prt_ast(parse());
}</langsyntaxhighlight>
 
{{out|case=prime numbers AST}}
Line 2,960 ⟶ 2,969:
Code by Steve Williams. Tested with GnuCOBOL 2.2.
 
<langsyntaxhighlight lang="cobol"> >>SOURCE FORMAT IS FREE
identification division.
*> this code is dedicated to the public domain
Line 3,565 ⟶ 3,574:
.
end program printast.
end program parser.</langsyntaxhighlight>
 
{{out|case=Primes}}
Line 3,664 ⟶ 3,673:
String "\n"
;</pre>
 
=={{header|Common Lisp}}==
{{works with|SBCL|2.2.3}}
{{works with|roswell|21.10.14.111}}
{{libheader|cl-ppcre}}
{{libheader|trivia}}
{{trans|Icon}}
 
 
<syntaxhighlight lang="lisp">#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
(ros:ensure-asdf)
#+quicklisp(ql:quickload '() :silent t))
 
(defpackage :ros.script.parse.3859374047
(:use :cl))
(in-package :ros.script.parse.3859374047)
 
;;;
;;; The Rosetta Code Tiny-Language Parser, in Common Lisp.
;;;
 
(require "cl-ppcre")
(require "trivia")
 
(defstruct tokstruc line-no column-no tok tokval)
 
(defconstant re-blank-line
(ppcre:create-scanner "^\\s*$"))
 
(defconstant re-token-1
(ppcre:create-scanner
"^\\s*(\\d+)\\s+(\\d+)\\s+(\\S+)\\s*$"))
 
(defconstant re-token-2
(ppcre:create-scanner
"^\\s*(\\d+)\\s+(\\d+)\\s+(\\S+)\\s+(\\S(.*\\S)?)\\s*$"))
 
(defun string-to-tok (s)
(trivia:match s
("Keyword_else" 'TOK-ELSE)
("Keyword_if" 'TOK-IF)
("Keyword_print" 'TOK-PRINT)
("Keyword_putc" 'TOK-PUTC)
("Keyword_while" 'TOK-WHILE)
("Op_multiply" 'TOK-MULTIPLY)
("Op_divide" 'TOK-DIVIDE)
("Op_mod" 'TOK-MOD)
("Op_add" 'TOK-ADD)
("Op_subtract" 'TOK-SUBTRACT)
("Op_negate" 'TOK-NEGATE)
("Op_less" 'TOK-LESS)
("Op_lessequal" 'TOK-LESSEQUAL)
("Op_greater" 'TOK-GREATER)
("Op_greaterequal" 'TOK-GREATEREQUAL)
("Op_equal" 'TOK-EQUAL)
("Op_notequal" 'TOK-NOTEQUAL)
("Op_not" 'TOK-NOT)
("Op_assign" 'TOK-ASSIGN)
("Op_and" 'TOK-AND)
("Op_or" 'TOK-OR)
("LeftParen" 'TOK-LEFTPAREN)
("RightParen" 'TOK-RIGHTPAREN)
("LeftBrace" 'TOK-LEFTBRACE)
("RightBrace" 'TOK-RIGHTBRACE)
("Semicolon" 'TOK-SEMICOLON)
("Comma" 'TOK-COMMA)
("Identifier" 'TOK-IDENTIFIER)
("Integer" 'TOK-INTEGER)
("String" 'TOK-STRING)
("End_of_input" 'TOK-END-OF-INPUT)
(_ (warn "unparseable token line")
(uiop:quit 1))))
 
(defun precedence (tok)
(case tok
(TOK-MULTIPLY 13)
(TOK-DIVIDE 13)
(TOK-MOD 13)
(TOK-ADD 12)
(TOK-SUBTRACT 12)
(TOK-NEGATE 14)
(TOK-NOT 14)
(TOK-LESS 10)
(TOK-LESSEQUAL 10)
(TOK-GREATER 10)
(TOK-GREATEREQUAL 10)
(TOK-EQUAL 9)
(TOK-NOTEQUAL 9)
(TOK-AND 5)
(TOK-OR 4)
(otherwise -1)))
 
(defun binary-p (tok)
(case tok
(TOK-ADD t)
(TOK-SUBTRACT t)
(TOK-MULTIPLY t)
(TOK-DIVIDE t)
(TOK-MOD t)
(TOK-LESS t)
(TOK-LESSEQUAL t)
(TOK-GREATER t)
(TOK-GREATEREQUAL t)
(TOK-EQUAL t)
(TOK-NOTEQUAL t)
(TOK-AND t)
(TOK-OR t)
(otherwise nil)))
 
(defun right-associative-p (tok)
(declare (ignorable tok))
nil) ; None of the current operators is right associative.
 
(defun tok-text (tok)
(ecase tok
(TOK-ELSE "else")
(TOK-IF "if")
(TOK-PRINT "print")
(TOK-PUTC "putc")
(TOK-WHILE "while")
(TOK-MULTIPLY "*")
(TOK-DIVIDE "/")
(TOK-MOD "%")
(TOK-ADD "+")
(TOK-SUBTRACT "-")
(TOK-NEGATE "-")
(TOK-LESS "<")
(TOK-LESSEQUAL "<=")
(TOK-GREATER ">")
(TOK-GREATEREQUAL ">=")
(TOK-EQUAL "==")
(TOK-NOTEQUAL "!=")
(TOK-NOT "!")
(TOK-ASSIGN "=")
(TOK-AND "&&")
(TOK-OR "((")
(TOK-LEFTPAREN "(")
(TOK-RIGHTPAREN ")")
(TOK-LEFTBRACE "{")
(TOK-RIGHTBRACE "}")
(TOK-SEMICOLON ";")
(TOK-COMMA ",")
(TOK-IDENTIFIER "Ident")
(TOK-INTEGER "Integer literal")
(TOK-STRING "String literal")
(TOK-END_OF_INPUT "EOI")))
 
(defun operator (tok)
(ecase tok
(TOK-MULTIPLY "Multiply")
(TOK-DIVIDE "Divide")
(TOK-MOD "Mod")
(TOK-ADD "Add")
(TOK-SUBTRACT "Subtract")
(TOK-NEGATE "Negate")
(TOK-NOT "Not")
(TOK-LESS "Less")
(TOK-LESSEQUAL "LessEqual")
(TOK-GREATER "Greater")
(TOK-GREATEREQUAL "GreaterEqual")
(TOK-EQUAL "Equal")
(TOK-NOTEQUAL "NotEqual")
(TOK-AND "And")
(TOK-OR "Or")))
 
(defun join (&rest args)
(apply #'concatenate 'string args))
 
(defun nxt (gettok)
(funcall gettok :nxt))
 
(defun curr (gettok)
(funcall gettok :curr))
 
(defun err (token msg)
(format t "(~A, ~A) error: ~A~%"
(tokstruc-line-no token)
(tokstruc-column-no token)
msg)
(uiop:quit 1))
 
(defun prt-ast (outf ast)
;;
;; For fun, let us do prt-ast *non*-recursively, with a stack and a
;; loop.
;;
(let ((stack `(,ast)))
(loop while stack
do (let ((x (car stack)))
(setf stack (cdr stack))
(cond ((not x) (format outf ";~%"))
((or (string= (car x) "Identifier")
(string= (car x) "Integer")
(string= (car x) "String"))
(format outf "~A ~A~%" (car x) (cadr x)))
(t (format outf "~A~%" (car x))
(setf stack (cons (caddr x) stack))
(setf stack (cons (cadr x) stack))))))))
 
(defun accept (gettok tok)
(if (eq (tokstruc-tok (curr gettok)) tok)
(nxt gettok)
nil))
 
(defun expect (gettok msg tok)
(let ((curr-tok (tokstruc-tok (curr gettok))))
(if (eq curr-tok tok)
(nxt gettok)
(err (curr gettok)
(join msg ": Expecting '"
(tok-text tok) "', found '"
(tok-text curr-tok) "'")))))
 
(defun parse (gettok)
(defun paren-expr (gettok)
(expect gettok "paren_expr" 'TOK-LEFTPAREN)
(let ((x (expr gettok 0)))
(expect gettok "paren_expr" 'TOK-RIGHTPAREN)
x))
 
(defun expr (gettok p)
(let* ((tok (curr gettok))
(x (case (tokstruc-tok tok)
(TOK-LEFTPAREN (paren-expr gettok))
(TOK-SUBTRACT
(nxt gettok)
(let ((y (expr gettok (precedence 'TOK-NEGATE))))
`("Negate" ,y ())))
(TOK-ADD
(nxt gettok)
(expr gettok (precedence 'TOK-NEGATE)))
(TOK-NOT
(nxt gettok)
(let ((y (expr gettok (precedence 'TOK-NOT))))
`("Not" ,y ())))
(TOK-IDENTIFIER
(let ((y `("Identifier" ,(tokstruc-tokval tok))))
(nxt gettok)
y))
(TOK-INTEGER
(let ((y `("Integer" ,(tokstruc-tokval tok))))
(nxt gettok)
y))
(otherwise
(err tok (join "Expecting a primary, found: "
(tok-text (tokstruc-tok tok))))))))
;;
;; Precedence climbing for binary operators.
;;
(loop for tok = (curr gettok)
for toktok = (tokstruc-tok tok)
while (and (binary-p toktok) (<= p (precedence toktok)))
do (progn (nxt gettok)
(let ((q (if (right-associative-p toktok)
(precedence toktok)
(1+ (precedence toktok)))))
(setf x `(,(operator toktok) ,x
,(expr gettok q))))))
x))
 
(defun stmt (gettok)
(cond ((accept gettok 'TOK-IF)
(let* ((e (paren-expr gettok))
(s (stmt gettok))
(x (if (accept gettok 'TOK-ELSE)
`("If" ,s ,(stmt gettok))
`("If" ,s ()))))
`("If" ,e ,x)))
 
((accept gettok 'TOK-PUTC)
(let ((x `("Prtc" ,(paren-expr gettok) ())))
(expect gettok "Putc" 'TOK-SEMICOLON)
x))
 
((accept gettok 'TOK-PRINT)
(expect gettok "Print" 'TOK-LEFTPAREN)
(let ((x '()))
(loop for tok = (curr gettok)
for toktok = (tokstruc-tok tok)
for e = (if (eq toktok 'TOK-STRING)
(let* ((tokval (tokstruc-tokval tok))
(leaf `("String" ,tokval))
(e `("Prts" ,leaf ())))
(nxt gettok)
e)
`("Prti" ,(expr gettok 0) ()))
do (setf x `("Sequence" ,x ,e))
while (accept gettok 'TOK-COMMA))
(expect gettok "Print" 'TOK-RIGHTPAREN)
(expect gettok "Print" 'TOK-SEMICOLON)
x))
 
((eq (tokstruc-tok (curr gettok)) 'TOK-SEMICOLON)
(nxt gettok))
 
((eq (tokstruc-tok (curr gettok)) 'TOK-IDENTIFIER)
(let ((v `("Identifier" ,(tokstruc-tokval (curr gettok)))))
(nxt gettok)
(expect gettok "assign" 'TOK-ASSIGN)
(let ((x `("Assign" ,v ,(expr gettok 0))))
(expect gettok "assign" 'TOK-SEMICOLON)
x)))
 
((accept gettok 'TOK-WHILE)
(let ((e (paren-expr gettok)))
`("While" ,e ,(stmt gettok))))
 
((accept gettok 'TOK-LEFTBRACE)
(let ((x '()))
(loop for tok = (curr gettok)
for toktok = (tokstruc-tok tok)
until (or (eq toktok 'TOK-RIGHTBRACE)
(eq toktok 'TOK-END-OF-INPUT))
do (setf x `("Sequence" ,x ,(stmt gettok))))
(expect gettok "Lbrace" 'TOK-RIGHTBRACE)
x))
 
((eq (tokstruc-tok (curr gettok)) 'TOK-END-OF-INPUT)
'())
 
(t (let* ((tok (curr gettok))
(toktok (tokstruc-tok tok)))
(err tok (join "expecting start of statement, found '"
(tok-text toktok) "'"))))))
 
;;
;; Parsing of the top-level statement sequence.
;;
(let ((x '()))
(nxt gettok)
(loop do (setf x `("Sequence" ,x ,(stmt gettok)))
until (eq (tokstruc-tok (curr gettok)) 'TOK-END-OF-INPUT))
x))
 
(defun string-to-tokstruc (s)
(let ((strings
(nth-value 1 (ppcre:scan-to-strings re-token-1 s))))
(if strings
(make-tokstruc :line-no (elt strings 0)
:column-no (elt strings 1)
:tok (string-to-tok (elt strings 2))
:tokval nil)
(let ((strings
(nth-value 1 (ppcre:scan-to-strings re-token-2 s))))
(if strings
(make-tokstruc :line-no (elt strings 0)
:column-no (elt strings 1)
:tok (string-to-tok (elt strings 2))
:tokval (elt strings 3))
(progn
(warn "unparseable token line")
(uiop:quit 1)))))))
 
(defun read-token-line (inpf)
(loop for line = (read-line inpf nil "End_of_input")
while (ppcre:scan re-blank-line line)
finally (return line)))
 
(defun open-inpf (inpf-filename)
(if (string= inpf-filename "-")
*standard-input*
(open inpf-filename :direction :input)))
 
(defun open-outf (outf-filename)
(if (string= outf-filename "-")
*standard-output*
(open outf-filename :direction :output
:if-exists :overwrite
:if-does-not-exist :create)))
 
(defun usage-error ()
(princ "Usage: parse [INPUTFILE [OUTPUTFILE]]" *standard-output*)
(terpri *standard-output*)
(princ "If either INPUTFILE or OUTPUTFILE is \"-\", the respective"
*standard-output*)
(princ " standard I/O is used." *standard-output*)
(terpri *standard-output*)
(uiop:quit 1))
 
(defun get-filenames (argv)
(trivia:match argv
((list) '("-" "-"))
((list inpf-filename) `(,inpf-filename "-"))
((list inpf-filename outf-filename) `(,inpf-filename
,outf-filename))
(_ (usage-error))))
 
(defun main (&rest argv)
(let* ((filenames (get-filenames argv))
(inpf-filename (car filenames))
(inpf (open-inpf inpf-filename))
(outf-filename (cadr filenames))
(outf (open-outf outf-filename)))
 
(let* ((current-token (list nil))
(gettok-curr (lambda () (elt current-token 0)))
(gettok-nxt (lambda ()
(let* ((s (read-token-line inpf))
(tok (string-to-tokstruc s)))
(setf (elt current-token 0) tok)
tok)))
(gettok (lambda (instruction)
(trivia:match instruction
(:curr (funcall gettok-curr))
(:nxt (funcall gettok-nxt)))))
(ast (parse gettok)))
(prt-ast outf ast))
 
(unless (string= inpf-filename "-")
(close inpf))
(unless (string= outf-filename "-")
(close outf))
 
(uiop:quit 0)))
 
;;; vim: set ft=lisp lisp:</syntaxhighlight>
 
{{out}}
<pre>$ ./parse.ros compiler-tests/primes.lex
Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier count
Integer 1
Assign
Identifier n
Integer 1
Assign
Identifier limit
Integer 100
While
Less
Identifier n
Identifier limit
Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier k
Integer 3
Assign
Identifier p
Integer 1
Assign
Identifier n
Add
Identifier n
Integer 2
While
And
LessEqual
Multiply
Identifier k
Identifier k
Identifier n
Identifier p
Sequence
Sequence
;
Assign
Identifier p
NotEqual
Multiply
Divide
Identifier n
Identifier k
Identifier k
Identifier n
Assign
Identifier k
Add
Identifier k
Integer 2
If
Identifier p
If
Sequence
Sequence
;
Sequence
Sequence
;
Prti
Identifier n
;
Prts
String " is prime\n"
;
Assign
Identifier count
Add
Identifier count
Integer 1
;
Sequence
Sequence
Sequence
;
Prts
String "Total primes found: "
;
Prti
Identifier count
;
Prts
String "\n"
;
quence
Sequence
Sequence
Sequence
;
Assign
Identifier x_x
Divide
Multiply
Identifier x
Identifier x
Integer 200
Assign
Identifier y_y
Divide
Multiply
Identifier y
Identifier y
Integer 200
If
Greater
Add
Identifier x_x
Identifier y_y
Integer 800
If
Sequence
Sequence
Sequence
;
Assign
Identifier the_char
Add
Integer 48
Identifier i
If
Greater
Identifier i
Integer 9
If
Sequence
;
Assign
Identifier the_char
Integer 64
;
Assign
Identifier i
Identifier max_iter
;
Assign
Identifier y
Add
Divide
Multiply
Identifier x
Identifier y
Integer 100
Identifier y0
Assign
Identifier x
Add
Subtract
Identifier x_x
Identifier y_y
Identifier x0
Assign
Identifier i
Add
Identifier i
Integer 1
Prtc
Identifier the_char
;
Assign
Identifier x0
Add
Identifier x0
Identifier x_step
Prtc
Integer 10
;
Assign
Identifier y0
Subtract
Identifier y0
Identifier y_step</pre>
 
 
=={{header|Forth}}==
Tested with Gforth 0.7.3.
<langsyntaxhighlight Forthlang="forth">CREATE BUF 0 , \ single-character look-ahead buffer
: PEEK BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC PEEK 0 BUF ! ;
Line 3,838 ⟶ 4,454:
: -EOI? TOKEN-TYPE End_of_input <> ;
: PARSE $NULL GETTOK BEGIN -EOI? WHILE STMT $SEQUENCE REPEAT ;
PARSE .NODE</langsyntaxhighlight>
 
{{out|case=Count AST}}
Line 3,876 ⟶ 4,492:
</pre>
</b>
 
 
=={{header|Fortran}}==
{{works with|gfortran|11.2.1}}
The following is Fortran 2008/2018 code with C preprocessing directives. If you call the program source ‘parse.F90’, with a capital ‘F’, then gfortran will know to run the C preprocessor.
<langsyntaxhighlight lang="fortran">!!!
!!! An implementation of the Rosetta Code parser task:
!!! https://rosettacode.org/wiki/Compiler/syntax_analyzer
Line 5,427 ⟶ 6,042:
end subroutine print_usage
end program parse</langsyntaxhighlight>
 
{{out}}
Line 5,529 ⟶ 6,144:
=={{header|Go}}==
{{trans|C}}
<langsyntaxhighlight lang="go">package main
 
import (
Line 5,882 ⟶ 6,497:
scanner = bufio.NewScanner(source)
prtAst(parse())
}</langsyntaxhighlight>
 
{{out}}
Line 5,991 ⟶ 6,606:
 
 
<syntaxhighlight lang="icon">#
<lang Icon>#
# The Rosetta Code Tiny-Language Parser, in Icon.
#
Line 6,348 ⟶ 6,963:
}
return s
end</langsyntaxhighlight>
 
{{out}}
Line 6,451 ⟶ 7,066:
Implementation:
 
<langsyntaxhighlight Jlang="j">require'format/printf'
tkref=: tokenize 'End_of_input*/%+--<<=>>===!=!&&||print=print(if{else}while;,putc)a""0'
Line 6,608 ⟶ 7,223:
end.
}}
</syntaxhighlight>
</lang>
 
Some quirks worth noting:
Line 6,624 ⟶ 7,239:
Task example:
 
<syntaxhighlight lang="j">
<lang J>
primes=: {{)n
/*
Line 6,744 ⟶ 7,359:
String "\n"
;
</syntaxhighlight>
</lang>
 
=={{header|Java}}==
Usage: java Parser infile [>outfile]
{{trans|Python}}
<langsyntaxhighlight lang="java">
import java.io.File;
import java.io.FileNotFoundException;
Line 7,101 ⟶ 7,716:
}
}
</syntaxhighlight>
</lang>
 
=={{header|Julia}}==
Julia tends to discourage large numbers of global variables, so this direct port from the Python reference implementation moves the globals into a function wrapper.
{{trans|Python}}
<langsyntaxhighlight lang="julia">struct ASTnode
nodetype::Int
left::Union{Nothing, ASTnode}
Line 7,358 ⟶ 7,973:
 
# syntaxanalyzer(length(ARGS) > 1 ? ARGS[1] : stdin) # for use as in the Python code
</syntaxhighlight>
</lang>
 
=={{header|M2000 Interpreter}}==
Line 7,366 ⟶ 7,981:
 
 
<syntaxhighlight lang="m2000 interpreter">
<lang M2000 Interpreter>
Module syntax_analyzer(b$){
enum tokens {
Line 7,739 ⟶ 8,354:
43 1 End_of_Input
}
</syntaxhighlight>
</lang>
 
{{out}}
Line 7,919 ⟶ 8,534:
Using the third version of Nim lexer.
 
<langsyntaxhighlight Nimlang="nim">import ast_lexer
 
type NodeKind* = enum
Line 8,167 ⟶ 8,782:
let code = if paramCount() < 1: stdin.readAll() else: paramStr(1).readFile()
let tree = parse(code)
tree.printAst()</langsyntaxhighlight>
 
{{out}}
Line 8,276 ⟶ 8,891:
 
 
<langsyntaxhighlight ObjectIconlang="objecticon"># -*- ObjectIcon -*-
#
# The Rosetta Code Tiny-Language Parser, in Object Icon.
Line 8,632 ⟶ 9,247:
}
return s
end</langsyntaxhighlight>
 
{{out}}
Line 8,736 ⟶ 9,351:
=={{header|Perl}}==
Tested on perl v5.26.1
<langsyntaxhighlight Perllang="perl">#!/usr/bin/perl
 
use strict; # parse.pl - inputs lex, outputs flattened ast
Line 8,809 ⟶ 9,424:
$_[0] <= 0 && /$h Op_or \n/gcx ? "Or\n$ast" . expr(1) :
return $ast while 1;
}</langsyntaxhighlight>
 
{{out|case=Count AST}}
Line 8,843 ⟶ 9,458:
=={{header|Phix}}==
Reusing lex.e (and core.e) from the [[Compiler/lexical_analyzer#Phix|Lexical Analyzer task]], and again written as a reusable module.
<!--<langsyntaxhighlight Phixlang="phix">(phixonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\parse.e
Line 8,996 ⟶ 9,611:
<span style="color: #008080;">return</span> <span style="color: #000000;">t</span>
<span style="color: #008080;">end</span> <span style="color: #008080;">function</span>
<!--</langsyntaxhighlight>-->
And a simple test driver for the specific task:
<!--<langsyntaxhighlight Phixlang="phix">(phixonline)-->
<span style="color: #000080;font-style:italic;">--
-- demo\rosetta\Compiler\parse.exw
Line 9,057 ⟶ 9,672:
--main({0,0,"primes.c"}) -- as Algol, C, Python (apart from spacing)
--main({0,0,"count.c"}) -- as AWK ( "" )</span>
<!--</langsyntaxhighlight>-->
{{out}}
<pre>
Line 9,066 ⟶ 9,681:
=={{header|Python}}==
Tested with Python 2.7 and 3.x
<langsyntaxhighlight Pythonlang="python">from __future__ import print_function
import sys, shlex, operator
 
Line 9,332 ⟶ 9,947:
error(0, 0, "Can't open %s" % sys.argv[1])
t = parse()
prt_ast(t)</langsyntaxhighlight>
 
{{out|case=prime numbers AST}}
Line 9,434 ⟶ 10,049:
</pre>
</b>
 
=={{header|RATFOR}}==
{{works with|ratfor77|[https://sourceforge.net/p/chemoelectric/ratfor77/ public domain 1.0]}}
{{works with|gfortran|11.2.1}}
{{works with|f2c|20100827}}
 
 
FORTRAN 77 is a non-recursive language, in the specific sense that it does not support recursive algorithms. What is missing is simple: there is no way to specify that a value should go onto a call stack. Local variables were all treated by compilers more or less as what C programmers would call "static". Subprogram parameters were all passed by reference, rather than by value as in C.
 
''However'', it is perfectly possible to implement a recursive language ''in'' FORTRAN 77 and do the programming in ''that''.
 
Which is what I do here. I have implemented the recursive algorithm of the parser pseudocode in a tiny, FORTH-like "language" specific for the task. The parser code, that is, is not written directly in Ratfor, but instead is written in a tiny "language" and interpreted by a Ratfor subroutine.
 
Printing the abstract syntax tree is done with a quite ordinary non-recursive tree traversal written directly in Ratfor.
 
There is no paradox in the notion of doing recursive programming within a Ratfor program by the method described above. All the recursion is at a higher level of abstraction than the Ratfor programming itself. If you examine the Ratfor code ''as'' Ratfor code, there is not a single recursive call.
 
 
<syntaxhighlight lang="ratfor">######################################################################
#
# The Rosetta Code parser in Ratfor 77.
#
#
# Ratfor 77 is a preprocessor for FORTRAN 77; therefore we do not have
# recursive calls available. For printing the flattened tree, I use an
# ordinary non-recursive implementation of the tree traversal. The
# mutually recursive parser itself is more difficult to handle; for
# that, I implement a tiny, FORTH-like token processor that supports
# recursive calls.
#
# How to deal with input is another problem. I use formatted input,
# treating each line as a (regrettably fixed length) array of type
# CHARACTER. It is a very simple method, and leaves the input in a
# form convenient for the necessary processing (given that the input
# is not formatted in columns).
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
# ratfor77 parse-in-ratfor.r > parse-in-ratfor.f
# f2c -C -Nc40 parse-in-ratfor.f
# cc parse-in-ratfor.c -lf2c
# ./a.out < compiler-tests/primes.lex
#
# With gfortran, a little differently:
#
# ratfor77 parse-in-ratfor.r > parse-in-ratfor.f
# gfortran -fcheck=all -std=legacy parse-in-ratfor.f
# ./a.out < compiler-tests/primes.lex
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output.
#
#---------------------------------------------------------------------
 
# Parameters that you can adjust.
 
define(LINESZ, 256) # Size of an input line.
define(STRNSZ, 4096) # Size of the string pool.
define(NODSSZ, 4096) # Size of the nodes pool.
define(DSTKSZ, 4096) # Size of the data stack.
define(PSTKSZ, 4096) # Size of the precedence stack.
define(XSTKSZ, 4096) # Size of the execution stack.
 
#---------------------------------------------------------------------
 
define(TOKSZ, 5) # Size of a lexical token, in integers.
define(ILN, 1) # Index for line number.
define(ICN, 2) # Index for column number.
define(ITK, 3) # Index for token number.
define(ITV, 4) # Index for the string pool index of the token value.
define(ITN, 5) # Index for the length of the token value.
 
define(NODESZ, 3)
define(NTAG, 1) # Index for the tag.
# For an internal node --
define(NLEFT, 2) # Index for the left node.
define(NRIGHT, 3) # Index for the right node.
# For a leaf node --
define(NITV, 2) # Index for the string pool index.
define(NITN, 3) # Length of the value.
 
define(NIL, -1) # Nil node.
 
define(TKELSE, 0)
define(TKIF, 1)
define(TKPRNT, 2)
define(TKPUTC, 3)
define(TKWHIL, 4)
define(TKMUL, 5)
define(TKDIV, 6)
define(TKMOD, 7)
define(TKADD, 8)
define(TKSUB, 9)
define(TKNEG, 10)
define(TKLT, 11)
define(TKLE, 12)
define(TKGT, 13)
define(TKGE, 14)
define(TKEQ, 15)
define(TKNE, 16)
define(TKNOT, 17)
define(TKASGN, 18)
define(TKAND, 19)
define(TKOR, 20)
define(TKLPAR, 21)
define(TKRPAR, 22)
define(TKLBRC, 23)
define(TKRBRC, 24)
define(TKSEMI, 25)
define(TKCMMA, 26)
define(TKID, 27)
define(TKINT, 28)
define(TKSTR, 29)
define(TKEOI, 30)
 
define(NDID, 0)
define(NDSTR, 1)
define(NDINT, 2)
define(NDSEQ, 3)
define(NDIF, 4)
define(NDPRTC, 5)
define(NDPRTS, 6)
define(NDPRTI, 7)
define(NDWHIL, 8)
define(NDASGN, 9)
define(NDNEG, 10)
define(NDNOT, 11)
define(NDMUL, 12)
define(NDDIV, 13)
define(NDMOD, 14)
define(NDADD, 15)
define(NDSUB, 16)
define(NDLT, 17)
define(NDLE, 18)
define(NDGT, 19)
define(NDGE, 20)
define(NDEQ, 21)
define(NDNE, 22)
define(NDAND, 23)
define(NDOR, 24)
 
subroutine string (src, isrc, nsrc, strngs, istrng, i, n)
 
# Store a string in the string pool.
 
implicit none
 
character src(*) # Source string.
integer isrc, nsrc # Index and length of the source substring.
character strngs(STRNSZ) # The string pool.
integer istrng # The string pool's next slot.
integer i, n # Index and length within the string pool.
 
integer j
 
if (STRNSZ < istrng + nsrc)
{
write (*, '(''string pool exhausted'')')
stop
}
for (j = 0; j < nsrc; j = j + 1)
strngs(istrng + j) = src(isrc + j)
i = istrng
n = nsrc
istrng = istrng + nsrc
end
 
subroutine astnod (node, nodes, inodes, i)
 
# Store a node in the nodes pool.
 
implicit none
 
integer node(NODESZ)
integer nodes(NODESZ, NODSSZ)
integer inodes
integer i
 
integer j
 
if (NODSSZ < inodes + 1)
{
write (*, '(''node pool exhausted'')')
stop
}
i = inodes
inodes = inodes + 1
for (j = 1; j <= NODESZ; j = j + 1)
nodes(j, i) = node(j)
end
 
function issp (c)
 
# Is a character a space character?
 
implicit none
 
character c
logical issp
 
integer ic
 
ic = ichar (c)
issp = (ic == 32 || (9 <= ic && ic <= 13))
end
 
function skipsp (str, i, imax)
 
# Skip past spaces in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipsp
 
logical issp
 
logical done
 
skipsp = i
done = .false.
while (!done)
{
if (imax <= skipsp)
done = .true.
else if (!issp (str(skipsp)))
done = .true.
else
skipsp = skipsp + 1
}
end
 
function skipns (str, i, imax)
 
# Skip past non-spaces in a string.
 
implicit none
 
character str(*)
integer i
integer imax
integer skipns
 
logical issp
 
logical done
 
skipns = i
done = .false.
while (!done)
{
if (imax <= skipns)
done = .true.
else if (issp (str(skipns)))
done = .true.
else
skipns = skipns + 1
}
end
 
function trimrt (str, n)
 
# Find the length of a string, if one ignores trailing spaces.
 
implicit none
 
character str(*)
integer n
integer trimrt
 
logical issp
 
logical done
 
trimrt = n
done = .false.
while (!done)
{
if (trimrt == 0)
done = .true.
else if (!issp (str(trimrt)))
done = .true.
else
trimrt = trimrt - 1
}
end
 
function mktok (str, i, n)
 
# Convert a substring to a token integer.
 
implicit none
 
character str(*)
integer i
integer n
integer mktok
 
character*16 tokstr(0:30)
character*16 test
integer j
logical done
 
data tokstr / 'Keyword_else ', _
'Keyword_if ', _
'Keyword_print ', _
'Keyword_putc ', _
'Keyword_while ', _
'Op_multiply ', _
'Op_divide ', _
'Op_mod ', _
'Op_add ', _
'Op_subtract ', _
'Op_negate ', _
'Op_less ', _
'Op_lessequal ', _
'Op_greater ', _
'Op_greaterequal ', _
'Op_equal ', _
'Op_notequal ', _
'Op_not ', _
'Op_assign ', _
'Op_and ', _
'Op_or ', _
'LeftParen ', _
'RightParen ', _
'LeftBrace ', _
'RightBrace ', _
'Semicolon ', _
'Comma ', _
'Identifier ', _
'Integer ', _
'String ', _
'End_of_input ' /
 
test = ' '
for (j = 0; j < n; j = j + 1)
test(j + 1 : j + 1) = str(i + j)
 
j = 0
done = .false.
while (!done)
{
if (TKEOI < j)
{
write (*, '(''unrecognized token'')')
stop
}
else if (test == tokstr(j))
done = .true.
else
j = j + 1
}
 
mktok = j
end
 
function mkint (str, i, n)
 
# Convert a unsigned integer substring to an integer.
 
implicit none
 
character str(*)
integer i
integer n
integer mkint
 
integer j
 
mkint = 0
for (j = 0; j < n; j = j + 1)
mkint = (10 * mkint) + (ichar (str(i + j)) - 48)
end
 
subroutine rdtok (strngs, istrng, blank, linno, colno, tokno, _
itkval, ntkval)
 
# Read a token from the input.
 
implicit none
 
character strngs(STRNSZ) # The string pool.
integer istrng # The string pool's next slot.
logical blank # Is the line blank?
integer linno # The line number.
integer colno # The column number.
integer tokno # The token number.
integer itkval, ntkval # Token value as a string.
 
integer skipsp, skipns, trimrt
integer mkint, mktok
 
character line(LINESZ)
character*20 fmt
integer n, i, j
 
# Read a line of text as an array of characters.
write (fmt, '(''('', I10, ''A1)'')') LINESZ
read (*, fmt) line
 
n = trimrt (line, LINESZ)
blank = (n == 0)
 
if (!blank)
{
i = skipsp (line, 1, n + 1)
j = skipns (line, i, n + 1)
linno = mkint (line, i, j - i)
 
i = skipsp (line, j, n + 1)
j = skipns (line, i, n + 1)
colno = mkint (line, i, j - i)
 
i = skipsp (line, j, n + 1)
j = skipns (line, i, n + 1)
tokno = mktok (line, i, j - i)
 
i = skipsp (line, j, n + 1)
j = n + 1
call string (line, i, j - i, strngs, istrng, itkval, ntkval)
}
end
 
subroutine gettok (strngs, istrng, tok)
 
# Get the next token.
 
implicit none
 
character strngs(STRNSZ) # The string pool.
integer istrng # The string pool's next slot.
integer tok(TOKSZ)
 
integer linno, colno, tokno, itkval, ntkval
logical blank
 
blank = .true.
while (blank)
call rdtok (strngs, istrng, blank, linno, colno, tokno, _
itkval, ntkval)
tok(ILN) = linno
tok(ICN) = colno
tok(ITK) = tokno
tok(ITV) = itkval
tok(ITN) = ntkval
end
 
function accept (strngs, istrng, curtok, tokno)
 
implicit none
 
character strngs(STRNSZ) # The string pool.
integer istrng # The string pool's next slot.
integer curtok(TOKSZ)
integer tokno
logical accept
 
accept = (curtok(ITK) == tokno)
if (accept)
call gettok (strngs, istrng, curtok)
end
 
subroutine expect (strngs, istrng, curtok, tokno)
 
implicit none
 
character strngs(STRNSZ) # The string pool.
integer istrng # The string pool's next slot.
integer curtok(TOKSZ)
integer tokno
 
logical accept
 
if (!accept (strngs, istrng, curtok, tokno))
{
# This is not the same message as printed by the reference C
# implementation. You can change that, if you wish.
write (*, 100) curtok(ILN), curtok(ICN)
100 format ('unexpected token at line ', I5, ', column ', I5)
stop
}
end
 
function prec (tokno)
 
# Precedence.
 
implicit none
 
integer tokno
integer prec
 
if (tokno == TKMUL || tokno == TKDIV || tokno == TKMOD)
prec = 13
else if (tokno == TKADD || tokno == TKSUB)
prec = 12
else if (tokno == TKNEG || tokno == TKNOT)
prec = 14
else if (tokno == TKLT || tokno == TKLE || _
tokno == TKGT || tokno == TKGE)
prec = 10
else if (tokno == TKEQ || tokno == TKNE)
prec = 9
else if (tokno == TKAND)
prec = 5
else if (tokno == TKOR)
prec = 4
else
prec = -1
end
 
function isbin (tokno)
 
# Is an operation binary?
 
implicit none
 
integer tokno
logical isbin
 
isbin = (tokno == TKADD || _
tokno == TKSUB || _
tokno == TKMUL || _
tokno == TKDIV || _
tokno == TKMOD || _
tokno == TKLT || _
tokno == TKLE || _
tokno == TKGT || _
tokno == TKGE || _
tokno == TKEQ || _
tokno == TKNE || _
tokno == TKAND || _
tokno == TKOR)
end
 
function rtassc (tokno)
 
# Is an operation right associative?
 
implicit none
 
integer tokno
logical rtassc
 
# None of the current operators is right associative.
rtassc = .false.
end
 
function opernt (tokno)
 
# Return the node tag for a binary operator.
 
implicit none
 
integer tokno
integer opernt
 
if (tokno == TKMUL)
opernt = NDMUL
else if (tokno == TKDIV)
opernt = NDDIV
else if (tokno == TKMOD)
opernt = NDMOD
else if (tokno == TKADD)
opernt = NDADD
else if (tokno == TKSUB)
opernt = NDSUB
else if (tokno == TKNEG)
opernt = NDNEG
else if (tokno == TKNOT)
opernt = NDNOT
else if (tokno == TKLT)
opernt = NDLT
else if (tokno == TKLE)
opernt = NDLE
else if (tokno == TKGT)
opernt = NDGT
else if (tokno == TKGE)
opernt = NDGE
else if (tokno == TKEQ)
opernt = NDEQ
else if (tokno == TKNE)
opernt = NDNE
else if (tokno == TKAND)
opernt = NDAND
else if (tokno == TKOR)
opernt = NDOR
else
{
write (*, '(''unrecognized binary operator'')')
stop
}
end
 
#---------------------------------------------------------------------
 
subroutine prtast (strngs, nodes, i, dstack)
 
# Print a tree in flattened format.
 
implicit none
 
character strngs(*)
integer nodes(NODESZ, NODSSZ)
integer i
integer dstack(DSTKSZ)
 
integer j
integer k
integer n
integer q, r
integer tag
 
character*80 fmt
 
dstack(1) = i
j = 2
while (j != 1)
{
j = j - 1
k = dstack(j)
if (k < 1)
write (*, '('';'')')
else
{
tag = nodes(NTAG, k)
if (tag == NDID)
{
n = nodes(NITN, k)
write (fmt, '(''("Identifier ", '', I5, ''A)'')') n
q = nodes(NITV, k)
write (*, fmt) (strngs(r), r = q, q + n - 1)
}
else if (tag == NDINT)
{
n = nodes(NITN, k)
write (fmt, '(''("Integer ", '', I5, ''A)'')') n
q = nodes(NITV, k)
write (*, fmt) (strngs(r), r = q, q + n - 1)
}
else if (tag == NDSTR)
{
n = nodes(NITN, k)
write (fmt, '(''("String ", '', I5, ''A)'')') n
q = nodes(NITV, k)
write (*, fmt) (strngs(r), r = q, q + n - 1)
}
else
{
if (tag == NDSEQ)
write (*, '(''Sequence'')')
else if (tag == NDIF)
write (*, '(''If'')')
else if (tag == NDPRTC)
write (*, '(''Prtc'')')
else if (tag == NDPRTS)
write (*, '(''Prts'')')
else if (tag == NDPRTI)
write (*, '(''Prti'')')
else if (tag == NDWHIL)
write (*, '(''While'')')
else if (tag == NDASGN)
write (*, '(''Assign'')')
else if (tag == NDNEG)
write (*, '(''Negate'')')
else if (tag == NDNOT)
write (*, '(''Not'')')
else if (tag == NDMUL)
write (*, '(''Multiply'')')
else if (tag == NDDIV)
write (*, '(''Divide'')')
else if (tag == NDMOD)
write (*, '(''Mod'')')
else if (tag == NDADD)
write (*, '(''Add'')')
else if (tag == NDSUB)
write (*, '(''Subtract'')')
else if (tag == NDLT)
write (*, '(''Less'')')
else if (tag == NDLE)
write (*, '(''LessEqual'')')
else if (tag == NDGT)
write (*, '(''Greater'')')
else if (tag == NDGE)
write (*, '(''GreaterEqual'')')
else if (tag == NDEQ)
write (*, '(''Equal'')')
else if (tag == NDNE)
write (*, '(''NotEqual'')')
else if (tag == NDAND)
write (*, '(''And'')')
else if (tag == NDOR)
write (*, '(''Or'')')
else
{
write (*, '(''unrecognized node type'')')
stop
}
if (DSTKSZ - 2 < n)
{
write (*, '(''node stack overflow'')')
stop
}
dstack(j) = nodes(NRIGHT, k)
dstack(j + 1) = nodes(NLEFT, k)
j = j + 2
}
}
}
end
 
#---------------------------------------------------------------------
 
# A tiny recursive language. Each instruction is two integers,
# although the second integer may be XPAD. XLOCs are named by
# integers.
 
define(XPAD, 0) # "Padding"
 
define(XLOC, 10) # "Jump or call location"
define(XJUMP, 20) # "Jump to a place"
define(XJUMPT, 30) # "Jump to a place, if true"
define(XJUMPF, 40) # "Jump to a place, if false"
define(XCALL, 50) # "Call a subprogram"
define(XRET, 60) # "Return from a subprogram"
 
define(XPUSH, 110) # "Push an immediate value"
define(XSWAP, 120) # "Swap top two stack entries"
 
define(XLT, 200) # "Less than?"
define(XADDI, 210) # "Add immediate."
 
define(XPPUSH, 610) # "Push top to precedence stack"
define(XPCOPY, 620) # "Copy top of prec stack to top"
define(XPDROP, 630) # "Drop top of precedence stack"
 
define(XGETTK, 710) # "Get the next token"
define(XTOKEQ, 720) # "Token equals the argument?"
define(XEXPCT, 730) # "Expect token"
define(XACCPT, 740) # "Accept token"
 
define(XTOK, 810) # "Push the token number"
define(XBINOP, 820) # "Is top a binary operator?"
define(XRASSC, 830) # "Is top a right associative op?"
define(XPREC, 840) # "Precedence of token no. on top"
define(XOPER, 850) # "Operator for token no. on top"
 
define(XINTND, 970) # "Make internal node"
define(XOPND, 975) # "Make internal node for operator"
define(XLEFND, 980) # "Make leaf node"
define(XNILND, 985) # "Make nil node"
 
define(XERROR, 1010) # "Error"
define(XRWARN, 1020) # "Unused right associative branch"
 
define(XPING, 2010) # Print a ping message (for debugging)
define(XPRTND, 2020) # Print node at stack top (for debugging)
define(XPRTTP, 2030) # Print stack top as integer (for debugging)
define(XPRTTK, 2040) # Print the current token (for debugging)
define(XPRTP, 2050) # Print the current precedence (for debugging)
define(XPRTST, 2060) # Print the whole data stack (for debugging)
 
# Call and jump locations in our program:
define(CSTMT, 1000) # stmt
define(STMT01, 1010)
define(STMT02, 1020)
define(STMT03, 1030)
define(STMT04, 1040)
define(STMT05, 1050)
define(STMT06, 1060)
define(STMT07, 1070)
define(STMT08, 1080)
define(STMT09, 1090)
define(STMT10, 1100)
define(STMT11, 1110)
define(STMT12, 1120)
define(STMT13, 1130)
define(STMT14, 1140)
define(STMT15, 1150)
define(CPEXPR, 2000) # paren_expr
define(CEXPR, 3000) # expr
define(EXPR01, 3010)
define(EXPR02, 3020)
define(EXPR03, 3030)
define(EXPR04, 3040)
define(EXPR05, 3050)
define(EXPR06, 3060)
define(EXPR10, 3100)
define(EXPR11, 3110)
define(EXPR12, 3120)
define(EXPR13, 3130)
define(PARS01, 4010) # parse
 
# Error numbers.
define(EXSTMT, 100) # "expecting start of statement"
define(EXPRIM, 200) # "expecting a primary"
 
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 
subroutine ld(code, i, instr1, instr2)
 
implicit none
 
integer code(*)
integer i
integer instr1, instr2
 
code(i) = instr1
code(i + 1) = instr2
i = i + 2
end
 
subroutine ldcode (code)
 
# Load the code that is in the recursive language. The array
# allocated to hold the code must be large enough, but we do not
# check.
 
implicit none
 
integer code(*)
integer i
 
i = 1
 
#--------------------------------------------------
 
# The main loop.
call ld (code, i, XNILND, XPAD) # Nil node for start of sequence.
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XLOC, PARS01) # Top of loop
call ld (code, i, XCALL, CSTMT)
call ld (code, i, XINTND, NDSEQ)
call ld (code, i, XTOKEQ, TKEOI) # End_of_input
call ld (code, i, XJUMPF, PARS01) # Loop unless end of input.
call ld (code, i, XRET, XPAD)
 
#--------------------------------------------------
 
call ld (code, i, XLOC, CEXPR) # Start of "expr"
call ld (code, i, XPPUSH, XPAD) # Push the precedence argument.
 
call ld (code, i, XTOKEQ, TKLPAR) # LeftParen
call ld (code, i, XJUMPF, EXPR01)
 
# "( ... )"
call ld (code, i, XCALL, CPEXPR)
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR01)
 
call ld (code, i, XACCPT, TKSUB) # Op_subtract
call ld (code, i, XJUMPF, EXPR02)
 
# Unary minus
call ld (code, i, XPUSH, TKNEG)
call ld (code, i, XPREC, XPAD)
call ld (code, i, XCALL, CEXPR) # expr <--
call ld (code, i, XNILND, XPAD) # expr nil <--
call ld (code, i, XINTND, NDNEG)
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR02)
 
call ld (code, i, XACCPT, TKADD) # Op_add
call ld (code, i, XJUMPF, EXPR03)
 
# Unary plus
call ld (code, i, XPUSH, TKNEG)
call ld (code, i, XPREC, XPAD)
call ld (code, i, XCALL, CEXPR) # expr <--
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR03)
 
call ld (code, i, XACCPT, TKNOT) # Op_not
call ld (code, i, XJUMPF, EXPR04)
 
# "!"
call ld (code, i, XPUSH, TKNOT)
call ld (code, i, XPREC, XPAD)
call ld (code, i, XCALL, CEXPR) # expr <--
call ld (code, i, XNILND, XPAD) # expr nil <--
call ld (code, i, XINTND, NDNOT)
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR04)
 
call ld (code, i, XTOKEQ, TKID) # Identifier
call ld (code, i, XJUMPF, EXPR05)
 
# Identifier
call ld (code, i, XLEFND, NDID)
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR05)
 
call ld (code, i, XTOKEQ, TKINT) # Integer
call ld (code, i, XJUMPF, EXPR06)
 
# Integer.
call ld (code, i, XLEFND, NDINT)
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XJUMP, EXPR10)
 
call ld (code, i, XLOC, EXPR06)
 
call ld (code, i, XERROR, EXPRIM)
 
call ld (code, i, XLOC, EXPR10) # Top of precedence climbing loop
 
call ld (code, i, XTOK, XPAD)
call ld (code, i, XBINOP, XPAD)
call ld (code, i, XJUMPF, EXPR11) # Exit loop, if not a binary op.
 
call ld (code, i, XTOK, XPAD)
call ld (code, i, XPREC, XPAD) # curtok_prec <--
call ld (code, i, XPCOPY, XPAD) # curtok_prec p <--
call ld (code, i, XLT, XPAD) # (curtok_prec < p)? <--
call ld (code, i, XJUMPT, EXPR11) # Exit loop if true.
 
call ld (code, i, XTOK, XPAD)
call ld (code, i, XOPER, XPAD) # x op <--
call ld (code, i, XSWAP, XPAD) # op x <--
 
call ld (code, i, XTOK, XPAD)
call ld (code, i, XRASSC, XPAD)
call ld (code, i, XJUMPT, EXPR12)
 
# Left associative.
call ld (code, i, XTOK, XPAD)
call ld (code, i, XPREC, XPAD)
call ld (code, i, XADDI, 1) # op x q:=(q + 1) <--
call ld (code, i, XJUMP, EXPR13)
 
call ld (code, i, XLOC, EXPR12)
 
# Right associative. (Currently an unused branch.)
call ld (code, i, XRWARN, XPAD) # Warn about unused branch.
call ld (code, i, XTOK, XPAD)
call ld (code, i, XPREC, XPAD) # op x q <--
 
call ld (code, i, XLOC, EXPR13)
 
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XCALL, CEXPR) # op x expr(q) <--
call ld (code, i, XOPND, XPAD) # new_x <--
 
call ld (code, i, XJUMP, EXPR10) # Continue looping.
 
call ld (code, i, XLOC, EXPR11) # Loop exit.
 
call ld (code, i, XPDROP, XPAD) # Drop the precedence argument.
call ld (code, i, XRET, XPAD) # End of "expr"
 
#--------------------------------------------------
 
call ld (code, i, XLOC, CPEXPR) # Start of "paren_expr"
call ld (code, i, XEXPCT, TKLPAR)
call ld (code, i, XPUSH, 0)
call ld (code, i, XCALL, CEXPR)
call ld (code, i, XEXPCT, TKRPAR)
call ld (code, i, XRET, XPAD)
 
#--------------------------------------------------
 
call ld (code, i, XLOC, CSTMT) # Start of "stmt"
 
call ld (code, i, XACCPT, TKIF) # Keyword_if
call ld (code, i, XJUMPF, STMT01)
 
# "if (...) then ... else ..."
call ld (code, i, XCALL, CPEXPR) # Get the paren expr ("if (...)").
call ld (code, i, XCALL, CSTMT) # Get the "then" clause.
call ld (code, i, XACCPT, TKELSE) # Keyword_else
call ld (code, i, XJUMPF, STMT02)
call ld (code, i, XCALL, CSTMT) # Get the "else" clause.
call ld (code, i, XJUMP, STMT03)
call ld (code, i, XLOC, STMT02)
call ld (code, i, XNILND, XPAD) # The "else" statement is nil.
call ld (code, i, XLOC, STMT03)
call ld (code, i, XINTND, NDIF) # ("If" pred ("If" then else))
call ld (code, i, XINTND, NDIF)
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT01)
 
call ld (code, i, XACCPT, TKPUTC) # Keyword_putc
call ld (code, i, XJUMPF, STMT04)
 
# "putc (...);"
call ld (code, i, XCALL, CPEXPR) # Get the paren expr.
call ld (code, i, XNILND, XPAD)
call ld (code, i, XINTND, NDPRTC) # ("Prtc" expr nil)
call ld (code, i, XEXPCT, TKSEMI) # Expect ";"
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT04)
 
call ld (code, i, XACCPT, TKPRNT) # Keyword_print
call ld (code, i, XJUMPF, STMT05)
 
# "print(... , ... , ...);"
call ld (code, i, XEXPCT, TKLPAR) # Expect "("
call ld (code, i, XNILND, XPAD) # nil for start of sequence
call ld (code, i, XLOC, STMT08) # Top of loop
call ld (code, i, XTOKEQ, TKSTR)
call ld (code, i, XJUMPT, STMT06)
call ld (code, i, XPUSH, 0)
call ld (code, i, XCALL, CEXPR)
call ld (code, i, XNILND, XPAD)
call ld (code, i, XINTND, NDPRTI) # ("Prti" expr nil)
call ld (code, i, XJUMP, STMT07)
call ld (code, i, XLOC, STMT06)
call ld (code, i, XLEFND, NDSTR)
call ld (code, i, XNILND, XPAD)
call ld (code, i, XINTND, NDPRTS) # ("Prts" ("String" ...) nil)
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XLOC, STMT07)
call ld (code, i, XINTND, NDSEQ) # ("Sequence" ... ...)
call ld (code, i, XACCPT, TKCMMA) # Comma
call ld (code, i, XJUMPT, STMT08) # Loop if comma.
call ld (code, i, XEXPCT, TKRPAR) # Expect ")"
call ld (code, i, XEXPCT, TKSEMI) # Expect ";"
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT05)
 
call ld (code, i, XACCPT, TKSEMI) # Semicolon
call ld (code, i, XJUMPF, STMT09)
 
# Accept a lone ";".
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT09)
 
call ld (code, i, XTOKEQ, TKID) # Identifier
call ld (code, i, XJUMPF, STMT10)
 
# "identifier = expr;"
call ld (code, i, XLEFND, NDID) # ("Identifier" ...)
call ld (code, i, XGETTK, XPAD)
call ld (code, i, XEXPCT, TKASGN)
call ld (code, i, XPUSH, 0)
call ld (code, i, XCALL, CEXPR)
call ld (code, i, XINTND, NDASGN) # ("Assign" ("Identifier" ...) expr)
call ld (code, i, XEXPCT, TKSEMI)
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT10)
 
call ld (code, i, XACCPT, TKWHIL) # While
call ld (code, i, XJUMPF, STMT11)
 
# "while (...) ..."
call ld (code, i, XCALL, CPEXPR)
call ld (code, i, XCALL, CSTMT)
call ld (code, i, XINTND, NDWHIL) # ("While" pred stmt)
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT11)
 
call ld (code, i, XACCPT, TKLBRC) # LeftBrace
call ld (code, i, XJUMPF, STMT12)
 
# "{ ... }"
call ld (code, i, XNILND, XPAD) # nil for start of sequence
call ld (code, i, XLOC, STMT13) # Top of loop
call ld (code, i, XTOKEQ, TKEOI)
call ld (code, i, XJUMPT, STMT14)
call ld (code, i, XTOKEQ, TKRBRC)
call ld (code, i, XJUMPT, STMT14)
call ld (code, i, XCALL, CSTMT)
call ld (code, i, XINTND, NDSEQ) # ("Sequence" ... ...)
call ld (code, i, XJUMP, STMT13) # Loop again.
call ld (code, i, XLOC, STMT14) # Loop exit
call ld (code, i, XEXPCT, TKRBRC) # Expect ";".
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT12)
 
call ld (code, i, XTOKEQ, TKEOI) # End_of_input
call ld (code, i, XJUMPF, STMT15)
 
call ld (code, i, XRET, XPAD)
 
call ld (code, i, XLOC, STMT15)
 
call ld (code, i, XERROR, EXSTMT) # "expecting start of stmt"
 
#--------------------------------------------------
 
end
 
subroutine dtpush (dstack, idstck, x)
 
# Push to the data stack.
 
implicit none
 
integer dstack(DSTKSZ)
integer idstck
integer x
 
if (DSTKSZ < idstck)
{
write (*, '(''node stack exhausted'')')
stop
}
dstack(idstck) = x
idstck = idstck + 1
end
 
function dtpop (dstack, idstck)
 
# Pop from the data stack.
 
implicit none
 
integer dstack(DSTKSZ)
integer idstck
integer dtpop
 
if (DSTKSZ < idstck)
{
write (*, '(''node stack exhausted'')')
stop
}
idstck = idstck - 1
dtpop = dstack(idstck)
end
 
subroutine ppush (pstack, ipstck, x)
 
# Push to the precedence stack.
 
implicit none
 
integer pstack(PSTKSZ)
integer ipstck
integer x
 
if (PSTKSZ < ipstck)
{
write (*, '(''precedence stack exhausted'')')
stop
}
pstack(ipstck) = x
ipstck = ipstck + 1
end
 
function ppop (pstack, ipstck)
 
# Pop from the precedence stack.
 
implicit none
 
integer pstack(PSTKSZ)
integer ipstck
integer ppop
 
if (PSTKSZ < ipstck)
{
write (*, '(''precedence stack exhausted'')')
stop
}
ipstck = ipstck - 1
ppop = pstack(ipstck)
end
 
function ipfind (code, loc)
 
# Find a location.
 
implicit none
 
integer code(*)
integer loc
integer ipfind
 
integer i
 
i = 1
while (code(i) != XLOC || code(i + 1) != loc)
i = i + 2
ipfind = i
end
 
subroutine ippush (xstack, ixstck, ip)
 
# Push the instruction pointer.
 
implicit none
 
integer xstack(XSTKSZ)
integer ixstck
integer ip
 
if (XSTKSZ < ixstck)
{
write (*, '(''recursive call stack exhausted'')')
stop
}
xstack(ixstck) = ip
ixstck = ixstck + 1
end
 
function ippop (xstack, ixstck)
 
# Pop an instruction pointer value.
 
implicit none
 
integer xstack(XSTKSZ)
integer ixstck
integer ippop
 
if (ixstck == 1)
{
write (*, '(''recursive call stack underflow'')')
stop
}
ixstck = ixstck - 1
ippop = xstack(ixstck)
end
 
function logl2i (u)
 
# Convert LOGICAL to INTEGER.
 
implicit none
 
logical u
integer logl2i
 
if (u)
logl2i = 1
else
logl2i = 0
end
 
subroutine recurs (strngs, istrng,
nodes, inodes, _
dstack, idstck, _
pstack, ipstck, _
xstack, ixstck, _
code, ip)
 
implicit none
 
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer nodes(NODESZ, NODSSZ) # Node pool
integer inodes # Node pool's next slot.
integer dstack(DSTKSZ) # Data stack.
integer idstck # Data stack pointer.
integer pstack(PSTKSZ) # Precedence stack.
integer ipstck # Precedence stack pointer.
integer xstack(XSTKSZ) # Execution stack.
integer ixstck # Execution stack pointer.
integer code(*) # Code in the recursive language.
integer ip # Instruction pointer.
 
integer prec
integer opernt
integer logl2i
integer dtpop
integer ppop
integer ippop
integer ipfind
logical accept
logical isbin
logical rtassc
 
integer curtok(TOKSZ)
integer node(NODESZ)
integer curprc # Current precedence value.
integer i, j
logical done
 
curprc = 0
done = .false.
while (.not. done)
{
if (code(ip) == XLOC)
{
ip = ip + 2
}
else if (code(ip) == XJUMP)
{
ip = ipfind (code, code(ip + 1))
}
else if (code(ip) == XJUMPT)
{
i = dtpop (dstack, idstck)
if (i != 0)
ip = ipfind (code, code(ip + 1))
else
ip = ip + 2
}
else if (code(ip) == XJUMPF)
{
i = dtpop (dstack, idstck)
if (i == 0)
ip = ipfind (code, code(ip + 1))
else
ip = ip + 2
}
else if (code(ip) == XCALL)
{
call ippush (xstack, ixstck, ip + 2)
ip = ipfind (code, code(ip + 1))
}
else if (code(ip) == XRET)
{
if (ixstck == 1)
done = .true.
else
ip = ippop (xstack, ixstck)
}
else if (code(ip) == XINTND)
{
node(NRIGHT) = dtpop (dstack, idstck)
node(NLEFT) = dtpop (dstack, idstck)
node(NTAG) = code(ip + 1)
call astnod (node, nodes, inodes, i)
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XOPND)
{
node(NRIGHT) = dtpop (dstack, idstck)
node(NLEFT) = dtpop (dstack, idstck)
node(NTAG) = dtpop (dstack, idstck)
call astnod (node, nodes, inodes, i)
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XLEFND)
{
node(NITV) = curtok(ITV)
node(NITN) = curtok(ITN)
node(NTAG) = code(ip + 1)
call astnod (node, nodes, inodes, i)
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XNILND)
{
call dtpush (dstack, idstck, NIL)
ip = ip + 2
}
else if (code(ip) == XGETTK)
{
call gettok (strngs, istrng, curtok)
ip = ip + 2
}
else if (code(ip) == XTOKEQ)
{
i = logl2i (curtok(ITK) == code(ip + 1))
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XEXPCT)
{
call expect (strngs, istrng, curtok, code(ip + 1))
ip = ip + 2
}
else if (code(ip) == XACCPT)
{
i = logl2i (accept (strngs, istrng, curtok, code(ip + 1)))
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XSWAP)
{
i = dtpop (dstack, idstck)
j = dtpop (dstack, idstck)
call dtpush (dstack, idstck, i)
call dtpush (dstack, idstck, j)
ip = ip + 2
}
else if (code(ip) == XLT)
{
j = dtpop (dstack, idstck)
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, logl2i (i < j))
ip = ip + 2
}
else if (code(ip) == XADDI)
{
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, i + code(ip + 1))
ip = ip + 2
}
else if (code(ip) == XPPUSH)
{
i = dtpop (dstack, idstck)
call ppush (pstack, ipstck, i)
ip = ip + 2
}
else if (code(ip) == XPCOPY)
{
i = ppop (pstack, ipstck)
call ppush (pstack, ipstck, i)
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XPDROP)
{
i = ppop (pstack, ipstck)
ip = ip + 2
}
else if (code(ip) == XBINOP)
{
i = dtpop (dstack, idstck)
i = logl2i (isbin (i))
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XRASSC)
{
i = dtpop (dstack, idstck)
i = logl2i (rtassc (i))
call dtpush (dstack, idstck, i)
ip = ip + 2
}
else if (code(ip) == XPREC)
{
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, prec (i))
ip = ip + 2
}
else if (code(ip) == XOPER)
{
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, opernt (i))
ip = ip + 2
}
else if (code(ip) == XTOK)
{
call dtpush (dstack, idstck, curtok(ITK))
ip = ip + 2
}
else if (code(ip) == XPUSH)
{
call dtpush (dstack, idstck, code(ip + 1))
ip = ip + 2
}
else if (code(ip) == XERROR)
{
if (code(ip + 1) == EXSTMT)
{
write (*, 1000) curtok(ILN), curtok(ICN)
1000 format ('expected start of statement at line ', _
I5, ', column ', I5)
}
else if (code(ip + 1) == EXPRIM)
{
write (*, 1010) curtok(ILN), curtok(ICN)
1010 format ('expected a primary at line ', _
I5, ', column ', I5)
}
else
{
write (*, 2000) curtok(ILN), curtok(ICN)
2000 format ('syntax error at line ', _
I5, ', column ', I5)
}
stop
}
else if (code(ip) == XRWARN)
{
write (*, 3000)
3000 format ('executing supposedly unused ', _
'"right associative" operator branch')
ip = ip + 2
}
else if (code(ip) == XPING)
{
write (*, '(''ping'')')
ip = ip + 2
}
else if (code(ip) == XPRTND)
{
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, i)
call prtast (strngs, nodes, i, dstack)
ip = ip + 2
}
else if (code(ip) == XPRTTP)
{
i = dtpop (dstack, idstck)
call dtpush (dstack, idstck, i)
write (*, '(''top = '', I20)') i
ip = ip + 2
}
else if (code(ip) == XPRTTK)
{
write (*, '(''curtok ='', 5(1X, I5))') curtok
ip = ip + 2
}
else if (code(ip) == XPRTP)
{
write (*, '(''curprc = '', I2)') curprc
ip = ip + 2
}
else if (code(ip) == XPRTST)
{
write (*, '(''dstack ='', 100000(1X, I5))') _
(dstack(i), i = 1, idstck - 1)
ip = ip + 2
}
else
{
write (*, '(''illegal instruction'')')
stop
}
}
end
 
#---------------------------------------------------------------------
 
program parse
 
implicit none
 
character strngs(STRNSZ) # String pool.
integer istrng # String pool's next slot.
integer nodes(NODESZ, NODSSZ) # Node pool
integer inodes # Node pool's next slot.
integer dstack(DSTKSZ) # Node stack.
integer idstck # Node stack pointer.
integer pstack(PSTKSZ) # Precedence stack.
integer ipstck # Precedence stack pointer.
integer xstack(XSTKSZ) # Execution stack.
integer ixstck # Execution stack pointer.
integer code(1000) # Recursive code.
integer ip # Instruction pointer.
 
integer i
 
integer dtpop
 
istrng = 1
inodes = 1
idstck = 1
ipstck = 1
ixstck = 1
 
call ldcode (code)
ip = 1
 
call recurs (strngs, istrng, nodes, inodes, _
dstack, idstck, pstack, ipstck, _
xstack, ixstck, code, ip)
i = dtpop (dstack, idstck)
call prtast (strngs, nodes, i, dstack)
end
 
######################################################################</syntaxhighlight>
 
 
{{out}}
To compile and run with gfortran on a POSIX system:
 
<pre>$ ratfor77 parse-in-ratfor.r > parse-in-ratfor.f && gfortran -O2 -fcheck=all -std=legacy parse-in-ratfor.f && ./a.out < compiler-tests/primes.lex</pre>
 
To use f2c instead of gfortran:
 
<pre>ratfor77 parse-in-ratfor.r > parse-in-ratfor.f && f2c -C -Nc40 parse-in-ratfor.f && cc -O parse-in-ratfor.c -lf2c && ./a.out < compiler-tests/primes.lex</pre>
 
The output should be:
 
<pre>Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier count
Integer 1
Assign
Identifier n
Integer 1
Assign
Identifier limit
Integer 100
While
Less
Identifier n
Identifier limit
Sequence
Sequence
Sequence
Sequence
Sequence
;
Assign
Identifier k
Integer 3
Assign
Identifier p
Integer 1
Assign
Identifier n
Add
Identifier n
Integer 2
While
And
LessEqual
Multiply
Identifier k
Identifier k
Identifier n
Identifier p
Sequence
Sequence
;
Assign
Identifier p
NotEqual
Multiply
Divide
Identifier n
Identifier k
Identifier k
Identifier n
Assign
Identifier k
Add
Identifier k
Integer 2
If
Identifier p
If
Sequence
Sequence
;
Sequence
Sequence
;
Prti
Identifier n
;
Prts
String " is prime\n"
;
Assign
Identifier count
Add
Identifier count
Integer 1
;
Sequence
Sequence
Sequence
;
Prts
String "Total primes found: "
;
Prti
Identifier count
;
Prts
String "\n"
;</pre>
 
=={{header|Scala}}==
Line 9,440 ⟶ 11,732:
The following code implements a configurable (from a symbol map provided as a parameter) Precedence Climbing parser for the output of the [http://rosettacode.org/wiki/Compiler/lexical_analyzer#Scala lexer]. The recursive descent language parser is closely based on the pseudo code given in the task description.
 
<langsyntaxhighlight lang="scala">
package xyz.hyperreal.rosettacodeCompiler
 
Line 9,650 ⟶ 11,942:
 
}
</syntaxhighlight>
</lang>
 
=={{header|Scheme}}==
Line 9,656 ⟶ 11,948:
Code implements a recursive descent parser based on the given grammar. Tested against all programs in [[Compiler/Sample programs]].
 
<langsyntaxhighlight lang="scheme">
(import (scheme base)
(scheme process-context)
Line 9,863 ⟶ 12,155:
(display-ast (parse-file (cadr (command-line))))
(display "Error: provide program filename\n"))
</syntaxhighlight>
</lang>
 
=={{header|Wren}}==
Line 9,870 ⟶ 12,162:
{{libheader|Wren-fmt}}
{{libheader|wren-ioutil}}
<langsyntaxhighlight ecmascriptlang="wren">import "./dynamic" for Enum, Struct, Tuple
import "./fmt" for Fmt
import "./ioutil" for FileUtil
 
var tokens = [
Line 10,186 ⟶ 12,478:
lines = FileUtil.readLines("source.txt")
lineCount = lines.count
prtAst.call(parse.call())</langsyntaxhighlight>
 
{{out}}
Line 10,288 ⟶ 12,580:
 
=={{header|Zig}}==
<langsyntaxhighlight lang="zig">
const std = @import("std");
 
Line 10,841 ⟶ 13,133:
return result;
}
</syntaxhighlight>
</lang>
9,476

edits