package main

import (
    "bufio"
    "fmt"
    "log"
    "os"
    "strconv"
    "strings"
)

type TokenType int

const (
    tkEOI TokenType = iota
    tkMul
    tkDiv
    tkMod
    tkAdd
    tkSub
    tkNegate
    tkNot
    tkLss
    tkLeq
    tkGtr
    tkGeq
    tkEql
    tkNeq
    tkAssign
    tkAnd
    tkOr
    tkIf
    tkElse
    tkWhile
    tkPrint
    tkPutc
    tkLparen
    tkRparen
    tkLbrace
    tkRbrace
    tkSemi
    tkComma
    tkIdent
    tkInteger
    tkString
)

type NodeType int

const (
    ndIdent NodeType = iota
    ndString
    ndInteger
    ndSequence
    ndIf
    ndPrtc
    ndPrts
    ndPrti
    ndWhile
    ndAssign
    ndNegate
    ndNot
    ndMul
    ndDiv
    ndMod
    ndAdd
    ndSub
    ndLss
    ndLeq
    ndGtr
    ndGeq
    ndEql
    ndNeq
    ndAnd
    ndOr
)

type tokS struct {
    tok    TokenType
    errLn  int
    errCol int
    text   string // ident or string literal or integer value
}

type Tree struct {
    nodeType NodeType
    left     *Tree
    right    *Tree
    value    string
}

// dependency: Ordered by tok, must remain in same order as TokenType consts
type atr struct {
    text             string
    enumText         string
    tok              TokenType
    rightAssociative bool
    isBinary         bool
    isUnary          bool
    precedence       int
    nodeType         NodeType
}

var atrs = []atr{
    {"EOI", "End_of_input", tkEOI, false, false, false, -1, -1},
    {"*", "Op_multiply", tkMul, false, true, false, 13, ndMul},
    {"/", "Op_divide", tkDiv, false, true, false, 13, ndDiv},
    {"%", "Op_mod", tkMod, false, true, false, 13, ndMod},
    {"+", "Op_add", tkAdd, false, true, false, 12, ndAdd},
    {"-", "Op_subtract", tkSub, false, true, false, 12, ndSub},
    {"-", "Op_negate", tkNegate, false, false, true, 14, ndNegate},
    {"!", "Op_not", tkNot, false, false, true, 14, ndNot},
    {"<", "Op_less", tkLss, false, true, false, 10, ndLss},
    {"<=", "Op_lessequal", tkLeq, false, true, false, 10, ndLeq},
    {">", "Op_greater", tkGtr, false, true, false, 10, ndGtr},
    {">=", "Op_greaterequal", tkGeq, false, true, false, 10, ndGeq},
    {"==", "Op_equal", tkEql, false, true, false, 9, ndEql},
    {"!=", "Op_notequal", tkNeq, false, true, false, 9, ndNeq},
    {"=", "Op_assign", tkAssign, false, false, false, -1, ndAssign},
    {"&&", "Op_and", tkAnd, false, true, false, 5, ndAnd},
    {"||", "Op_or", tkOr, false, true, false, 4, ndOr},
    {"if", "Keyword_if", tkIf, false, false, false, -1, ndIf},
    {"else", "Keyword_else", tkElse, false, false, false, -1, -1},
    {"while", "Keyword_while", tkWhile, false, false, false, -1, ndWhile},
    {"print", "Keyword_print", tkPrint, false, false, false, -1, -1},
    {"putc", "Keyword_putc", tkPutc, false, false, false, -1, -1},
    {"(", "LeftParen", tkLparen, false, false, false, -1, -1},
    {")", "RightParen", tkRparen, false, false, false, -1, -1},
    {"{", "LeftBrace", tkLbrace, false, false, false, -1, -1},
    {"}", "RightBrace", tkRbrace, false, false, false, -1, -1},
    {";", "Semicolon", tkSemi, false, false, false, -1, -1},
    {",", "Comma", tkComma, false, false, false, -1, -1},
    {"Ident", "Identifier", tkIdent, false, false, false, -1, ndIdent},
    {"Integer literal", "Integer", tkInteger, false, false, false, -1, ndInteger},
    {"String literal", "String", tkString, false, false, false, -1, ndString},
}

var displayNodes = []string{
    "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",
}

var (
    err     error
    token   tokS
    scanner *bufio.Scanner
)

func reportError(errLine, errCol int, msg string) {
    log.Fatalf("(%d, %d) error : %s\n", errLine, errCol, msg)
}

func check(err error) {
    if err != nil {
        log.Fatal(err)
    }
}

func getEum(name string) TokenType { // return internal version of name#
    for _, atr := range atrs {
        if atr.enumText == name {
            return atr.tok
        }
    }
    reportError(0, 0, fmt.Sprintf("Unknown token %s\n", name))
    return tkEOI
}

func getTok() tokS {
    tok := tokS{}
    if scanner.Scan() {
        line := strings.TrimRight(scanner.Text(), " \t")
        fields := strings.Fields(line)
        // [ ]*{lineno}[ ]+{colno}[ ]+token[ ]+optional
        tok.errLn, err = strconv.Atoi(fields[0])
        check(err)
        tok.errCol, err = strconv.Atoi(fields[1])
        check(err)
        tok.tok = getEum(fields[2])
        le := len(fields)
        if le == 4 {
            tok.text = fields[3]
        } else if le > 4 {
            idx := strings.Index(line, `"`)
            tok.text = line[idx:]
        }
    }
    check(scanner.Err())
    return tok
}

func makeNode(nodeType NodeType, left *Tree, right *Tree) *Tree {
    return &Tree{nodeType, left, right, ""}
}

func makeLeaf(nodeType NodeType, value string) *Tree {
    return &Tree{nodeType, nil, nil, value}
}

func expect(msg string, s TokenType) {
    if token.tok == s {
        token = getTok()
        return
    }
    reportError(token.errLn, token.errCol,
        fmt.Sprintf("%s: Expecting '%s', found '%s'\n", msg, atrs[s].text, atrs[token.tok].text))
}

func expr(p int) *Tree {
    var x, node *Tree
    switch token.tok {
    case tkLparen:
        x = parenExpr()
    case tkSub, tkAdd:
        op := token.tok
        token = getTok()
        node = expr(atrs[tkNegate].precedence)
        if op == tkSub {
            x = makeNode(ndNegate, node, nil)
        } else {
            x = node
        }
    case tkNot:
        token = getTok()
        x = makeNode(ndNot, expr(atrs[tkNot].precedence), nil)
    case tkIdent:
        x = makeLeaf(ndIdent, token.text)
        token = getTok()
    case tkInteger:
        x = makeLeaf(ndInteger, token.text)
        token = getTok()
    default:
        reportError(token.errLn, token.errCol,
            fmt.Sprintf("Expecting a primary, found: %s\n", atrs[token.tok].text))
    }

    for atrs[token.tok].isBinary && atrs[token.tok].precedence >= p {
        op := token.tok
        token = getTok()
        q := atrs[op].precedence
        if !atrs[op].rightAssociative {
            q++
        }
        node = expr(q)
        x = makeNode(atrs[op].nodeType, x, node)
    }
    return x
}

func parenExpr() *Tree {
    expect("parenExpr", tkLparen)
    t := expr(0)
    expect("parenExpr", tkRparen)
    return t
}

func stmt() *Tree {
    var t, v, e, s, s2 *Tree
    switch token.tok {
    case tkIf:
        token = getTok()
        e = parenExpr()
        s = stmt()
        s2 = nil
        if token.tok == tkElse {
            token = getTok()
            s2 = stmt()
        }
        t = makeNode(ndIf, e, makeNode(ndIf, s, s2))
    case tkPutc:
        token = getTok()
        e = parenExpr()
        t = makeNode(ndPrtc, e, nil)
        expect("Putc", tkSemi)
    case tkPrint: // print '(' expr {',' expr} ')'
        token = getTok()
        for expect("Print", tkLparen); ; expect("Print", tkComma) {
            if token.tok == tkString {
                e = makeNode(ndPrts, makeLeaf(ndString, token.text), nil)
                token = getTok()
            } else {
                e = makeNode(ndPrti, expr(0), nil)
            }
            t = makeNode(ndSequence, t, e)
            if token.tok != tkComma {
                break
            }
        }
        expect("Print", tkRparen)
        expect("Print", tkSemi)
    case tkSemi:
        token = getTok()
    case tkIdent:
        v = makeLeaf(ndIdent, token.text)
        token = getTok()
        expect("assign", tkAssign)
        e = expr(0)
        t = makeNode(ndAssign, v, e)
        expect("assign", tkSemi)
    case tkWhile:
        token = getTok()
        e = parenExpr()
        s = stmt()
        t = makeNode(ndWhile, e, s)
    case tkLbrace: // {stmt}
        for expect("Lbrace", tkLbrace); token.tok != tkRbrace && token.tok != tkEOI; {
            t = makeNode(ndSequence, t, stmt())
        }
        expect("Lbrace", tkRbrace)
    case tkEOI:
        // do nothing
    default:
        reportError(token.errLn, token.errCol,
            fmt.Sprintf("expecting start of statement, found '%s'\n", atrs[token.tok].text))
    }
    return t
}

func parse() *Tree {
    var t *Tree
    token = getTok()
    for {
        t = makeNode(ndSequence, t, stmt())
        if t == nil || token.tok == tkEOI {
            break
        }
    }
    return t
}

func prtAst(t *Tree) {
    if t == nil {
        fmt.Print(";\n")
    } else {
        fmt.Printf("%-14s ", displayNodes[t.nodeType])
        if t.nodeType == ndIdent || t.nodeType == ndInteger || t.nodeType == ndString {
            fmt.Printf("%s\n", t.value)
        } else {
            fmt.Println()
            prtAst(t.left)
            prtAst(t.right)
        }
    }
}

func main() {
    source, err := os.Open("source.txt")
    check(err)
    defer source.Close()
    scanner = bufio.NewScanner(source)
    prtAst(parse())
}


@echo off
setlocal enabledelayedexpansion

set Count=0
:loop
if not "%1"=="" (
   set /a count+=1
   set parameter[!count!]=%1
   shift
   goto loop
)

for /l %%a in (1,1,%count%) do (
   echo !parameter[%%a]!
)


global _start

: syscall ( num:eax -- result:eax | rcx ) syscall ;

: exit ( status:edi -- noret ) 60 syscall ;
: bye ( -- noret ) 0 exit ;
: die ( err:eax -- noret ) neg exit ;

: unwrap ( result:eax -- value:eax ) dup 0 cmp ' die xl ;
: ordie ( result -- ) unwrap drop ;

1 const stdout

: write ( buf:esi len:edx fd:edi -- ) 1 syscall ordie ;
: print ( buf len -- ) stdout write ;

: newline ( -- ) s" \n" print ;
: println ( buf len -- ) print newline ;

: find0 ( start:rsi -- end:rsi ) lodsb 0 cmp latest xne ;
: cstrlen ( str:rdi -- len:rsi ) dup find0 swap sub dec ;
: cstr>str ( cstr:rdx -- str:rsi len:rdx ) dup cstrlen xchg ;

: print-arg ( arg -- ) cstr>str println ;

: _start ( rsp -- noret ) dup @ swap
: print-args ( argc:rcx argv:rsp -- noret )
	8 add @ print-arg latest loop
	bye
;


from __future__ import print_function
import sys, struct, shlex, operator

nd_Ident, nd_String, nd_Integer, nd_Sequence, nd_If, nd_Prtc, nd_Prts, nd_Prti, nd_While, \
nd_Assign, nd_Negate, nd_Not, nd_Mul, nd_Div, nd_Mod, nd_Add, nd_Sub, nd_Lss, nd_Leq,     \
nd_Gtr, nd_Geq, nd_Eql, nd_Neq, nd_And, nd_Or = range(25)

all_syms = {
    "Identifier"  : nd_Ident,    "String"      : nd_String,
    "Integer"     : nd_Integer,  "Sequence"    : nd_Sequence,
    "If"          : nd_If,       "Prtc"        : nd_Prtc,
    "Prts"        : nd_Prts,     "Prti"        : nd_Prti,
    "While"       : nd_While,    "Assign"      : nd_Assign,
    "Negate"      : nd_Negate,   "Not"         : nd_Not,
    "Multiply"    : nd_Mul,      "Divide"      : nd_Div,
    "Mod"         : nd_Mod,      "Add"         : nd_Add,
    "Subtract"    : nd_Sub,      "Less"        : nd_Lss,
    "LessEqual"   : nd_Leq,      "Greater"     : nd_Gtr,
    "GreaterEqual": nd_Geq,      "Equal"       : nd_Eql,
    "NotEqual"    : nd_Neq,      "And"         : nd_And,
    "Or"          : nd_Or}

FETCH, STORE, PUSH, ADD, SUB, MUL, DIV, MOD, LT, GT, LE, GE, EQ, NE, AND, OR, NEG, NOT, \
JMP, JZ, PRTC, PRTS, PRTI, HALT = range(24)

operators = {nd_Lss: LT, nd_Gtr: GT, nd_Leq: LE, nd_Geq: GE, nd_Eql: EQ, nd_Neq: NE,
    nd_And: AND, nd_Or: OR, nd_Sub: SUB, nd_Add: ADD, nd_Div: DIV, nd_Mul: MUL, nd_Mod: MOD}

unary_operators = {nd_Negate: NEG, nd_Not: NOT}

input_file  = None
code        = bytearray()
string_pool = {}
globals     = {}
string_n    = 0
globals_n   = 0
word_size   = 4

#*** show error and exit
def error(msg):
    print("%s" % (msg))
    exit(1)

def int_to_bytes(val):
    return struct.pack("<i", val)

def bytes_to_int(bstr):
    return struct.unpack("<i", bstr)

class Node:
    def __init__(self, node_type, left = None, right = None, value = None):
        self.node_type  = node_type
        self.left  = left
        self.right = right
        self.value = value

#***
def make_node(oper, left, right = None):
    return Node(oper, left, right)

#***
def make_leaf(oper, n):
    return Node(oper, value = n)

#***
def emit_byte(x):
    code.append(x)

#***
def emit_word(x):
    s = int_to_bytes(x)
    for x in s:
        code.append(x)

def emit_word_at(at, n):
    code[at:at+word_size] = int_to_bytes(n)

def hole():
    t = len(code)
    emit_word(0)
    return t

#***
def fetch_var_offset(name):
    global globals_n

    n = globals.get(name, None)
    if n == None:
        globals[name] = globals_n
        n = globals_n
        globals_n += 1
    return n

#***
def fetch_string_offset(the_string):
    global string_n

    n = string_pool.get(the_string, None)
    if n == None:
        string_pool[the_string] = string_n
        n = string_n
        string_n += 1
    return n

#***
def code_gen(x):
    if x == None: return
    elif x.node_type == nd_Ident:
        emit_byte(FETCH)
        n = fetch_var_offset(x.value)
        emit_word(n)
    elif x.node_type == nd_Integer:
        emit_byte(PUSH)
        emit_word(x.value)
    elif x.node_type == nd_String:
        emit_byte(PUSH)
        n = fetch_string_offset(x.value)
        emit_word(n)
    elif x.node_type == nd_Assign:
        n = fetch_var_offset(x.left.value)
        code_gen(x.right)
        emit_byte(STORE)
        emit_word(n)
    elif x.node_type == nd_If:
        code_gen(x.left)              # expr
        emit_byte(JZ)                 # if false, jump
        p1 = hole()                   # make room for jump dest
        code_gen(x.right.left)        # if true statements
        if (x.right.right != None):
            emit_byte(JMP)            # jump over else statements
            p2 = hole()
        emit_word_at(p1, len(code) - p1)
        if (x.right.right != None):
            code_gen(x.right.right)   # else statements
            emit_word_at(p2, len(code) - p2)
    elif x.node_type == nd_While:
        p1 = len(code)
        code_gen(x.left)
        emit_byte(JZ)
        p2 = hole()
        code_gen(x.right)
        emit_byte(JMP)                       # jump back to the top
        emit_word(p1 - len(code))
        emit_word_at(p2, len(code) - p2)
    elif x.node_type == nd_Sequence:
        code_gen(x.left)
        code_gen(x.right)
    elif x.node_type == nd_Prtc:
        code_gen(x.left)
        emit_byte(PRTC)
    elif x.node_type == nd_Prti:
        code_gen(x.left)
        emit_byte(PRTI)
    elif x.node_type == nd_Prts:
        code_gen(x.left)
        emit_byte(PRTS)
    elif x.node_type in operators:
        code_gen(x.left)
        code_gen(x.right)
        emit_byte(operators[x.node_type])
    elif x.node_type in unary_operators:
        code_gen(x.left)
        emit_byte(unary_operators[x.node_type])
    else:
        error("error in code generator - found %d, expecting operator" % (x.node_type))

#***
def code_finish():
    emit_byte(HALT)

#***
def list_code():
    print("Datasize: %d Strings: %d" % (len(globals), len(string_pool)))

    for k in sorted(string_pool, key=string_pool.get):
        print(k)

    pc = 0
    while pc < len(code):
        print("%4d " % (pc), end='')
        op = code[pc]
        pc += 1
        if op == FETCH:
            x = bytes_to_int(code[pc:pc+word_size])[0]
            print("fetch [%d]" % (x));
            pc += word_size
        elif op == STORE:
            x = bytes_to_int(code[pc:pc+word_size])[0]
            print("store [%d]" % (x));
            pc += word_size
        elif op == PUSH:
            x = bytes_to_int(code[pc:pc+word_size])[0]
            print("push  %d" % (x));
            pc += word_size
        elif op == ADD:   print("add")
        elif op == SUB:   print("sub")
        elif op == MUL:   print("mul")
        elif op == DIV:   print("div")
        elif op == MOD:   print("mod")
        elif op == LT:    print("lt")
        elif op == GT:    print("gt")
        elif op == LE:    print("le")
        elif op == GE:    print("ge")
        elif op == EQ:    print("eq")
        elif op == NE:    print("ne")
        elif op == AND:   print("and")
        elif op == OR:    print("or")
        elif op == NEG:   print("neg")
        elif op == NOT:   print("not")
        elif op == JMP:
            x = bytes_to_int(code[pc:pc+word_size])[0]
            print("jmp    (%d) %d" % (x, pc + x));
            pc += word_size
        elif op == JZ:
            x = bytes_to_int(code[pc:pc+word_size])[0]
            print("jz     (%d) %d" % (x, pc + x));
            pc += word_size
        elif op == PRTC:  print("prtc")
        elif op == PRTI:  print("prti")
        elif op == PRTS:  print("prts")
        elif op == HALT:  print("halt")
        else: error("list_code: Unknown opcode %d", (op));

def load_ast():
    line = input_file.readline()
    line_list = shlex.split(line, False, False)

    text = line_list[0]
    if text == ";":
        return None
    node_type = all_syms[text]

    if len(line_list) > 1:
        value = line_list[1]
        if value.isdigit():
            value = int(value)
        return make_leaf(node_type, value)

    left = load_ast()
    right = load_ast()
    return make_node(node_type, left, right)

#*** main driver
input_file = sys.stdin
if len(sys.argv) > 1:
    try:
        input_file = open(sys.argv[1], "r", 4096)
    except IOError as e:
        error("Can't open %s" % sys.argv[1])

n = load_ast()
code_gen(n)
code_finish()
list_code()


; Single line comment
#| Multi-line
comment |#


;This is a comment

PROC Main() ;This is a comment as well
RETURN


-- All Ada comments begin with "--" and extend to the end of the line


#
# The Rosetta Code Tiny-Language Parser, in Icon.
#
# This implementation is based closely on the pseudocode and the C
# reference implementation.
#

# ximage from the IPL is useful for debugging. Use "xdump(x)" to
# pretty-print x.
#link ximage

record token_record (line_no, column_no, tok, tokval)
record token_getter (nxt, curr)

procedure main (args)
  local inpf_name, outf_name
  local inpf, outf
  local nexttok, currtok, current_token, gettok
  local ast

  inpf_name := "-"
  outf_name := "-"
  if 1 <= *args then inpf_name := args[1]
  if 2 <= *args then outf_name := args[2]

  inpf :=
      if inpf_name == "-" then
          &input
      else
          (open(inpf_name, "r") |
           stop("failed to open \"" || inpf_name || "\" for input"))
  outf :=
      if outf_name == "-" then
          &output
      else
          (open(outf_name, "w") |
           stop("failed to open \"" || outf_name || "\" for output"))

  current_token := [&null]
  nexttok := create generate_tokens(inpf, current_token)
  currtok := create get_current_token (current_token)
  gettok := token_getter(nexttok, currtok)
  ast := parse(gettok)
  prt_ast(outf, ast)

  close(inpf)
  close(outf)
end

procedure prt_ast (outf, ast)
  if *ast = 0 then {
    write(outf, ";")
  } else {
    writes(outf, ast[1])
    if ast[1] == ("Identifier" | "Integer" | "String") then {
      write(outf, " ", ast[2])
    } else {
      write(outf)
      prt_ast(outf, ast[2])
      prt_ast(outf, ast[3])
    }
  }
end

procedure generate_tokens (inpf, current_token)
  local s

  while s := read(inpf) do {
    if trim(s) ~== "" then {
      current_token[1] := string_to_token_record(s)
      suspend current_token[1]
    }
  }
end

procedure get_current_token (current_token)
  repeat (suspend current_token[1])
end

procedure string_to_token_record (s)
  local line_no, column_no, tok, tokval

  static spaces

  initial {
    spaces := ' \t\f\v\r\n'
  }

  trim(s) ? {
    tab(many(spaces))
    line_no := integer(tab(many(&digits)))
    tab(many(spaces))
    column_no := integer(tab(many(&digits)))
    tab(many(spaces))
    tok := tab(many(&letters ++ '_'))
    tab(many(spaces))
    tokval := tab(0)
  }
  return token_record(line_no, column_no, tok, tokval)
end

procedure parse (gettok)
  local tok
  local t

  t := []
  @gettok.nxt
  tok := "Not End_of_input"
  while tok ~== "End_of_input" do {
    t := ["Sequence", t, stmt(gettok)]
    tok := (@gettok.curr).tok
  }
  return t
end

procedure stmt (gettok)
  local e, s, t, v
  local tok
  local done

  t := []
  if accept(gettok, "Keyword_if") then {
    e := paren_expr(gettok)
    s := stmt(gettok)
    t := ["If", e, ["If", s,
                    if accept(gettok, "Keyword_else")
                    then stmt(gettok) else []]]
  } else if accept(gettok, "Keyword_putc") then {
    t := ["Prtc", paren_expr(gettok), []]
    expect(gettok, "Putc", "Semicolon")
  } else if accept(gettok, "Keyword_print") then {
    expect(gettok, "Print", "LeftParen")
    done := 0
    while done = 0 do {
      tok := @gettok.curr
      if tok.tok == "String" then {
        e := ["Prts", ["String", tok.tokval], []]
        @gettok.nxt
      } else {
        e := ["Prti", expr(gettok, 0), []]
      }
      t := ["Sequence", t, e]
      accept(gettok, "Comma") | (done := 1)
    }
    expect(gettok, "Print", "RightParen")
    expect(gettok, "Print", "Semicolon")
  } else if (@gettok.curr).tok == "Semicolon" then {
    @gettok.nxt
  } else if (@gettok.curr).tok == "Identifier" then {
    v := ["Identifier", (@gettok.curr).tokval]
    @gettok.nxt
    expect(gettok, "assign", "Op_assign")
    t := ["Assign", v, expr(gettok, 0)]
    expect(gettok, "assign", "Semicolon")
  } else if accept(gettok, "Keyword_while") then {
    e := paren_expr(gettok)
    t := ["While", e, stmt(gettok)]
  } else if accept(gettok, "LeftBrace") then {
    until (@gettok.curr).tok == ("RightBrace" | "End_of_input") do {
      t := ["Sequence", t, stmt(gettok)]
    }
    expect(gettok, "Lbrace", "RightBrace")
  } else if (@gettok.curr).tok ~== "End_of_input" then {
    tok := @gettok.curr
    error(tok, ("expecting start of statement, found '" ||
                text(tok.tok) || "'"))
  }
  return t
end

procedure paren_expr (gettok)
  local x

  expect(gettok, "paren_expr", "LeftParen");
  x := expr(gettok, 0);
  expect(gettok, "paren_expr", "RightParen");
  return x
end

procedure expr (gettok, p)
  local tok, save_tok
  local x, y
  local q

  tok := @gettok.curr
  case tok.tok of {
    "LeftParen" : {
      x := paren_expr(gettok)
    }
    "Op_subtract" : {
      @gettok.nxt
      y := expr(gettok, precedence("Op_negate"))
      x := ["Negate", y, []]
    }
    "Op_add" : {
      @gettok.nxt
      x := expr(gettok, precedence("Op_negate"))
    }
    "Op_not" : {
      @gettok.nxt
      y := expr(gettok, precedence("Op_not"))
      x := ["Not", y, []]
    }
    "Identifier" : {
      x := ["Identifier", tok.tokval]
      @gettok.nxt
    }
    "Integer" : {
      x := ["Integer", tok.tokval]
      @gettok.nxt
    }
    default : {
      error(tok, "Expecting a primary, found: " || text(tok.tok))
    }
  }

  while (tok := @gettok.curr &
         is_binary(tok.tok) &
         p <= precedence(tok.tok)) do
      {
        save_tok := tok
        @gettok.nxt
        q := precedence(save_tok.tok)
        if not is_right_associative(save_tok.tok) then q +:= 1
        x := [operator(save_tok.tok), x, expr(gettok, q)]
      }

  return x
end

procedure accept (gettok, tok)
  local nxt

  if (@gettok.curr).tok == tok then nxt := @gettok.nxt else fail
  return nxt
end

procedure expect (gettok, msg, tok)
  if (@gettok.curr).tok ~== tok then {
    error(@gettok.curr,
          msg || ": Expecting '" || text(tok) || "', found '" ||
          text((@gettok.curr).tok) || "'")
  }
  return @gettok.nxt
end

procedure error (token, msg)
  write("(", token.line_no, ", ", token.column_no, ") error: ", msg)
  exit(1)
end

procedure precedence (tok)
  local p

  case tok of {
    "Op_multiply" : p := 13
    "Op_divide" : p := 13
    "Op_mod" : p := 13
    "Op_add" : p := 12
    "Op_subtract" : p := 12
    "Op_negate" : p := 14
    "Op_not" : p := 14
    "Op_less" : p := 10
    "Op_lessequal" : p := 10
    "Op_greater" : p := 10
    "Op_greaterequal" : p := 10
    "Op_equal" : p := 9
    "Op_notequal" : p := 9
    "Op_and" : p := 5
    "Op_or" : p := 4
    default : p := -1
  }
  return p
end

procedure is_binary (tok)
  return ("Op_add" |
          "Op_subtract" |
          "Op_multiply" |
          "Op_divide" |
          "Op_mod" |
          "Op_less" |
          "Op_lessequal" |
          "Op_greater" |
          "Op_greaterequal" |
          "Op_equal" |
          "Op_notequal" |
          "Op_and" |
          "Op_or") == tok
  fail
end

procedure is_right_associative (tok)
  # None of the current operators is right associative.
  fail
end

procedure operator (tok)
  local s

  case tok of {
    "Op_multiply" : s := "Multiply"
    "Op_divide" : s := "Divide"
    "Op_mod" : s := "Mod"
    "Op_add" : s := "Add"
    "Op_subtract" : s := "Subtract"
    "Op_negate" : s := "Negate"
    "Op_not" : s := "Not"
    "Op_less" : s := "Less"
    "Op_lessequal" : s := "LessEqual"
    "Op_greater" : s := "Greater"
    "Op_greaterequal" : s := "GreaterEqual"
    "Op_equal" : s := "Equal"
    "Op_notequal" : s := "NotEqual"
    "Op_and" : s := "And"
    "Op_or" : s := "Or"
  }
  return s
end

procedure text (tok)
  local s

  case tok of {
    "Keyword_else"    :  s := "else"
    "Keyword_if"      :  s := "if"
    "Keyword_print"   :  s := "print"
    "Keyword_putc"    :  s := "putc"
    "Keyword_while"   :  s := "while"
    "Op_multiply"     :  s := "*"
    "Op_divide"       :  s := "/"
    "Op_mod"          :  s := "%"
    "Op_add"          :  s := "+"
    "Op_subtract"     :  s := "-"
    "Op_negate"       :  s := "-"
    "Op_less"         :  s := "<"
    "Op_lessequal"    :  s := "<="
    "Op_greater"      :  s := ">"
    "Op_greaterequal" :  s := ">="
    "Op_equal"        :  s := "=="
    "Op_notequal"     :  s := "!="
    "Op_not"          :  s := "!"
    "Op_assign"       :  s := "="
    "Op_and"          :  s := "&&"
    "Op_or"           :  s := "||"
    "LeftParen"       :  s := "("
    "RightParen"      :  s := ")"
    "LeftBrace"       :  s := "{"
    "RightBrace"      :  s := "}"
    "Semicolon"       :  s := ";"
    "Comma"           :  s := ","
    "Identifier"      :  s := "Ident"
    "Integer"         :  s := "Integer literal"
    "String"          :  s := "String literal"
    "End_of_input"    :  s := "EOI"
  }
  return s
end


#include <stdlib.h>
#include <stdio.h>

int main(int argc, char* argv[])
{
  int i;
  (void) printf("This program is named %s.\n", argv[0]);
  for (i = 1; i < argc; ++i)
    (void) printf("the argument #%d is %s\n", i, argv[i]);
  return EXIT_SUCCESS;
}


using System;

namespace RosettaCode {
    class Program {
        static void Main(string[] args) {
            for (int i = 0; i < args.Length; i++)
                Console.WriteLine(String.Format("Argument {0} is '{1}'", i, args[i]));
        }
    }
}


my %opnames = <
    Less   lt     LessEqual    le     Multiply mul    Subtract sub    NotEqual ne
    Divide div    GreaterEqual ge     Equal    eq     Greater  gt     Negate   neg
>;

my (@AST, %strings, %names);
my $string-count = my $name-count = my $pairsym = my $pc = 0;

sub tree {
    my ($A, $B) = ( '_' ~ ++$pairsym, '_' ~ ++$pairsym );
    my $line = @AST.shift // return '';
    $line ~~ /^ $<instr> = (\w+|';') [\s+ $<arg> =(.*)]? / or die "bad input $line";
    given $<instr> {
        when 'Identifier' { "fetch [{%names{$<arg>} //= $name-count++ }]\n" }
        when 'Sequence'   { tree() ~ tree() }
        when 'Integer'    { "push  $<arg>\n" }
        when 'String'     { "push  { %strings{$<arg>} //= $string-count++ }\n" }
        when 'Assign'     { join '', reverse (tree().subst( /fetch/, 'store')), tree() }
        when 'While'      { "$A:\n{ tree() }jz    $B\n{ tree() }jmp   $A\n$B:\n" }
        when 'If'         { tree() ~ "jz    $A\n{ [email protected] ~ tree() }jmp   $B\n$A:\n{ tree() }$B:\n" }
        when ';'          { '' }
        default           { tree() ~ tree() ~ (%opnames{$<instr>} // $<instr>.lc) ~ "\n" }
    }
}

@AST = slurp('ast.txt').lines;
my $code = tree() ~ "halt\n";

$code ~~ s:g/^^ jmp \s+ (\S+) \n ('_'\d+:\n) $0:\n/$1/;                                          # remove jmp next
$code ~~ s:g/^^ (<[a..z]>\w* (\N+)? ) $$/{my $l=$pc.fmt("%4d "); $pc += $0[0] ?? 5 !! 1; $l}$0/; # add locations
my %labels = ($code ~~ m:g/^^ ('_' \d+) ':' \n \s* (\d+)/)».Slip».Str;                           # pc addr of labels
$code ~~ s:g/^^ \s* (\d+) \s j[z|mp] \s* <(('_'\d+)/ ({%labels{$1} - $0 - 1}) %labels{$1}/;      # fix jumps
$code ~~ s:g/^^ '_'\d+.*?\n//;                                                                   # remove labels

say "Datasize: $name-count Strings: $string-count\n"
   ~ join('', %strings.keys.sort.reverse «~» "\n")
   ~ $code;


# single line comment

#/ multi-line comment
   - ends with the "/ followed by #" terminator on the next line
/#

/* multi-line comment - C-style
   - ends with the "* followed by /" terminator on the next line
*/


'COMMENT' this is a first comment;
'COMMENT'
****** this is a second comment ******
;


£ This is a hash/pound comment for a UK keyboard £


require'format/printf'

tkref=: tokenize 'End_of_input*/%+--<<=>>===!=!&&||print=print(if{else}while;,putc)a""0'
tkref,. (tknames)=: tknames=:;: {{)n
 End_of_input Op_multiply Op_divide Op_mod Op_add Op_subtract Op_negate Op_less
 Op_lessequal Op_greater Op_greaterequal Op_equal Op_notequal Op_not Op_and
 Op_or Keyword_print Op_assign Keyword_print LeftParen Keyword_if LeftBrace Keyword_else RightBrace
 Keyword_while Semicolon Comma Keyword_putc RightParen
 Identifier String Integer
}}-.LF

tkV=: 2 (tkref i.tokenize '*/%+-<<=>>===!=&&||')} (#tktyp)#0
tkV=: 1 (1 0+tkref i.tokenize '-!')} tkV
tkPrec=: 13 13 13 12 12 10 10 10 10 9 9 5 4 (tkref i.tokenize'*/%+-<<=>>==!=&&||')} tkV<._1
tkPrec=: 14 (1 0+tkref i.tokenize'-!')} tkPrec
NB. proofread |:(<"1 tkV,.tkPrec),tkref,:tknames

tkref,.(ndDisp)=: ndDisp=:;:{{)n
 Sequence Multiply Divide Mod Add Subtract Negate Less LessEqual Greater
 GreaterEqual Equal NotEqual Not And Or Prts Assign Prti x If x x x While
 x x Prtc x Identifier String Integer
}}-.LF
NB. proofread |:tkref,:ndDisp

gettoken=: {{
  'tok_ln tok_col'=: (0;ndx){::x
  'tok_name tok_value'=: (1;ndx){::x
  if. 'Error'-:tok_name do.
    error 'invalid word ',":tok_value
  end.
  ind=. tknames i.<tok_name
  tok_text=: ind{::tkref
  tok_valence=: ind{::tkV
  tok_precedence=: ind{::tkPrec
  ndx=:ndx+1
  node_display=: ind{::ndDisp
}}

parse=: {{
  ndx=: tok_ln=: tok_col=: 0
  gettok=: y&gettoken
  gettok''
  t=.a:
  whilst.-.(a:-:t)+.tok_name-:End_of_input do.
    t=. Sequence make_node t stmt''
  end.
}}

stmt=:{{)v
  t=. a:
  select.tok_name
    case.Keyword_if do.
      s=. stmt e=. paren_expr gettok''
      if.Keyword_else-:tok_name
      do.   S=. stmt gettok''
      else. S=. a: end.
      t=. If make_node e If make_node s S
    case.Keyword_putc do.
      e=. paren_expr gettok''
      t=. Prtc make_node e a:
      Prtc expect Semicolon
    case.Keyword_print do.gettok''
      'Print' expect LeftParen
      while.do.
        if.String-:tok_name
        do. gettok e=. Prts make_node (String make_leaf tok_value) a:
        else. e=. Prti make_node (expr 0) a: end.
        t=. Sequence make_node t e
        if.Comma-:tok_name
        do.Comma expect Comma
        else.break.end.
      end.
      'Print' expect RightParen
      'Print' expect Semicolon
    case.Semicolon do.gettok''
    case.Identifier do.
      gettok v=. Identifier make_leaf tok_value
      Assign expect Op_assign
      t=. Assign make_node v e=. expr 0
      Assign expect Semicolon
    case.Keyword_while do.
      t=. While make_node e s=. stmt e=. paren_expr gettok''
    case.LeftBrace do.
      'LeftBrace' expect LeftBrace
      while.-.(<tok_name) e.  RightBrace;End_of_input do.
        t=. Sequence make_node t stmt''
      end.
      'LeftBrace' expect RightBrace
    case.End_of_input do.
    case.do. error 'Expecting start of statement, found %s'sprintf<tok_text
  end.
  t
}}

paren_expr=: {{
  'paren_expr' expect LeftParen
  t=. expr 0
  'paren_expr' expect RightParen
  t
}}

not_prec=: tkPrec{~tknames i.<Op_not
expr=: {{
  select.tok_name
    case.LeftParen do.e=. paren_expr''
    case.Op_add do.gettok''
      e=. expr not_prec
    case.Op_subtract do.gettok''
      e=. Negate make_node (expr not_prec) a:
    case.Op_not do.gettok''
      e=. Not make_node (expr not_prec) a:
    case.Identifier do.
      gettok e=. Identifier make_leaf tok_value
    case.Integer do.
      gettok e=. Integer make_leaf tok_value
    case.do. error 'Expecting a primary, found %s'sprintf<tok_text
  end.
  while.(2=tok_valence)*tok_precedence>:y do.
    q=. 1+tok_precedence [ op=. node_display NB. no right associative operators
    gettok''
    node=. expr q
    e=. op make_node e node
  end.
  e
}}

expect=: {{
  if.y-:tok_name do. gettok'' return.end.
  error '%s: Expecting "%s", found "%s"'sprintf x;(tkref{::~tknames i.<y);tok_text
}}

make_leaf=: {{
  x;y
}}

make_node=: {{
  m;n;<y
}}

error=: {{
  echo 'Error: line %d, column %d: %s\n'sprintf tok_ln;tok_col;y throw.
}}

syntax=: {{
  ;(flatAST parse y),each LF
}}

flatAST=: {{
  assert.*L.y
  select.#y
    case.1 do.<';' assert.y-:a:
    case.2 do.<;:inv ":each y
    case.3 do.({.y),(flatAST 1{::y),flatAST 2{::y
    case.do.assert.0
  end.
}}


#include <iostream>

int main(int argc, char* argv[])
{
  std::cout << "This program is named " << argv[0] << std::endl;
  std::cout << "There are " << argc-1 << " arguments given." << std::endl;
  for (int i = 1; i < argc; ++i)
    std::cout << "the argument #" << i << " is " << argv[i] << std::endl;

  return 0;
}


(dorun (map println *command-line-args*))


% This program needs to be merged with PCLU's "useful.lib",
% where get_argv lives.
%
% pclu -merge $CLUHOME/lib/useful.lib -compile cmdline.clu

start_up = proc ()
    po: stream := stream$primary_output()

    args: sequence[string] := get_argv()

    for arg: string in sequence[string]$elements(args) do
        stream$putl(po, "arg: " || arg)
    end
end start_up


######################################################################
#
# The Rosetta Code code generator in Ratfor 77.
#
#
# In FORTRAN 77 and therefore in Ratfor 77, there is no way to specify
# that a value should be put on a call stack. Therefore there is no
# way to implement recursive algorithms in Ratfor 77 (although see the
# Ratfor for the "syntax analyzer" task, where a recursive language is
# implemented *in* Ratfor). We are forced to use non-recursive
# algorithms.
#
# How to deal with FORTRAN 77 input is another problem. I use
# formatted input, treating each line as an array of type
# CHARACTER--regrettably of no more than some predetermined, finite
# length. It is a very simple method and presents no significant
# difficulties, aside from the restriction on line length of the
# input.
#
#
# On a POSIX platform, the program can be compiled with f2c and run
# somewhat as follows:
#
#    ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
#    f2c -C -Nc80 gen-in-ratfor.f
#    cc gen-in-ratfor.c -lf2c
#    ./a.out < compiler-tests/primes.ast
#
# With gfortran, a little differently:
#
#    ratfor77 gen-in-ratfor.r > gen-in-ratfor.f
#    gfortran -fcheck=all -std=legacy gen-in-ratfor.f
#    ./a.out < compiler-tests/primes.ast
#
#
# I/O is strictly from default input and to default output, which, on
# POSIX systems, usually correspond respectively to standard input and
# standard output. (I did not wish to have to deal with unit numbers;
# these are now standardized in ISO_FORTRAN_ENV, but that is not
# available in FORTRAN 77.)
#
#---------------------------------------------------------------------

# Some parameters you may wish to modify.

define(LINESZ, 256)           # Size of an input line.
define(OUTLSZ, 1024)          # Size of an output line.
define(STRNSZ, 4096)          # Size of the string pool.
define(NODSSZ, 4096)          # Size of the nodes pool.
define(STCKSZ, 4096)          # Size of stacks.
define(MAXVAR, 256)           # Maximum number of variables.
define(MAXSTR, 256)           # Maximum number of strings.
define(CODESZ, 16384)         # Maximum size of a compiled program.

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

define(NEWLIN, 10)            # The Unix newline character (ASCII LF).
define(DQUOTE, 34)            # The double quote character.
define(BACKSL, 92)            # The backslash character.

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

define(NODESZ, 3)
define(NNEXTF, 1)               # Index for next-free.
define(NTAG,   1)               # Index for the tag.
                                # For an internal node --
define(NLEFT,  2)               #   Index for the left node.
define(NRIGHT, 3)               #   Index for the right node.
                                # For a leaf node --
define(NITV,   2)               #   Index for the string pool index.
define(NITN,   3)               #   Length of the value.

define(NIL, -1)                 # Nil node.

define(RGT, 10000)
define(STAGE2, 20000)
define(STAGE3, 30000)
define(STAGE4, 40000)

# The following all must be less than RGT.
define(NDID,    0)
define(NDSTR,   1)
define(NDINT,   2)
define(NDSEQ,   3)
define(NDIF,    4)
define(NDPRTC,  5)
define(NDPRTS,  6)
define(NDPRTI,  7)
define(NDWHIL,  8)
define(NDASGN,  9)
define(NDNEG,  10)
define(NDNOT,  11)
define(NDMUL,  12)
define(NDDIV,  13)
define(NDMOD,  14)
define(NDADD,  15)
define(NDSUB,  16)
define(NDLT,   17)
define(NDLE,   18)
define(NDGT,   19)
define(NDGE,   20)
define(NDEQ,   21)
define(NDNE,   22)
define(NDAND,  23)
define(NDOR,   24)

define(OPHALT,  1)
define(OPADD,   2)
define(OPSUB,   3)
define(OPMUL,   4)
define(OPDIV,   5)
define(OPMOD,   6)
define(OPLT,    7)
define(OPGT,    8)
define(OPLE,    9)
define(OPGE,   10)
define(OPEQ,   11)
define(OPNE,   12)
define(OPAND,  13)
define(OPOR,   14)
define(OPNEG,  15)
define(OPNOT,  16)
define(OPPRTC, 17)
define(OPPRTI, 18)
define(OPPRTS, 19)
define(OPFTCH, 20)
define(OPSTOR, 21)
define(OPPUSH, 22)
define(OPJMP,  23)
define(OPJZ,   24)

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

function issp (c)

  # Is a character a space character?

  implicit none

  character c
  logical issp

  integer ic

  ic = ichar (c)
  issp = (ic == 32 || (9 <= ic && ic <= 13))
end

function skipsp (str, i, imax)

  # Skip past spaces in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipsp

  logical issp

  logical done

  skipsp = i
  done = .false.
  while (!done)
    {
      if (imax <= skipsp)
        done = .true.
      else if (!issp (str(skipsp)))
        done = .true.
      else
        skipsp = skipsp + 1
    }
end

function skipns (str, i, imax)

  # Skip past non-spaces in a string.

  implicit none

  character str(*)
  integer i
  integer imax
  integer skipns

  logical issp

  logical done

  skipns = i
  done = .false.
  while (!done)
    {
      if (imax <= skipns)
        done = .true.
      else if (issp (str(skipns)))
        done = .true.
      else
        skipns = skipns + 1
    }
end

function trimrt (str, n)

  # Find the length of a string, if one ignores trailing spaces.

  implicit none

  character str(*)
  integer n
  integer trimrt

  logical issp

  logical done

  trimrt = n
  done = .false.
  while (!done)
    {
      if (trimrt == 0)
        done = .true.
      else if (!issp (str(trimrt)))
        done = .true.
      else
        trimrt = trimrt - 1
    }
end

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

subroutine addstr (strngs, istrng, src, i0, n0, i, n)

  # Add a string to the string pool.

  implicit none

  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  character src(*)              # Source string.
  integer i0, n0                # Index and length in source string.
  integer i, n                  # Index and length in string pool.

  integer j

  if (STRNSZ < istrng + (n0 - 1))
    {
      write (*, '(''string pool exhausted'')')
      stop
    }
  if (n0 == 0)
    {
      i = 0
      n = 0
    }
  else
    {
      for (j = 0; j < n0; j = j + 1)
        strngs(istrng + j) = src(i0 + j)
      i = istrng
      n = n0
      istrng = istrng + n0
    }
end

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

subroutine push (stack, sp, i)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer i                     # Value to push.

  if (sp == STCKSZ)
    {
      write (*, '(''stack overflow in push'')')
      stop
    }
  stack(sp) = i
  sp = sp + 1
end

function pop (stack, sp)

  implicit none

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer pop

  if (sp == 1)
    {
      write (*, '(''stack underflow in pop'')')
      stop
    }
  sp = sp - 1
  pop = stack(sp)
end

function nstack (sp)

  implicit none

  integer sp                    # Stack pointer.
  integer nstack

  nstack = sp - 1               # Current cardinality of the stack.
end

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

subroutine initnd (nodes, frelst)

  # Initialize the nodes pool.

  implicit none

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.

  integer i

  for (i = 1; i < NODSSZ; i = i + 1)
    nodes(NNEXTF, i) = i + 1
  nodes(NNEXTF, NODSSZ) = NIL
  frelst = 1
end

subroutine newnod (nodes, frelst, i)

  # Get the index for a new node taken from the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the new node.

  integer j

  if (frelst == NIL)
    {
      write (*, '(''nodes pool exhausted'')')
      stop
    }
  i = frelst
  frelst = nodes(NNEXTF, frelst)
  for (j = 1; j <= NODESZ; j = j + 1)
    nodes(j, i) = 0
end

subroutine frenod (nodes, frelst, i)

  # Return a node to the free list.

  integer nodes (NODESZ, NODSSZ)
  integer frelst                # Head of the free list.
  integer i                     # Index of the node to free.

  nodes(NNEXTF, i) = frelst
  frelst = i
end

function strtag (str, i, n)

  implicit none

  character str(*)
  integer i, n
  integer strtag

  character*16 s
  integer j

  for (j = 0; j < 16; j = j + 1)
    if (j < n)
      s(j + 1 : j + 1) = str(i + j)
    else
      s(j + 1 : j + 1) = ' '

  if (s == "Identifier      ")
    strtag = NDID
  else if (s == "String          ")
    strtag = NDSTR
  else if (s == "Integer         ")
    strtag = NDINT
  else if (s == "Sequence        ")
    strtag = NDSEQ
  else if (s == "If              ")
    strtag = NDIF
  else if (s == "Prtc            ")
    strtag = NDPRTC
  else if (s == "Prts            ")
    strtag = NDPRTS
  else if (s == "Prti            ")
    strtag = NDPRTI
  else if (s == "While           ")
    strtag = NDWHIL
  else if (s == "Assign          ")
    strtag = NDASGN
  else if (s == "Negate          ")
    strtag = NDNEG
  else if (s == "Not             ")
    strtag = NDNOT
  else if (s == "Multiply        ")
    strtag = NDMUL
  else if (s == "Divide          ")
    strtag = NDDIV
  else if (s == "Mod             ")
    strtag = NDMOD
  else if (s == "Add             ")
    strtag = NDADD
  else if (s == "Subtract        ")
    strtag = NDSUB
  else if (s == "Less            ")
    strtag = NDLT
  else if (s == "LessEqual       ")
    strtag = NDLE
  else if (s == "Greater         ")
    strtag = NDGT
  else if (s == "GreaterEqual    ")
    strtag = NDGE
  else if (s == "Equal           ")
    strtag = NDEQ
  else if (s == "NotEqual        ")
    strtag = NDNE
  else if (s == "And             ")
    strtag = NDAND
  else if (s == "Or              ")
    strtag = NDOR
  else if (s == ";               ")
    strtag = NIL
  else
    {
      write (*, '(''unrecognized input line: '', A16)') s
      stop
    }
end

subroutine readln (strngs, istrng, tag, iarg, narg)

  # Read a line of the AST input.

  implicit none

  character strngs(STRNSZ) # String pool.
  integer istrng           # String pool's next slot.
  integer tag              # The node tag or NIL.
  integer iarg             # Index of an argument in the string pool.
  integer narg             # Length of an argument in the string pool.

  integer trimrt
  integer strtag
  integer skipsp
  integer skipns

  character line(LINESZ)
  character*20 fmt
  integer i, j, n

  # Read a line of text as an array of characters.
  write (fmt, '(''('', I10, ''A)'')') LINESZ
  read (*, fmt) line

  n = trimrt (line, LINESZ)

  i = skipsp (line, 1, n + 1)
  j = skipns (line, i, n + 1)
  tag = strtag (line, i, j - i)

  i = skipsp (line, j, n + 1)
  call addstr (strngs, istrng, line, i, (n + 1) - i, iarg, narg)
end

function hasarg (tag)

  implicit none

  integer tag
  logical hasarg

  hasarg = (tag == NDID || tag == NDINT || tag == NDSTR)
end

subroutine rdast (strngs, istrng, nodes, frelst, iast)

  # Read in the AST. A non-recursive algorithm is used.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  integer iast                   # Index of root node of the AST.

  integer nstack
  integer pop
  logical hasarg

  integer stack(STCKSZ)
  integer sp                    # Stack pointer.
  integer tag, iarg, narg
  integer i, j, k

  sp = 1

  call readln (strngs, istrng, tag, iarg, narg)
  if (tag == NIL)
    iast = NIL
  else
    {
      call newnod (nodes, frelst, i)
      iast = i
      nodes(NTAG, i) = tag
      nodes(NITV, i) = 0
      nodes(NITN, i) = 0
      if (hasarg (tag))
        {
          nodes(NITV, i) = iarg
          nodes(NITN, i) = narg
        }
      else
        {
          call push (stack, sp, i + RGT)
          call push (stack, sp, i)
          while (nstack (sp) != 0)
            {
              j = pop (stack, sp)
              k = mod (j, RGT)
              call readln (strngs, istrng, tag, iarg, narg)
              if (tag == NIL)
                i = NIL
              else
                {
                  call newnod (nodes, frelst, i)
                  nodes(NTAG, i) = tag
                  if (hasarg (tag))
                    {
                      nodes(NITV, i) = iarg
                      nodes(NITN, i) = narg
                    }
                  else
                    {
                      call push (stack, sp, i + RGT)
                      call push (stack, sp, i)
                    }
                }
              if (j == k)
                nodes(NLEFT, k) = i
              else
                nodes(NRIGHT, k) = i
            }
        }
    }
end

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

subroutine flushl (outbuf, noutbf)

  # Flush a line from the output buffer.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.

  character*20 fmt
  integer i

  if (noutbf == 0)
    write (*, '()')
  else
    {
      write (fmt, 1000) noutbf
1000  format ('(', I10, 'A)')
      write (*, fmt) (outbuf(i), i = 1, noutbf)
      noutbf = 0
    }
end

subroutine wrtchr (outbuf, noutbf, ch)

  # Write a character to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character ch                  # The character to output.

  # This routine silently truncates anything that goes past the buffer
  # boundary.

  if (ch == char (NEWLIN))
    call flushl (outbuf, noutbf)
  else if (noutbf < OUTLSZ)
    {
      noutbf = noutbf + 1
      outbuf(noutbf) = ch
    }
end

subroutine wrtstr (outbuf, noutbf, str, i, n)

  # Write a substring to output.

  implicit none

  character outbuf(OUTLSZ)      # Output line buffer.
  integer noutbf                # Number of characters in outbuf.
  character str(*)              # The string from which to output.
  integer i, n                  # Index and length of the substring.

  integer j

  for (j = 0; j < n; j = j + 1)
    call wrtchr (outbuf, noutbf, str(i + j))
end

subroutine wrtint (outbuf, noutbf, ival, colcnt)

  # Write a non-negative integer to output.

  implicit none

  character outbuf(OUTLSZ)    # Output line buffer.
  integer noutbf              # Number of characters in outbuf.
  integer ival                # The non-negative integer to print.
  integer colcnt              # Column count, or zero for free format.

  integer skipsp

  character*40 buf
  integer i, j

  write (buf, '(I40)') ival
  i = skipsp (buf, 1, 41)
  if (0 < colcnt)
    for (j = 1; j < colcnt - (40 - i); j = j + 1)
      call wrtchr (outbuf, noutbf, ' ')
  while (i <= 40)
    {
      call wrtchr (outbuf, noutbf, buf(i:i))
      i = i + 1
    }
end

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

define(VARSZ,  3)
define(VNAMEI, 1)          # Variable name's index in the string pool.
define(VNAMEN, 2)          # Length of the name.
define(VVALUE, 3)          # Variable's number in the VM's data pool.

function fndvar (vars, numvar, strngs, istrng, i0, n0)

  implicit none

  integer vars(VARSZ, MAXVAR)   # Variables.
  integer numvar                # Number of variables.
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer i0, n0                # Index and length in the string pool.
  integer fndvar                # The location of the variable.

  integer j, k
  integer i, n
  logical done1
  logical done2

  j = 1
  done1 = .false.
  while (!done1)
    if (j == numvar + 1)
      done1 = .true.
    else if (n0 == vars(VNAMEN, j))
      {
        k = 0
        done2 = .false.
        while (!done2)
          if (n0 <= k)
            done2 = .true.
          else if (strngs(i0 + k) == strngs(vars(VNAMEI, j) + k))
            k = k + 1
          else
            done2 = .true.
        if (k < n0)
          j = j + 1
        else
          {
            done2 = .true.
            done1 = .true.
          }
      }
    else
      j = j + 1

  if (j == numvar + 1)
    {
      if (numvar == MAXVAR)
        {
          write (*, '(''too many variables'')')
          stop
        }
      numvar = numvar + 1
      call addstr (strngs, istrng, strngs, i0, n0, i, n)
      vars(VNAMEI, numvar) = i
      vars(VNAMEN, numvar) = n
      vars(VVALUE, numvar) = numvar - 1
      fndvar = numvar
    }
  else
    fndvar = j
end

define(STRSZ,  3)
define(STRI, 1)        # String's index in this program's string pool.
define(STRN, 2)        # Length of the string.
define(STRNO, 3)       # String's number in the VM's string pool.

function fndstr (strs, numstr, strngs, istrng, i0, n0)

  implicit none

  integer strs(STRSZ, MAXSTR)   # Strings for the VM's string pool.
  integer numstr                # Number of such strings.
  character strngs(STRNSZ)      # String pool.
  integer istrng                # String pool's next slot.
  integer i0, n0                # Index and length in the string pool.
  integer fndstr # The location of the string in the VM's string pool.

  integer j, k
  integer i, n
  logical done1
  logical done2

  j = 1
  done1 = .false.
  while (!done1)
    if (j == numstr + 1)
      done1 = .true.
    else if (n0 == strs(STRN, j))
      {
        k = 0
        done2 = .false.
        while (!done2)
          if (n0 <= k)
            done2 = .true.
          else if (strngs(i0 + k) == strngs(strs(STRI, j) + k))
            k = k + 1
          else
            done2 = .true.
        if (k < n0)
          j = j + 1
        else
          {
            done2 = .true.
            done1 = .true.
          }
      }
    else
      j = j + 1

  if (j == numstr + 1)
    {
      if (numstr == MAXSTR)
        {
          write (*, '(''too many string literals'')')
          stop
        }
      numstr = numstr + 1
      call addstr (strngs, istrng, strngs, i0, n0, i, n)
      strs(STRI, numstr) = i
      strs(STRN, numstr) = n
      strs(STRNO, numstr) = numstr - 1
      fndstr = numstr
    }
  else
    fndstr = j
end

function strint (strngs, i, n)

  # Convert a string to a non-negative integer.

  implicit none

  character strngs(STRNSZ)       # String pool.
  integer i, n
  integer strint

  integer j

  strint = 0
  for (j = 0; j < n; j = j + 1)
    strint = (10 * strint) + (ichar (strngs(i + j)) - ichar ('0'))
end

subroutine put1 (code, ncode, i, opcode)

  # Store a 1-byte operation.

  implicit none

  integer code(0 : CODESZ - 1)  # Generated code.
  integer ncode                 # Number of VM bytes in the code.
  integer i                     # Address to put the code at.
  integer opcode

  if (CODESZ - i < 1)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
  ncode = max (ncode, i + 1)
end

subroutine put5 (code, ncode, i, opcode, ival)

  # Store a 5-byte operation.

  implicit none

  integer code(0 : CODESZ - 1)  # Generated code.
  integer ncode                 # Number of VM bytes in the code.
  integer i                     # Address to put the code at.
  integer opcode
  integer ival                  # Immediate integer value.

  if (CODESZ - i < 5)
    {
      write (*, '(''address beyond the size of memory'')')
      stop
    }
  code(i) = opcode
  code(i + 1) = ival  # Do not bother to break the integer into bytes.
  code(i + 2) = 0
  code(i + 3) = 0
  code(i + 4) = 0
  ncode = max (ncode, i + 5)
end

subroutine compil (vars, numvar, _
                   strs, numstr, _
                   strngs, istrng, _
                   nodes, frelst, _
                   code, ncode, iast)

  # Compile the AST to virtual machine code. The algorithm employed is
  # non-recursive.

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  integer code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  integer iast                   # Root node of the AST.

  integer fndvar
  integer fndstr
  integer nstack
  integer pop
  integer strint

  integer xstack(STCKSZ)        # Node stack.
  integer ixstck                # Node stack pointer.
  integer i
  integer i0, n0
  integer tag
  integer ivar
  integer inode1, inode2, inode3
  integer addr1, addr2

  ixstck = 1
  call push (xstack, ixstck, iast)
  while (nstack (ixstck) != 0)
    {
      i = pop (xstack, ixstck)
      if (i == NIL)
        tag = NIL
      else
        tag = nodes(NTAG, i)
      if (tag == NIL)
        continue
      else if (tag < STAGE2)
        {
          if (tag == NDSEQ)
            {
              if (nodes(NRIGHT, i) != NIL)
                call push (xstack, ixstck, nodes(NRIGHT, i))
              if (nodes(NLEFT, i) != NIL)
                call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDID)
            {
              # Fetch the value of a variable.
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
              ivar = vars(VVALUE, ivar)
              call put5 (code, ncode, ncode, OPFTCH, ivar)
            }
          else if (tag == NDINT)
            {
              # Push the value of an integer literal.
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              call put5 (code, ncode, ncode, OPPUSH, _
                         strint (strngs, i0, n0))
            }
          else if (tag == NDNEG)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDNEG + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDNOT)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDNOT + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDAND)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDAND + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDOR)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDOR + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDADD)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDADD + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDSUB)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDSUB + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDMUL)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDMUL + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDDIV)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDDIV + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDMOD)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDMOD + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDLT)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDLT + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDLE)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDLE + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDGT)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDGT + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDGE)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDGE + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDEQ)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDEQ + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDNE)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDNE + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDASGN)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDASGN + STAGE2
              nodes(NITV, inode1) = nodes(NITV, nodes(NLEFT, i))
              nodes(NITN, inode1) = nodes(NITN, nodes(NLEFT, i))
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NRIGHT, i))
            }
          else if (tag == NDPRTS)
            {
              i0 = nodes(NITV, nodes(NLEFT, i))
              n0 = nodes(NITN, nodes(NLEFT, i))
              ivar = fndstr (strs, numstr, strngs, istrng, i0, n0)
              ivar = strs(STRNO, ivar)
              call put5 (code, ncode, ncode, OPPUSH, ivar)
              call put1 (code, ncode, ncode, OPPRTS)
            }
          else if (tag == NDPRTC)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDPRTC + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDPRTI)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDPRTI + STAGE2
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDWHIL)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDWHIL + STAGE2
              nodes(NLEFT, inode1) = nodes(NRIGHT, i) # Loop body.
              nodes(NRIGHT, inode1) = ncode # Addr. of top of loop.
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
          else if (tag == NDIF)
            {
              call newnod (nodes, frelst, inode1)
              nodes(NTAG, inode1) = NDIF + STAGE2
              # The "then" and "else" clauses, respectively:
              nodes(NLEFT, inode1) = nodes(NLEFT, nodes(NRIGHT, i))
              nodes(NRIGHT, inode1) = nodes(NRIGHT, nodes(NRIGHT, i))
              call push (xstack, ixstck, inode1)
              call push (xstack, ixstck, nodes(NLEFT, i))
            }
        }
      else
        {
          if (tag == NDNEG + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNEG)
            }
          else if (tag == NDNOT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNOT)
            }
          else if (tag == NDAND + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPAND)
            }
          else if (tag == NDOR + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPOR)
            }
          else if (tag == NDADD + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPADD)
            }
          else if (tag == NDSUB + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPSUB)
            }
          else if (tag == NDMUL + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPMUL)
            }
          else if (tag == NDDIV + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPDIV)
            }
          else if (tag == NDMOD + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPMOD)
            }
          else if (tag == NDLT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPLT)
            }
          else if (tag == NDLE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPLE)
            }
          else if (tag == NDGT + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPGT)
            }
          else if (tag == NDGE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPGE)
            }
          else if (tag == NDEQ + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPEQ)
            }
          else if (tag == NDNE + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPNE)
            }
          else if (tag == NDASGN + STAGE2)
            {
              i0 = nodes(NITV, i)
              n0 = nodes(NITN, i)
              call frenod (nodes, frelst, i)
              ivar = fndvar (vars, numvar, strngs, istrng, i0, n0)
              ivar = vars(VVALUE, ivar)
              call put5 (code, ncode, ncode, OPSTOR, ivar)
            }
          else if (tag == NDPRTC + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPPRTC)
            }
          else if (tag == NDPRTI + STAGE2)
            {
              call frenod (nodes, frelst, i)
              call put1 (code, ncode, ncode, OPPRTI)
            }
          else if (tag == NDWHIL + STAGE2)
            {
              inode1 = nodes(NLEFT, i) # Loop body.
              addr1 = nodes(NRIGHT, i) # Addr. of top of loop.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJZ, 0)
              call newnod (nodes, frelst, inode2)
              nodes(NTAG, inode2) = NDWHIL + STAGE3
              nodes(NLEFT, inode2) = addr1      # Top of loop.
              nodes(NRIGHT, inode2) = ncode - 4 # Fixup address.
              call push (xstack, ixstck, inode2)
              call push (xstack, ixstck, inode1)
            }
          else if (tag == NDWHIL + STAGE3)
            {
              addr1 = nodes(NLEFT, i)  # Top of loop.
              addr2 = nodes(NRIGHT, i) # Fixup address.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJMP, addr1)
              code(addr2) = ncode
            }
          else if (tag == NDIF + STAGE2)
            {
              inode1 = nodes(NLEFT, i)  # "Then" clause.
              inode2 = nodes(NRIGHT, i) # "Else" clause.
              call frenod (nodes, frelst, i)
              call put5 (code, ncode, ncode, OPJZ, 0)
              call newnod (nodes, frelst, inode3)
              nodes(NTAG, inode3) = NDIF + STAGE3
              nodes(NLEFT, inode3) = ncode - 4 # Fixup address.
              nodes(NRIGHT, inode3) = inode2   # "Else" clause.
              call push (xstack, ixstck, inode3)
              call push (xstack, ixstck, inode1)
            }
          else if (tag == NDIF + STAGE3)
            {
              addr1 = nodes(NLEFT, i)   # Fixup address.
              inode1 = nodes(NRIGHT, i) # "Else" clause.
              call frenod (nodes, frelst, i)
              if (inode2 == NIL)
                code(addr1) = ncode
              else
                {
                  call put5 (code, ncode, ncode, OPJMP, 0)
                  addr2 = ncode - 4 # Another fixup address.
                  code(addr1) = ncode
                  call newnod (nodes, frelst, inode2)
                  nodes(NTAG, inode2) = NDIF + STAGE4
                  nodes(NLEFT, inode2) = addr2
                  call push (xstack, ixstck, inode2)
                  call push (xstack, ixstck, inode1)
                }
            }
          else if (tag == NDIF + STAGE4)
            {
              addr1 = nodes(NLEFT, i) # Fixup address.
              call frenod (nodes, frelst, i)
              code(addr1) = ncode
            }
        }
    }
  call put1 (code, ncode, ncode, OPHALT)
end

function opname (opcode)

  implicit none

  integer opcode
  character*8  opname

  if (opcode == OPHALT)
    opname = 'halt    '
  else if (opcode == OPADD)
    opname = 'add     '
  else if (opcode == OPSUB)
    opname = 'sub     '
  else if (opcode == OPMUL)
    opname = 'mul     '
  else if (opcode == OPDIV)
    opname = 'div     '
  else if (opcode == OPMOD)
    opname = 'mod     '
  else if (opcode == OPLT)
    opname = 'lt      '
  else if (opcode == OPGT)
    opname = 'gt      '
  else if (opcode == OPLE)
    opname = 'le      '
  else if (opcode == OPGE)
    opname = 'ge      '
  else if (opcode == OPEQ)
    opname = 'eq      '
  else if (opcode == OPNE)
    opname = 'ne      '
  else if (opcode == OPAND)
    opname = 'and     '
  else if (opcode == OPOR)
    opname = 'or      '
  else if (opcode == OPNEG)
    opname = 'neg     '
  else if (opcode == OPNOT)
    opname = 'not     '
  else if (opcode == OPPRTC)
    opname = 'prtc    '
  else if (opcode == OPPRTI)
    opname = 'prti    '
  else if (opcode == OPPRTS)
    opname = 'prts    '
  else if (opcode == OPFTCH)
    opname = 'fetch   '
  else if (opcode == OPSTOR)
    opname = 'store   '
  else if (opcode == OPPUSH)
    opname = 'push    '
  else if (opcode == OPJMP)
    opname = 'jmp     '
  else if (opcode == OPJZ)
    opname = 'jz      '
  else
    {
      write (*, '(''Unrecognized opcode: '', I5)') opcode
      stop
    }
end

subroutine prprog (numvar, strs, numstr, strngs, istrng, _
                   code, ncode, outbuf, noutbf)

  implicit none

  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.

  character*8 opname

  integer i0, n0
  integer i, j
  integer opcode
  character*8 name

  character buf(20)
  buf(1) = 'D'
  buf(2) = 'a'
  buf(3) = 't'
  buf(4) = 'a'
  buf(5) = 's'
  buf(6) = 'i'
  buf(7) = 'z'
  buf(8) = 'e'
  buf(9) = ':'
  buf(10) = ' '
  call wrtstr (outbuf, noutbf, buf, 1, 10)
  call wrtint (outbuf, noutbf, numvar, 0)
  buf(1) = ' '
  buf(2) = 'S'
  buf(3) = 't'
  buf(4) = 'r'
  buf(5) = 'i'
  buf(6) = 'n'
  buf(7) = 'g'
  buf(8) = 's'
  buf(9) = ':'
  buf(10) = ' '
  call wrtstr (outbuf, noutbf, buf, 1, 10)
  call wrtint (outbuf, noutbf, numstr, 0)
  call wrtchr (outbuf, noutbf, char (NEWLIN))

  for (i = 1; i <= numstr; i = i + 1)
    {
      i0 = strs(STRI, i)
      n0 = strs(STRN, i)
      call wrtstr (outbuf, noutbf, strngs, i0, n0)
      call wrtchr (outbuf, noutbf, char (NEWLIN))
    }

  i = 0
  while (i != ncode)
    {
      opcode = code(i)
      name = opname (opcode)
      call wrtint (outbuf, noutbf, i, 10)
      for (j = 1; j <= 2; j = j + 1)
        call wrtchr (outbuf, noutbf, ' ')
      for (j = 1; j <= 8; j = j + 1)
        {
          if (opcode == OPFTCH _
                || opcode == OPSTOR _
                || opcode == OPPUSH _
                || opcode == OPJMP _
                || opcode == OPJZ)
            call wrtchr (outbuf, noutbf, name(j:j))
          else if (name(j:j) != ' ')
            call wrtchr (outbuf, noutbf, name(j:j))
        }
      if (opcode == OPPUSH)
        {
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          i = i + 5
        }
      else if (opcode == OPFTCH || opcode == OPSTOR)
        {
          call wrtchr (outbuf, noutbf, '[')
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          call wrtchr (outbuf, noutbf, ']')
          i = i + 5
        }
      else if (opcode == OPJMP || opcode == OPJZ)
        {
          call wrtchr (outbuf, noutbf, '(')
          call wrtint (outbuf, noutbf, code(i + 1) - (i + 1), 0)
          call wrtchr (outbuf, noutbf, ')')
          call wrtchr (outbuf, noutbf, ' ')
          call wrtint (outbuf, noutbf, code(i + 1), 0)
          i = i + 5
        }
      else
        i = i + 1
      call wrtchr (outbuf, noutbf, char (NEWLIN))
    }
end

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

program gen

  implicit none

  integer vars(VARSZ, MAXVAR)    # Variables.
  integer numvar                 # Number of variables.
  integer strs(STRSZ, MAXSTR)    # Strings for the VM's string pool.
  integer numstr                 # Number of such strings.
  character strngs(STRNSZ)       # String pool.
  integer istrng                 # String pool's next slot.
  integer nodes (NODESZ, NODSSZ) # Nodes pool.
  integer frelst                 # Head of the free list.
  character outbuf(OUTLSZ)       # Output line buffer.
  integer noutbf                 # Number of characters in outbuf.
  integer code(0 : CODESZ - 1)   # Generated code.
  integer ncode                  # Number of VM bytes in the code.
  integer iast                   # Root node of the AST.

  numvar = 0
  numstr = 0
  istrng = 1
  noutbf = 0
  ncode = 0

  call initnd (nodes, frelst)
  call rdast (strngs, istrng, nodes, frelst, iast)

  call compil (vars, numvar, strs, numstr, _
               strngs, istrng, nodes, frelst, _
               code, ncode, iast)
  call prprog (numvar, strs, numstr, strngs, istrng, _
               code, ncode, outbuf, noutbf)

  if (noutbf != 0)
    call flushl (outbuf, noutbf)
end

######################################################################


begin
    comment a comment;
    % another comment
    ;
    % and
      another
    %
end this_word_is_also_a_comment.


/* multiline comment
are like C ... */
-> this is a end of line comment


with Ada.Text_IO;

with PDF_Out;

procedure Color_Pinstripe_Printer
is
   use PDF_Out;

   package Point_IO
   is new Ada.Text_Io.Float_IO (Real);

   procedure Pinstripe (Doc          : in out Pdf_Out_File;
                        Line_Width   : Real;
                        Line_Height  : Real;
                        Screen_Width : Real;
                        Y            : Real)
   is
      type Color_Range is (Blck, Red, Green, Blue, Magenta, Cyan, Yellow, White);
      Colors : constant array (Color_Range) of Color_Type
        := (Blck    => (0.0, 0.0, 0.0), Red   => (1.0, 0.0, 0.0),
            Green   => (0.0, 1.0, 0.0), Blue  => (0.0, 0.0, 1.0),
            Magenta => (1.0, 0.0, 1.0), Cyan  => (0.0, 1.0, 1.0),
            Yellow  => (1.0, 1.0, 0.0), White => (1.0, 1.0, 1.0));
      Col : Color_Range := Color_Range'First;

      Count  : constant Natural
        := Natural (Real'Floor (Screen_Width / Line_Width));
      Corner      : constant Point := (Doc.Left_Margin, Doc.Bottom_Margin);
      Corner_Box  : constant Point := Corner     + (10.0, 10.0);
      Corner_Text : constant Point := Corner_Box + (10.0, 10.0);
      Light_Gray  : constant Color_Type := (0.9, 0.9, 0.9);
      Image : String (1 .. 4);
   begin
      --  Pinstripes
      for A in 0 .. Count loop
         Doc.Color (Colors (Col));
         Doc.Draw (What => Corner +
                     Rectangle'(X_Min  => Real (A) * Line_Width,
                                Y_Min  => Y,
                                Width  => Line_Width,
                                Height => Line_Height),
                   Rendering => Fill);
         Col := (if Col = Color_Range'Last
                 then Color_Range'First
                 else Color_Range'Succ (Col));
      end loop;

      --  Box
      Doc.Stroking_Color (Black);
      Doc.Color (Light_Gray);
      Doc.Line_Width (3.0);
      Doc.Draw (What => Corner_Box + (0.0, Y, 150.0, 26.0),
                Rendering => Fill_Then_Stroke);
      --  Text
      Doc.Color (Black);
      Doc.Text_Rendering_Mode (Fill);
      Point_Io.Put (Image, Line_Width, Aft => 1, Exp => 0);
      Doc.Put_XY (Corner_Text.X, Corner_Text.Y + Y,
                  Image & " point color pinstripe");
   end Pinstripe;

   Doc : PDF_Out_File;
begin
   Doc.Create ("color-pinstripe.pdf");
   Doc.Page_Setup (A4_Portrait);
   Doc.Margins (Margins_Type'(Left   => Cm_2_5,
                              others => One_cm));
   declare
      Width  : constant Real
        := A4_Portrait.Width - Doc.Left_Margin - Doc.Right_Margin;
      Height : constant Real
        := A4_Portrait.Height - Doc.Top_Margin - Doc.Bottom_Margin;
   begin
      for Point in 1 .. 11 loop
         Pinstripe (Doc,
                    Line_Width   => Real (Point),
                    Line_Height  => One_Inch,
                    Screen_Width => Width,
                    Y            => Height - Real (Point) * One_Inch);
      end loop;
   end;
   Doc.Close;
end Color_Pinstripe_Printer;


import java.io.File;
import java.io.FileNotFoundException;
import java.util.Scanner;
import java.util.StringTokenizer;
import java.util.List;
import java.util.ArrayList;
import java.util.Map;
import java.util.HashMap;

class Parser {
	private List<Token> source;
	private Token token;
	private int position;

	static class Node {
		public NodeType nt;
		public Node left, right;
		public String value;

		Node() {
			this.nt = null;
			this.left = null;
			this.right = null;
			this.value = null;
		}
		Node(NodeType node_type, Node left, Node right, String value) {
			this.nt = node_type;
			this.left = left;
			this.right = right;
			this.value = value;
		}
		public static Node make_node(NodeType nodetype, Node left, Node right) {
			return new Node(nodetype, left, right, "");
		}
		public static Node make_node(NodeType nodetype, Node left) {
			return new Node(nodetype, left, null, "");
		}
		public static Node make_leaf(NodeType nodetype, String value) {
			return new Node(nodetype, null, null, value);
		}
	}

	static class Token {
		public TokenType tokentype;
		public String value;
		public int line;
		public int pos;

		Token(TokenType token, String value, int line, int pos) {
			this.tokentype = token; this.value = value; this.line = line; this.pos = pos;
		}
		@Override
		public String toString() {
			return String.format("%5d  %5d %-15s %s", this.line, this.pos, this.tokentype, this.value);
		}
	}

	static enum TokenType {
		End_of_input(false, false, false, -1, NodeType.nd_None),
		Op_multiply(false, true, false, 13, NodeType.nd_Mul),
		Op_divide(false, true, false, 13, NodeType.nd_Div),
		Op_mod(false, true, false, 13, NodeType.nd_Mod),
		Op_add(false, true, false, 12, NodeType.nd_Add),
		Op_subtract(false, true, false, 12, NodeType.nd_Sub),
		Op_negate(false, false, true, 14, NodeType.nd_Negate),
		Op_not(false, false, true, 14, NodeType.nd_Not),
		Op_less(false, true, false, 10, NodeType.nd_Lss),
		Op_lessequal(false, true, false, 10, NodeType.nd_Leq),
		Op_greater(false, true, false, 10, NodeType.nd_Gtr),
		Op_greaterequal(false, true, false, 10, NodeType.nd_Geq),
		Op_equal(false, true, true, 9, NodeType.nd_Eql),
		Op_notequal(false, true, false, 9, NodeType.nd_Neq),
		Op_assign(false, false, false, -1, NodeType.nd_Assign),
		Op_and(false, true, false, 5, NodeType.nd_And),
		Op_or(false, true, false, 4, NodeType.nd_Or),
		Keyword_if(false, false, false, -1, NodeType.nd_If),
		Keyword_else(false, false, false, -1, NodeType.nd_None),
		Keyword_while(false, false, false, -1, NodeType.nd_While),
		Keyword_print(false, false, false, -1, NodeType.nd_None),
		Keyword_putc(false, false, false, -1, NodeType.nd_None),
		LeftParen(false, false, false, -1, NodeType.nd_None),
		RightParen(false, false, false, -1, NodeType.nd_None),
		LeftBrace(false, false, false, -1, NodeType.nd_None),
		RightBrace(false, false, false, -1, NodeType.nd_None),
		Semicolon(false, false, false, -1, NodeType.nd_None),
		Comma(false, false, false, -1, NodeType.nd_None),
		Identifier(false, false, false, -1, NodeType.nd_Ident),
		Integer(false, false, false, -1, NodeType.nd_Integer),
		String(false, false, false, -1, NodeType.nd_String);

		private final int precedence;
		private final boolean right_assoc;
		private final boolean is_binary;
		private final boolean is_unary;
		private final NodeType node_type;

		TokenType(boolean right_assoc, boolean is_binary, boolean is_unary, int precedence, NodeType node) {
			this.right_assoc = right_assoc;
			this.is_binary = is_binary;
			this.is_unary = is_unary;
			this.precedence = precedence;
			this.node_type = node;
		}
		boolean isRightAssoc() { return this.right_assoc; }
		boolean isBinary() { return this.is_binary; }
		boolean isUnary() { return this.is_unary; }
		int getPrecedence() { return this.precedence; }
		NodeType getNodeType() { return this.node_type; }
	}
	static enum NodeType {
		nd_None(""), nd_Ident("Identifier"), nd_String("String"), nd_Integer("Integer"), nd_Sequence("Sequence"), nd_If("If"),
		nd_Prtc("Prtc"), nd_Prts("Prts"), nd_Prti("Prti"), nd_While("While"),
		nd_Assign("Assign"), nd_Negate("Negate"), nd_Not("Not"), nd_Mul("Multiply"), nd_Div("Divide"), nd_Mod("Mod"), nd_Add("Add"),
		nd_Sub("Subtract"), nd_Lss("Less"), nd_Leq("LessEqual"),
		nd_Gtr("Greater"), nd_Geq("GreaterEqual"), nd_Eql("Equal"), nd_Neq("NotEqual"), nd_And("And"), nd_Or("Or");

		private final String name;

		NodeType(String name) {
			this.name = name;
		}

		@Override
		public String toString() { return this.name; }
	}
	static void error(int line, int pos, String msg) {
		if (line > 0 && pos > 0) {
			System.out.printf("%s in line %d, pos %d\n", msg, line, pos);
		} else {
			System.out.println(msg);
		}
		System.exit(1);
	}
	Parser(List<Token> source) {
		this.source = source;
		this.token = null;
		this.position = 0;
	}
	Token getNextToken() {
		this.token = this.source.get(this.position++);
		return this.token;
	}
	Node expr(int p) {
		Node result = null, node;
		TokenType op;
		int q;

		if (this.token.tokentype == TokenType.LeftParen) {
			result = paren_expr();
		} else if (this.token.tokentype == TokenType.Op_add || this.token.tokentype == TokenType.Op_subtract) {
			op = (this.token.tokentype == TokenType.Op_subtract) ? TokenType.Op_negate : TokenType.Op_add;
			getNextToken();
			node = expr(TokenType.Op_negate.getPrecedence());
			result = (op == TokenType.Op_negate) ? Node.make_node(NodeType.nd_Negate, node) : node;
		} else if (this.token.tokentype == TokenType.Op_not) {
			getNextToken();
			result = Node.make_node(NodeType.nd_Not, expr(TokenType.Op_not.getPrecedence()));
		} else if (this.token.tokentype == TokenType.Identifier) {
			result = Node.make_leaf(NodeType.nd_Ident, this.token.value);
			getNextToken();
		} else if (this.token.tokentype == TokenType.Integer) {
			result = Node.make_leaf(NodeType.nd_Integer, this.token.value);
			getNextToken();
		} else {
			error(this.token.line, this.token.pos, "Expecting a primary, found: " + this.token.tokentype);
		}

		while (this.token.tokentype.isBinary() && this.token.tokentype.getPrecedence() >= p) {
			op = this.token.tokentype;
			getNextToken();
			q = op.getPrecedence();
			if (!op.isRightAssoc()) {
				q++;
			}
			node = expr(q);
			result = Node.make_node(op.getNodeType(), result, node);
		}
		return result;
	}
	Node paren_expr() {
		expect("paren_expr", TokenType.LeftParen);
		Node node = expr(0);
		expect("paren_expr", TokenType.RightParen);
		return node;
	}
	void expect(String msg, TokenType s) {
		if (this.token.tokentype == s) {
			getNextToken();
			return;
		}
		error(this.token.line, this.token.pos, msg + ": Expecting '" + s + "', found: '" + this.token.tokentype + "'");
	}
	Node stmt() {
		Node s, s2, t = null, e, v;
		if (this.token.tokentype == TokenType.Keyword_if) {
			getNextToken();
			e = paren_expr();
			s = stmt();
			s2 = null;
			if (this.token.tokentype == TokenType.Keyword_else) {
				getNextToken();
				s2 = stmt();
			}
			t = Node.make_node(NodeType.nd_If, e, Node.make_node(NodeType.nd_If, s, s2));
		} else if (this.token.tokentype == TokenType.Keyword_putc) {
			getNextToken();
			e = paren_expr();
			t = Node.make_node(NodeType.nd_Prtc, e);
			expect("Putc", TokenType.Semicolon);
		} else if (this.token.tokentype == TokenType.Keyword_print) {
			getNextToken();
			expect("Print", TokenType.LeftParen);
			while (true) {
				if (this.token.tokentype == TokenType.String) {
					e = Node.make_node(NodeType.nd_Prts, Node.make_leaf(NodeType.nd_String, this.token.value));
					getNextToken();
				} else {
					e = Node.make_node(NodeType.nd_Prti, expr(0), null);
				}
				t = Node.make_node(NodeType.nd_Sequence, t, e);
				if (this.token.tokentype != TokenType.Comma) {
					break;
				}
				getNextToken();
			}
			expect("Print", TokenType.RightParen);
			expect("Print", TokenType.Semicolon);
		} else if (this.token.tokentype == TokenType.Semicolon) {
			getNextToken();
		} else if (this.token.tokentype == TokenType.Identifier) {
			v = Node.make_leaf(NodeType.nd_Ident, this.token.value);
			getNextToken();
			expect("assign", TokenType.Op_assign);
			e = expr(0);
			t = Node.make_node(NodeType.nd_Assign, v, e);
			expect("assign", TokenType.Semicolon);
		} else if (this.token.tokentype == TokenType.Keyword_while) {
			getNextToken();
			e = paren_expr();
			s = stmt();
			t = Node.make_node(NodeType.nd_While, e, s);
		} else if (this.token.tokentype == TokenType.LeftBrace) {
			getNextToken();
			while (this.token.tokentype != TokenType.RightBrace && this.token.tokentype != TokenType.End_of_input) {
				t = Node.make_node(NodeType.nd_Sequence, t, stmt());
			}
			expect("LBrace", TokenType.RightBrace);
		} else if (this.token.tokentype == TokenType.End_of_input) {
		} else {
			error(this.token.line, this.token.pos, "Expecting start of statement, found: " + this.token.tokentype);
		}
		return t;
	}
	Node parse() {
		Node t = null;
		getNextToken();
		while (this.token.tokentype != TokenType.End_of_input) {
			t = Node.make_node(NodeType.nd_Sequence, t, stmt());
		}
		return t;
	}
	void printAST(Node t) {
		int i = 0;
		if (t == null) {
			System.out.println(";");
		} else {
			System.out.printf("%-14s", t.nt);
			if (t.nt == NodeType.nd_Ident || t.nt == NodeType.nd_Integer || t.nt == NodeType.nd_String) {
				System.out.println(" " + t.value);
			} else {
				System.out.println();
				printAST(t.left);
				printAST(t.right);
			}
		}
	}
	public static void main(String[] args) {
		if (args.length > 0) {
			try {
				String value, token;
				int line, pos;
				Token t;
				boolean found;
				List<Token> list = new ArrayList<>();
				Map<String, TokenType> str_to_tokens = new HashMap<>();

				str_to_tokens.put("End_of_input", TokenType.End_of_input);
				str_to_tokens.put("Op_multiply", TokenType.Op_multiply);
				str_to_tokens.put("Op_divide", TokenType.Op_divide);
				str_to_tokens.put("Op_mod", TokenType.Op_mod);
				str_to_tokens.put("Op_add", TokenType.Op_add);
				str_to_tokens.put("Op_subtract", TokenType.Op_subtract);
				str_to_tokens.put("Op_negate", TokenType.Op_negate);
				str_to_tokens.put("Op_not", TokenType.Op_not);
				str_to_tokens.put("Op_less", TokenType.Op_less);
				str_to_tokens.put("Op_lessequal", TokenType.Op_lessequal);
				str_to_tokens.put("Op_greater", TokenType.Op_greater);
				str_to_tokens.put("Op_greaterequal", TokenType.Op_greaterequal);
				str_to_tokens.put("Op_equal", TokenType.Op_equal);
				str_to_tokens.put("Op_notequal", TokenType.Op_notequal);
				str_to_tokens.put("Op_assign", TokenType.Op_assign);
				str_to_tokens.put("Op_and", TokenType.Op_and);
				str_to_tokens.put("Op_or", TokenType.Op_or);
				str_to_tokens.put("Keyword_if", TokenType.Keyword_if);
				str_to_tokens.put("Keyword_else", TokenType.Keyword_else);
				str_to_tokens.put("Keyword_while", TokenType.Keyword_while);
				str_to_tokens.put("Keyword_print", TokenType.Keyword_print);
				str_to_tokens.put("Keyword_putc", TokenType.Keyword_putc);
				str_to_tokens.put("LeftParen", TokenType.LeftParen);
				str_to_tokens.put("RightParen", TokenType.RightParen);
				str_to_tokens.put("LeftBrace", TokenType.LeftBrace);
				str_to_tokens.put("RightBrace", TokenType.RightBrace);
				str_to_tokens.put("Semicolon", TokenType.Semicolon);
				str_to_tokens.put("Comma", TokenType.Comma);
				str_to_tokens.put("Identifier", TokenType.Identifier);
				str_to_tokens.put("Integer", TokenType.Integer);
				str_to_tokens.put("String", TokenType.String);

				Scanner s = new Scanner(new File(args[0]));
				String source = " ";
				while (s.hasNext()) {
					String str = s.nextLine();
					StringTokenizer st = new StringTokenizer(str);
					line = Integer.parseInt(st.nextToken());
					pos = Integer.parseInt(st.nextToken());
					token = st.nextToken();
					value = "";
					while (st.hasMoreTokens()) {
						value += st.nextToken() + " ";
					}
					found = false;
					if (str_to_tokens.containsKey(token)) {
						found = true;
						list.add(new Token(str_to_tokens.get(token), value, line, pos));
					}
					if (found == false) {
						throw new Exception("Token not found: '" + token + "'");
					}
				}
				Parser p = new Parser(list);
				p.printAST(p.parse());
			} catch (FileNotFoundException e) {
				error(-1, -1, "Exception: " + e.getMessage());
			} catch (Exception e) {
				error(-1, -1, "Exception: " + e.getMessage());
			}
		} else {
			error(-1, -1, "No args");
		}
	}
}


       IDENTIFICATION DIVISION.
       PROGRAM-ID. accept-all-args.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  args                   PIC X(50).

       PROCEDURE DIVISION.
       main-line.
           ACCEPT args FROM COMMAND-LINE
           DISPLAY args

           GOBACK
           .


(defun argv ()
  (or
   #+clisp (ext:argv)
   #+sbcl sb-ext:*posix-argv*
   #+abcl ext:*command-line-argument-list*
   #+clozure (ccl::command-line-arguments)
   #+gcl si:*command-args*
   #+ecl (loop for i from 0 below (si:argc) collect (si:argv i))
   #+cmu extensions:*command-line-strings*
   #+allegro (sys:command-line-arguments)
   #+lispworks sys:*line-arguments-list*
   nil))


package xyz.hyperreal.rosettacodeCompiler

import scala.collection.mutable.{ArrayBuffer, HashMap}
import scala.io.Source

object CodeGenerator {

  def fromStdin = fromSource(Source.stdin)

  def fromString(src: String) = fromSource(Source.fromString(src))

  def fromSource(ast: Source) = {
    val vars              = new HashMap[String, Int]
    val strings           = new ArrayBuffer[String]
    val code              = new ArrayBuffer[String]
    var s: Stream[String] = ast.getLines.toStream

    def line =
      if (s.nonEmpty) {
        val n = s.head

        s = s.tail

        n.split(" +", 2) match {
          case Array(n) => n
          case a        => a
        }
      } else
        sys.error("unexpected end of AST")

    def variableIndex(name: String) =
      vars get name match {
        case None =>
          val idx = vars.size

          vars(name) = idx
          idx
        case Some(idx) => idx
      }

    def stringIndex(s: String) =
      strings indexOf s match {
        case -1 =>
          val idx = strings.length

          strings += s
          idx
        case idx => idx
      }

    var loc = 0

    def addSimple(inst: String) = {
      code += f"$loc%4d $inst"
      loc += 1
    }

    def addOperand(inst: String, operand: String) = {
      code += f"$loc%4d $inst%-5s $operand"
      loc += 5
    }

    def fixup(inst: String, idx: Int, at: Int) = code(idx) = f"$at%4d $inst%-5s (${loc - at - 1}) $loc"

    generate
    addSimple("halt")
    println(s"Datasize: ${vars.size} Strings: ${strings.length}")

    for (s <- strings)
      println(s)

    println(code mkString "\n")

    def generate: Unit =
      line match {
        case "Sequence" =>
          generate
          generate
        case ";" =>
        case "Assign" =>
          val idx =
            line match {
              case Array("Identifier", name: String) =>
                variableIndex(name)
              case l => sys.error(s"expected identifier: $l")
            }

          generate
          addOperand("store", s"[$idx]")
        case Array("Identifier", name: String) => addOperand("fetch", s"[${variableIndex(name)}]")
        case Array("Integer", n: String)       => addOperand("push", s"$n")
        case Array("String", s: String)        => addOperand("push", s"${stringIndex(s)}")
        case "If" =>
          generate

          val cond    = loc
          val condidx = code.length

          addOperand("", "")
          s = s.tail
          generate

          if (s.head == ";") {
            s = s.tail
            fixup("jz", condidx, cond)
          } else {
            val jump    = loc
            val jumpidx = code.length

            addOperand("", "")
            fixup("jz", condidx, cond)
            generate
            fixup("jmp", jumpidx, jump)
          }
        case "While" =>
          val start = loc

          generate

          val cond    = loc
          val condidx = code.length

          addOperand("", "")
          generate
          addOperand("jmp", s"(${start - loc - 1}) $start")
          fixup("jz", condidx, cond)
        case op =>
          generate
          generate
          addSimple(
            op match {
              case "Prti"         => "prti"
              case "Prts"         => "prts"
              case "Prtc"         => "prtc"
              case "Add"          => "add"
              case "Subtract"     => "sub"
              case "Multiply"     => "mul"
              case "Divide"       => "div"
              case "Mod"          => "mod"
              case "Less"         => "lt"
              case "LessEqual"    => "le"
              case "Greater"      => "gt"
              case "GreaterEqual" => "ge"
              case "Equal"        => "eq"
              case "NotEqual"     => "ne"
              case "And"          => "and"
              case "Or"           => "or"
              case "Negate"       => "neg"
              case "Not"          => "not"
            }
          )
      }
  }

}


System.debug ('I will execute');   // This comment is ignored.
/*
 I am a large comment, completely ignored as well.
*/


      PD_RETURNDC = 256
      _LOGPIXELSY = 90

      DIM pd{lStructSize%, hwndOwner%, hDevMode%, hDevNames%, \
      \      hdc%, flags%, nFromPage{l&,h&}, nToPage{l&,h&}, \
      \      nMinPage{l&,h&}, nMaxPage{l&,h&}, nCopies{l&,h&}, \
      \      hInstance%, lCustData%, lpfnPrintHook%, lpfnSetupHook%, \
      \      lpPrintTemplateName%, lpSetupTemplateName%, \
      \      hPrintTemplate%, hSetupTemplate%}
      pd.lStructSize% = DIM(pd{})
      pd.hwndOwner% = @hwnd%
      pd.flags% = PD_RETURNDC

      SYS "PrintDlg", pd{} TO ok%
      IF ok%=0 THEN QUIT
      SYS "DeleteDC", @prthdc%
      @prthdc% = pd.hdc%
      *MARGINS 0,0,0,0

      dx% = @vdu%[email protected]%!232
      dy% = @vdu%[email protected]%!240
      SYS "GetDeviceCaps", @prthdc%, _LOGPIXELSY TO dpi%

      DIM rc{l%,t%,r%,b%}
      DIM colour%(7)
      colour%() = &000000, &0000FF, &00FF00, &FF0000, \
      \           &FF00FF, &FFFF00, &00FFFF, &FFFFFF

      VDU 2,1,32,3
      pitch% = 1
      FOR y% = 0 TO dy% STEP dpi%
        col% = 0
        FOR x% = 0 TO dx%-pitch% STEP pitch%
          rc.l% = x% : rc.r% = x% + pitch%
          rc.t% = y% : rc.b% = y% + dpi%
          SYS "CreateSolidBrush", colour%(col% MOD 8) TO brush%
          SYS "FillRect", @prthdc%, rc{}, brush%
          SYS "DeleteObject", brush%
          col% += 1
        NEXT
        pitch% += 1
      NEXT y%
      VDU 2,1,12,3


Dim As String exename
#ifdef __FB_WIN32__
    exename = "mspaint.exe /pt"
#endif
#ifdef __FB_LINUX__
    exename = "lp -o media=A4 "
#endif

Dim As Uinteger ps, col, h, w, x, y1, y2

' (A4) # 595 x 842 dots
w = 842 : h = 595
' create display size window, 8bit color (palette), no frame
Screenres w, h, 8,, 8

h \= 7 : y2 = h -1

For ps = 1 To 7
    col = 0
    For x = 0 To (w - ps -1) Step ps
        Line (x, y1) - (x + ps -1, y2), col, bf
        col = (col +1) And 255
    Next x
    y1 += h : y2 += h
Next ps

Dim As String filename = "color_pinstripe.bmp"
If Bsave(filename, 0) <> 0 Then
    Cls: Print "Error saving: "; fileName : Sleep
Else
    Dim As Integer result = Exec(exename, filename)
    If result = -1 Then Print "Error running "; exename : Sleep
End If
End


package main

import (
    "github.com/fogleman/gg"
    "log"
    "os/exec"
    "runtime"
)

var palette = [8]string{
    "000000", // black
    "FF0000", // red
    "00FF00", // green
    "0000FF", // blue
    "FF00FF", // magenta
    "00FFFF", // cyan
    "FFFF00", // yellow
    "FFFFFF", // white
}

func pinstripe(dc *gg.Context) {
    w := dc.Width()
    h := dc.Height() / 7
    for b := 1; b <= 11; b++ {
        for x, ci := 0, 0; x < w; x, ci = x+b, ci+1 {
            dc.SetHexColor(palette[ci%8])
            y := h * (b - 1)
            dc.DrawRectangle(float64(x), float64(y), float64(b), float64(h))
            dc.Fill()
        }
    }
}

func main() {
    dc := gg.NewContext(842, 595)
    pinstripe(dc)
    fileName := "color_pinstripe.png"
    dc.SavePNG(fileName)
    var cmd *exec.Cmd
    if runtime.GOOS == "windows" {
        cmd = exec.Command("mspaint", "/pt", fileName)
    } else {
        cmd = exec.Command("lp", fileName)
    }
    if err := cmd.Run(); err != nil {
        log.Fatal(err)
    }
}