to compile :file
if namep "peekchar [ern "peekchar]
if namep "peektoken [ern "peektoken]
if not namep "idlist [opsetup]
if not emptyp :file [openread :file]
setread :file
ignore error
catch "error [program]
localmake "error error
if not emptyp :error [print first butfirst :error]
setread []
if not emptyp :file [close :file]
end

;; Global setup

to opsetup
make "numregs 32
make "memsize 3000
pprop "|=| "binary [eql 2 [boolean []] 1]
pprop "|<>| "binary [neq 2 [boolean []] 1]
pprop "|<| "binary [less 2 [boolean []] 1]
pprop "|>| "binary [gtr 2 [boolean []] 1]
pprop "|<=| "binary [leq 2 [boolean []] 1]
pprop "|>=| "binary [geq 2 [boolean []] 1]
pprop "|+| "binary [add 2 [[] []] 2]
pprop "|-| "binary [sub 2 [[] []] 2]
pprop "or "binary [lor 2 [boolean boolean] 2]
pprop "|*| "binary [mul 2 [[] []] 3]
pprop "|/| "binary [quo 2 [real []] 3]
pprop "div "binary [div 2 [integer integer] 3]
pprop "mod "binary [rem 2 [integer integer] 3]
pprop "and "binary [land 2 [boolean boolean] 3]
pprop "|+| "unary [plus 1 [[] []] 4]
pprop "|-| "unary [minus 1 [[] []] 4]
pprop "not "unary [lnot 1 [boolean boolean] 4]
make "idlist `[[trunc function int [1 ,[framesize.fun+1]]]
               [round function round [1 ,[framesize.fun+1]]]
               [random function random [1 ,[framesize.fun+1]]]]
make "int [integer real]
make "round [integer real]
make "random [integer integer]
end

;; Block structure

to program
mustbe "program
localmake "progname token
ifbe "|(| [ignore commalist [id]  mustbe "|)|]
mustbe "|;|
localmake "lexical.depth 0
localmake "namesused []
localmake "needint "false
localmake "needround "false
localmake "needrandom "false
localmake "idlist :idlist
localmake "frame [0 0]
localmake "id (list :progname "program (newlname :progname) :frame)
push "idlist :id
localmake "codeinto word "% :progname
make :codeinto []
localmake "framesize framesize.proc
program1
mustbe ".
code [exit]
foreach [int round random] "plibrary
make :codeinto reverse thing :codeinto
end

to program1
localmake "regsused (array :numregs 0)
for [i reg.firstfree :numregs-1] [setitem :i :regsused "false]
ifbe "var [varpart]
.setfirst butfirst :frame :framesize
if :lexical.depth = 0 [code (list "add reg.globalptr reg.zero reg.zero)
                       code (list "add reg.frameptr reg.zero reg.zero)
                       code (list "addi reg.stackptr reg.zero :framesize)]
localmake "bodytag gensym
code (list "jump (word "" :bodytag))
tryprocpart
code :bodytag
mustbe "begin
blockbody "end
end

to plibrary :func
if not thing (word "need :func) [stop]
code :func
code (list "rload reg.firstfree (memaddr framesize.fun reg.frameptr))
code (list (word "s :func) reg.retval reg.firstfree)
code (list "add reg.stackptr reg.frameptr reg.zero)
code (list "rload reg.frameptr (memaddr frame.prevframe reg.stackptr))
code (list "jr reg.retaddr)
end

;; Variable declarations

to varpart
local [token namelist type]
make "token token
make "peektoken :token
if reservedp :token [stop]
vargroup
foreach :namelist [newvar ? :type]
mustbe "|;|
varpart
end

to vargroup
make "namelist commalist [id]
mustbe ":
ifbe "packed []
make "type token
ifelse equalp :type "array [make "type arraytype] [typecheck :type]
end

to id
localmake "token token
if letterp ascii first :token [output :token]
make "peektoken :token
output []
end

to arraytype
local [ranges type]
mustbe "|[|
make "ranges commalist [range]
mustbe "|]|
mustbe "of
make "type token
typecheck :type
output list :type :ranges
end

to range
local [first last]
make "first range1
mustbe "..
make "last range1
if :first > :last ~  
   [(throw "error (sentence [array bounds not increasing:]
                            :first ".. :last))]
output list :first (1 + :last - :first)
end

to range1
localmake "bound token
if equalp first :bound "' [output ascii first butfirst :bound]
if equalp :bound "|-| [make "bound minus token]
if equalp :bound int :bound [output :bound]
(throw "error sentence [array bound not ordinal:] :bound)
end

to typecheck :type
if memberp :type [real integer char boolean] [stop]
(throw "error sentence [undefined type] :type)
end

to newvar :pname :type
if reservedp :pname [(throw "error sentence :pname [reserved word])]
push "idlist (list :pname :type (list :lexical.depth :framesize) "false)
make "framesize :framesize + ifelse listp :type [arraysize :type] [1]
end

to arraysize :type
output reduce "product map [last ?] last :type
end

;; Procedure and function declarations

to tryprocpart
ifbeelse "procedure ~
         [procedure tryprocpart] ~
         [ifbe "function [function tryprocpart]]
end

to procedure
proc1 "procedure framesize.proc
end

to function
proc1 "function framesize.fun
end

to proc1 :proctype :framesize
localmake "procname token
localmake "lexical.depth :lexical.depth+1
localmake "frame (list :lexical.depth 0)
push "idlist (list :procname :proctype (newlname :procname) :frame)
localmake "idlist :idlist
make lname :procname []
ifbe "|(| [arglist]
if equalp :proctype "function ~
   [mustbe ":
    localmake "type token
    typecheck :type
    make lname :procname fput :type thing lname :procname]
mustbe "|;|
code lname :procname
code (list "store reg.retaddr (memaddr frame.retaddr reg.frameptr))
program1
if equalp :proctype "function ~
   [code (list "rload reg.retval (memaddr frame.retval reg.frameptr))]
code (list "rload reg.retaddr (memaddr frame.retaddr reg.frameptr))
code (list "add reg.stackptr reg.frameptr reg.zero)
code (list "rload reg.frameptr (memaddr frame.prevframe reg.stackptr))
code (list "jr reg.retaddr)
mustbe "|;|
end

to arglist
local [token namelist type varflag]
make "varflag "false
ifbe "var [make "varflag "true]
vargroup
foreach :namelist [newarg ? :type :varflag]
ifbeelse "|;| [arglist] [mustbe "|)|]
end

to newarg :pname :type :varflag
if reservedp :pname [(throw "error sentence :pname [reserved word])]
localmake "pointer (list :lexical.depth :framesize)
push "idlist (list :pname :type :pointer :varflag)
make "framesize :framesize + ifelse (and listp :type not :varflag) ~
                                    [arraysize :type] [1]
queue lname :procname ifelse :varflag [list "var :type] [:type]
end

;; Statement part

to blockbody :endword
statement
ifbeelse "|;| [blockbody :endword] [mustbe :endword]
end

to statement
local [token type]
ifbe "begin [compound stop]
ifbe "for [pfor stop]
ifbe "if [pif stop]
ifbe "while [pwhile stop]
ifbe "repeat [prepeat stop]
ifbe "write [pwrite stop]
ifbe "writeln [pwriteln stop]
make "token token
make "peektoken :token
if memberp :token [|;| end until] [stop]
make "type gettype :token
if emptyp :type [(throw "error sentence :token [can't begin statement])]
if equalp :type "procedure [pproccall stop]
if equalp :type "function [pfunset stop]
passign
end

;; Compound statement

to compound
blockbody "end
end

;; Structured statements

to pif
local [cond elsetag endtag]
make "cond pboolean pexpr
make "elsetag gensym
make "endtag gensym
mustbe "then
code (list "jumpf :cond (word "" :elsetag))
regfree :cond
statement
code (list "jump (word "" :endtag))
code :elsetag
ifbe "else [statement]
code :endtag
end

to prepeat
local [cond looptag]
make "looptag gensym
code :looptag
blockbody "until
make "cond pboolean pexpr
code (list "jumpf :cond (word "" :looptag))
regfree :cond
end

to pfor
local [var init step final looptag endtag testreg]
make "var token
mustbe "|:=|
make "init pinteger pexpr
make "step 1
ifbeelse "downto [make "step -1] [mustbe "to]
make "final pinteger pexpr
mustbe "do
make "looptag gensym
make "endtag gensym
code :looptag
localmake "id getid :var
codestore :init (id.pointer :id) (id.varp :id) 0
make "testreg newregister
code (list (ifelse :step<0 ["less] ["gtr]) :testreg :init :final)
code (list "jumpt :testreg (word "" :endtag))
regfree :testreg
statement
code (list "addi :init :init :step)
code (list "jump (word "" :looptag))
code :endtag
regfree :init
regfree :final
end

to pwhile
local [cond looptag endtag]
make "looptag gensym
make "endtag gensym
code :looptag
make "cond pboolean pexpr
code (list "jumpf :cond (word "" :endtag))
regfree :cond
mustbe "do
statement
code (list "jump (word "" :looptag))
code :endtag
end

;; Simple statements: procedure call

to pproccall
localmake "pname token
localmake "id getid :pname
localmake "lname id.lname :id
localmake "vartypes thing :lname
pproccall1 framesize.proc
end

to pproccall1 :offset
code (list "store reg.newfp (memaddr frame.save.newfp reg.stackptr))
code (list "add reg.newfp reg.stackptr reg.zero)
code (list "addi reg.stackptr reg.stackptr (last id.frame :id))
code (list "store reg.frameptr (memaddr frame.prevframe reg.newfp))
localmake "newdepth first id.frame :id
ifelse :newdepth > :lexical.depth ~
       [code (list "store reg.frameptr
                   (memaddr frame.outerframe reg.newfp))] ~
       [localmake "tempreg newregister
        code (list "rload :tempreg (memaddr frame.outerframe reg.frameptr))
        repeat (:lexical.depth - :newdepth)
               [code (list "rload :tempreg 
                           (memaddr frame.outerframe :tempreg))]
        code (list "store :tempreg (memaddr frame.outerframe reg.newfp))
        regfree :tempreg]
if not emptyp :vartypes [mustbe "|(|  procargs :vartypes :offset]
for [i reg.firstfree :numregs-1] ~
    [if item :i :regsused
        [code (list "store :i (memaddr frame.regsave+:i reg.frameptr))]]
code (list "add reg.frameptr reg.newfp reg.zero)
code (list "rload reg.newfp (memaddr frame.save.newfp reg.frameptr))
code (list "jal reg.retaddr (word "" :lname))
for [i reg.firstfree :numregs-1] ~
    [if item :i :regsused
        [code (list "rload :i (memaddr frame.regsave+:i reg.frameptr))]]
end

to procargs :types :offset
if emptyp :types [mustbe "|)|  stop]
localmake "next procarg first :types :offset
if not emptyp butfirst :types [mustbe ",]
procargs butfirst :types :offset+:next
end

to procarg :type :offset
if equalp first :type "var [output procvararg last :type]
if listp :type [output procarrayarg :type]
localmake "result check.type :type pexpr
code (list "store :result (memaddr :offset reg.newfp))
regfree :result
output 1
end

to procvararg :ftype
local [pname id type index]
make "pname token
make "id getid :pname
make "type id.type :id
ifelse wordp :ftype ~
       [setindex "true] ~
       [make "index 0]
if not equalp :type :ftype ~
   [(throw "error sentence :pname [arg wrong type])]
localmake "target memsetup (id.pointer :id) (id.varp :id) :index
localmake "tempreg newregister
code (list "addi :tempreg (last :target) (first :target))
code (list "store :tempreg (memaddr :offset reg.newfp))
regfree last :target
regfree :tempreg
output 1
end

to procarrayarg :type
localmake "pname token
localmake "id getid :pname
if not equalp :type (id.type :id) ~
   [(throw "error (sentence "array :pname [wrong type for arg]))]
localmake "size arraysize :type
localmake "rtarget memsetup (id.pointer :id) (id.varp :id) 0
localmake "pointreg newregister
code (list "addi :pointreg reg.newfp :offset)
localmake "ltarget (list 0 :pointreg)
copyarray
output :size
end

;; Simple statements: write and writeln

to pwrite
mustbe "|(|
pwrite1
end

to pwrite1
pwrite2
ifbe "|)| [stop]
ifbeelse ", [pwrite1] [(throw "error [missing comma])]
end

to pwrite2
localmake "result pwrite3
ifbe ": [.setfirst (butfirst :result) token]
code :result
if not equalp first :result "putstr [regfree last :result]
end

to pwrite3
localmake "token token
if equalp first :token "' ~
   [output (list "putstr 1 (list butlast butfirst :token))]
make "peektoken :token
localmake "result pexpr
if equalp first :result "char [output (list "putch 1 pchar :result)]
if equalp first :result "boolean [output (list "puttf 1 pboolean :result)]
if equalp first :result "integer [output (list "putint 10 pinteger :result)]
output (list "putreal 20 preal :result)
end

to pwriteln
ifbe "|(| [pwrite1]
code [newline]
end

;; Simple statements: assignment statement (including function value)

to passign
local [name id type index value pointer target]
make "name token
make "index []
ifbe "|[| [make "index commalist [pexpr] mustbe "|]|]
mustbe "|:=|
make "id getid :name
make "pointer id.pointer :id
make "type id.type :id
passign1
end

to pfunset
local [name id type index value pointer target]
make "name token
make "index []
if not equalp :name :procname ~
   [(throw "error sentence [assign to wrong function] :name)]
mustbe "|:=|
make "pointer (list :lexical.depth frame.retval)
make "type first thing lname :name
make "id (list :name :type :pointer "false)
passign1
end

to passign1
if and (listp :type) (emptyp :index) [parrayassign :id  stop]
setindex "false
make "value check.type :type pexpr
codestore :value (id.pointer :id) (id.varp :id) :index
regfree :value
end

to noimmediate :value
if not equalp exp.mode :value "immediate [output :value]
localmake "reg newregister
code (list "addi :reg reg.zero exp.value :value)
output (list exp.type :value "register :reg)
end

to check.type :type :result
if equalp :type "real [output preal :result]
if equalp :type "integer [output pinteger :result]
if equalp :type "char [output pchar :result]
if equalp :type "boolean [output pboolean :result]
end

to preal :expr [:pval noimmediate :expr]
if equalp exp.type :pval "real [output exp.value :pval]
output pinteger :pval
end

to pinteger :expr [:pval noimmediate :expr]
localmake "type exp.type :pval
if memberp :type [integer boolean char] [output exp.value :pval]
(throw "error sentence exp.type :pval [isn't ordinal])
end

to pchar :expr [:pval noimmediate :expr]
if equalp exp.type :pval "char [output exp.value :pval]
(throw "error sentence exp.type :pval [not character value])
end

to pboolean :expr [:pval noimmediate :expr]
if equalp exp.type :pval "boolean [output exp.value :pval]
(throw "error sentence exp.type :pval [not true or false])
end

to parrayassign :id
localmake "right token
if equalp first :right "' ~
   [pstringassign :type (butlast butfirst :right)  stop]
localmake "rid getid :right
if not equalp (id.type :id) (id.type :rid) ~
   [(throw "error (sentence "arrays :name "and :right [unequal types]))]
localmake "size arraysize id.type :id
localmake "ltarget memsetup (id.pointer :id) (id.varp :id) 0
localmake "rtarget memsetup (id.pointer :rid) (id.varp :rid) 0
copyarray
end

to pstringassign :type :string
if not equalp first :type "char [stringlose]
if not emptyp butfirst last :type [stringlose]
if not equalp (last first last :type) (count :string) [stringlose]
localmake "ltarget memsetup (id.pointer :id) (id.varp :id) 0
pstringassign1 newregister (first :ltarget) (last :ltarget) :string
regfree last :ltarget
end

to pstringassign1 :tempreg :offset :reg :string
if emptyp :string [regfree :tempreg  stop]
code (list "addi :tempreg reg.zero ascii first :string)
code (list "store :tempreg (memaddr :offset :reg))
pstringassign1 :tempreg :offset+1 :reg (butfirst :string)
end

to stringlose
(throw "error sentence :name [not string array or wrong size])
end

;; Multiple array indices to linear index computation

to setindex :parseflag
ifelse listp :type ~
       [if :parseflag
           [mustbe "|[|  make "index commalist [pexpr]  mustbe "|]| ]
        make "index lindex last :type :index
        make "type first :type] ~
       [make "index 0]
end

to lindex :bounds :index
output lindex1 (offset pinteger noimmediate first :index
                       first first :bounds) ~
               butfirst :bounds butfirst :index
end

to lindex1 :sofar :bounds :index
if emptyp :bounds [output :sofar]
output lindex1 (nextindex :sofar
                          last first :bounds
                          pinteger noimmediate first :index
                          first first :bounds) ~
               butfirst :bounds butfirst :index
end

to nextindex :old :factor :new :offset
code (list "muli :old :old :factor)
localmake "newreg offset :new :offset
code (list "add :old :old :newreg)
regfree :newreg
output :old
end

to offset :indexreg :lowbound
if not equalp :lowbound 0 [code (list "subi :indexreg :indexreg :lowbound)]
output :indexreg
end

;; Memory interface: load and store instructions

to codeload :reg :pointer :varflag :index
localmake "target memsetup :pointer :varflag :index
code (list "rload :reg targetaddr)
regfree last :target
end

to codestore :reg :pointer :varflag :index
localmake "target memsetup :pointer :varflag :index
code (list "store :reg targetaddr)
regfree last :target
end

to targetaddr
output memaddr (first :target) (last :target)
end

to memaddr :offset :index
output (word :offset "\( :index "\))
end

to memsetup :pointer :varflag :index
localmake "depth first :pointer
localmake "offset last :pointer
local "newreg
ifelse equalp :depth 0 ~
       [make "newreg reg.globalptr] ~
       [ifelse equalp :depth :lexical.depth
               [make "newreg reg.frameptr]
               [make "newreg newregister
                code (list "rload :newreg
                           (memaddr frame.outerframe reg.frameptr))
                repeat (:lexical.depth - :depth) - 1
                       [code (list "rload :newreg
                                   (memaddr frame.outerframe :newreg))]]]
if :varflag ~
   [ifelse :newreg = reg.frameptr
           [make "newreg newregister
            code (list "rload :newreg (memaddr :offset reg.frameptr))]
           [code (list "rload :newreg (memaddr :offset :newreg))]
    make "offset 0]
if not equalp :index 0 ~
   [code (list "add :index :index :newreg)
    regfree :newreg
    make "newreg :index]
output list :offset :newreg
end

to copyarray
localmake "looptag gensym
localmake "sizereg newregister
code (list "addi :sizereg reg.zero :size)
code :looptag
localmake "tempreg newregister
code (list "rload :tempreg (memaddr (first :rtarget) (last :rtarget)))
code (list "store :tempreg (memaddr (first :ltarget) (last :ltarget)))
code (list "addi (last :rtarget) (last :rtarget) 1)
code (list "addi (last :ltarget) (last :ltarget) 1)
code (list "subi :sizereg :sizereg 1)
code (list "gtr :tempreg :sizereg reg.zero)
code (list "jumpt :tempreg (word "" :looptag))
regfree :sizereg
regfree :tempreg
regfree last :ltarget
regfree last :rtarget
end

;; Expressions

to pexpr
local [opstack datastack parenlevel]
make "opstack [[popen 1 0]]
make "datastack []
make "parenlevel 0
output pexpr1
end

to pexpr1
local [token op]
make "token token
while [equalp :token "|(|] [popen  make "token token]
make "op pgetunary :token
if not emptyp :op [output pexprop :op]
push "datastack pdata :token
make "token token
while [and (:parenlevel > 0) (equalp :token "|)| )] ~
      [pclose  make "token token]
make "op pgetbinary :token
if not emptyp :op [output pexprop :op]
make "peektoken :token
pclose
if not emptyp :opstack [(throw "error [too many operators])]
if not emptyp butfirst :datastack [(throw "error [too many operands])]
output pop "datastack
end

to pexprop :op
while [(op.prec :op) < (1 + op.prec first :opstack)] [ppopop]
push "opstack :op
output pexpr1
end

to popen
push "opstack [popen 1 0]
make "parenlevel :parenlevel + 1
end

to pclose
while [(op.prec first :opstack) > 0] [ppopop]
ignore pop "opstack
make "parenlevel :parenlevel - 1
end

to pgetunary :token
output gprop :token "unary
end

to pgetbinary :token
output gprop :token "binary
end

to ppopop
local [op function args left right type reg]
make "op pop "opstack
make "function op.instr :op
if equalp :function "plus [stop]
make "args op.nargs :op
make "right pop "datastack
make "left (ifelse equalp :args 2 [pop "datastack] [[[] []]])
make "type pnewtype :op exp.type :left exp.type :right
if equalp exp.mode :left "immediate ~
   [localmake "leftreg newregister
    code (list "addi :leftreg reg.zero exp.value :left)
    make "left (list exp.type :left "register :leftreg)]
ifelse equalp exp.mode :left "register ~
       [make "reg exp.value :left] ~
       [ifelse equalp exp.mode :right "register
               [make "reg exp.value :right]
               [make "reg newregister]]
if equalp :function "minus ~
   [make "left (list exp.type :right "register reg.zero)
    make "function "sub
    make "args 2]
if equalp exp.mode :right "immediate ~
   [make "function word :function "i]
ifelse equalp :args 2 ~
       [code (list :function :reg exp.value :left exp.value :right)] ~
       [code (list :function :reg exp.value :right)]
if not equalp :reg exp.value :left [regfree exp.value :left]
if (and (equalp exp.mode :right "register)
        (not equalp :reg exp.value :right)) ~
   [regfree exp.value :right]
push "datastack (list :type "register :reg)
end

to pnewtype :op :ltype :rtype
localmake "type op.types :op
if emptyp :ltype [make "ltype :rtype]
if not emptyp last :type [pchecktype last :type :ltype :rtype]
if and (equalp :ltype "real) (equalp :rtype "integer) [make "rtype "real]
if and (equalp :ltype "integer) (equalp :rtype "real) [make "ltype "real]
if not equalp :ltype :rtype [(throw "error [type clash])]
if emptyp last :type ~
   [if not memberp :rtype [integer real]
       [(throw "error [nonarithmetic type])]]
if emptyp first :type [output :rtype]
output first :type
end

to pchecktype :want :left :right
if not equalp :want :left [(throw "error (sentence :left "isn't :want))]
if not equalp :want :right [(throw "error (sentence :right "isn't :want))]
end

;; Expression elements

to pdata :token
if equalp :token "true [output [boolean immediate 1]]
if equalp :token "false [output [boolean immediate 0]]
if equalp first :token "' [output pchardata :token]
if numberp :token [output (list numtype :token "immediate :token)]
localmake "id getid :token
if emptyp :id [(throw "error sentence [undefined symbol] :token)]
localmake "type id.type :id
if equalp :type "function [output pfuncall :token]
local "index
setindex "true
localmake "reg newregister
codeload :reg (id.pointer :id) (id.varp :id) :index
output (list :type "register :reg)
end

to pchardata :token
if not equalp count :token 3 ~
   [(throw "error sentence :token [not single character])]
output (list "char "immediate ascii first butfirst :token)
end

to numtype :number
if memberp ". :number [output "real]
if memberp "e :number [output "real]
output "integer
end

to pfuncall :pname
localmake "id getid :pname
localmake "lname id.lname :id
if namep (word "need :lname) [make (word "need :lname) "true]
localmake "vartypes thing :lname
localmake "returntype first :vartypes
make "vartypes butfirst :vartypes
pproccall1 framesize.fun
localmake "reg newregister
code (list "add :reg reg.retval reg.zero)
output (list :returntype "register :reg)
end

;; Parsing assistance

to code :stuff
if emptyp :stuff [stop]
push :codeinto :stuff
end

to commalist :test [:sofar []]
local [result token]
make "result run :test
if emptyp :result [output :sofar]
ifbe ", [output (commalist :test (lput :result :sofar))]
output lput :result :sofar
end

.macro ifbe :wanted :action
localmake "token token
if equalp :token :wanted [output :action]
make "peektoken :token
output []
end

.macro ifbeelse :wanted :action :else
localmake "token token
if equalp :token :wanted [output :action]
make "peektoken :token
output :else
end

to mustbe :wanted
localmake "token token
if equalp :token :wanted [stop]
(throw "error (sentence "expected :wanted "got :token))
end

to newregister
for [i reg.firstfree :numregs-1] ~
    [if not item :i :regsused [setitem :i :regsused "true  output :i]]
(throw "error [not enough registers available])
end

to regfree :reg
setitem :reg :regsused "false
end

to reservedp :word
output memberp :word [and array begin case const div do downto else end ~
                      file for forward function goto if in label mod nil ~
                      not of packed procedure program record repeat set ~
                      then to type until var while with]
end

;; Lexical analysis

to token
local [token char]
if namep "peektoken [make "token :peektoken
                     ern "peektoken   output :token]
make "char getchar
if equalp :char "|{| [skipcomment output token]
if equalp :char char 32 [output token]
if equalp :char char 13 [output token]
if equalp :char char 10 [output token]
if equalp :char "' [output string "']
if memberp :char [+ - * / = ( , ) |[| |]| |;|] [output :char]
if equalp :char "|<| [output twochar "|<| [= >]]
if equalp :char "|>| [output twochar "|>| [=]]
if equalp :char ". [output twochar ". [.]]
if equalp :char ": [output twochar ": [=]]
if numberp :char [output number :char]
if letterp ascii :char [output token1 lowercase :char]
(throw "error sentence [unrecognized character:] :char)
end

to skipcomment
if equalp getchar "|}| [stop]
skipcomment
end

to string :string
localmake "char getchar
if not equalp :char "' [output string word :string :char]
make "char getchar
if equalp :char "' [output string word :string :char]
make "peekchar :char
output word :string "'
end

to twochar :old :ok
localmake "char getchar
if memberp :char :ok [output word :old :char]
make "peekchar :char
output :old
end

to number :num
localmake "char getchar
if equalp :char ". ~
   [make "char getchar ~
    ifelse equalp :char ". ~
           [make "peektoken ".. output :num] ~
           [make "peekchar :char output number word :num ".]]
if equalp :char "e [output number word :num twochar "e [+ -]]
if numberp :char [output number word :num :char]
make "peekchar :char  output :num
end

to token1 :token
localmake "char getchar
if or letterp ascii :char numberp :char ~
   [output token1 word :token lowercase :char]
make "peekchar :char  output :token
end

to letterp :code
if and (:code > 64) (:code < 91) [output "true]
output and (:code > 96) (:code < 123)
end

to getchar
local "char
if namep "peekchar [make "char :peekchar  ern "peekchar  output :char]
ifelse eofp [output char 1] [output rc1]
end

to rc1
localmake "result readchar
type :result  output :result
end

;; Data abstraction: ID List

to newlname :word
if memberp :word :namesused [output gensym]
if namep word "% :word [output gensym]
push "namesused :word
output word "% :word
end

to lname :word
localmake "result getid :word
if not emptyp :result [output item 3 :result]
(throw "error sentence [unrecognized identifier] :word)
end

to gettype :word
localmake "result getid :word
if not emptyp :result [output item 2 :result]
(throw "error sentence [unrecognized identifier] :word)
end

to getid :word [:list :idlist]
if emptyp :list [output []]
if equalp :word first first :list [output first :list]
output (getid :word butfirst :list)
end

to id.type :id                     to id.varp :id
output item 2 :id                  output item 4 :id
end                                end

to id.pointer :id                  to id.frame :id
output item 3 :id                  output item 4 :id
end                                end

to id.lname :id
output item 3 :id
end

;; Data abstraction: Operators

to op.instr :op                    to op.types :op
output first :op                   output item 3 :op
end                                end

to op.nargs :op                    to op.prec :op
output first bf :op                output last :op
end                                end

;; Data abstraction: Expressions

to exp.type :exp
output first :exp
end

to exp.mode :exp
output first butfirst :exp
end

to exp.value :exp
output last :exp
end

;; Data abstraction: Frame slots

to frame.retaddr                   to frame.regsave
output 0                           output 4
end                                end

to frame.save.newfp                to framesize.proc
output 1                           output 4+:numregs
end                                end

to frame.outerframe                to frame.retval
output 2                           output 4+:numregs
end                                end

to frame.prevframe                 to framesize.fun
output 3                           output 5+:numregs
end                                end

;; Data abstraction: Registers

to reg.zero                        to reg.frameptr
output 0                           output 4
end                                end

to reg.retaddr                     to reg.newfp
output 1                           output 5
end                                end

to reg.stackptr                    to reg.retval
output 2                           output 6
end                                end

to reg.globalptr                   to reg.firstfree
output 3                           output 7
end                                end

;; Runtime (machine simulation)

to prun :progname
localmake "prog thing word "% :progname
localmake "regs (array :numregs 0)
local filter "wordp :prog
foreach :prog [if wordp ? [make ? ?rest]]
localmake "memory (array :memsize 0)
setitem 0 :regs 0
if not procedurep "add [runsetup]
prun1 :prog
end

to prun1 :pc
if emptyp :pc [stop]
if listp first :pc [run first :pc]
prun1 butfirst :pc
end

to rload :reg :offset :index
setitem :reg :regs (item (item :index :regs)+:offset :memory)
end

to store :reg :offset :index
setitem (item :index :regs)+:offset :memory (item :reg :regs)
end

to runsetup
foreach [[add sum] [sub difference] [mul product] [quo quotient]
         [div [int quotient]] [rem remainder] [land product]
         [lor [tobool lessp 0 sum]] [eql [tobool equalp]]
         [neq [tobool not equalp]] [less [tobool lessp]]
         [gtr [tobool greaterp]] [leq [tobool not greaterp]]
         [geq [tobool not lessp]]] ~
        [define first ?
                `[[dest src1 src2]
                  [setitem :dest :regs ,@[last ?] (item :src1 :regs)
                                                  (item :src2 :regs)]]
         define word first ? "i
                `[[dest src1 immed]
                  [setitem :dest :regs ,@[last ?] (item :src1 :regs)
                                                  :immed]]]
foreach [[lnot [difference 1]] [sint int] [sround round] [srandom random]] ~
        [define first ?
                `[[dest src]
                  [setitem :dest :regs ,@[last ?] (item :src :regs)]]
         define word first ? "i
                `[[dest immed]
                  [setitem :dest :regs ,@[last ?] :immed]]]
end

to tobool :tf
output ifelse :tf [1] [0]
end

to jump :label
make "pc fput :label thing :label
end

to jumpt :reg :label
if (item :reg :regs)=1 [jump :label]
end

to jumpf :reg :label
if (item :reg :regs)=0 [jump :label]
end

to jr :reg
make "pc item :reg :regs
end

to jal :reg :label
setitem :reg :regs :pc
jump :label
end

to putch :width :reg
spaces :width 1
type char (item :reg :regs)
end

to putstr :width :string
spaces :width (count first :string)
type :string
end

to puttf :width :bool
spaces :width 1
type ifelse (item :bool :regs)=0 ["F] ["T]
end

to putint :width :reg
localmake "num (item :reg :regs)
spaces :width count :num
type :num
end

to putreal :width :reg
putint :width :reg
end

to spaces :width :count
if :width > :count [repeat :width - :count [type "| |]]
end

to newline
print []
end

to exit
make "pc [exit]
end