Module CodeGenerator (s$){
	Function code$(op$) {
		=format$("{0::-6} {1}", pc, op$)
		pc++
	}
	Function code2$(op$, n$) {
		=format$("{0::-6} {1} {2}", pc, op$, n$)
		pc+=5
	}
	Function code3$(op$,pc, st, ed) {
		=format$("{0::-6} {1} ({2}) {3}", pc, op$, ed-st-1, ed)
	}

	Enum tok {
		gneg, gnot, gmul, gdiv, gmod, gadd, gle, gsub, glt
		gle, ggt, gge, geq, gne, gand, gor, gprtc, gprti, gprts,
		gif, gwhile, gAssign, gSeq, gstring, gidentifier, gint, gnone
	}

	\\ Inventories are lists with keys, or keys/data (key must be unique)
	\\ there is one type more the Invetory Queue which get same keys.
	\\ But here not used.
	Inventory symb="Multiply":=gmul, "Divide":=gdiv, "Mod":=gmod, "Add":=gadd
	Append  symb, "Negate":=gneg, "Not":=gnot,"Less":=glt,"Subtract":=gsub
	Append  symb, "LessEqual":=gle, "Greater":=ggt, "GreaterEqual":=gge, "Sequence":=gSeq
	Append  symb, "Equal":=geq, "NotEqual":=gne,  "And":=gand, "Or":=gor, "While":=gwhile
	Append  symb, "Prtc":=gprtc,"Prti":=gprti,"Prts":=gprts, "Assign":=gAssign, "If":=gif
	Append  symb, "String":=gstring, "Identifier":=gidentifier, "Integer":=gint, ";", gnone

	Inventory DataSet
	\\ We set string as key. key maybe an empty string, a string or a number.
	\\ so we want eash string to saved one time only.
	Inventory Strings

	Const nl$=chr$(13)+chr$(10), Ansi=3
	Def z$, lim, line$, newvar_ok, i=0
	Document message$=nl$
	Global pc     \\ functions have own scope, so we make it global, for this module, and childs.

	Dim lines$()
	s$=filter$(s$,chr$(9))   \\ exclude tabs
	Lines$()=piece$(s$,nl$) \\ break to lines
	lim=len(Lines$())
	Flush ' empty stack (there is a current stack of values which we use here)

	Load_Ast()
	If not stack.size=1 Then Flush : Error "Ast not loaded"
	AST=array   \\ pop the array from stack
	Document Assembly$, Header$

	\\ all lines of assembly goes to stack. Maybe not in right order.
	\\ Push statement push to top, Data statement push to bottom of stack

	CodeGenerator(Ast)
	Data  code$("halt") ' append to end of stack
	\\ So now we get all data (letters) from stack
	While not empty
		Assembly$=letter$+nl$
	end while
	\\ So now we have to place them in order
	Sort Assembly$

	\\ Let's make the header
	Header$=format$("Datasize: {0} Strings: {1}", Len(Dataset),Len(strings))
	\\ we use an iterator object, str^ is the counter, readonly, but Eval$() use it from object.
	str=each(strings)
	While str
		Header$=nl$+Eval$(str)
	End while
	Assembly$=nl$
	\\ insert to line 1 the Header
	Insert 1 Assembly$=Header$
	\\ Also we check for warnings
	If len(message$)>2 then Assembly$="Warnings: "+nl$+message$
	\\ So now we get a report
	\\ (at each 3/4 of window's lines, the printing stop and wait for user response, any key)
	Report Assembly$
	Clipboard Assembly$
	Save.Doc Assembly$, "code.t", Ansi
	End
	\\ subs have 10000 limit for recursion but can be extended to 1000000 or more.
	Sub CodeGenerator(t)

		If len(t)=3 then
			select case  t#val(0)
			Case gSeq
				CodeGenerator(t#val(1)) : CodeGenerator(t#val(2))
			Case gwhile
			{
				local spc=pc
				CodeGenerator(t#val(1))
				local pc1=pc
				pc+=5 ' room for jz
				CodeGenerator(t#val(2))
				data code3$("jz",pc1, pc1, pc+5)
				data code3$("jmp",pc,  pc, spc)
				pc+=5  ' room for jmp
			}
			Case gif
			{
				CodeGenerator(t#val(1))
				local pc1=pc, pc2
				pc+=5
				CodeGenerator(t#val(2)#val(1))
				If len(t#val(2)#val(2))>0 then
					pc2=pc
					pc+=5
					data code3$("jz",pc1, pc1, pc)
					CodeGenerator(t#val(2)#val(2))
					data code3$("jmp",pc2, pc2, pc)
				else
					data code3$("jz",pc1, pc1, pc)
				end If
			}
			Case gAssign
			{
				CodeGenerator(t#val(2))
				local newvar_ok=true
				CodeGenerator(t#val(1))
			}
			case gneg to gnot, gprtc to gprts
				CodeGenerator(t#val(1)) : data code$(mid$(eval$(t#val(0)),2))
			case gmul to gor
			{
				CodeGenerator(t#val(1))
				CodeGenerator(t#val(2))
				data code$(mid$(eval$(t#val(0)),2))
			}
			End select
		Else.if len(t)=2 then
			select case  t#val(0)
			Case gString
			{
				local spos
				If exist(strings,t#val$(1)) then
					spos=eval(strings!)
				else
					append strings, t#val$(1)
					spos=len(strings)-1
				end If
				Push code2$("push",str$(spos,0))
			}
			Case gInt
				Push code2$("push",t#val$(1), pc)
			Case gIdentifier
			{
				local ipos
				If exist(dataset,t#val$(1)) then
					ipos=Eval(dataset!)  ' return position
				else.if newvar_ok then
					Append dataset, t#val$(1)
					ipos=len(dataset)-1
				else
					message$="Variable "+t#val$(1)+" not initialized"+nl$

				end If
				If newvar_ok then
					Push code2$("store","["+str$(ipos, 0)+"]")
				else
					Push code2$("fetch","["+str$(ipos, 0)+"]")
				end If
			}
			end select
		End If
	End Sub
	Sub Load_Ast()
			If i>=lim then Push (,) : exit sub
			do
			line$=Trim$(lines$(i))
			I++
			tok$=piece$(line$," ")(0)
			until line$<>"" or i>=lim
			If tok$="Identifier" then
				Push (gidentifier,trim$(Mid$(line$,11)))
			else.if tok$="Integer" then
				long n=Val(Mid$(line$,8))  ' check overflow
				Push (gint, Trim$(Mid$(line$,8)))
			else.if tok$="String" then
				Push (gstring,Trim$(Mid$(line$,7)))
			else.if tok$=";" then
				Push (,)
			Else
				local otok=symb(tok$)
				Load_Ast()
				Load_Ast()
				Shift 2
				Push (otok,array, array)
			End If
	End Sub
}

CodeGenerator {
	Sequence
	Sequence
	;
	Assign
	Identifier    count
	Integer       1
	While
	Less
	Identifier    count
	Integer       10
	Sequence
	Sequence
	;
	Sequence
	Sequence
	Sequence
	;
	Prts
	String        "count is: "
	;
	Prti
	Identifier    count
	;
	Prts
	String        "\n"
	;
	Assign
	Identifier    count
	Add
	Identifier    count
	Integer       1
}


// Single line comment
\\ Also single line comment (continuation of the comment in previous line)

\[ This is
a multi line
comment ]

\{ And
this }

\( And
this )

\‘ And
this ’


CREATE BUF 0 ,              \ single-character look-ahead buffer
: PEEK   BUF @ 0= IF KEY BUF ! THEN BUF @ ;
: GETC   PEEK  0 BUF ! ;
: SPACE?   DUP BL = SWAP  9 14 WITHIN  OR ;
: >SPACE   BEGIN PEEK SPACE? WHILE GETC DROP REPEAT ;
: DIGIT?   48 58 WITHIN ;
: GETINT   >SPACE  0
   BEGIN  PEEK DIGIT?
   WHILE  GETC [CHAR] 0 -  SWAP 10 * +
   REPEAT ;
: GETNAM   >SPACE PAD 1+
   BEGIN PEEK SPACE? INVERT
   WHILE GETC OVER C! CHAR+
   REPEAT  PAD TUCK - 1-  PAD C! ;
: GETSTR   >SPACE PAD  1+ GETC DROP   \ skip leading "
   BEGIN GETC  DUP [CHAR] " <>
   WHILE OVER C! CHAR+
   REPEAT  DROP  PAD TUCK - 1-  PAD C! ;
: INTERN   HERE SWAP  DUP [email protected] 1+ BOUNDS DO I [email protected] C, LOOP  ALIGN ;

CREATE #TK 0 ,
: TK:   CREATE #TK @ ,  1 #TK +!  DOES> @ ;
TK: End_of_input      TK: Keyword_if        TK: Keyword_else
TK: Keyword_while     TK: Keyword_print     TK: Keyword_putc
TK: String            TK: Integer           TK: Identifier
TK: LeftParen         TK: RightParen
TK: LeftBrace         TK: RightBrace
TK: Semicolon         TK: Comma
TK: Op_assign         TK: Op_not
: (BINARY?)   [ #TK @ ] literal >= ;
TK: Op_subtract       TK: Op_add
TK: Op_mod            TK: Op_multiply       TK: Op_divide
TK: Op_equal          TK: Op_notequal
TK: Op_less           TK: Op_lessequal
TK: Op_greater        TK: Op_greaterequal
TK: Op_and            TK: Op_or
CREATE TOKEN  0 , 0 , 0 , 0 ,
: TOKEN-TYPE   TOKEN 2 CELLS + @ ;
: TOKEN-VALUE   TOKEN 3 CELLS + @ ;
: GETTOK   GETINT GETINT TOKEN 2!
           GETNAM FIND DROP EXECUTE
	   DUP Integer    = IF GETINT ELSE
	   DUP String     = IF GETSTR INTERN ELSE
	   DUP Identifier = IF GETNAM INTERN ELSE
	   0 THEN THEN THEN
	   TOKEN 3 CELLS + !  TOKEN 2 CELLS + ! ;
: BINARY?   TOKEN-TYPE (BINARY?) ;

CREATE PREC #TK @ CELLS ALLOT  PREC #TK @ CELLS -1 FILL
: PREC!   CELLS PREC + ! ;
14 Op_not          PREC!  13 Op_multiply     PREC!
13 Op_divide       PREC!  13 Op_mod          PREC!
12 Op_add          PREC!  12 Op_subtract     PREC!
10 Op_less         PREC!  10 Op_greater      PREC!
10 Op_lessequal    PREC!  10 Op_greaterequal PREC!
 9 Op_equal        PREC!   9 Op_notequal     PREC!
 5 Op_and          PREC!   4 Op_or           PREC!
: [email protected]   CELLS PREC + @ ;

\ Each AST Node is a sequence of cells in data space consisting
\ of the execution token of a printing word, followed by that
\ node's data.  Each printing word receives the address of the
\ node's data, and is responsible for printing that data
\ appropriately.

DEFER .NODE
: .NULL   DROP ." ;" CR ;
CREATE $NULL  ' .NULL ,
: .IDENTIFIER   ." Identifier " @ COUNT TYPE CR ;
: $IDENTIFIER ( a-addr --)  HERE SWAP  ['] .IDENTIFIER , , ;
: .INTEGER   ." Integer " @ . CR ;
: $INTEGER ( n --)  HERE SWAP  ['] .INTEGER , , ;
: "TYPE"   [CHAR] " EMIT  TYPE  [CHAR] " EMIT ;
: .STRING   ." String " @ COUNT "TYPE" CR ;
: $STRING ( a-addr --)  HERE SWAP  ['] .STRING , , ;
: .LEAF   DUP  @ COUNT TYPE CR  CELL+ @ .NODE  0 .NULL ;
: LEAF   CREATE HERE CELL+ ,  BL WORD INTERN .
          DOES> HERE >R ['] .LEAF ,  @ , ,  R> ;
LEAF $PRTC Prtc    LEAF $PRTS Prts       LEAF $PRTI Prti
LEAF $NOT Not      LEAF $NEGATE Negate
: .BINARY   DUP  @ COUNT TYPE CR
            CELL+ DUP @ .NODE  CELL+ @ .NODE ;
: BINARY   CREATE HERE CELL+ ,  BL WORD INTERN .
           DOES> HERE >R ['] .BINARY ,  @ ,  SWAP 2,  R> ;
BINARY $SEQUENCE Sequence   BINARY $ASSIGN Assign
BINARY $WHILE While         BINARY $IF If
BINARY $SUBTRACT Subtract   BINARY $ADD Add
BINARY $MOD Mod             BINARY $MULTIPLY Multiply
BINARY $DIVIDE Divide
BINARY $LESS Less           BINARY $LESSEQUAL LessEqual
BINARY $GREATER Greater     BINARY $GREATEREQUAL GreaterEqual
BINARY $EQUAL Equal         BINARY $NOTEQUAL NotEqual
BINARY $AND And             BINARY $OR Or

: TOK-CONS ( x* -- node-xt) TOKEN-TYPE  CASE
   Op_subtract     OF ['] $SUBTRACT     ENDOF
   Op_add          OF ['] $ADD          ENDOF
   op_mod          OF ['] $MOD          ENDOF
   op_multiply     OF ['] $MULTIPLY     ENDOF
   Op_divide       OF ['] $DIVIDE       ENDOF
   Op_equal        OF ['] $EQUAL        ENDOF
   Op_notequal     OF ['] $NOTEQUAL     ENDOF
   Op_less         OF ['] $LESS         ENDOF
   Op_lessequal    OF ['] $LESSEQUAL    ENDOF
   Op_greater      OF ['] $GREATER      ENDOF
   Op_greaterequal OF ['] $GREATEREQUAL ENDOF
   Op_and          OF ['] $AND          ENDOF
   Op_or           OF ['] $OR           ENDOF
   ENDCASE ;

: (.NODE)   DUP CELL+ SWAP @ EXECUTE ;
' (.NODE) IS .NODE

: .- ( n --)  0 <# #S #> TYPE ;
: EXPECT ( tk --)  DUP TOKEN-TYPE <>
   IF CR ." stdin:" TOKEN [email protected] SWAP .- ." :" .-
     ." : unexpected token, expecting " . CR BYE
   THEN  DROP GETTOK ;
: '('   LeftParen EXPECT ;
: ')'   RightParen EXPECT ;
: '}'   RightBrace EXPECT ;
: ';'   Semicolon EXPECT ;
: ','   Comma EXPECT ;
: '='   Op_assign EXPECT ;

DEFER *EXPR  DEFER EXPR  DEFER STMT
: PAREN-EXPR   '(' EXPR ')' ;
: PRIMARY
   TOKEN-TYPE LeftParen   = IF PAREN-EXPR              EXIT THEN
   TOKEN-TYPE Op_add      = IF GETTOK 12 *EXPR         EXIT THEN
   TOKEN-TYPE Op_subtract = IF GETTOK 14 *EXPR $NEGATE EXIT THEN
   TOKEN-TYPE Op_not      = IF GETTOK 14 *EXPR $NOT    EXIT THEN
   TOKEN-TYPE Identifier  = IF TOKEN-VALUE $IDENTIFIER      ELSE
   TOKEN-TYPE Integer     = IF TOKEN-VALUE $INTEGER    THEN THEN
   GETTOK ;
: (*EXPR) ( n -- node)
   PRIMARY ( n node)
   BEGIN OVER TOKEN-TYPE [email protected] SWAP OVER <=  BINARY?  AND
   WHILE ( n node prec) 1+ TOK-CONS SWAP GETTOK *EXPR SWAP EXECUTE
   REPEAT ( n node prec) DROP NIP ( node) ;
: (EXPR)   0 *EXPR ;
: -)?   TOKEN-TYPE RightParen <> ;
: -}?   TOKEN-TYPE RightBrace <> ;
: (STMT)
   TOKEN-TYPE Semicolon = IF GETTOK STMT EXIT THEN
   TOKEN-TYPE Keyword_while =
     IF GETTOK  PAREN-EXPR STMT $WHILE  EXIT THEN
   TOKEN-TYPE Keyword_if =
     IF GETTOK  PAREN-EXPR STMT
       TOKEN-TYPE Keyword_else = IF GETTOK STMT ELSE $NULL THEN
       $IF $IF EXIT
     THEN
   TOKEN-TYPE Keyword_putc =
     IF GETTOK  PAREN-EXPR ';' $PRTC  EXIT THEN
   TOKEN-TYPE Keyword_print =
     IF GETTOK  '(' $NULL
        BEGIN TOKEN-TYPE String =
           IF TOKEN-VALUE $STRING $PRTS  GETTOK
           ELSE EXPR $PRTI THEN  $SEQUENCE  -)?
        WHILE ',' REPEAT  ')' ';'  EXIT THEN
   TOKEN-TYPE Identifier =
     IF TOKEN-VALUE $IDENTIFIER GETTOK '=' EXPR ';' $ASSIGN
        EXIT THEN
   TOKEN-TYPE LeftBrace =
     IF $NULL GETTOK BEGIN -}? WHILE STMT $SEQUENCE REPEAT
        '}' EXIT THEN
   TOKEN-TYPE End_of_input = IF EXIT THEN  EXPR ;
' (*EXPR) IS *EXPR  ' (EXPR) IS EXPR  ' (STMT) IS STMT

: -EOI?   TOKEN-TYPE End_of_input <> ;
: PARSE   $NULL GETTOK BEGIN -EOI? WHILE STMT $SEQUENCE REPEAT ;
PARSE  .NODE


// This is a little endian machine
const WORD_SIZE=4;
const{ var _n=-1; var[proxy]N=fcn{ _n+=1 } }  // enumerator
const FETCH=N, STORE=N, PUSH=N, ADD=N, SUB=N, MUL=N, DIV=N, MOD=N,
   LT=N, GT=N, LE=N, GE=N, EQ=N, NE=N, AND=N, OR=N, NEG=N, NOT=N,
   JMP=N, JZ=N, PRTC=N, PRTS=N, PRTI=N, HALT=N;

var [const]
   bops=Dictionary(ADD,'+, SUB,'-, MUL,'*, DIV,'/, MOD,'%,
		   LT,'<, GT,'>, LE,'<=, GE,'>=, NE,'!=, EQ,'==, NE,'!=),
   strings=List();  // filled in by the loader
;

   // do a binary op
fcn bop(stack,op){ a,b:=stack.pop(),stack.pop(); stack.append(bops[op](b,a)) }

fcn run_vm(code,stackSz){
   stack,pc := List.createLong(stackSz,0), 0;
   while(True){
      op:=code[pc]; pc+=1;
      switch(op){
         case(FETCH){
	    stack.append(stack[code.toLittleEndian(pc,WORD_SIZE,False)]);
            pc+=WORD_SIZE;
	 }
	 case(STORE){
	    stack[code.toLittleEndian(pc,WORD_SIZE)]=stack.pop();
	    pc+=WORD_SIZE;
	 }
         case(PUSH){
	    stack.append(code.toLittleEndian(pc,WORD_SIZE,False));  // signed
	    pc+=WORD_SIZE;
	 }
	 case(ADD,SUB,MUL,DIV,MOD,LT,GT,LE,GE,EQ,NE) { bop(stack,op) }
	 case(AND){ stack[-2] = stack[-2] and stack[-1]; stack.pop() }
	 case(OR) { stack[-2] = stack[-2] or  stack[-1]; stack.pop() }
	 case(NEG){ stack[-1] = -stack[-1]    }
	 case(NOT){ stack[-1] = not stack[-1] }
	 case(JMP){ pc+=code.toLittleEndian(pc,WORD_SIZE,False); }  // signed
	 case(JZ) {
	    if(stack.pop()) pc+=WORD_SIZE;
	    else            pc+=code.toLittleEndian(pc,WORD_SIZE,False);
	 }
	 case(PRTC){ }	// not implemented
	 case(PRTS){ print(strings[stack.pop()]) }
	 case(PRTI){ print(stack.pop()) }
	 case(HALT){ break }
	 else{ throw(Exception.AssertionError(
		"Bad op code (%d) @%d".fmt(op,pc-1))) }
      }
   }
}

code:=File(vm.nthArg(0)).read();	// binary code file
    // the string table is prepended to the code:
    //    66,1 byte len,text, no trailing '\0' needed
while(code[0]==66){	// read the string table
   sz:=code[1];
   strings.append(code[2,sz].text);
   code.del(0,sz+2);
}
run_vm(code,1000);


/* ARM assembly Raspberry PI  */
/*  program commandLine.s   */

/* Constantes    */
.equ STDOUT, 1                         @ Linux output console
.equ EXIT,   1                         @ Linux syscall
.equ WRITE,  4                         @ Linux syscall
/* Initialized data */
.data
szCarriageReturn:  .asciz "\n"

/* UnInitialized data */
.bss
.align 4

/*  code section */
.text
.global main
main:                                   @ entry of program
    push {fp,lr}                        @ saves registers
    add fp,sp,#8                        @  fp <- start address
    ldr r4,[fp]                         @ number of Command line arguments
    add r5,fp,#4                        @ first parameter address
    mov r2,#0                           @ init loop counter
loop:
    ldr r0,[r5,r2,lsl #2]               @ string address parameter
    bl affichageMess                    @ display string
    ldr r0,iAdrszCarriageReturn
    bl affichageMess                    @ display carriage return
    add r2,#1                           @ increment counter
    cmp r2,r4                           @ number parameters ?
    blt loop                            @ loop

100:                                    @ standard end of the program
    mov r0, #0                          @ return code
    pop {fp,lr}                         @restaur  registers
    mov r7, #EXIT                       @ request to exit program
    swi 0                               @ perform the system call

iAdrszCarriageReturn:    .int szCarriageReturn

/******************************************************************/
/*     display text with size calculation                         */
/******************************************************************/
/* r0 contains the address of the message */
affichageMess:
    push {r0,r1,r2,r7,lr}                          @ save  registres
    mov r2,#0                                      @ counter length
1:                                                 @ loop length calculation
    ldrb r1,[r0,r2]                                @ read octet start position + index
    cmp r1,#0                                      @ if 0 its over
    addne r2,r2,#1                                 @ else add 1 in the length
    bne 1b                                         @ and loop
                                                   @ so here r2 contains the length of the message
    mov r1,r0                                      @ address message in r1
    mov r0,#STDOUT                                 @ code to write to the standard output Linux
    mov r7, #WRITE                                 @ code call system "write"
    svc #0                                         @ call systeme
    pop {r0,r1,r2,r7,lr}                           @ restaur 2 registres
    bx lr                                          @ return


import os, re, streams, strformat, strutils, tables, std/decls

type

  # AST node types.
  NodeKind = enum
             nIdentifier = "Identifier"
             nString = "String"
             nInteger = "Integer"
             nSequence = "Sequence"
             nIf = "If"
             nPrtc = "Prtc"
             nPrts = "Prts"
             nPrti = "Prti"
             nWhile = "While"
             nAssign = "Assign"
             nNegate = "Negate"
             nNot = "Not"
             nMultiply = "Multiply"
             nDivide = "Divide"
             nMod = "Mod"
             nAdd = "Add"
             nSubtract = "Subtract"
             nLess = "Less"
             nLessEqual = "LessEqual"
             nGreater = "Greater"
             nGreaterEqual = "GreaterEqual"
             nEqual = "Equal"
             nNotEqual = "NotEqual"
             nAnd = "And"
             nOr = "Or"

  # Ast node description.
  Node = ref object
    left: Node
    right: Node
    case kind: NodeKind
    of nString: stringVal: string
    of nInteger: intVal: int
    of nIdentifier: name: string
    else: nil

  # Virtual machine opcodes.
  OpCode = enum
           opFetch = "fetch"
           opStore = "store"
           opPush = "push"
           opJmp = "jmp"
           opJz = "jz"
           opAdd = "add"
           opSub = "sub"
           opMul = "mul"
           opDiv = "div"
           opMod = "mod"
           opLt = "lt"
           opgt = "gt"
           opLe = "le"
           opGe = "ge"
           opEq = "eq"
           opNe = "ne"
           opAnd = "and"
           opOr = "or"
           opNeg = "neg"
           opNot = "not"
           opPrtc = "prtc"
           opPrti = "prti"
           opPrts = "prts"
           opHalt = "halt"
           opInvalid = "invalid"

  # Code generator context.
  CodeGen = object
    address: int              # Current address in code part.
    instr: seq[string]        # List of instructions.
    vars: Table[string, int]  # Mapping variable name -> variable index.
    strings: seq[string]      # List of strings.

  # Node ranges.
  UnaryOpNode = range[nNegate..nNot]
  BinaryOpNode = range[nMultiply..nOr]
  PrintNode = range[nPrtc..nPrti]

const

  # Mapping unary operator Node -> OpCode.
  UnOp: array[UnaryOpNode, OpCode] = [opNeg, opNot]

  # Mapping binary operator Node -> OpCode.
  BinOp: array[BinaryOpNode, OpCode] = [opMul, opDiv, opMod, opAdd, opSub, opLt,
                                        opLe, opGt, opGe, opEq, opNe, opAnd, opOr]

  # Mapping print Node -> OpCode.
  PrintOp: array[PrintNode, OpCode] = [opPrtc, opPrts, opPrti]

####################################################################################################
# Code generator.

proc genSimpleInst(gen: var CodeGen; opcode: OpCode) =
  ## Build a simple instruction (no operand).
  gen.instr.add &"{gen.address:>5} {opcode}"

#---------------------------------------------------------------------------------------------------

proc genMemInst(gen: var CodeGen; opcode: OpCode; memIndex: int) =
  ## Build a memory access instruction (opFetch, opStore).
  gen.instr.add &"{gen.address:>5} {opcode:<5} [{memIndex}]"

#---------------------------------------------------------------------------------------------------

proc genJumpInst(gen: var CodeGen; opcode: OpCode): int =
  ## Build a jump instruction. We use the letters X and Y as placeholders
  ## for the offset and the target address.
  result = gen.instr.len
  gen.instr.add &"{gen.address:>5} {opcode:<5} (X) Y"

#---------------------------------------------------------------------------------------------------

proc genPush(gen: var CodeGen; value: int) =
  ## Build a push instruction.
  gen.instr.add &"{gen.address:>5} {opPush:<5} {value}"

#---------------------------------------------------------------------------------------------------

proc updateJumpInst(gen: var CodeGen; index: int; jumpAddress, targetAddress: int) =
  ## Update the offset and the target address of a jump instruction.

  var instr {.byAddr.} = gen.instr[index]
  let offset = targetAddress - jumpAddress - 1
  for idx in countdown(instr.high, 0):
    case instr[idx]
    of 'Y':
      instr[idx..idx] = $targetAddress
    of 'X':
      instr[idx..idx] = $offset
      break
    else:
      discard

#---------------------------------------------------------------------------------------------------

proc process(gen: var CodeGen; node: Node) =
  ## Generate code for a node.

  if node.isNil: return

  case node.kind:

  of nInteger:
    gen.genPush(node.intVal)
    inc gen.address, 5

  of nIdentifier:
    if node.name notin gen.vars:
      gen.vars[node.name] = gen.vars.len
    gen.genMemInst(opFetch, gen.vars[node.name])
    inc gen.address, 5

  of nString:
    var index = gen.strings.find(node.stringVal)
    if index < 0:
      index = gen.strings.len
      gen.strings.add(node.stringVal)
    gen.genPush(index)
    inc gen.address, 5

  of nAssign:
    gen.process(node.right)
    if node.left.name notin gen.vars:
      gen.vars[node.left.name] = gen.vars.len
    gen.genMemInst(opStore, gen.vars[node.left.name])
    inc gen.address, 5

  of UnaryOpNode.low..UnaryOpNode.high:
    gen.process(node.left)
    gen.genSimpleInst(UnOp[node.kind])
    inc gen.address

  of BinaryOpNode.low..BinaryOpNode.high:
    gen.process(node.left)
    gen.process(node.right)
    gen.genSimpleInst(BinOp[node.kind])
    inc gen.address

  of PrintNode.low..PrintNode.high:
    gen.process(node.left)
    gen.genSimpleInst(PrintOp[node.kind])
    inc gen.address

  of nIf:
    # Generate condition expression.
    gen.process(node.left)
    # Generate jump if zero.
    let jzAddr = gen.address
    let jzInst = gen.genJumpInst(opJz)
    inc gen.address, 5
    # Generate then branch expression.
    gen.process(node.right.left)
    # If there is an "else" clause, generate unconditional jump
    var jmpAddr, jmpInst: int
    let hasElseClause = not node.right.right.isNil
    if hasElseClause:
      jmpAddr = gen.address
      jmpInst = gen.genJumpInst(opJmp)
      inc gen.address, 5
    # Update JZ offset.
    gen.updateJumpInst(jzInst, jzAddr, gen.address)
    # Generate else expression.
    if hasElseClause:
      gen.process(node.right.right)
      # Update JMP offset.
      gen.updateJumpInst(jmpInst, jmpAddr, gen.address)

  of nWhile:
    let condAddr = gen.address
    # Generate condition expression.
    gen.process(node.left)
    # Generate jump if zero.
    let jzAddr = gen.address
    let jzInst = gen.genJumpInst(opJz)
    inc gen.address, 5
    # Generate loop code.
    gen.process(node.right)
    # Generate unconditional jump.
    let jmpAddr = gen.address
    let jmpInst = gen.genJumpInst(opJmp)
    inc gen.address, 5
    # Update JMP offset.
    gen.updateJumpInst(jmpInst, jmpAddr, condAddr)
    # Update JZ offset.
    gen.updateJumpInst(jzInst, jzAddr, gen.address)

  of nSequence:
    gen.process(node.left)
    gen.process(node.right)

#---------------------------------------------------------------------------------------------------

proc run(gen: var CodeGen; ast: Node) =
  ## Run the code generator on the AST.

  # Process recursively the nodes.
  gen.process(ast)
  gen.genSimpleInst(opHalt)   # Add a Halt operator at the end.

  # Output header.
  echo &"Datasize: {gen.vars.len} Strings: {gen.strings.len}"
  # Output strings.
  for s in gen.strings:
    echo s.escape().replace("\\x0A", "\\n")
  # Output code.
  for inst in gen.instr:
    echo inst

####################################################################################################
# AST loader.

proc newNode(kind: NodeKind; left: Node; right: Node = nil): Node =
  ## Create a new node with given left and right children.
  result = Node(kind: kind, left: left, right: right)

#---------------------------------------------------------------------------------------------------

proc loadAst(stream: Stream): Node =
  ## Load a linear AST and build a binary tree.

  let line = stream.readLine().strip()
  if line.startsWith(';'):
    return nil

  var fields = line.split(' ', 1)
  let kind = parseEnum[NodeKind](fields[0])
  if kind in {nIdentifier, nString, nInteger}:
    if fields.len < 2:
      raise newException(ValueError, "Missing value field for " & fields[0])
    else:
      fields[1] = fields[1].strip()
  case kind
  of nIdentifier:
    return Node(kind: nIdentifier, name: fields[1])
  of nString:
    let str = fields[1].replacef(re"([^\\])(\\n)", "$1\n").replace(r"\\", r"\").replace("\"", "")
    return Node(kind: nString, stringVal: str)
  of nInteger:
    return Node(kind: nInteger, intVal: parseInt(fields[1]))
  else:
    if fields.len > 1:
      raise newException(ValueError, "Extra field for " & fields[0])

  let left = stream.loadAst()
  let right = stream.loadAst()
  result = newNode(kind, left, right)

#———————————————————————————————————————————————————————————————————————————————————————————————————

var stream: Stream
var toClose = false
var codegen: CodeGen

if paramCount() < 1:
  stream = newFileStream(stdin)
else:
  stream = newFileStream(paramStr(1))
  toClose = true

let ast = loadAst(stream)
if toClose: stream.close()

codegen.run(ast)


#!/usr/bin/perl

use strict;   # gen.pl - flatAST to stack machine code
use warnings; # http://www.rosettacode.org/wiki/Compiler/code_generator

my $stringcount = my $namecount = my $pairsym = my $pc = 0;
my (%strings, %names);
my %opnames = qw( Less lt LessEqual le Multiply mul Subtract sub Divide div
  GreaterEqual ge Equal eq Greater gt NotEqual ne Negate neg );

sub tree
  {
  my ($A, $B) = ( '_' . ++$pairsym, '_' . ++$pairsym ); # labels for jumps
  my $line = <> // return '';
  (local $_, my $arg) = $line =~ /^(\w+|;)\s+(.*)/ or die "bad input $line";
  /Identifier/ ? "fetch [@{[ $names{$arg} //= $namecount++ ]}]\n" :
    /Sequence/ ? tree() . tree() :
    /Integer/  ? "push  $arg\n" :
    /String/   ? "push  @{[ $strings{$arg} //= $stringcount++ ]}\n" :
    /Assign/   ? join '', reverse tree() =~ s/fetch/store/r, tree() :
    /While/    ? "$A:\n@{[ tree() ]}jz    $B\n@{[ tree() ]}jmp   $A\n$B:\n" :
    /If/       ? tree() . "jz    $A\n@{[ !<> . # !<> skips second 'If'
                  tree() ]}jmp   $B\n$A:\n@{[ tree() ]}$B:\n" :
    /;/        ? '' :
    tree() . tree() . ($opnames{$_} // lc) . "\n";
  }

$_ = tree() . "halt\n";

s/^jmp\s+(\S+)\n(_\d+:\n)\1:\n/$2/gm;                # remove jmp next
s/^(?=[a-z]\w*(.*))/                                 # add locations
  (sprintf("%4d ", $pc), $pc += $1 ? 5 : 1)[0] /gem;
my %labels = /^(_\d+):(?=(?:\n_\d+:)*\n *(\d+) )/gm; # pc addr of labels
s/^ *(\d+) j(?:z|mp) *\K(_\d+)$/ (@{[                # fix jumps
  $labels{$2} - $1 - 1]}) $labels{$2}/gm;
s/^_\d+.*\n//gm;                                     # remove labels

print "Datasize: $namecount Strings: $stringcount\n";
print "$_\n" for sort { $strings{$a} <=> $strings{$b} } keys %strings;
print;


* An asterisk in column one denotes a comment line
* Comments may also follow any syntactically complete instruction:
         LA    1,0           Comment
         NOP                 Comment (after a NOP instruction)
* Comments after instructions with omitted operands require a comma ","
         END   ,             Comment (without comma, "Comment" assumed an operand of "END")


`Comments in 4th Dimension begin with the accent character and extend to the end of the line (until 4D version 2004).
// This is a comment starting from 4D v11 and newer. Accent character is replaced by //


nop           ; comments begin with a semicolon


!!!
!!! An implementation of the Rosetta Code parser task:
!!! https://rosettacode.org/wiki/Compiler/syntax_analyzer
!!!
!!! The implementation is based on the published pseudocode.
!!!

module compiler_type_kinds
  use, intrinsic :: iso_fortran_env, only: int32
  use, intrinsic :: iso_fortran_env, only: int64

  implicit none
  private

  ! Synonyms.
  integer, parameter, public :: size_kind = int64
  integer, parameter, public :: length_kind = size_kind
  integer, parameter, public :: nk = size_kind

  ! Synonyms for character capable of storing a Unicode code point.
  integer, parameter, public :: unicode_char_kind = selected_char_kind ('ISO_10646')
  integer, parameter, public :: ck = unicode_char_kind

  ! Synonyms for integers capable of storing a Unicode code point.
  integer, parameter, public :: unicode_ichar_kind = int32
  integer, parameter, public :: ick = unicode_ichar_kind
end module compiler_type_kinds

module string_buffers
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, intrinsic :: iso_fortran_env, only: int64
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick

  implicit none
  private

  public :: strbuf_t

  type :: strbuf_t
     integer(kind = nk), private :: len = 0
     !
     ! ‘chars’ is made public for efficient access to the individual
     ! characters.
     !
     character(1, kind = ck), allocatable, public :: chars(:)
   contains
     procedure, pass, private :: ensure_storage => strbuf_t_ensure_storage
     procedure, pass :: to_unicode_full_string => strbuf_t_to_unicode_full_string
     procedure, pass :: to_unicode_substring => strbuf_t_to_unicode_substring
     procedure, pass :: length => strbuf_t_length
     procedure, pass :: set => strbuf_t_set
     procedure, pass :: append => strbuf_t_append
     generic :: to_unicode => to_unicode_full_string
     generic :: to_unicode => to_unicode_substring
     generic :: assignment(=) => set
  end type strbuf_t

contains

  function strbuf_t_to_unicode_full_string (strbuf) result (s)
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable :: s

    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !

    integer(kind = nk) :: i

    allocate (character(len = strbuf%len, kind = ck) :: s)
    do i = 1, strbuf%len
       s(i:i) = strbuf%chars(i)
    end do
  end function strbuf_t_to_unicode_full_string

  function strbuf_t_to_unicode_substring (strbuf, i, j) result (s)
    !
    ! ‘Extreme’ values of i and j are allowed, as shortcuts for ‘from
    ! the beginning’, ‘up to the end’, or ‘empty substring’.
    !
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i, j
    character(:, kind = ck), allocatable :: s

    !
    ! This does not actually ensure that the string is valid Unicode;
    ! any 31-bit ‘character’ is supported.
    !

    integer(kind = nk) :: i1, j1
    integer(kind = nk) :: n
    integer(kind = nk) :: k

    i1 = max (1_nk, i)
    j1 = min (strbuf%len, j)
    n = max (0_nk, (j1 - i1) + 1_nk)

    allocate (character(n, kind = ck) :: s)
    do k = 1, n
       s(k:k) = strbuf%chars(i1 + (k - 1_nk))
    end do
  end function strbuf_t_to_unicode_substring

  elemental function strbuf_t_length (strbuf) result (n)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk) :: n

    n = strbuf%len
  end function strbuf_t_length

  elemental function next_power_of_two (x) result (y)
    integer(kind = nk), intent(in) :: x
    integer(kind = nk) :: y

    !
    ! It is assumed that no more than 64 bits are used.
    !
    ! The branch-free algorithm is that of
    ! https://archive.is/nKxAc#RoundUpPowerOf2
    !
    ! Fill in bits until one less than the desired power of two is
    ! reached, and then add one.
    !

    y = x - 1
    y = ior (y, ishft (y, -1))
    y = ior (y, ishft (y, -2))
    y = ior (y, ishft (y, -4))
    y = ior (y, ishft (y, -8))
    y = ior (y, ishft (y, -16))
    y = ior (y, ishft (y, -32))
    y = y + 1
  end function next_power_of_two

  elemental function new_storage_size (length_needed) result (size)
    integer(kind = nk), intent(in) :: length_needed
    integer(kind = nk) :: size

    ! Increase storage by orders of magnitude.

    if (2_nk**32 < length_needed) then
       size = huge (1_nk)
    else
       size = next_power_of_two (length_needed)
    end if
  end function new_storage_size

  subroutine strbuf_t_ensure_storage (strbuf, length_needed)
    class(strbuf_t), intent(inout) :: strbuf
    integer(kind = nk), intent(in) :: length_needed

    integer(kind = nk) :: new_size
    type(strbuf_t) :: new_strbuf

    if (.not. allocated (strbuf%chars)) then
       ! Initialize a new strbuf%chars array.
       new_size = new_storage_size (length_needed)
       allocate (strbuf%chars(1:new_size))
    else if (ubound (strbuf%chars, 1) < length_needed) then
       ! Allocate a new strbuf%chars array, larger than the current
       ! one, but containing the same characters.
       new_size = new_storage_size (length_needed)
       allocate (new_strbuf%chars(1:new_size))
       new_strbuf%chars(1:strbuf%len) = strbuf%chars(1:strbuf%len)
       call move_alloc (new_strbuf%chars, strbuf%chars)
    end if
  end subroutine strbuf_t_ensure_storage

  subroutine strbuf_t_set (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n = len (src, kind = nk)
       call dst%ensure_storage(n)
       do i = 1, n
          dst%chars(i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n = src%len
       call dst%ensure_storage(n)
       dst%chars(1:n) = src%chars(1:n)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_set

  subroutine strbuf_t_append (dst, src)
    class(strbuf_t), intent(inout) :: dst
    class(*), intent(in) :: src

    integer(kind = nk) :: n_dst, n_src, n
    integer(kind = nk) :: i

    select type (src)
    type is (character(*, kind = ck))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    type is (character(*))
       n_dst = dst%len
       n_src = len (src, kind = nk)
       n = n_dst + n_src
       call dst%ensure_storage(n)
       do i = 1, n_src
          dst%chars(n_dst + i) = src(i:i)
       end do
       dst%len = n
    class is (strbuf_t)
       n_dst = dst%len
       n_src = src%len
       n = n_dst + n_src
       call dst%ensure_storage(n)
       dst%chars((n_dst + 1):n) = src%chars(1:n_src)
       dst%len = n
    class default
       error stop
    end select
  end subroutine strbuf_t_append

end module string_buffers

module reading_one_line_from_a_stream
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers

  implicit none
  private

  ! get_line_from_stream: read an entire input line from a stream into
  ! a strbuf_t.
  public :: get_line_from_stream

  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)

  ! The following is correct for Unix and its relatives.
  character(1, kind = ck), parameter :: newline_char = linefeed_char

contains

  subroutine get_line_from_stream (unit_no, eof, no_newline, strbuf)
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof ! End of file?
    logical, intent(out) :: no_newline ! There is a line but it has no
                                       ! newline? (Thus eof also must
                                       ! be .true.)
    class(strbuf_t), intent(inout) :: strbuf

    character(1, kind = ck) :: ch

    strbuf = ''
    call get_ch (unit_no, eof, ch)
    do while (.not. eof .and. ch /= newline_char)
       call strbuf%append (ch)
       call get_ch (unit_no, eof, ch)
    end do
    no_newline = eof .and. (strbuf%length() /= 0)
  end subroutine get_line_from_stream

  subroutine get_ch (unit_no, eof, ch)
    !
    ! Read a single code point from the stream.
    !
    ! Currently this procedure simply inputs ‘ASCII’ bytes rather than
    ! Unicode code points.
    !
    integer, intent(in) :: unit_no
    logical, intent(out) :: eof
    character(1, kind = ck), intent(out) :: ch

    integer :: stat
    character(1) :: c = '*'

    eof = .false.

    if (unit_no == input_unit) then
       call get_input_unit_char (c, stat)
    else
       read (unit = unit_no, iostat = stat) c
    end if

    if (stat < 0) then
       ch = ck_'*'
       eof = .true.
    else if (0 < stat) then
       write (error_unit, '("Input error with status code ", I0)') stat
       stop 1
    else
       ch = char (ichar (c, kind = ick), kind = ck)
    end if
  end subroutine get_ch

!!!
!!! If you tell gfortran you want -std=f2008 or -std=f2018, you likely
!!! will need to add also -fall-intrinsics or -U__GFORTRAN__
!!!
!!! The first way, you get the FGETC intrinsic. The latter way, you
!!! get the C interface code that uses getchar(3).
!!!
#ifdef __GFORTRAN__

  subroutine get_input_unit_char (c, stat)
    !
    ! The following works if you are using gfortran.
    !
    ! (FGETC is considered a feature for backwards compatibility with
    ! g77. However, I know of no way to reconfigure input_unit as a
    ! Fortran 2003 stream, for use with ordinary ‘read’.)
    !
    character, intent(inout) :: c
    integer, intent(out) :: stat

    call fgetc (input_unit, c, stat)
  end subroutine get_input_unit_char

#else

  subroutine get_input_unit_char (c, stat)
    !
    ! An alternative implementation of get_input_unit_char. This
    ! actually reads input from the C standard input, which might not
    ! be the same as input_unit.
    !
    use, intrinsic :: iso_c_binding, only: c_int
    character, intent(inout) :: c
    integer, intent(out) :: stat

    interface
       !
       ! Use getchar(3) to read characters from standard input. This
       ! assumes there is actually such a function available, and that
       ! getchar(3) does not exist solely as a macro. (One could write
       ! one’s own getchar() if necessary, of course.)
       !
       function getchar () result (c) bind (c, name = 'getchar')
         use, intrinsic :: iso_c_binding, only: c_int
         integer(kind = c_int) :: c
       end function getchar
    end interface

    integer(kind = c_int) :: i_char

    i_char = getchar ()
    !
    ! The C standard requires that EOF have a negative value. If the
    ! value returned by getchar(3) is not EOF, then it will be
    ! representable as an unsigned char. Therefore, to check for end
    ! of file, one need only test whether i_char is negative.
    !
    if (i_char < 0) then
       stat = -1
    else
       stat = 0
       c = char (i_char)
    end if
  end subroutine get_input_unit_char

#endif

end module reading_one_line_from_a_stream

module lexer_token_facts
  implicit none
  private

  integer, parameter, public :: tk_EOI = 0
  integer, parameter, public :: tk_Mul = 1
  integer, parameter, public :: tk_Div = 2
  integer, parameter, public :: tk_Mod = 3
  integer, parameter, public :: tk_Add = 4
  integer, parameter, public :: tk_Sub = 5
  integer, parameter, public :: tk_Negate = 6
  integer, parameter, public :: tk_Not = 7
  integer, parameter, public :: tk_Lss = 8
  integer, parameter, public :: tk_Leq = 9
  integer, parameter, public :: tk_Gtr = 10
  integer, parameter, public :: tk_Geq = 11
  integer, parameter, public :: tk_Eq = 12
  integer, parameter, public :: tk_Neq = 13
  integer, parameter, public :: tk_Assign = 14
  integer, parameter, public :: tk_And = 15
  integer, parameter, public :: tk_Or = 16
  integer, parameter, public :: tk_If = 17
  integer, parameter, public :: tk_Else = 18
  integer, parameter, public :: tk_While = 19
  integer, parameter, public :: tk_Print = 20
  integer, parameter, public :: tk_Putc = 21
  integer, parameter, public :: tk_Lparen = 22
  integer, parameter, public :: tk_Rparen = 23
  integer, parameter, public :: tk_Lbrace = 24
  integer, parameter, public :: tk_Rbrace = 25
  integer, parameter, public :: tk_Semi = 26
  integer, parameter, public :: tk_Comma = 27
  integer, parameter, public :: tk_Ident = 28
  integer, parameter, public :: tk_Integer = 29
  integer, parameter, public :: tk_String = 30
  integer, parameter, public :: tk_Positive = 31

  character(16), parameter, public :: lexer_token_string(0:31) = &
       (/ "EOI             ",   &
       &  "*               ",   &
       &  "/               ",   &
       &  "%               ",   &
       &  "+               ",   &
       &  "-               ",   &
       &  "-               ",   &
       &  "!               ",   &
       &  "<               ",   &
       &  "<=              ",   &
       &  ">               ",   &
       &  ">=              ",   &
       &  "==              ",   &
       &  "!=              ",   &
       &  "=               ",   &
       &  "&&              ",   &
       &  "||              ",   &
       &  "if              ",   &
       &  "else            ",   &
       &  "while           ",   &
       &  "print           ",   &
       &  "putc            ",   &
       &  "(               ",   &
       &  ")               ",   &
       &  "{               ",   &
       &  "}               ",   &
       &  ";               ",   &
       &  ",               ",   &
       &  "Ident           ",   &
       &  "Integer literal ",   &
       &  "String literal  ",   &
       &  "+               " /)

  integer, parameter, public :: lexer_token_arity(0:31) = &
       & (/ -1,                   & ! EOI
       &    2, 2, 2, 2, 2,        & ! * / % + -
       &    1, 1,                 & ! negate !
       &    2, 2, 2, 2, 2, 2,     & ! < <= > >= == !=
       &    -1,                   & ! =
       &    2, 2,                 & ! && ||
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1,       & !
       &    1 /)                    ! positive

  integer, parameter, public :: lexer_token_precedence(0:31) = &
       & (/ -1,                   & ! EOI
       &    13, 13, 13,           & ! * / %
       &    12, 12,               & ! + -
       &    14, 14,               & ! negate !
       &    10, 10, 10, 10,       & ! < <= > >=
       &    9, 9,                 & ! == !=
       &    -1,                   & ! =
       &    5,                    & ! &&
       &    4,                    & ! ||
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1, -1,   & !
       &    -1, -1, -1, -1,       & !
       &    14 /)                   ! positive

  integer, parameter, public :: left_associative = 0
  integer, parameter, public :: right_associative = 1

  ! All current operators are left associative. (The values in the
  ! array for things that are not operators are unimportant.)
  integer, parameter, public :: lexer_token_associativity(0:31) = left_associative

end module lexer_token_facts

module reading_of_lexer_tokens
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: reading_one_line_from_a_stream
  use, non_intrinsic :: lexer_token_facts

  implicit none
  private

  public :: lexer_token_t
  public :: get_lexer_token

  character(1, kind = ck), parameter :: horizontal_tab_char = char (9, kind = ck)
  character(1, kind = ck), parameter :: linefeed_char = char (10, kind = ck)
  character(1, kind = ck), parameter :: vertical_tab_char = char (11, kind = ck)
  character(1, kind = ck), parameter :: formfeed_char = char (12, kind = ck)
  character(1, kind = ck), parameter :: carriage_return_char = char (13, kind = ck)
  character(1, kind = ck), parameter :: space_char = ck_' '

  type :: lexer_token_t
     integer :: token_no = -(huge (1))
     character(:, kind = ck), allocatable :: val
     integer(nk) :: line_no = -(huge (1_nk))
     integer(nk) :: column_no = -(huge (1_nk))
  end type lexer_token_t

contains

  subroutine get_lexer_token (unit_no, lex_line_no, eof, token)
    !
    ! Lines that are empty or contain only whitespace are tolerated.
    !
    ! Also tolerated are comment lines, whose first character is a
    ! '!'. It is convenient for debugging to be able to comment out
    ! lines.
    !
    ! A last line be without a newline is *not* tolerated, unless it
    ! contains only whitespace.
    !
    ! Letting there be some whitespace is partly for the sake of
    ! reading cut-and-paste from a browser display.
    !
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    logical, intent(out) :: eof
    type(lexer_token_t), intent(out) :: token

    type(strbuf_t) :: strbuf
    logical :: no_newline
    logical :: input_found

    ! Let a negative setting initialize the line number.
    lex_line_no = max (0_nk, lex_line_no)

    strbuf = ''
    eof = .false.
    input_found = .false.
    do while (.not. eof .and. .not. input_found)
       call get_line_from_stream (unit_no, eof, no_newline, strbuf)
       if (eof) then
          if (no_newline) then
             lex_line_no = lex_line_no + 1
             if (.not. strbuf_is_all_whitespace (strbuf)) then
                call start_error_message (lex_line_no)
                write (error_unit, '("lexer line ends without a newline")')
                stop 1
             end if
          end if
       else
          lex_line_no = lex_line_no + 1
          input_found = .true.
          if (strbuf_is_all_whitespace (strbuf)) then
             ! A blank line.
             input_found = .false.
          else if (0 < strbuf%length()) then
             if (strbuf%chars(1) == ck_'!') then
                ! A comment line.
                input_found = .false.
             end if
          end if
       end if
    end do

    token = lexer_token_t ()
    if (.not. eof) then
       token = strbuf_to_token (lex_line_no, strbuf)
    end if
  end subroutine get_lexer_token

  function strbuf_to_token (lex_line_no, strbuf) result (token)
    integer(kind = nk), intent(in) :: lex_line_no
    class(strbuf_t), intent(in) :: strbuf
    type(lexer_token_t) :: token

    character(:, kind = ck), allocatable :: line_no
    character(:, kind = ck), allocatable :: column_no
    character(:, kind = ck), allocatable :: token_name
    character(:, kind = ck), allocatable :: val_string
    integer :: stat
    integer(kind = nk) :: n

    call split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)

    read (line_no, *, iostat = stat) token%line_no
    if (stat /= 0) then
       call start_error_message (lex_line_no)
       write (error_unit, '("line number field is unreadable or too large")')
       stop 1
    end if

    read (column_no, *, iostat = stat) token%column_no
    if (stat /= 0) then
       call start_error_message (lex_line_no)
       write (error_unit, '("column number field is unreadable or too large")')
       stop 1
    end if

    token%token_no = token_name_to_token_no (lex_line_no, token_name)

    select case (token%token_no)
    case (tk_Ident)
       ! I do no checking of identifier names.
       allocate (token%val, source = val_string)
    case (tk_Integer)
       call check_is_all_digits (lex_line_no, val_string)
       allocate (token%val, source = val_string)
    case (tk_String)
       n = len (val_string, kind = nk)
       if (n < 2) then
          call string_literal_missing_or_no_good
       else if (val_string(1:1) /= ck_'"' .or. val_string(n:n) /= ck_'"') then
          call string_literal_missing_or_no_good
       else
          allocate (token%val, source = val_string)
       end if
    case default
       if (len (val_string, kind = nk) /= 0) then
          call start_error_message (lex_line_no)
          write (error_unit, '("token should not have a value")')
          stop 1
       end if
    end select

  contains

    subroutine string_literal_missing_or_no_good
      call start_error_message (lex_line_no)
      write (error_unit, '("""String"" token requires a string literal")')
      stop 1
    end subroutine string_literal_missing_or_no_good

  end function strbuf_to_token

  subroutine split_line (lex_line_no, strbuf, line_no, column_no, token_name, val_string)
    integer(kind = nk), intent(in) :: lex_line_no
    class(strbuf_t), intent(in) :: strbuf
    character(:, kind = ck), allocatable, intent(out) :: line_no
    character(:, kind = ck), allocatable, intent(out) :: column_no
    character(:, kind = ck), allocatable, intent(out) :: token_name
    character(:, kind = ck), allocatable, intent(out) :: val_string

    integer(kind = nk) :: i, j

    i = skip_whitespace (strbuf, 1_nk)
    j = skip_non_whitespace (strbuf, i)
    line_no = strbuf%to_unicode(i, j - 1)
    call check_is_all_digits (lex_line_no, line_no)

    i = skip_whitespace (strbuf, j)
    j = skip_non_whitespace (strbuf, i)
    column_no = strbuf%to_unicode(i, j - 1)
    call check_is_all_digits (lex_line_no, column_no)

    i = skip_whitespace (strbuf, j)
    j = skip_non_whitespace (strbuf, i)
    token_name = strbuf%to_unicode(i, j - 1)

    i = skip_whitespace (strbuf, j)
    if (strbuf%length() < i) then
       val_string = ck_''
    else if (strbuf%chars(i) == ck_'"') then
       j = skip_whitespace_backwards (strbuf, strbuf%length())
       if (strbuf%chars(j) == ck_'"') then
          val_string = strbuf%to_unicode(i, j)
       else
          call start_error_message (lex_line_no)
          write (error_unit, '("string literal does not end in a double quote")')
          stop 1
       end if
    else
       j = skip_non_whitespace (strbuf, i)
       val_string = strbuf%to_unicode(i, j - 1)
       i = skip_whitespace (strbuf, j)
       if (i <= strbuf%length()) then
          call start_error_message (lex_line_no)
          write (error_unit, '("token line contains unexpected text")')
          stop 1
       end if
    end if
  end subroutine split_line

  function token_name_to_token_no (lex_line_no, token_name) result (token_no)
    integer(kind = nk), intent(in) :: lex_line_no
    character(*, kind = ck), intent(in) :: token_name
    integer :: token_no

    !!
    !! This implementation is not optimized in any way, unless the
    !! Fortran compiler can optimize the SELECT CASE.
    !!

    select case (token_name)
    case (ck_"End_of_input")
       token_no = tk_EOI
    case (ck_"Op_multiply")
       token_no = tk_Mul
    case (ck_"Op_divide")
       token_no = tk_Div
    case (ck_"Op_mod")
       token_no = tk_Mod
    case (ck_"Op_add")
       token_no = tk_Add
    case (ck_"Op_subtract")
       token_no = tk_Sub
    case (ck_"Op_negate")
       token_no = tk_Negate
    case (ck_"Op_not")
       token_no = tk_Not
    case (ck_"Op_less")
       token_no = tk_Lss
    case (ck_"Op_lessequal    ")
       token_no = tk_Leq
    case (ck_"Op_greater")
       token_no = tk_Gtr
    case (ck_"Op_greaterequal")
       token_no = tk_Geq
    case (ck_"Op_equal")
       token_no = tk_Eq
    case (ck_"Op_notequal")
       token_no = tk_Neq
    case (ck_"Op_assign")
       token_no = tk_Assign
    case (ck_"Op_and")
       token_no = tk_And
    case (ck_"Op_or")
       token_no = tk_Or
    case (ck_"Keyword_if")
       token_no = tk_If
    case (ck_"Keyword_else")
       token_no = tk_Else
    case (ck_"Keyword_while")
       token_no = tk_While
    case (ck_"Keyword_print")
       token_no = tk_Print
    case (ck_"Keyword_putc")
       token_no = tk_Putc
    case (ck_"LeftParen")
       token_no = tk_Lparen
    case (ck_"RightParen")
       token_no = tk_Rparen
    case (ck_"LeftBrace")
       token_no = tk_Lbrace
    case (ck_"RightBrace")
       token_no = tk_Rbrace
    case (ck_"Semicolon")
       token_no = tk_Semi
    case (ck_"Comma")
       token_no = tk_Comma
    case (ck_"Identifier")
       token_no = tk_Ident
    case (ck_"Integer")
       token_no = tk_Integer
    case (ck_"String")
       token_no = tk_String
    case default
       call start_error_message (lex_line_no)
       write (error_unit, '("unrecognized token name: ", A)') token_name
       stop 1
    end select
  end function token_name_to_token_no

  function skip_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_whitespace

  function skip_non_whitespace (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (at_end_of_line (strbuf, j)) then
          done = .true.
       else if (isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j + 1
       end if
    end do
  end function skip_non_whitespace

  function skip_whitespace_backwards (strbuf, i) result (j)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    integer(kind = nk) :: j

    logical :: done

    j = i
    done = .false.
    do while (.not. done)
       if (j == -1) then
          done = .true.
       else if (.not. isspace (strbuf%chars(j))) then
          done = .true.
       else
          j = j - 1
       end if
    end do
  end function skip_whitespace_backwards

  function at_end_of_line (strbuf, i) result (bool)
    class(strbuf_t), intent(in) :: strbuf
    integer(kind = nk), intent(in) :: i
    logical :: bool

    bool = (strbuf%length() < i)
  end function at_end_of_line

  elemental function strbuf_is_all_whitespace (strbuf) result (bool)
    class(strbuf_t), intent(in) :: strbuf
    logical :: bool

    integer(kind = nk) :: n
    integer(kind = nk) :: i

    n = strbuf%length()
    if (n == 0) then
       bool = .true.
    else
       i = 1
       bool = .true.
       do while (bool .and. i /= n + 1)
          bool = isspace (strbuf%chars(i))
          i = i + 1
       end do
    end if
  end function strbuf_is_all_whitespace

  elemental function isspace (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    bool = (ch == horizontal_tab_char) .or.  &
         & (ch == linefeed_char) .or.        &
         & (ch == vertical_tab_char) .or.    &
         & (ch == formfeed_char) .or.        &
         & (ch == carriage_return_char) .or. &
         & (ch == space_char)
  end function isspace

  elemental function isdigit (ch) result (bool)
    character(1, kind = ck), intent(in) :: ch
    logical :: bool

    integer(kind = ick), parameter :: zero = ichar (ck_'0', kind = ick)
    integer(kind = ick), parameter :: nine = ichar (ck_'9', kind = ick)

    integer(kind = ick) :: i_ch

    i_ch = ichar (ch, kind = ick)
    bool = (zero <= i_ch .and. i_ch <= nine)
  end function isdigit

  subroutine check_is_all_digits (lex_line_no, str)
    integer(kind = nk), intent(in) :: lex_line_no
    character(*, kind = ck), intent(in) :: str

    integer(kind = nk) :: n
    integer(kind = nk) :: i

    n = len (str, kind = nk)
    if (n == 0_nk) then
       call start_error_message (lex_line_no)
       write (error_unit, '("a required field is missing")')
       stop 1
    else
       do i = 1, n
          if (.not. isdigit (str(i:i))) then
             call start_error_message (lex_line_no)
             write (error_unit, '("a numeric field contains a non-digit")')
             stop 1
          end if
       end do
    end if
  end subroutine check_is_all_digits

  subroutine start_error_message (lex_line_no)
    integer(kind = nk), intent(in) :: lex_line_no

    write (error_unit, '("Token stream error at line ", I0, ": ")', advance = 'no') &
         &    lex_line_no
  end subroutine start_error_message

end module reading_of_lexer_tokens

module syntactic_analysis
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: compiler_type_kinds, only: nk, ck, ick
  use, non_intrinsic :: string_buffers
  use, non_intrinsic :: lexer_token_facts
  use, non_intrinsic :: reading_of_lexer_tokens

  implicit none
  private

  public :: ast_node_t
  public :: ast_t
  public :: parse_token_stream
  public :: output_ast_flattened

  integer, parameter, public :: tk_start_of_statement = -1
  integer, parameter, public :: tk_primary = -2

  integer, parameter :: node_Identifier = 1
  integer, parameter :: node_String = 2
  integer, parameter :: node_Integer = 3
  integer, parameter :: node_Sequence = 4
  integer, parameter :: node_If = 5
  integer, parameter :: node_Prtc = 6
  integer, parameter :: node_Prts = 7
  integer, parameter :: node_Prti = 8
  integer, parameter :: node_While = 9
  integer, parameter :: node_Assign = 10
  integer, parameter :: node_Negate = 11
  integer, parameter :: node_Not = 12
  integer, parameter :: node_Multiply = 13
  integer, parameter :: node_Divide = 14
  integer, parameter :: node_Mod = 15
  integer, parameter :: node_Add = 16
  integer, parameter :: node_Subtract = 17
  integer, parameter :: node_Less = 18
  integer, parameter :: node_LessEqual = 19
  integer, parameter :: node_Greater = 20
  integer, parameter :: node_GreaterEqual = 21
  integer, parameter :: node_Equal = 22
  integer, parameter :: node_NotEqual = 23
  integer, parameter :: node_And = 24
  integer, parameter :: node_Or = 25

  character(16), parameter :: node_variety_string(1:25) = &
       (/ "Identifier      ",    &
       &  "String          ",    &
       &  "Integer         ",    &
       &  "Sequence        ",    &
       &  "If              ",    &
       &  "Prtc            ",    &
       &  "Prts            ",    &
       &  "Prti            ",    &
       &  "While           ",    &
       &  "Assign          ",    &
       &  "Negate          ",    &
       &  "Not             ",    &
       &  "Multiply        ",    &
       &  "Divide          ",    &
       &  "Mod             ",    &
       &  "Add             ",    &
       &  "Subtract        ",    &
       &  "Less            ",    &
       &  "LessEqual       ",    &
       &  "Greater         ",    &
       &  "GreaterEqual    ",    &
       &  "Equal           ",    &
       &  "NotEqual        ",    &
       &  "And             ",    &
       &  "Or              " /)

  type :: ast_node_t
     integer :: node_variety
     character(:, kind = ck), allocatable :: val
     type(ast_node_t), pointer :: left => null ()
     type(ast_node_t), pointer :: right => null ()
   contains
     procedure, pass :: assign => ast_node_t_assign
     generic :: assignment(=) => assign
     final :: ast_node_t_finalize
  end type ast_node_t

  ! ast_t phases.
  integer, parameter :: building = 1
  integer, parameter :: completed = 2

  type :: ast_t
     !
     ! This type is used to build the subtrees, as well as for the
     ! completed AST. The difference is in the setting of ‘phase’.
     !
     type(ast_node_t), pointer :: node => null ()
     integer, private :: phase = building
   contains
     procedure, pass :: assign => ast_t_assign
     generic :: assignment(=) => assign
     final :: ast_t_finalize
  end type ast_t

  type(ast_t), parameter :: ast_nil = ast_t (null ())

contains

  recursive subroutine ast_node_t_assign (node, other)
    class(ast_node_t), intent(out) :: node
    class(*), intent(in) :: other

    select type (other)
    class is (ast_node_t)
       node%node_variety = other%node_variety
       if (allocated (other%val)) allocate (node%val, source = other%val)
       if (associated (other%left)) allocate (node%left, source = other%left)
       if (associated (other%right)) allocate (node%right, source = other%right)
    class default
       ! This branch should never be reached.
       error stop
    end select
  end subroutine ast_node_t_assign

  recursive subroutine ast_node_t_finalize (node)
    type(ast_node_t), intent(inout) :: node

    if (associated (node%left)) deallocate (node%left)
    if (associated (node%right)) deallocate (node%right)
  end subroutine ast_node_t_finalize

  recursive subroutine ast_t_assign (ast, other)
    class(ast_t), intent(out) :: ast
    class(*), intent(in) :: other

    select type (other)
    class is (ast_t)
       if (associated (other%node)) allocate (ast%node, source = other%node)
       !
       ! Whether it is better to set phase to ‘building’ or to set it
       ! to ‘other%phase’ is unclear to me. Probably ‘building’ is the
       ! better choice. Which variable controls memory recovery is
       ! clear and unchanging, in that case: it is the original,
       ! ‘other’, that does.
       !
       ast%phase = building
    class default
       ! This should not happen.
       error stop
    end select
  end subroutine ast_t_assign

  subroutine ast_t_finalize (ast)
    type(ast_t), intent(inout) :: ast

    !
    ! When we are building the tree, the tree’s nodes should not be
    ! deallocated when the ast_t variable temporarily holding them
    ! goes out of scope.
    !
    ! However, once the AST is completed, we do want the memory
    ! recovered when the variable goes out of scope.
    !
    ! (Elsewhere I have written a primitive garbage collector for
    ! Fortran programs, but in this case it would be a lot of overhead
    ! for little gain. In fact, we could reasonably just let the
    ! memory leak, in this program.
    !
    ! Fortran runtimes *are* allowed by the standard to have garbage
    ! collectors built in. To my knowledge, at the time of this
    ! writing, only NAG Fortran has a garbage collector option.)
    !

    if (ast%phase == completed) then
       if (associated (ast%node)) deallocate (ast%node)
    end if
  end subroutine ast_t_finalize

  function parse_token_stream (unit_no) result (ast)
    integer, intent(in) :: unit_no
    type(ast_t) :: ast

    integer(kind = nk) :: lex_line_no
    type(ast_t) :: statement
    type(lexer_token_t) :: token

    lex_line_no = -1_nk
    call get_token (unit_no, lex_line_no, token)
    call parse_statement (unit_no, lex_line_no, token, statement)
    ast = make_internal_node (node_Sequence, ast, statement)
    do while (token%token_no /= tk_EOI)
       call parse_statement (unit_no, lex_line_no, token, statement)
       ast = make_internal_node (node_Sequence, ast, statement)
    end do
    ast%phase = completed
  end function parse_token_stream

  recursive subroutine parse_statement (unit_no, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast

    ast = ast_nil

    select case (token%token_no)
    case (tk_If)
       call parse_ifelse_construct
    case (tk_Putc)
       call parse_putc
    case (tk_Print)
       call parse_print
    case (tk_Semi)
       call get_token (unit_no, lex_line_no, token)
    case (tk_Ident)
       call parse_identifier
    case (tk_While)
       call parse_while_construct
    case (tk_Lbrace)
       call parse_lbrace_construct
    case (tk_EOI)
       continue
    case default
       call syntax_error_message ("", tk_start_of_statement, token)
       stop 1
    end select

  contains

    recursive subroutine parse_ifelse_construct
      type(ast_t) :: predicate
      type(ast_t) :: statement_for_predicate_true
      type(ast_t) :: statement_for_predicate_false

      call expect_token ("If", tk_If, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
      call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_true)
      if (token%token_no == tk_Else) then
         call get_token (unit_no, lex_line_no, token)
         call parse_statement (unit_no, lex_line_no, token, statement_for_predicate_false)
         ast = make_internal_node (node_If, statement_for_predicate_true, &
              &                    statement_for_predicate_false)
      else
         ast = make_internal_node (node_If, statement_for_predicate_true, ast_nil)
      end if
      ast = make_internal_node (node_If, predicate, ast)
    end subroutine parse_ifelse_construct

    recursive subroutine parse_putc
      type(ast_t) :: arguments

      call expect_token ("Putc", tk_Putc, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, arguments)
      ast = make_internal_node (node_Prtc, arguments, ast_nil)
      call expect_token ("Putc", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_putc

    recursive subroutine parse_print
      logical :: done
      type(ast_t) :: arg
      type(ast_t) :: printer

      call expect_token ("Print", tk_Print, token)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("Print", tk_Lparen, token)
      done = .false.
      do while (.not. done)
         call get_token (unit_no, lex_line_no, token)
         select case (token%token_no)
         case (tk_String)
            arg = make_leaf_node (node_String, token%val)
            printer = make_internal_node (node_Prts, arg, ast_nil)
            call get_token (unit_no, lex_line_no, token)
         case default
            call parse_expression (unit_no, 0, lex_line_no, token, arg)
            printer = make_internal_node (node_Prti, arg, ast_nil)
         end select
         ast = make_internal_node (node_Sequence, ast, printer)
         done = (token%token_no /= tk_Comma)
      end do
      call expect_token ("Print", tk_Rparen, token)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("Print", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_print

    recursive subroutine parse_identifier
      type(ast_t) :: left_side
      type(ast_t) :: right_side

      left_side = make_leaf_node (node_Identifier, token%val)
      call get_token (unit_no, lex_line_no, token)
      call expect_token ("assign", tk_Assign, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_expression (unit_no, 0, lex_line_no, token, right_side)
      ast = make_internal_node (node_Assign, left_side, right_side)
      call expect_token ("assign", tk_Semi, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_identifier

    recursive subroutine parse_while_construct
      type(ast_t) :: predicate
      type(ast_t) :: statement_to_be_repeated

      call expect_token ("While", tk_While, token)
      call get_token (unit_no, lex_line_no, token)
      call parse_parenthesized_expression (unit_no, lex_line_no, token, predicate)
      call parse_statement (unit_no, lex_line_no, token, statement_to_be_repeated)
      ast = make_internal_node (node_While, predicate, statement_to_be_repeated)
    end subroutine parse_while_construct

    recursive subroutine parse_lbrace_construct
      type(ast_t) :: statement

      call expect_token ("Lbrace", tk_Lbrace, token)
      call get_token (unit_no, lex_line_no, token)
      do while (token%token_no /= tk_Rbrace .and. token%token_no /= tk_EOI)
         call parse_statement (unit_no, lex_line_no, token, statement)
         ast = make_internal_node (node_Sequence, ast, statement)
      end do
      call expect_token ("Lbrace", tk_Rbrace, token)
      call get_token (unit_no, lex_line_no, token)
    end subroutine parse_lbrace_construct

  end subroutine parse_statement

  recursive subroutine parse_expression (unit_no, p, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer, intent(in) :: p
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast

    integer :: precedence
    type(ast_t) :: expression

    select case (token%token_no)
    case (tk_Lparen)
       call parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
    case (tk_Sub)
       token%token_no = tk_Negate
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = make_internal_node (node_Negate, expression, ast_nil)
    case (tk_Add)
       token%token_no = tk_Positive
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = expression
    case (tk_Not)
       precedence = lexer_token_precedence(token%token_no)
       call get_token (unit_no, lex_line_no, token)
       call parse_expression (unit_no, precedence, lex_line_no, token, expression)
       ast = make_internal_node (node_Not, expression, ast_nil)
    case (tk_Ident)
       ast = make_leaf_node (node_Identifier, token%val)
       call get_token (unit_no, lex_line_no, token)
    case (tk_Integer)
       ast = make_leaf_node (node_Integer, token%val)
       call get_token (unit_no, lex_line_no, token)
    case default
       call syntax_error_message ("", tk_primary, token)
       stop 1
    end select

    do while (lexer_token_arity(token%token_no) == 2 .and. &
         &    p <= lexer_token_precedence(token%token_no))
       block
         type(ast_t) :: right_expression
         integer :: q
         integer :: node_variety

         if (lexer_token_associativity(token%token_no) == right_associative) then
            q = lexer_token_precedence(token%token_no)
         else
            q = lexer_token_precedence(token%token_no) + 1
         end if
         node_variety = binary_operator_node_variety (token%token_no)
         call get_token (unit_no, lex_line_no, token)
         call parse_expression (unit_no, q, lex_line_no, token, right_expression)
         ast = make_internal_node (node_variety, ast, right_expression)
       end block
    end do
  end subroutine parse_expression

  recursive subroutine parse_parenthesized_expression (unit_no, lex_line_no, token, ast)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(inout) :: token
    type(ast_t), intent(out) :: ast

    call expect_token ("paren_expr", tk_Lparen, token)
    call get_token (unit_no, lex_line_no, token)
    call parse_expression (unit_no, 0, lex_line_no, token, ast)
    call expect_token ("paren_expr", tk_Rparen, token)
    call get_token (unit_no, lex_line_no, token)
  end subroutine parse_parenthesized_expression

  elemental function binary_operator_node_variety (token_no) result (node_variety)
    integer, intent(in) :: token_no
    integer :: node_variety

    select case (token_no)
    case (tk_Mul)
       node_variety = node_Multiply
    case (tk_Div)
       node_variety = node_Divide
    case (tk_Mod)
       node_variety = node_Mod
    case (tk_Add)
       node_variety = node_Add
    case (tk_Sub)
       node_variety = node_Subtract
    case (tk_Lss)
       node_variety = node_Less
    case (tk_Leq)
       node_variety = node_LessEqual
    case (tk_Gtr)
       node_variety = node_Greater
    case (tk_Geq)
       node_variety = node_GreaterEqual
    case (tk_Eq)
       node_variety = node_Equal
    case (tk_Neq)
       node_variety = node_NotEqual
    case (tk_And)
       node_variety = node_And
    case (tk_Or)
       node_variety = node_Or
    case default
       ! This branch should never be reached.
       error stop
    end select
  end function binary_operator_node_variety

  function make_internal_node (node_variety, left, right) result (ast)
    integer, intent(in) :: node_variety
    class(ast_t), intent(in) :: left, right
    type(ast_t) :: ast

    type(ast_node_t), pointer :: node

    allocate (node)
    node%node_variety = node_variety
    node%left => left%node
    node%right => right%node
    ast%node => node
  end function make_internal_node

  function make_leaf_node (node_variety, val) result (ast)
    integer, intent(in) :: node_variety
    character(*, kind = ck), intent(in) :: val
    type(ast_t) :: ast

    type(ast_node_t), pointer :: node

    allocate (node)
    node%node_variety = node_variety
    node%val = val
    ast%node => node
  end function make_leaf_node

  subroutine get_token (unit_no, lex_line_no, token)
    integer, intent(in) :: unit_no
    integer(kind = nk), intent(inout) :: lex_line_no
    type(lexer_token_t), intent(out) :: token

    logical :: eof

    call get_lexer_token (unit_no, lex_line_no, eof, token)
    if (eof) then
       write (error_unit, '("Parser error: the stream of input tokens is incomplete")')
       stop 1
    end if
  end subroutine get_token

  subroutine expect_token (message, token_no, token)
    character(*), intent(in) :: message
    integer, intent (in) :: token_no
    class(lexer_token_t), intent(in) :: token

    if (token%token_no /= token_no) then
       call syntax_error_message (message, token_no, token)
       stop 1
    end if
  end subroutine expect_token

  subroutine syntax_error_message (message, expected_token_no, token)
    character(*), intent(in) :: message
    integer, intent(in) :: expected_token_no
    class(lexer_token_t), intent(in) :: token

    ! Write a message to an output unit dedicated to printing
    ! errors. The message could, of course, be more detailed than what
    ! we are doing here.
    write (error_unit, '("Syntax error at ", I0, ".", I0)') &
         &    token%line_no, token%column_no

    !
    ! For the sake of the exercise, also write, to output_unit, a
    ! message in the style of the C reference program.
    !
    write (output_unit, '("(", I0, ", ", I0, ") error: ")', advance = 'no') &
         &    token%line_no, token%column_no
    select case (expected_token_no)
    case (tk_start_of_statement)
       write (output_unit, '("expecting start of statement, found ''", 1A, "''")') &
            &    trim (lexer_token_string(token%token_no))
    case (tk_primary)
       write (output_unit, '("Expecting a primary, found ''", 1A, "''")') &
            &    trim (lexer_token_string(token%token_no))
    case default
       write (output_unit, '(1A, ": Expecting ''", 1A, "'', found ''", 1A, "''")') &
            &    trim (message), trim (lexer_token_string(expected_token_no)), &
            &    trim (lexer_token_string(token%token_no))
    end select
  end subroutine syntax_error_message

  subroutine output_ast_flattened (unit_no, ast)
    integer, intent(in) :: unit_no
    type(ast_t), intent(in) :: ast

    call output_ast_node_flattened (unit_no, ast%node)
  end subroutine output_ast_flattened

  recursive subroutine output_ast_node_flattened (unit_no, node)
    integer, intent(in) :: unit_no
    type(ast_node_t), pointer, intent(in) :: node

      if (.not. associated (node)) then
         write (unit_no, '(";")')
      else
         if (allocated (node%val)) then
            write (unit_no, '(1A16, 2X, 1A)') &
                 &   node_variety_string(node%node_variety), node%val
         else
            write (unit_no, '(1A)') &
                 &   trim (node_variety_string(node%node_variety))
            call output_ast_node_flattened (unit_no, node%left)
            call output_ast_node_flattened (unit_no, node%right)
         end if
      end if
    end subroutine output_ast_node_flattened

end module syntactic_analysis

program parse
  use, intrinsic :: iso_fortran_env, only: input_unit
  use, intrinsic :: iso_fortran_env, only: output_unit
  use, intrinsic :: iso_fortran_env, only: error_unit
  use, non_intrinsic :: syntactic_analysis

  implicit none

  integer, parameter :: inp_unit_no = 100
  integer, parameter :: outp_unit_no = 101

  integer :: arg_count
  character(200) :: arg
  integer :: inp
  integer :: outp

  arg_count = command_argument_count ()
  if (3 <= arg_count) then
     call print_usage
  else
     if (arg_count == 0) then
        inp = input_unit
        outp = output_unit
     else if (arg_count == 1) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        outp = output_unit
     else if (arg_count == 2) then
        call get_command_argument (1, arg)
        inp = open_for_input (trim (arg))
        call get_command_argument (2, arg)
        outp = open_for_output (trim (arg))
     end if

     block
       type(ast_t) :: ast

       ast = parse_token_stream (inp)
       call output_ast_flattened (outp, ast)
     end block
  end if

contains

  function open_for_input (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no

    integer :: stat

    open (unit = inp_unit_no, file = filename, status = 'old', &
         & action = 'read', access = 'stream', form = 'unformatted',  &
         & iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for input")') filename
       stop 1
    end if
    unit_no = inp_unit_no
  end function open_for_input

  function open_for_output (filename) result (unit_no)
    character(*), intent(in) :: filename
    integer :: unit_no

    integer :: stat

    open (unit = outp_unit_no, file = filename, action = 'write', iostat = stat)
    if (stat /= 0) then
       write (error_unit, '("Error: failed to open ", 1A, " for output")') filename
       stop 1
    end if
    unit_no = outp_unit_no
  end function open_for_output

  subroutine print_usage
    character(200) :: progname

    call get_command_argument (0, progname)
    write (output_unit, '("Usage: ", 1A, " [INPUT_FILE [OUTPUT_FILE]]")') &
         &      trim (progname)
  end subroutine print_usage

end program parse


Loop %0% ; number of parameters
  params .= %A_Index% . A_Space
If params !=
  MsgBox, %0% parameters were passed:`n`n %params%
Else
  Run, %A_AhkPath% "%A_ScriptFullPath%" -c "\"alpha beta\"" -h "\"gamma\""


#!/usr/bin/awk -f

BEGIN {
  print "There are " ARGC "command line parameters"
  for(l=1; l<ARGC; l++) {
    print "Argument " l " is " ARGV[l]
  }
}


--
-- demo\rosetta\Compiler\cgen.e
-- ============================
--
--  The reusable part of cgen.exw
--
without js -- (machine code!)
include parse.e

global sequence vars = {},
                strings = {},
                stringptrs = {}

global integer chain = 0
global sequence code = {}

function var_idx(sequence inode)
    if inode[1]!=tk_Identifier then ?9/0 end if
    string ident = inode[2]
    integer n = find(ident,vars)
    if n=0 then
        vars = append(vars,ident)
        n = length(vars)
    end if
    return n
end function

function string_idx(sequence inode)
    if inode[1]!=tk_String then ?9/0 end if
    string s = inode[2]
    integer n = find(s,strings)
    if n=0 then
        strings = append(strings,s)
        stringptrs = append(stringptrs,0)
        n = length(strings)
    end if
    return n
end function

function gen_size(object t)
-- note: must be kept precisely in sync with gen_rec!
--        (relentlessly tested via estsize/actsize)
integer size = 0
    if t!=NULL then
        integer n_type = t[1]
        string node_type = tkNames[n_type]
        switch n_type do
            case tk_Sequence:
                size += gen_size(t[2])
                size += gen_size(t[3])
            case tk_assign:
                size += gen_size(t[3])+6
            case tk_Integer:
                size += 5
            case tk_Identifier:
                size += 6
            case tk_String:
                size += 5
            case tk_while:
                -- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:
                size += gen_size(t[2])+3
                integer body = gen_size(t[3])
                integer stail = iff(size+body+2>128?5:2)
                integer stop  = iff(body+stail >127?6:2)
                size += stop+body+stail
            case tk_lt:
            case tk_le:
            case tk_ne:
            case tk_eq:
            case tk_gt:
            case tk_ge:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 10
            case tk_and:
            case tk_or:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 15
            case tk_add:
            case tk_sub:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 4
            case tk_mul:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 5
            case tk_div:
            case tk_mod:
                size += gen_size(t[2])
                size += gen_size(t[3])
                size += 6
            case tk_putc:
            case tk_Printi:
            case tk_Prints:
                size += gen_size(t[2])
                size += 5
            case tk_if:
                size += gen_size(t[2])+3
                if t[3][1]!=tk_if then ?9/0 end if
                integer truesize = gen_size(t[3][2])
                integer falsesize = gen_size(t[3][3])
                integer elsejmp = iff(falsesize=0?0:iff(falsesize>127?5:2))
                integer mainjmp = iff(truesize+elsejmp>127?6:2)
                size += mainjmp+truesize+elsejmp+falsesize
            case tk_not:
                size += gen_size(t[2])
                size += 9
            case tk_neg:
                size += gen_size(t[2])
                size += 4
            else:
                ?9/0
        end switch
    end if
    return size
end function

procedure gen_rec(object t)
-- the recursive part of code_gen
    if t!=NULL then
        integer initsize = length(code)
        integer estsize = gen_size(t)   -- (test the gen_size function)
        integer n_type = t[1]
        string node_type = tkNames[n_type]
        switch n_type do
            case tk_Sequence:
                gen_rec(t[2])
                gen_rec(t[3])
            case tk_assign:
                integer n = var_idx(t[2])
                gen_rec(t[3])
                code &= {0o217,0o005,chain,1,n,0}   -- pop [i]
                chain = length(code)-3
            case tk_Integer:
                integer n = t[2]
                code &= 0o150&int_to_bytes(n)       -- push imm32
            case tk_while:
                -- emit: @@:<condition><topjmp(@f)><body><tailjmp(@b)>@@:
                integer looptop = length(code)
                gen_rec(t[2])
                code &= {0o130,                                 -- pop eax
                         0o205,0o300}                           -- test eax,eax
                integer bodysize = gen_size(t[3])
                -- can we use short jumps?
                -- disclaimer: size calcs are not heavily tested; if in
                --             doubt reduce 128/7 by 8, and if that works
                --             then yep, you just found a boundary case.
                integer stail = iff(length(code)+bodysize+4-looptop>128?5:2)
                integer offset = bodysize+stail
                integer stop  = iff(offset>127?6:2)
                if stop=2 then
                    code &= {0o164,offset}                      -- jz (short) end
                else
                    code &= {0o017,0o204}&int_to_bytes(offset)  -- jz (long) end
                end if
                gen_rec(t[3])
                offset = looptop-(length(code)+stail)
                if stail=2 then
                    code &= 0o353&offset                        -- jmp looptop (short)
                else
                    code &= 0o351&int_to_bytes(offset)          -- jmp looptop (long)
                end if
            case tk_lt:
            case tk_le:
            case tk_gt:
            case tk_ge:
            case tk_ne:
            case tk_eq:
                gen_rec(t[2])
                gen_rec(t[3])
                integer xrm
                if    n_type=tk_ne then xrm = 0o225 -- (#95)
                elsif n_type=tk_lt then xrm = 0o234 -- (#9C)
                elsif n_type=tk_ge then xrm = 0o235 -- (#9D)
                elsif n_type=tk_le then xrm = 0o236 -- (#9E)
                elsif n_type=tk_gt then xrm = 0o237 -- (#9F)
                else ?9/0
                end if
                code &= { 0o061,0o300,                          -- xor eax,eax
                          0o132,                                -- pop edx
                          0o131,                                -- pop ecx
                          0o071,0o321,                          -- cmp ecx,edx
                          0o017,xrm,0o300,                      -- setcc al
                          0o120}                                -- push eax
            case tk_or:
            case tk_and:
                gen_rec(t[2])
                gen_rec(t[3])
                integer op = find(n_type,{tk_or,0,0,tk_and})
                op *= 0o010
                code &= { 0o130,                                -- pop eax
                          0o131,                                -- pop ecx
                          0o205,0o300,                          -- test eax,eax
                          0o017,0o225,0o300,                    -- setne al
                          0o205,0o311,                          -- test ecx,ecx
                          0o017,0o225,0o301,                    -- setne cl
                          op,0o310,                             -- or/and al,cl
                          0o120}                                -- push eax
            case tk_add:
            case tk_sub:
                gen_rec(t[2])
                gen_rec(t[3])
                integer op = find(n_type,{tk_add,0,0,0,0,tk_sub})
                op = 0o001 + (op-1)*0o010
                code &= { 0o130,                                -- pop eax
                          op,0o004,0o044}                       -- add/or/and/sub [esp],eax
            case tk_mul:
                gen_rec(t[2])
                gen_rec(t[3])
                code &= { 0o131,                                -- pop ecx
                          0o130,                                -- pop eax
                          0o367,0o341,                          -- mul ecx
                          0o120}                                -- push eax
            case tk_div:
            case tk_mod:
                gen_rec(t[2])
                gen_rec(t[3])
                integer push = 0o120+(n_type=tk_mod)*2
                code &= { 0o131,                                -- pop ecx
                          0o130,                                -- pop eax
                          0o231,                                -- cdq (eax -> edx:eax)
                          0o367,0o371,                          -- idiv ecx
                          push}                                 -- push eax|edx
            case tk_Identifier:
                integer n = var_idx(t)
                code &= {0o377,0o065,chain,1,n,0}               -- push [n]
                chain = length(code)-3
            case tk_putc:
            case tk_Printi:
            case tk_Prints:
                gen_rec(t[2])
                integer n = find(n_type,{tk_putc,tk_Printi,tk_Prints})
                code &= {0o350,chain,3,n,0}                     -- call :printc/i/s
                chain = length(code)-3
            case tk_String:
                integer n = string_idx(t)
                code &= {0o150,chain,2,n,0}                     -- push RawStringPtr(string)
                chain = length(code)-3
            case tk_if:
                -- emit: <condition><mainjmp><truepart>[<elsejmp><falsepart>]
                gen_rec(t[2])
                code &= {0o130,                                 -- pop eax
                         0o205,0o300}                           -- test eax,eax
                if t[3][1]!=tk_if then ?9/0 end if
                integer truesize = gen_size(t[3][2])
                integer falsesize = gen_size(t[3][3])
                integer elsejmp = iff(falsesize=0?0:iff(falsesize>127?5:2))
                integer offset = truesize+elsejmp
                integer mainjmp = iff(offset>127?6:2)
                if mainjmp=2 then
                    code &= {0o164,offset}                      -- jz (short) else/end
                else
                    code &= {0o017,0o204}&int_to_bytes(offset)  -- jz (long) else/end
                end if
                gen_rec(t[3][2])
                if falsesize!=0 then
                    offset = falsesize
                    if elsejmp=2 then
                        code &= 0o353&offset                    -- jmp end if (short)
                    else
                        code &= 0o351&int_to_bytes(offset)      -- jmp end if (long)
                    end if
                    gen_rec(t[3][3])
                end if
            case tk_not:
                gen_rec(t[2])
                code &= {0o132,                                 -- pop edx
                         0o061,0o300,                           -- xor eax,eax
                         0o205,0o322,                           -- test edx,edx
                         0o017,0o224,0o300,                     -- setz al
                         0o120}                                 -- push eax
            case tk_neg:
                gen_rec(t[2])
                code &= {0o130,                             -- pop eax
                         0o367,0o330,                       -- neg eax
                         0o120}                             -- push eax
            else:
                error("error in code generator - found %d, expecting operator\n", {n_type})
        end switch
        integer actsize = length(code)
        if initsize+estsize!=actsize then ?"9/0" end if -- (test gen_size)
    end if
end procedure

global procedure code_gen(object t)
--
-- Generates proper machine code.
--
-- Example: i=10; print "\n"; print i; print "\n"
-- Result in vars, strings, chain, code (declared above)
--    where vars is: {"i"},
--          strings is {"\n"},
--          code is { 0o150,#0A,#00,#00,#00,        -- 1: push 10
--                    0o217,0o005,0,1,1,0           -- 6: pop [i]
--                    0o150,8,2,1,0,                -- 12: push ("\n")
--                    0o350,13,3,3,0,               -- 17: call :prints
--                    0o377,0o065,18,1,1,0,         -- 22: push [i]
--                    0o350,24,3,2,0,               -- 28: call :printi
--                    0o150,29,2,1,0,               -- 33: push ("\n")
--                    0o350,34,3,3,0,               -- 38: call :prints
--                    0o303}                        -- 43: ret
--          and chain is 39 (->34->29->24->18->13->8->0)
-- The chain connects all places where we need an actual address before
--  the code is executed, with the byte after the link differentiating
--  between var(1), string(2), and builtin(3), and the byte after that
--  determining the instance of the given type - not that any of them
--  are actually limited to a byte in the above intermediate form, and
--  of course the trailing 0 of each {link,type,id,0} is just there to
--  reserve the space we will need.
--
    gen_rec(t)
    code = append(code,0o303)   -- ret (0o303=#C3)
end procedure

include builtins/VM/puts1.e -- low-level console i/o routines

function setbuiltins()
atom printc,printi,prints
    #ilASM{
        jmp :setbuiltins
    ::printc
        lea edi,[esp+4]
        mov esi,1
        call :%puts1ediesi  -- (edi=raw text, esi=length)
        ret 4
    ::printi
        mov eax,[esp+4]
        push 0              -- no cr
        call :%putsint      -- (nb limited to +/-9,999,999,999)
        ret 4
    ::prints
        mov edi,[esp+4]
        mov esi,[edi-12]
        call :%puts1ediesi  -- (edi=raw text, esi=length)
        ret 4
    ::setbuiltins
        mov eax,:printc
        lea edi,[printc]
        call :%pStoreMint
        mov eax,:printi
        lea edi,[printi]
        call :%pStoreMint
        mov eax,:prints
        lea edi,[prints]
        call :%pStoreMint
          }
    return {printc,printi,prints}
end function

global constant builtin_names = {"printc","printi","prints"}
global constant builtins = setbuiltins()

global atom var_mem, code_mem

function RawStringPtr(integer n)    -- (based on IupRawStringPtr from pGUI.e)
--
-- Returns a raw string pointer for s, somewhat like allocate_string(s), but using the existing memory.
-- NOTE: The return is only valid as long as the value passed as the parameter remains in existence.
--
atom res
    string s = strings[n]
    #ilASM{
            mov eax,[s]
            lea edi,[res]
            shl eax,2
            call :%pStoreMint
          }
    stringptrs[n] = res
    return res
end function

global procedure fixup()
    var_mem = allocate(length(vars)*4)
    mem_set(var_mem,0,length(vars)*4)
    code_mem = allocate(length(code))
    poke(code_mem,code)
    while chain!=0 do
        integer this = chain
        chain = code[this]
        integer ftype = code[this+1]
        integer id = code[this+2]
        switch ftype do
            case 1: -- vars
                poke4(code_mem+this-1,var_mem+(id-1)*4)
            case 2: -- strings
                poke4(code_mem+this-1,RawStringPtr(id))
            case 3: -- builtins
                poke4(code_mem+this-1,builtins[id]-(code_mem+this+3))
        end switch
    end while
end procedure


MOVEM.L D0-D7/A0-A6,-(SP)  ;push all registers onto the stack


	MOV AX, 4C00h 		; go back to DOS
	INT 21h                 ; BIOS interrupt 21 base 16


/* ARM assembly AARCH64 Raspberry PI 3B */
/*  comments multi lines

    end comments
    */

               // comment end of ligne