A compiler for an algol-style syntax, C-style semantic language in QBasic (written in 1992)

about.md

This is a compiler I wrote back in the days. It is actually in QBasic because I did not have anything else available (I only got hold of Linux 0.99 a while later.) The output were DOS .com files which have the most simple memory model available on DOS/Windows.

The most remarkable thing I remember is that I used a lisp s-expr style representation for the parse tree; since basic data structures were lacking (and because I wanted the short syntax of car(a) and cdr(a)) I used two arrays car and cdr where the same place in both formed one cons cell; positive numbers in the array referred to other cons cells, negative one to a string array.

(This is not the entire thing; the assembler and linker have been bootstrapped into compiled executables, but their source code may have been lost.)

p.bas

DECLARE SUB shexec (cmd$)
DECLARE SUB forceunit (u$)
DECLARE SUB pulluses (u$)
DECLARE FUNCTION existnfile% (a$)
DECLARE SUB addmod (m$)
DECLARE SUB writemoddir ()
DECLARE SUB remmod ()
DECLARE SUB adduse (t$)
DECLARE SUB writeuse ()
DECLARE SUB remuses ()
DECLARE SUB writedir ()
DECLARE SUB updateunit (u$)
DECLARE SUB addunit (u$)
DECLARE SUB readdir ()
DECLARE FUNCTION pfname$ (u$, n%)
DECLARE FUNCTION findlocvar% (p%)
DECLARE SUB modreset ()
DECLARE SUB scopeincls ()
DECLARE FUNCTION findmodtype% (r%, m%)
DECLARE SUB addfname (t$)
DECLARE FUNCTION findmodvar% (r%, m%)
DECLARE SUB putstrings ()
DECLARE SUB remodscope ()
DECLARE SUB readimp (t$)
DECLARE SUB setword (a$)
DECLARE FUNCTION haswords% ()
DECLARE FUNCTION getword$ ()
DECLARE FUNCTION tnum% (w$, b%)
DECLARE SUB typut (r%)
DECLARE SUB tyinit ()
DECLARE SUB tydump ()
DECLARE FUNCTION tyadd$ (r%)
DECLARE FUNCTION tynum$ (r%)
DECLARE SUB bssscope ()
DECLARE FUNCTION ahsh% (l$)
DECLARE SUB cgconstdecl (r%)
DECLARE FUNCTION evalconst% (r%)
DECLARE FUNCTION pconst% ()
DECLARE FUNCTION getorref% (t%)
DECLARE FUNCTION isleamov% (t$)
DECLARE FUNCTION isleamovas% (t$)
DECLARE SUB score (t$)
DECLARE FUNCTION sname$ (r%)
DECLARE FUNCTION vectoref% (t%)
DECLARE FUNCTION pname$ (r%)
DECLARE FUNCTION newvectnode% (t%, l%)
DECLARE FUNCTION straddr$ (r%)
DECLARE FUNCTION pexpor% ()
DECLARE FUNCTION pexand% ()
DECLARE FUNCTION pexrel% ()
DECLARE FUNCTION pexsum% ()
DECLARE FUNCTION noregs% (t$, r1$, r2$)
DECLARE FUNCTION isx8% (t$)
DECLARE SUB aslop (l$)
DECLARE SUB aputw (w%)
DECLARE FUNCTION agetlbl% (l$)
DECLARE FUNCTION agop2$ (t$)
DECLARE FUNCTION agop$ (t$)
DECLARE FUNCTION agov% (t$)
DECLARE SUB aputb (b%)
DECLARE SUB aputh (t$)
DECLARE SUB aopenline ()
DECLARE FUNCTION myhex$ (h%, l%)
DECLARE FUNCTION asetlbl% (l$, v%)
DECLARE SUB a86 ()
DECLARE SUB asopt ()
DECLARE FUNCTION isnumstr% (t$)
DECLARE FUNCTION isx% (t$)
DECLARE SUB asflsh ()
DECLARE SUB asputnode (t%)
DECLARE SUB aslbl (l$)
DECLARE SUB asrem (r$)
DECLARE SUB asop (o$)
DECLARE SUB terrdiag (t$)
DECLARE FUNCTION src86$ (a$)
DECLARE SUB mka86 ()
DECLARE FUNCTION ignb$ (l$)
DECLARE FUNCTION isbool% (t%)
DECLARE FUNCTION cgtest% (r%, w$, f$)
DECLARE FUNCTION strlist$ (ss$, r%)
DECLARE FUNCTION newreftnode% (t%)
DECLARE FUNCTION parlist% (r%)
DECLARE FUNCTION extsu$ (t%)
DECLARE FUNCTION addtype% (p%, t%)
DECLARE FUNCTION findtype% (r%)
DECLARE FUNCTION addr$ (p%)
DECLARE SUB showscope (uu%)
DECLARE FUNCTION gentype% (r%)
DECLARE SUB machout (t$)
DECLARE SUB prtype (x%)
DECLARE FUNCTION newtyp% (p%, s%, t%)
DECLARE FUNCTION newtnode% ()
DECLARE FUNCTION newsym% (p%, s%, t%)
DECLARE SUB cgpreptype (r%)
DECLARE SUB cgtypedecl (r%)
DECLARE SUB fptree (x%)
TYPE symtab
  succ AS INTEGER
  vars AS INTEGER
  types AS INTEGER
  size AS INTEGER
  strat AS INTEGER
  modname AS INTEGER
  modules AS INTEGER
END TYPE
TYPE syment
   succ AS INTEGER
   id AS INTEGER
   typ AS INTEGER
   offs AS INTEGER
   ref AS INTEGER
END TYPE
TYPE typent
   succ AS INTEGER
   id AS INTEGER
   typ AS INTEGER
END TYPE
REM TYPE enode
REM    op AS INTEGER
REM    t AS INTEGER
REM    l AS INTEGER
REM    r AS INTEGER
REM    a AS INTEGER
REM END TYPE
TYPE tnode
   size AS INTEGER
   t AS INTEGER
   subtyp AS INTEGER
   elems AS INTEGER
END TYPE
TYPE mds
   chr AS STRING * 1
END TYPE
DECLARE SUB skiptok (t$)
DECLARE FUNCTION fitsize% (t%, m%)
DECLARE FUNCTION isnum% (t%)
DECLARE FUNCTION isunsigned% (t%)
DECLARE FUNCTION sametype% (a%, b%)
DECLARE FUNCTION siz$ (m%)
DECLARE FUNCTION mkop% (o$, aa%, bb%)
DECLARE FUNCTION isptr% (t%)
DECLARE FUNCTION sizeof% (t%)
DECLARE SUB addscope (p%)
DECLARE SUB remscope ()
DECLARE FUNCTION findvar% (r%)
DECLARE SUB cgvardecl (r%)
DECLARE SUB lout (t$)
DECLARE FUNCTION cgaddr% (r%)
DECLARE FUNCTION mklbl$ ()
DECLARE SUB cout (t$)
DECLARE SUB remout (t$)
DECLARE SUB cgfunction (r%)
DECLARE FUNCTION cgexpr% (r%)
DECLARE SUB cgen (r%)
DECLARE FUNCTION pstmts% (t$, u$)
DECLARE FUNCTION pblock% (t$, b$)
DECLARE FUNCTION ltn% (a%, l%)
DECLARE FUNCTION plen% (a%)
DECLARE SUB pptree (x%)
DECLARE FUNCTION pqualname% ()
DECLARE FUNCTION ptypedecl% ()
DECLARE FUNCTION revl% (x%)
DECLARE FUNCTION mcode% (m$, r%, l%)
DECLARE FUNCTION mkstr% (m$)
DECLARE FUNCTION ptype% ()
DECLARE FUNCTION pvar% ()
DECLARE FUNCTION pstmt% ()
DECLARE SUB tree (x%)
DEFINT A-Z
DECLARE FUNCTION pside ()
DECLARE FUNCTION cons (r, l)
DECLARE SUB checktok (t$)
DECLARE SUB terror (e$)
DECLARE FUNCTION pexpr ()
DECLARE FUNCTION pterm ()
DECLARE FUNCTION pfactor ()
DECLARE SUB gettok ()
DECLARE FUNCTION addvar (p, t, qref)
CLEAR , , 2000
tt0& = TIMER
tt1& = 0
tt2& = 0
tt3& = 0
tt4& = 0
OPEN "n.log" FOR OUTPUT AS 4
neu = -1
CONST ndirs = 60
DIM SHARED ndiro$(ndirs), ndirn$(ndirs), usedir$(ndirs), moddir$(ndirs)
readdir
complist$ = ""
units$ = ""
fl$ = "+"
OPEN "units.dir" FOR INPUT AS 1
WHILE NOT EOF(1)
  LINE INPUT #1, u$
  u$ = LTRIM$(RTRIM$(u$))
  IF u$ = "(" THEN
    IF LEFT$(fl$, 1) = "+" THEN
      fl$ = "+" + fl$
    ELSE
      fl$ = "-" + fl$
    END IF
  ELSEIF u$ = ")" THEN
    fl$ = MID$(fl$, 2)
  ELSEIF u$ = "+" THEN
    fl$ = "+" + MID$(fl$, 2)
  ELSEIF u$ = "-" THEN
    fl$ = "-" + MID$(fl$, 2)
  ELSEIF LEFT$(u$, 1) <> ";" AND INSTR(fl$, "-") = 0 THEN
    addunit (u$)
  END IF
WEND
CLOSE #1
IF 0 THEN
  addunit ("modules")
  addunit ("abf")
  addunit ("asmod")
  addunit ("asect")
  addunit ("aoutl")
  addunit ("a86")
  addunit ("amods")
  addunit ("autl")
  addunit ("ilopt")
END IF
IF 0 THEN
  addunit ("tok")
  addunit ("nlex")
  addunit ("tokt")
  addunit ("gtok")
  addunit ("putl")
  addunit ("ptree")
  addunit ("parse")
  addunit ("types")
'  addunit ("typutl")
  addunit ("ilc")
'  addunit ("ilout")
'  addunit ("iltype")
  addunit ("gtype")
  addunit ("cgen")
  addunit ("nc")
  addunit ("ilt")
END IF
IF 0 THEN
  addunit ("t")
  addunit ("inv")
END IF
IF 0 THEN
  addunit ("obf")
  addunit ("ot")
  addunit ("lkfile")
  addunit ("lk")
  addunit ("ar")
  addunit ("tm")
END IF
IF 0 THEN
  addunit ("ccnt")
  addunit ("xd")
  addunit ("texwri")
  addunit ("writex")
END IF
100 IF LEN(units$) = 0 THEN
  CLOSE #4
  tt5& = TIMER
  PRINT "complist:"; complist$
  PRINT "Total times:"; tt1&; "Parse,"; tt2&; "Compile,";
  PRINT tt3&; "ILOpt,"; tt4&; "Assemble."
  PRINT "Total time"; tt5& - tt0&; "s."
  SYSTEM
END IF
dp = INSTR(units$, "$")
IF dp = 1 THEN
  units$ = MID$(units$, 2)
  GOTO 100
END IF
IF dp = 0 THEN
  unit$ = units$
  units$ = ""
ELSE
  unit$ = LEFT$(units$, dp - 1)
  units$ = MID$(units$, dp + 1)
END IF
nunit = 0
punit = 0
pon = 0
killil = -1
kills = -1
remuses
remmod
complist$ = complist$ + unit$ + ":"
PRINT "File("; unit$; ")"
ncells = 7000
REDIM SHARED car(ncells)
REDIM SHARED cdr(ncells)
REDIM SHARED names$(600)
REDIM SHARED nametag(600)
tokcnt = 0
olcnt = 0
namecnt = 0
cellcnt = 0
DIM SHARED modlist(20)
modcnt = 0
DIM SHARED sta(30), stb(30)
sti = 0
toterrs = 0
terrcnt = 0
t0& = TIMER
REDIM SHARED errtab$(10)
REDIM SHARED symtabs(60) AS symtab
currsymtab = 0
symtabcnt = 0
freesymtabs = 0
currfunctype = 0
currretlbl$ = "Lstop"
currlocsize = 0
currfuncname$ = ""
globoff = 0
DIM SHARED ttab(400)
tput = 0
tget = 0
REDIM SHARED syms(900) AS syment
symcnt = 0
REDIM SHARED typs(450) AS typent
typcnt = 0
REDIM SHARED tnodes(800) AS tnode
CONST voidtp = 1, inttp = 2, uinttp = 3, chartp = 4, uchartp = 5
CONST booltp = 6, niltp = 7, reftp = 8, undeftp = 9, functp = 10
CONST rectp = 11, vectp = 12, enumtp = 13
tnodes(voidtp).size = 0
tnodes(voidtp).t = voidtp
tnodes(voidtp).subtyp = 0
tnodes(voidtp).elems = 0
tnodes(inttp).size = 2
tnodes(inttp).t = inttp
tnodes(inttp).subtyp = 0
tnodes(inttp).elems = 0
tnodes(uinttp).size = 2
tnodes(uinttp).t = uinttp
tnodes(uinttp).subtyp = 0
tnodes(uinttp).elems = 0
tnodes(chartp).size = 1
tnodes(chartp).t = chartp
tnodes(chartp).subtyp = 0
tnodes(chartp).elems = 0
tnodes(uchartp).size = 1
tnodes(uchartp).t = uchartp
tnodes(uchartp).subtyp = 0
tnodes(uchartp).elems = 0
tnodes(booltp).size = 1
tnodes(booltp).t = booltp
tnodes(booltp).subtyp = 0
tnodes(booltp).elems = 0
tnodes(niltp).size = 2
tnodes(niltp).t = niltp
tnodes(niltp).subtyp = 0
tnodes(niltp).elems = 0
tnodecnt = reftp
DEF fnpn$ (x)
  SELECT CASE x
  CASE IS > 0
    fnpn$ = STR$(x)
  CASE IS < 0
    fnpn$ = names$(-x)
  CASE ELSE
    fnpn$ = "@nil"
  END SELECT
END DEF
prtlvl = 0
DIM SHARED prtarr(20)
REM ===================================================== IL-Daten
TYPE asnode
   op AS STRING * 10
   a1 AS STRING * 40
   a2 AS STRING * 30
END TYPE
REM ===================================================== Assemblerdaten
REDIM SHARED ahash(10)
FOR i = 1 TO 10
  ahash(i) = 0
NEXT
REM ===================================================== Parsen
OPEN unit$ + ".n" FOR INPUT AS 1
REM PRINT "Anfang "
blklvl = 0
cline$ = ""
gettok
r = pstmts("$$", "$$")
DO WHILE NOT currtok$ = "$$"
  PRINT "gettok "; currtok$;
  IF currtok$ = "id" THEN PRINT " ["; currname$; "]";
  PRINT
  gettok
LOOP
CLOSE #1
REM tree (r)
REM PRINT
REM ===================================================== Baum raus
REM pptree (r)
REM  "t.ast"
REM OPEN "t.ast" FOR OUTPUT AS #9
REM fptree (r)
REM CLOSE #9
REM ===================================================== Code Generation
REDIM SHARED filenames$(30)
REDIM SHARED modules$(30)
filenamecnt = 0
ilopen = 0
t1& = TIMER
REM  "t.il"
REM OPEN "t.il" FOR OUTPUT AS #9
cgen (r)
IF globoff <> 0 THEN
  terror ("fgloboff not zero")
END IF
REM CLOSE #9
REM ===================================================== Abschluss
t2& = TIMER
terrdiag ("Compile")
PRINT namecnt; "Names,"; tokcnt; "Tokens,"; cellcnt; "Cells,";
PRINT globoff; "GlBytes,"; olcnt; "IL Lines,"
PRINT symcnt; "Symbols,"; typcnt; "Type names,"; tnodecnt; "Type nodes."
REM ===================================================== IL Processing
ERASE car, cdr, names$
ilopen = 1
FOR ii = 1 TO filenamecnt
  REDIM SHARED asnodes(30) AS asnode
  asfill = 0
  REDIM SHARED scorelist$(30)
  REDIM SHARED scorecnts(30)
  ff$ = filenames$(ii)
  PRINT "ilopt(" + ff$ + ")"
  IF 1 THEN
    IF neu THEN
      shexec ("bilopt " + ff$)
      IF killil THEN KILL ff$ + ".il"
      PRINT "a86(" + ff$ + ")"
      shexec ("ba86 " + ff$)
      IF kills THEN KILL ff$ + ".s"
      PRINT "ar(" + ff$ + ")"
      shexec ("bar u o.a " + ff$ + ".o")
      KILL ff$ + ".o"
    ELSE
      shexec ("pilopt " + ff$)
      KILL ff$ + ".il"
    END IF
  ELSE
    scorecnt = 0
    DIM SHARED aoptcnt(3)
    FOR i = 1 TO 3
      aoptcnt(i) = 0
    NEXT
    olcnt = 0
    terrcnt = 0
    asinsn = 0
    asoinsn = 0
    OPEN ff$ + ".il" FOR INPUT AS 7
    REM  ".s"
    OPEN ff$ + ".s" FOR OUTPUT AS 9
    mka86
    CLOSE #9
    CLOSE #7
    terrdiag ("Intermediate code")
    PRINT olcnt; "Assembler Lines,"; asinsn; "to"; asoinsn; "Instructions."
    REM PRINT "Gained Insns:"; aoptcnt(1); aoptcnt(2); aoptcnt(3)
    REM FOR i = 1 TO scorecnt
    REM   ll$ = STR$(scorecnts(i))
    REM   IF LEN(ll$) < 5 THEN ll$ = SPACE$(5 - LEN(ll$)) + ll$
    REM   PRINT ll$ + " " + scorelist$(i)
    REM NEXT
  END IF
NEXT
t3& = TIMER
IF toterrs = 0 THEN
  REM PRINT "No errors so far, starting assembler..."
  updateunit (unit$)
  writedir
  WHILE punit < nunit
    unitn$ = pfname$(unit$, punit)
    punit = punit + 1
    IF neu THEN
      PRINT "lk(" + unitn$ + ")"
      shexec ("blk " + unitn$)
    ELSE
      PRINT "a86(" + unitn$ + ")"
      shexec ("pa86 " + unitn$)
    END IF
    REM KILL unitn$ + ".lst"
  WEND
END IF
t4& = TIMER
PRINT "Times:"; t1& - t0&; "Parse,"; t2& - t1&; "Compile,";
PRINT t3& - t2&; "ILOpt,"; t4& - t3&; "Assemble."
tt1& = tt1& + t1& - t0&
tt2& = tt2& + t2& - t1&
tt3& = tt3& + t3& - t2&
tt4& = tt4& + t4& - t3&
writemoddir
writeuse
pulluses (unit$)
GOTO 100
SYSTEM
REM ===================================================== Assembler
REM
REM
REM
REM
REM
REDIM SHARED albls$(1000)
REDIM SHARED asucc(1000)
REDIM SHARED avals(1000)
aoline$ = ""
aolcnt = 0
abytcnt = 0
aspccnt = 0
terrcnt = 0
arg1 = 0
arg2 = 0
OPEN "t.s" FOR INPUT AS 7
aoutp = 0
apc = 0
alblcnt = 0
a86
terrdiag ("Assembler, Pass 1")
terrcnt = 0
OPEN "t.s" FOR INPUT AS 7
REM KILL "t.com"
OPEN "t.com" FOR BINARY AS 8
REM KILL "t.lst"
OPEN "t.lst" FOR OUTPUT AS 9
aoutp = -1
a86
CLOSE #9
CLOSE #8
terrdiag ("Assembler, Pass 2")
PRINT abytcnt; "Bytes,"; aolcnt; "Listing Lines,"; alblcnt; "Labels."
REM FOR i = 1 TO alblcnt
REM   PRINT myhex$(avals(i), 4); "  "; albls$(i)
REM NEXT

SUB a86
  SHARED apc, aoline$, aoutp, aolcnt
  SHARED arg1, arg2
  PRINT "No Assembler"
  STOP
END SUB

SUB addfname (t$)
  SHARED filenamecnt
  filenamecnt = filenamecnt + 1
  filenames$(filenamecnt) = t$
END SUB

SUB addmod (m$)
  SHARED unit$
REM  PRINT "addmod(" + unit$ + ", " + m$; ")"
  FOR i = 1 TO ndirs
    a$ = moddir$(i)
    IF LEFT$(a$, LEN(unit$) + 1) = unit$ + ":" THEN
      moddir$(i) = a$ + m$ + ":"
REM      PRINT moddir$(i)
      EXIT SUB
    END IF
  NEXT
  FOR i = 1 TO ndirs
    a$ = moddir$(i)
    IF a$ = "" THEN
      moddir$(i) = unit$ + ":" + m$ + ":"
REM      PRINT moddir$(i)
      EXIT SUB
    END IF
  NEXT
END SUB

FUNCTION addr$ (p)
  v = syms(p).ref
  maj$ = LTRIM$(STR$(ABS(v)))
  min$ = LTRIM$(STR$(syms(p).offs))
  SELECT CASE v
  CASE 2
    p$ = "f"
  CASE -1
    p$ = "f"
  CASE 0
    p$ = "g"
  CASE 3
    p$ = "p"
    min$ = names$(syms(p).offs)
  CASE 5
    p$ = "d"
    min$ = names$(syms(p).offs)
  CASE ELSE
    IF v > 0 THEN
      p$ = "x"
    ELSE
      p$ = "y"
    END IF
      p$ = p$ + "." + maj$
  END SELECT
  addr$ = p$ + "." + min$
END FUNCTION

SUB addscope (p)
  REM p=2 argument list
  REM p=6 outer block scope
  REM p=7 inner block scope
  REM p=-1 local variables
  SHARED currsymtab, freesymtabs, symtabcnt
  oc = currsymtab
  IF freesymtabs THEN
    currsymtab = freesymtabs
    freesymtabs = symtabs(currsymtab).succ
  ELSE
    symtabcnt = symtabcnt + 1
    currsymtab = symtabcnt
  END IF
  symtabs(currsymtab).succ = oc
  symtabs(currsymtab).vars = 0
  symtabs(currsymtab).types = 0
  symtabs(currsymtab).size = 0
  symtabs(currsymtab).strat = p
  symtabs(currsymtab).modname = 0
  symtabs(currsymtab).modules = 0
  IF p = 999 AND symtabs(currsymtab).succ THEN
    REM special case, use last strat mode
    ls = symtabs(symtabs(currsymtab).succ).strat
    IF ls = 2 THEN
      ls = -1
    ELSEIF ls = 6 THEN
      symtabs(currsymtab).modname = symtabs(symtabs(currsymtab).succ).modname
      ls = 7
    ELSEIF ls = 7 THEN
      ls = 0
    ELSEIF ls = -1 THEN
      REM start at old size in nested local blocks
      symtabs(currsymtab).size = symtabs(symtabs(currsymtab).succ).size
    END IF
    symtabs(currsymtab).strat = ls
  END IF
END SUB

FUNCTION addtype (p, t)
  SHARED currsymtab
  IF currsymtab = 0 THEN STOP
  x = symtabs(currsymtab).modules
  DO WHILE x > 0
    IF symtabs(x).modname = p THEN
      terror (" type " + names$(p) + " hides module name")
    END IF
    x = symtabs(x).succ
  LOOP
  x = symtabs(currsymtab).types
  DO WHILE x > 0
    IF typs(x).id = p THEN
      IF typs(x).typ THEN
        IF tnodes(typs(x).typ).t = undeftp THEN
          addtype = x
          tnodes(typs(x).typ).size = tnodes(t).size
          tnodes(typs(x).typ).t = tnodes(t).t
          tnodes(typs(x).typ).subtyp = tnodes(t).subtyp
          tnodes(typs(x).typ).elems = tnodes(t).elems
        ELSE
          PRINT "Dup name "; names$(p)
          addtype = 0
        END IF
      ELSE
        typs(x).typ = t
        addtype = x
      END IF
      EXIT FUNCTION
    END IF
    x = typs(x).succ
  LOOP
  x = newtyp(p, symtabs(currsymtab).types, t)
  symtabs(currsymtab).types = x
REM  showscope (currsymtab)
  addtype = x
END FUNCTION

SUB addunit (u$)
  SHARED units$
REM  PRINT "adding unit " + u$
  n$ = UCASE$(u$) + SPACE$(8 - LEN(u$))
  i = 1
  DO WHILE i <= ndirs
    IF n$ = LEFT$(ndiro$(i), 8) THEN
      j = 1
      DO WHILE j <= ndirs
        IF n$ = LEFT$(ndirn$(j), 8) THEN
          IF ndiro$(i) = ndirn$(j) THEN
            PRINT ndirn$(j)
            EXIT SUB
          END IF
        END IF
        j = j + 1
      LOOP
    END IF
    i = i + 1
  LOOP
  forceunit (u$)
REM  PRINT units$
END SUB

SUB adduse (m$)
  SHARED unit$
  i = 1
  t$ = ""
  DO WHILE i <= ndirs
    IF INSTR(moddir$(i), ":" + m$ + ":") THEN
      p = INSTR(moddir$(i), ":")
      t$ = LEFT$(moddir$(i), p - 1)
      EXIT DO
    END IF
    i = i + 1
  LOOP
  IF t$ = "" THEN
REM    PRINT "adduse: no file for module " + m$
    EXIT SUB
  END IF
REM  PRINT "adduse(" + unit$ + ", " + t$ + ")"
  FOR i = 1 TO ndirs
    a$ = usedir$(i)
    IF t$ + ":" = LEFT$(a$, LEN(t$) + 1) THEN
      p = INSTR(a$, ":" + unit$ + ":")
      IF p = 0 THEN
        usedir$(i) = a$ + unit$ + ":"
REM        PRINT usedir$(i)
      END IF
      EXIT SUB
    END IF
    IF a$ = "" THEN
      usedir$(i) = t$ + ":" + unit$ + ":"
REM      PRINT usedir$(i)
      EXIT SUB
    END IF
  NEXT
END SUB

FUNCTION addvar (p, t, qref)
  SHARED currsymtab, currlocsize
  SHARED globoff
  IF currsymtab = 0 THEN STOP
  x = symtabs(currsymtab).modules
  DO WHILE x > 0
    IF symtabs(x).modname = p THEN
      terror (" variable " + names$(p) + " hides module name")
    END IF
    x = symtabs(x).succ
  LOOP
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
    IF syms(x).id = p THEN
      terror (" Dup name " + names$(p))
      addvar = 0
      EXIT FUNCTION
    END IF
    x = syms(x).succ
  LOOP
  x = newsym(p, symtabs(currsymtab).vars, t)
  sz = tnodes(t).size
  IF (symtabs(currsymtab).strat = 6 OR symtabs(currsymtab).strat = 7) AND qref = 0 THEN
    REM Globale variablen mit Namen versehen
    qref = 5
  END IF
  IF qref = 0 THEN
    IF symtabs(currsymtab).strat > 0 THEN
      of = symtabs(currsymtab).size
      IF symtabs(currsymtab).strat = 2 THEN
        REM wordalign on stack
        IF sz AND 1 THEN sz = sz + 1
      END IF
      symtabs(currsymtab).size = of + sz
    ELSEIF symtabs(currsymtab).strat < 0 THEN
      of = -symtabs(currsymtab).size
      of = of - sz
      symtabs(currsymtab).size = -of
      IF symtabs(currsymtab).strat = -1 THEN
        IF currlocsize < -of THEN currlocsize = -of
      END IF
    ELSE
      of = globoff
      globoff = of + sz
    END IF
    syms(x).ref = symtabs(currsymtab).strat
    syms(x).offs = of
  ELSE
    syms(x).ref = qref
    IF qref = 3 OR qref = 5 THEN
      syms(x).offs = p
      IF symtabs(currsymtab).strat = 7 THEN
        nm = symtabs(currsymtab).modname
        IF nm THEN
          syms(x).offs = -mkstr("_" + LTRIM$(STR$(LEN(names$(nm)))) + names$(nm) + names$(p))
        END IF
      END IF
    END IF
  END IF
  symtabs(currsymtab).vars = x
REM  showscope (currsymtab)
  addvar = x
END FUNCTION

SUB bssscope
  SHARED currsymtab, modncnt
  REM make data section for global scope
  IF symtabs(currsymtab).strat <> 7 THEN EXIT SUB
  n = symtabs(symtabs(currsymtab).succ).modname
  IF n <= 0 THEN STOP
REM  PRINT "--- bss scope", currsymtab
  x = symtabs(currsymtab).modules
  DO WHILE x > 0
    modncnt = modncnt + 1
    modules$(modncnt) = names$(symtabs(x).modname)
    x = symtabs(x).succ
  LOOP
  cout ("bss")
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
REM    PRINT names$(syms(x).id); " ref"; syms(x).ref
    IF syms(x).ref = 5 THEN
      cout ("var    " + names$(syms(x).offs) + "," + siz$(syms(x).typ))
    END IF
    x = syms(x).succ
  LOOP
  IF names$(n) = "" THEN
    EXIT SUB
  END IF
  addmod (names$(n))
  PRINT "Export(" + names$(n);
  OPEN "exp\" + names$(n) + ".exp" FOR OUTPUT AS 11
  tyinit
  REM mark all needed types
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
    typut (syms(x).typ)
    x = syms(x).succ
  LOOP
  x = symtabs(currsymtab).types
  DO WHILE x > 0
    typut (typs(x).typ)
    x = typs(x).succ
  LOOP
  tydump
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
    IF syms(x).ref = 4 THEN
      PRINT #11, "const "; syms(x).offs;
    ELSE
      PRINT #11, "var ";
    END IF
    PRINT #11, " "; names$(syms(x).id); " "; tynum$(syms(x).typ)
    x = syms(x).succ
  LOOP
  x = symtabs(currsymtab).types
  DO WHILE x > 0
    PRINT #11, "type "; names$(typs(x).id); " "; tynum$(typs(x).typ)
    x = typs(x).succ
  LOOP
  PRINT ")"
  CLOSE #11
END SUB

FUNCTION cgaddr (r)
REM  PRINT "cgaddr(" + fnpn$(r) + ")"
  t = 0
  IF r > 0 THEN
    IF car(r) < 0 THEN
      SELECT CASE names$(-car(r))
      CASE "group"
        t = cgaddr(car(cdr(r)))
      CASE "array"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("add", t, u)
        IF tnodes(t).t = reftp THEN
          t = tnodes(t).subtyp
        ELSE
          terror ("no ref for deref")
        END IF
      CASE "deref"
        t = cgexpr(car(cdr(r)))
        IF tnodes(t).t = reftp THEN
          t = tnodes(t).subtyp
        ELSE
          terror ("no ref for deref")
        END IF
      CASE "select"
        IF car(cdr(r)) < 0 AND car(cdr(cdr(r))) < 0 THEN
          v = findmodvar(-car(cdr(cdr(r))), -car(cdr(r)))
          IF v >= 0 THEN GOTO varaddr
        END IF
        t = cgaddr(car(cdr(r)))
        IF isptr(t) THEN
          IF tnodes(tnodes(t).subtyp).t = rectp THEN
            cout ("get." + siz$(t))
            t = tnodes(t).subtyp
          END IF
        END IF
        IF tnodes(t).t = rectp THEN
          e = tnodes(t).elems
          n = -car(cdr(cdr(r)))
          DO WHILE e
            IF syms(e).id = n THEN EXIT DO
            e = syms(e).succ
          LOOP
          IF e = 0 THEN
            terror ("ffield " + names$(n) + " not in record")
          END IF
          cout ("add.a   " + LTRIM$(STR$(syms(e).offs)) + " ; ." + names$(n))
          t = syms(e).typ
        ELSE
          prtype (t)
          terror (" no record in select")
        END IF
      CASE ELSE
        terror ("scgaddr: bad node " + names$(-car(r)))
        pptree (r)
      END SELECT
    ELSE
      terror ("scgaddr: list node")
      pptree (r)
    END IF
  ELSEIF r < 0 THEN
    v = findvar(-r)
varaddr:
    t = syms(v).typ
    IF syms(v).ref = 4 THEN
      terror ("fconstants have no address")
    ELSE
      cout ("lea     " + addr$(v) + " ; " + strlist$("", r))
    END IF
  ELSE
    terror ("scgaddr: no expr")
  END IF
  cgaddr = t
END FUNCTION

SUB cgconstdecl (r)
  t = r
  DO WHILE t > 0
    vl = car(car(t))
    tp = car(cdr(car(t)))
    v = evalconst(tp)
    z = addvar(-vl, inttp, 4)
    syms(z).offs = v
    t = cdr(t)
  LOOP
END SUB

SUB cgen (r)
  SHARED currfunctype, currretlbl$, currsymtab, ilopen, nunit, unit$, cmod$, neu
REM  PRINT "cgen(" + fnpn$(r) + ")"
REM  remout ("           " + strlist$("", r))
  IF r = 0 THEN EXIT SUB
  IF r > 0 THEN
    IF car(r) < 0 THEN
      SELECT CASE names$(-car(r))
      CASE "import"
        x = cdr(r)
        PRINT "   Import(";
        DO WHILE x > 0
          PRINT names$(-car(x));
          readimp (names$(-car(x)))
          x = cdr(x)
          IF x > 0 THEN
            PRINT ",";
          ELSE
            PRINT ")"
          END IF
        LOOP
      CASE "module"
        nn$ = names$(-car(cdr(r)))
        PRINT "  Module (" + nn$ + ")"
        PRINT #4, unit$, nn$
        cmod$ = nn$
        addfname (nn$)
        OPEN nn$ + ".il" FOR OUTPUT AS #9
        modreset
        ilopen = 1
        addscope (6)
        symtabs(currsymtab).modname = -car(cdr(r))
        cout ("module  " + nn$)
        cgen (car(cdr(cdr(r))))
        bssscope
        putstrings
        cout ("endm    " + nn$)
        remscope
        ilopen = 0
        CLOSE #9
      CASE "program"
        unitn$ = pfname$(unit$, nunit)
        PRINT "  Program (" + unitn$ + ")"
        nunit = nunit + 1
        cmod$ = "$" + unitn$
        PRINT #4, unit$, cmod$
        addfname (unitn$)
        modreset
        OPEN unitn$ + ".il" FOR OUTPUT AS #9
        ilopen = 1
        addscope (6)
        symtabs(currsymtab).modname = -mkstr("")
        IF neu THEN
        ELSE
          cout ("include  nlib.i")
        END IF
        cout ("module  0")
        cgen (car(cdr(r)))
        bssscope
        putstrings
        cout ("endm    0")
        scopeincls
        remscope
        IF neu THEN
        ELSE
          cout ("end")
        END IF
        ilopen = 0
        CLOSE #9
      CASE "block", "blk"
        addscope (999)
        x = cdr(r)
        DO WHILE x > 0
          IF car(x) > 0 THEN
            IF fnpn$(car(car(x))) = "type" THEN
              cgpreptype (cdr(car(x)))
            END IF
          END IF
          x = cdr(x)
        LOOP
        x = cdr(r)
        DO WHILE x > 0
          cgen (car(x))
          x = cdr(x)
        LOOP
        bssscope
        remscope
      CASE "stmts"
        x = cdr(r)
        DO WHILE x > 0
          cgen (car(x))
          x = cdr(x)
        LOOP
      CASE "function"
        cgfunction (cdr(r))
      CASE "var"
        cgvardecl (cdr(r))
      CASE "const"
        cgconstdecl (cdr(r))
      CASE "type"
        cgtypedecl (cdr(r))
      CASE "expr"
        t = cgexpr(car(cdr(r)))
        IF tnodes(t).t <> voidtp THEN
          pptree (r)
          terror (" expr has result type <> void")
        END IF
      CASE "for"
        la$ = mklbl$
        lb$ = mklbl$
        lc$ = mklbl$
        IF car(cdr(r)) THEN
          t = cgexpr(car(cdr(r)))
          IF tnodes(t).t <> voidtp THEN
            terror (" for: init expr has result type <> void")
          END IF
        END IF
        lout (la$)
        IF car(cdr(cdr(r))) THEN
          z = cgtest(car(cdr(cdr(r))), lb$, lc$)
        ELSE
          cout ("jmp " + lb$)
        END IF
        lout (lb$)
        cgen (car(cdr(cdr(cdr(cdr(r))))))
        IF car(cdr(cdr(cdr(r)))) THEN
          t = cgexpr(car(cdr(cdr(cdr(r)))))
          IF tnodes(t).t <> voidtp THEN
            terror (" for: step expr has result type <> void")
          END IF
        END IF
        cout ("jmp " + la$)
        lout (lc$)
      CASE "while"
        la$ = mklbl$
        lb$ = mklbl$
        lc$ = mklbl$
        lout (la$)
        z = cgtest(car(cdr(r)), lb$, lc$)
        lout (lb$)
        cgen (car(cdr(cdr(r))))
        cout ("jmp " + la$)
        lout (lc$)
      CASE "if"
        la$ = mklbl$
        lc$ = mklbl$
        z = cgtest(car(cdr(r)), lc$, la$)
        lout (lc$)
        cgen (car(cdr(cdr(r))))
        IF cdr(cdr(cdr(r))) THEN
          lb$ = mklbl$
          cout ("jmp " + lb$)
          lout (la$)
          cgen (car(cdr(cdr(cdr(r)))))
          lout (lb$)
        ELSE
          lout (la$)
        END IF
      CASE "return"
        IF cdr(r) THEN
          t = cgexpr(car(cdr(r)))
        ELSE
          t = voidtp
        END IF
        IF tnodes(t).t <> voidtp THEN
          t = fitsize(t, currfunctype)
REM          IF NOT sametype(t, currfunctype) THEN
REM            prtype (currfunctype)
REM            prtype (t)
REM            terror ("fbad return value type")
REM          END IF
        ELSE
          IF tnodes(currfunctype).t <> voidtp THEN
            terror ("return not void")
          END IF
        END IF
        cout ("jmp " + currretlbl$)
      CASE ELSE
        terror ("scgen: bad node " + names$(-car(r)))
        pptree (r)
      END SELECT
    ELSE
      terror ("scgen: list node")
      pptree (r)
    END IF
  ELSE
    terror ("scgen: no list")
  END IF
END SUB

FUNCTION cgexpr (r)
REM  PRINT "cgexpr(" + fnpn$(r) + ")"
  t = 0
  IF r > 0 THEN
    IF car(r) < 0 THEN
      SELECT CASE names$(-car(r))
      CASE "<", ">", "<=", ">=", "<>", "="
        t = inttp
        la$ = mklbl$
        lb$ = mklbl$
        lc$ = mklbl$
        z = cgtest(r, la$, lb$)
        lout (la$)
        cout ("imm." + siz$(t) + "   1")
        cout ("jmp " + lc$)
        lout (lb$)
        cout ("imm." + siz$(t) + "   0")
        lout (lc$)
      CASE "group"
        t = cgexpr(car(cdr(r)))
      CASE "nil"
        cout ("imm." + siz$(niltp) + "   0")
        t = niltp
      CASE "addrof"
        t = cgaddr(car(cdr(r)))
        t = newreftnode(t)
      CASE "neg"
        t = cgexpr(car(cdr(r)))
        IF NOT isnum(t) THEN terror (" nonnumeric in -expr")
        cout ("neg." + siz$(t))
      CASE ":="
        l = cgaddr(car(cdr(r)))
        t = cgexpr(car(cdr(cdr(r))))
        t = fitsize(t, l)
        cout ("store." + siz$(t))
        t = voidtp
      CASE "and"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("and", t, u)
      CASE "or"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("or", t, u)
      CASE "+"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("add", t, u)
      CASE "-"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("sub", t, u)
      CASE "*"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("mul", t, u)
      CASE "/"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("div", t, u)
      CASE "mod"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("mod", t, u)
      CASE "val"
        t = inttp
        cout ("imm." + siz$(t) + "   " + names$(-car(cdr(r))))
      CASE "strval"
        t = newvectnode(chartp, LEN(names$(-car(cdr(r)))))
        cout ("lea     s." + straddr$(car(cdr(r))))
        t = vectoref(t)
      CASE "array"
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("add", t, u)
        IF NOT tnodes(t).t = reftp THEN
          prtype (t)
          terror ("fbad type for deref")
        END IF
        t = tnodes(t).subtyp
        t = getorref(t)
      CASE "deref"
        t = cgexpr(car(cdr(r)))
        IF NOT tnodes(t).t = reftp THEN
          prtype (t)
          terror ("fbad type for deref")
        END IF
        t = tnodes(t).subtyp
        t = getorref(t)
        REM cout ("get." + siz$(t))
      CASE "select"
        IF car(cdr(r)) < 0 AND car(cdr(cdr(r))) < 0 THEN
          v = findmodvar(-car(cdr(cdr(r))), -car(cdr(r)))
          IF v >= 0 THEN GOTO varexpr
        END IF
        t = cgaddr(r)
        t = getorref(t)
      CASE "fcall"
        h = cdr(cdr(r))
        cout ("fparbeg")
        DO WHILE h
          t = cgexpr(car(h))
          cout ("fparam." + siz$(t))
          h = cdr(h)
        LOOP
        t = cgaddr(car(cdr(r)))
        IF tnodes(t).t = functp THEN
          t = tnodes(t).subtyp
          IF tnodes(t).t = voidtp THEN
            cout ("fcall")
          ELSE
            cout ("fcall." + siz$(t))
          END IF
        ELSE
          terror (" no function in call")
        END IF
      CASE "new"
        t = gentype(car(cdr(r)))
        cout ("alloc   " + siz$(t))
        t = newreftnode(t)
      CASE ELSE
        terror ("scgexpr: bad node " + names$(-car(r)))
        pptree (r)
      END SELECT
    ELSE
      terror ("scgexpr: list node")
      pptree (r)
    END IF
  ELSEIF r < 0 THEN
    v = findvar(-r)
varexpr:
    t = syms(v).typ
    IF syms(v).ref = 4 THEN
      REM a constant
      IF tnodes(t).t <> inttp THEN STOP
      cout ("imm." + siz$(t) + "  " + STR$(syms(v).offs))
    ELSE
      IF tnodes(t).t = vectp THEN
        t = vectoref(t)
        cout ("lea     " + addr$(v) + " ; " + strlist$("", r))
      ELSE
        cout ("load." + siz$(t) + "  " + addr$(v) + " ; " + strlist$("", r))
      END IF
    END IF
  ELSE
    pptree (r)
    terror ("scgexpr: no expr")
    STOP
  END IF
  cgexpr = t
END FUNCTION

SUB cgfunction (r)
  SHARED currfunctype, currretlbl$, currlocsize, currfuncname$, cmod$, unit$
  lft = currfunctype
  lfn$ = currfuncname$
  lcr$ = currretlbl$
  lls = currlocsize
  currfunctype = gentype(car(cdr(r)))
REM  PRINT "cft=", currfunctype
  t = newtnode
  tnodes(t).t = functp
  tnodes(t).subtyp = currfunctype
  tnodes(t).elems = parlist(car(cdr(cdr(r))))
  z = findlocvar(-car(r))
  currfuncname$ = names$(-car(r))
PRINT "   Function("; currfuncname$; ")"
  IF z > 0 THEN
    IF sametype(syms(z).typ, t) = 0 THEN
      terror (" declarations of " + names$(-car(r)) + " not of same type")
    END IF
  ELSE
    z = addvar(-car(r), t, 3)
    PRINT #4, unit$, cmod$; "."; currfuncname$
  END IF
  REM patch to label
  REM syms(z).offs = -car(r)
  IF cdr(cdr(cdr(r))) THEN
    REM code there, generate
    currretlbl$ = mklbl$
    sl$ = mklbl$
    cout ("proc    " + names$(-car(r)) + "," + sl$)
    addscope (2)
    REM reserve place for return address and old frame ptr
    z = addvar(-mkstr(".bp"), inttp, 0)
    z = addvar(-mkstr(".ret"), inttp, 0)
    cgvardecl (car(cdr(cdr(r))))
    cgen (car(cdr(cdr(cdr(r)))))
    remscope
    lout (currretlbl$)
    IF tnodes(currfunctype).t = voidtp THEN
      cout ("ret")
    ELSE
      cout ("ret." + siz$(currfunctype))
    END IF
    cout ("set     " + sl$ + "," + LTRIM$(STR$(-currlocsize)))
    cout ("endp    " + names$(-car(r)))
  END IF
  currlocsize = lls
  currfuncname$ = lfn$
  currfunctype = lft
  currretlbl$ = lcr$
END SUB

SUB cgpreptype (r)
  REM prepare a type entry
  x = r
  DO WHILE x > 0
    z = addtype(-car(car(x)), 0)
    x = cdr(x)
  LOOP
END SUB

FUNCTION cgtest (r, w$, f$)
  IF r > 0 THEN
    IF car(r) < 0 THEN
      c$ = ""
      SELECT CASE names$(-car(r))
      CASE "<="
        c$ = "le"
        d$ = "be"
      CASE "="
        c$ = "e "
        d$ = "e "
      CASE ">="
        c$ = "ge"
        d$ = "ae"
      CASE "<"
        c$ = "l "
        d$ = "b "
      CASE ">"
        c$ = "g "
        d$ = "a "
      CASE "<>"
        c$ = "ne"
        d$ = "ne"
      END SELECT
      IF c$ <> "" THEN
        t = cgexpr(car(cdr(cdr(r))))
        u = cgexpr(car(cdr(r)))
        t = mkop("cmp", t, u)
        IF isunsigned(t) OR isptr(t) THEN c$ = d$
        cout ("jmp." + c$ + "      " + w$)
        cout ("jmp     " + f$)
        cgtest = 0
        EXIT FUNCTION
      END IF
    END IF
  END IF
  t = cgexpr(r)
  IF isbool(t) OR isnum(t) OR isptr(t) THEN
    cout ("test." + siz$(t))
  ELSE
    terror (" test: no value")
  END IF
  cout ("jmp.nz      " + w$)
  cout ("jmp     " + f$)
  REM Bl”des Qbasic
  cgtest = 0
END FUNCTION

SUB cgtypedecl (r)
  REM make a type entry
  x = r
  DO WHILE x > 0
    z = addtype(-car(car(x)), gentype(car(cdr(car(x)))))
    x = cdr(x)
  LOOP
END SUB

SUB cgvardecl (r)
  t = r
  DO WHILE t > 0
    vl = car(car(t))
    tp = gentype(car(cdr(car(t))))
    DO WHILE vl > 0
      z = addvar(-car(vl), tp, 0)
      vl = cdr(vl)
    LOOP
    t = cdr(t)
  LOOP
END SUB

SUB checktok (t$)
SHARED currtok$, currname$
  IF currtok$ = t$ THEN
  gettok
  ELSE
    terror (" expected " + t$ + " instead of " + currtok$)
    gettok
  END IF
END SUB

FUNCTION cons (r, l)
  SHARED cellcnt
  cellcnt = cellcnt + 1
  car(cellcnt) = r
  cdr(cellcnt) = l
REM  PRINT cellcnt; ": ("; fnpn$(r); ";"; fnpn$(l); ")"
  cons = cellcnt
END FUNCTION

SUB cout (t$)
  machout ("        " + t$)
END SUB

FUNCTION evalconst (q)
  IF q > 0 THEN
    IF car(q) < 0 THEN
      SELECT CASE names$(-car(q))
      CASE "neg"
        h = -evalconst(car(cdr(q)))
      CASE "val"
        h = VAL(names$(-car(cdr(q))))
      CASE "*"
        h = evalconst(car(cdr(q))) * evalconst(car(cdr(cdr(q))))
      CASE "+"
        h = evalconst(car(cdr(q))) + evalconst(car(cdr(cdr(q))))
      CASE ELSE
        terror ("fevalconst: bad node " + names$(-car(q)))
        h = 0
      END SELECT
      evalconst = h
      EXIT FUNCTION
    END IF
  ELSEIF q < 0 THEN
    v = findvar(-q)
    t = syms(v).typ
    IF syms(v).ref = 4 THEN
      h = syms(v).offs
      evalconst = h
      EXIT FUNCTION
    END IF
  END IF
  pptree (q)
  terror ("fevalconst: bad constant")
  evalconst = 0
END FUNCTION

FUNCTION existnfile (a$)
  p = INSTR(a$, ":")
  IF p THEN
    b$ = LEFT$(a$, p - 1)
  ELSE
    b$ = a$
  END IF
  b$ = UCASE$(b$) + SPACE$(8 - LEN(b$))
REM  PRINT "existfile " + a$ + " -" + b$ + "-"
  FOR i = 1 TO ndirs
    IF ndirn$(i) = "" THEN
      existnfile = 0
      EXIT FUNCTION
    END IF
    IF LEFT$(ndirn$(i), 8) = b$ THEN
      existnfile = -1
      EXIT FUNCTION
    END IF
  NEXT
  existnfile = 0
END FUNCTION

FUNCTION extsu$ (t)
  IF isunsigned(t) THEN
    extsu$ = "extu"
  ELSE
    extsu$ = "exts"
  END IF
END FUNCTION

FUNCTION findlocvar (p)
  SHARED currsymtab
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
    IF syms(x).id = p THEN
      findlocvar = x
      EXIT FUNCTION
    END IF
    x = syms(x).succ
  LOOP
  findlocvar = 0
END FUNCTION

FUNCTION findmodtype (r, m)
  SHARED currsymtab
REM  PRINT "findmodtype (" + names$(r) + ", " + names$(m) + ")"
  s = currsymtab
  DO WHILE s > 0
    q = symtabs(s).modules
    DO WHILE q > 0
      IF symtabs(q).modname = m THEN
        p = symtabs(q).types
        DO WHILE p > 0
          IF typs(p).id = r THEN
            findmodtype = p
            EXIT FUNCTION
          END IF
          p = typs(p).succ
        LOOP
        terror ("ftype " + names$(r) + " in module " + names$(m) + " not found")
        findmodtype = 0
        EXIT FUNCTION
      END IF
      q = symtabs(q).succ
    LOOP
    s = symtabs(s).succ
  LOOP
  terror ("fmodule " + names$(m) + " not found")
  findmodtype = 0
END FUNCTION

FUNCTION findmodvar (r, m)
  SHARED currsymtab
REM  PRINT "findmodvar (" + names$(r) + ", " + names$(m) + ")"
  s = currsymtab
  DO WHILE s > 0
    q = symtabs(s).modules
    DO WHILE q > 0
      IF symtabs(q).modname = m THEN
        p = symtabs(q).vars
        DO WHILE p > 0
          IF syms(p).id = r THEN
            findmodvar = p
            EXIT FUNCTION
          END IF
          p = syms(p).succ
        LOOP
        terror ("fvar " + names$(r) + " in module " + names$(m) + " not found")
        findmodvar = 0
        EXIT FUNCTION
      END IF
      q = symtabs(q).succ
    LOOP
    s = symtabs(s).succ
  LOOP
  findmodvar = -1
END FUNCTION

FUNCTION findtype (r)
  SHARED currsymtab
  s = currsymtab
  DO WHILE s > 0
    p = symtabs(s).types
    DO WHILE p > 0
      IF typs(p).id = r THEN
        findtype = p
        EXIT FUNCTION
      END IF
      p = typs(p).succ
    LOOP
    s = symtabs(s).succ
  LOOP
  terror ("ftype " + names$(r) + " not found")
  findtype = 0
END FUNCTION

FUNCTION findvar (r)
  SHARED currsymtab
  s = currsymtab
  DO WHILE s > 0
    p = symtabs(s).vars
    DO WHILE p > 0
      IF syms(p).id = r THEN
        findvar = p
        EXIT FUNCTION
      END IF
      p = syms(p).succ
    LOOP
    s = symtabs(s).succ
  LOOP
  s = currsymtab
  DO WHILE s > 0
    q = symtabs(s).modules
    pp = 0
    DO WHILE q > 0
      p = symtabs(q).vars
      DO WHILE p > 0
        IF syms(p).id = r THEN
          IF pp THEN
            terror (" var " + names$(r) + " in more than one module found")
          ELSE
            pp = p
          END IF
        END IF
        p = syms(p).succ
      LOOP
      q = symtabs(q).succ
    LOOP
    IF pp THEN
      findvar = pp
      EXIT FUNCTION
    END IF
    s = symtabs(s).succ
  LOOP
  terror ("fvar " + names$(r) + " not found")
  findvar = 0
END FUNCTION

FUNCTION fitsize (t, m)
  REM convert size of tos (type t) to type m
REM  PRINT "fitsize"
REM  prtype (t)
REM  prtype (m)
  IF tnodes(m).t = reftp AND tnodes(t).t = niltp THEN
    fitsize = t
    EXIT FUNCTION
  END IF
  IF sametype(t, m) THEN
    fitsize = t
    EXIT FUNCTION
  END IF
REM  IF tnodes(t).t = vectp AND tnodes(m).t = reftp THEN
REM    IF sametype(tnodes(a).subtyp, tnodes(b).subtyp) THEN
REM      fitsize = t
REM      EXIT FUNCTION
REM    END IF
REM  END IF
  IF NOT isnum(t) OR NOT isnum(m) THEN
    prtype (t)
    prtype (m)
    terror ("ffitsize: nonnumeric types")
  END IF
  ts = sizeof(t)
  ms = sizeof(m)
  c$ = siz$(t) + "." + siz$(m)
  IF ts > ms THEN
    cout ("trunc." + c$)
    t = m
  ELSEIF ts < ms THEN
    IF isunsigned(t) THEN
      cout ("extu." + c$)
    ELSE
      cout ("exts." + c$)
    END IF
    t = m
  END IF
  fitsize = t
END FUNCTION

SUB forceunit (u$)
  SHARED units$
  IF INSTR("$" + units$ + "$", "$" + u$ + "$") = 0 THEN
    units$ = units$ + "$" + u$
REM    PRINT "forceunit new "; u$; " "; units$
  ELSE
REM    PRINT "forceunit old "; u$; " "; units$
  END IF
END SUB

SUB fptree (x)
  DIM ind(20)
  DIM p(20)
  DIM rc(20)
  DIM mc(20)
  ci = 0
  l = 1
  ind(l) = 0
  p(l) = x
  rc(l) = 1
  mc(1) = 0
  IF x < 0 THEN
    PRINT #9, names$(-x)
    ci = ci + LEN(names$(-x))
  ELSE
    DO WHILE l > 0
      IF mc(l) = 0 THEN
        PRINT #9, "(";
        ci = ci + 1
        h = 1
        IF ltn(p(l), 75 - ci) = 0 THEN
          rc(l) = -1
          IF p(l) > 0 THEN
            IF car(p(l)) < 0 THEN
              SELECT CASE names$(-car(p(l)))
              CASE "var", "type", "if", "module"
                rc(l) = 2
              END SELECT
            END IF
          END IF
        ELSEIF p(l) > 0 THEN
          IF car(p(l)) < 0 THEN
            h = LEN(names$(-car(p(l)))) + 2
            IF INSTR("abcdefghijklmnopqrstuvwxyz", LEFT$(names$(-car(p(l))), 1)) THEN
              rc(l) = 2
            END IF
          ELSE
            IF ltn(car(p(l)), 75 - ci) THEN
              ind(l) = ci + 2
              rc(l) = 0
            ELSE
              rc(l) = -1
            END IF
          END IF
        END IF
      END IF
      IF l < 7 AND mc(l) > -1 AND rc(l) = 0 AND NOT p(l) = 0 THEN
        PRINT #9,
        PRINT #9, SPACE$(ind(l));
        ci = ind(l)
      ELSE
        IF mc(l) > 0 AND NOT p(l) = 0 THEN
          PRINT #9, " ";
          ci = ci + 1
        END IF
        ind(l) = ci
      END IF
      IF NOT rc(l) = 0 THEN rc(l) = rc(l) - 1
      IF p(l) = 0 THEN
        PRINT #9, ")";
        ci = ci + 1
        l = l - 1
      ELSEIF p(l) < 0 THEN
        PRINT #9, "."; names$(-p(l)); ")";
        ci = ci + 2 + LEN(names$(-p(l)))
        l = l - 1
      ELSE
        mc(l) = mc(l) + 1
        IF car(p(l)) < 0 THEN
          PRINT #9, names$(-car(p(l)));
          ci = ci + LEN(names$(-car(p(l))))
          p(l) = cdr(p(l))
        ELSE
          l = l + 1
          ind(l) = ind(l - 1)
          p(l) = car(p(l - 1))
          p(l - 1) = cdr(p(l - 1))
          mc(l) = 0
          rc(l) = -1
        END IF
      END IF
    LOOP
    PRINT #9,
  END IF
END SUB

FUNCTION gentype (r)
  REM make a type from a syntax list
  s = 0
  SELECT CASE fnpn$(car(r))
  CASE "enum"
    terror ("senum handled badly")
    s = inttp
  CASE "void"
    s = voidtp
  CASE "int"
    s = inttp
  CASE "uint"
    s = uinttp
  CASE "char"
    s = chartp
  CASE "uchar"
    s = uchartp
  CASE "ref"
    s = newreftnode(gentype(car(cdr(r))))
  CASE "vector"
    t = gentype(car(cdr(cdr(r))))
    q = car(cdr(r))
    s = 0
    h = evalconst(q)
    IF h < 1 OR h > 20000 THEN
      terror ("fbad array dimension")
    END IF
    s = newvectnode(t, h)
  CASE "name"
    IF cdr(cdr(r)) THEN
      t = findmodtype(-car(cdr(cdr(r))), -car(cdr(r)))
    ELSE
      t = findtype(-car(cdr(r)))
    END IF
    IF t THEN
      s = typs(t).typ
      IF s = 0 THEN
        s = newtnode
        typs(t).typ = s
        tnodes(s).t = undeftp
      END IF
    END IF
  CASE "record"
    offs = 0
    sl = 0
    l = cdr(r)
    DO WHILE l > 0
      t = gentype(car(cdr(car(l))))
      IF tnodes(t).t = undeftp THEN
        terror ("sundefined type in record")
      END IF
      m = car(car(l))
      DO WHILE m > 0
        sl = newsym(-car(m), sl, t)
        syms(sl).offs = offs
        offs = offs + sizeof(t)
        m = cdr(m)
      LOOP
      l = cdr(l)
    LOOP
    s = newtnode
    tnodes(s).size = offs
    tnodes(s).t = rectp
    DO WHILE sl
      h = sl
      sl = syms(h).succ
      syms(h).succ = tnodes(s).elems
      tnodes(s).elems = h
    LOOP
  END SELECT
  IF s = 0 THEN
    pptree (r)
    STOP
  END IF
  gentype = s
END FUNCTION

FUNCTION getorref (t)
  IF tnodes(t).t = vectp THEN
    getorref = vectoref(t)
  ELSE
    cout ("get." + siz$(t))
    getorref = t
  END IF
END FUNCTION

SUB gettok
SHARED cline$, currtok$, currname$, cellcnt, tokcnt, blklvl, pon, killil, kills
  tokcnt = tokcnt + 1
  currtok$ = ""
  idset$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz_"
  WHILE LEN(cline$) > 0 OR NOT EOF(1)
    IF LEN(cline$) = 0 THEN
      LINE INPUT #1, cline$
      IF pon THEN PRINT USING "#### # [&]"; cellcnt; blklvl; cline$
    ELSE
      fc$ = LEFT$(cline$, 1)
      cline$ = MID$(cline$, 2)
      IF fc$ = " " OR fc$ = CHR$(9) THEN
      ELSEIF fc$ = "%" THEN
        IF LEN(cline$) > 2 THEN
          SELECT CASE LEFT$(cline$, 3)
          CASE "$p+"
            pon = -1
          CASE "$p-"
            pon = 0
          CASE "$s+"
            kills = 0
          CASE "$i+"
            killil = 0
          CASE "$s-"
            kills = -1
          CASE "$i-"
            killil = -1
          END SELECT
        END IF
        cline$ = ""
      ELSEIF fc$ = "-" AND LEFT$(cline$, 1) = "-" THEN
        cline$ = ""
      ELSEIF INSTR(idset$, fc$) > 0 THEN
        x = 1
        idset$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz_0123456789"
        DO WHILE LEN(cline$) > x - 1
          IF INSTR(idset$, MID$(cline$, x, 1)) < 1 THEN EXIT DO
          x = x + 1
        LOOP
        IF (x > 1) THEN
          fc$ = fc$ + LEFT$(cline$, x - 1)
          cline$ = MID$(cline$, x)
        END IF
        SELECT CASE fc$
        CASE "begin", "end", "while", "if", "then", "else", "fi"
          currtok$ = fc$
        CASE "integer", "real", "bool", "string", "record", "array", "object"
          currtok$ = fc$
        CASE "function", "module", "ref", "char", "do", "return", "enum"
          currtok$ = fc$
        CASE "type", "var", "new", "delete", "nil", "and", "or", "not", "mod"
          currtok$ = fc$
        CASE "word", "byte", "vector", "of", "const", "for", "import"
          currtok$ = fc$
        CASE "program"
          currtok$ = fc$
        CASE ELSE
          currtok$ = "id"
          currname$ = fc$
        END SELECT
        EXIT SUB
      ELSEIF INSTR("0123456789", fc$) > 0 THEN
        x = 1
        DO WHILE LEN(cline$) > x - 1
          IF INSTR("0123456789", MID$(cline$, x, 1)) < 1 THEN EXIT DO
          x = x + 1
        LOOP
        IF (x > 1) THEN
          fc$ = fc$ + LEFT$(cline$, x - 1)
          cline$ = MID$(cline$, x)
        END IF
        currtok$ = "num"
        currname$ = fc$
        EXIT SUB
      ELSEIF fc$ = CHR$(34) THEN
        currname$ = ""
        cline$ = MID$(cline$, 1)
        DO WHILE LEN(cline$) > 0
          fc$ = LEFT$(cline$, 1)
          IF fc$ = "\" AND LEN(cline$) > 1 THEN
            fc$ = MID$(cline$, 2, 1)
            SELECT CASE fc$
            CASE "n"
              fc$ = CHR$(10)
            CASE "t"
              fc$ = CHR$(9)
            CASE "r"
              fc$ = CHR$(13)
            END SELECT
            cline$ = MID$(cline$, 3)
          ELSE
            cline$ = MID$(cline$, 2)
            IF fc$ = CHR$(34) THEN EXIT DO
          END IF
          currname$ = currname$ + fc$
        LOOP
        currname$ = currname$ + CHR$(0)
        currtok$ = "strval"
        EXIT SUB
      ELSEIF fc$ = "⋯ 伀刀 昀挀␀ 㴀 ∀✀∀ 吀䠀䔀一ഀ        挀甀爀爀渀愀洀攀␀ 㴀 ∀∀ഀ        挀氀椀渀攀␀ 㴀 䴀䤀䐀␀⠀挀氀椀渀攀␀Ⰰ ㄀⤀ഀ        䐀伀 圀䠀䤀䰀䔀 䰀䔀一⠀挀氀椀渀攀␀⤀ 㸀 　ഀ          昀挀␀ 㴀 䰀䔀䘀吀␀⠀挀氀椀渀攀␀Ⰰ ㄀⤀ഀ          䤀䘀 昀挀␀ 㴀 ∀尀∀ 䄀一䐀 䰀䔀一⠀挀氀椀渀攀␀⤀ 㸀 ㄀ 吀䠀䔀一ഀ            昀挀␀ 㴀 䴀䤀䐀␀⠀挀氀椀渀攀␀Ⰰ ㈀Ⰰ ㄀⤀ഀ            匀䔀䰀䔀䌀吀 䌀䄀匀䔀 昀挀␀ഀ            䌀䄀匀䔀 ∀渀∀ഀ              昀挀␀ 㴀 䌀䠀刀␀⠀㄀　⤀ഀ            䌀䄀匀䔀 ∀琀∀ഀ              昀挀␀ 㴀 䌀䠀刀␀⠀㤀⤀ഀ            䌀䄀匀䔀 ∀爀∀ഀ              昀挀␀ 㴀 䌀䠀刀␀⠀㄀㌀⤀ഀ            䔀一䐀 匀䔀䰀䔀䌀吀ഀ            挀氀椀渀攀␀ 㴀 䴀䤀䐀␀⠀挀氀椀渀攀␀Ⰰ ㌀⤀ഀ          䔀䰀匀䔀ഀ            挀氀椀渀攀␀ 㴀 䴀䤀䐀␀⠀挀氀椀渀攀␀Ⰰ ㈀⤀ഀ            䤀䘀 昀挀␀ 㴀 ∀" OR fc$ = "'" THEN EXIT DO
          END IF
          currname$ = currname$ + fc$
        LOOP
        IF LEN(currname$) <> 1 THEN
          terror ("char const: bad length")
          currname$ = "0"
        ELSE
          currname$ = LTRIM$(STR$(ASC(currname$)))
        END IF
        currtok$ = "num"
        EXIT SUB
      ELSE
        IF LEN(cline$) > 0 THEN
          nfc$ = fc$ + LEFT$(cline$, 1)
          SELECT CASE nfc$
          CASE ":=", "<=", ">=", "<>", "@=", "+=", "-="
            fc$ = nfc$
            cline$ = MID$(cline$, 2)
          END SELECT
        END IF
        currtok$ = fc$
        EXIT SUB
      END IF
    END IF
  WEND
  currtok$ = "$$"
  tokcnt = tokcnt - 1
END SUB

FUNCTION getword$
  SHARED wordl$
  x = INSTR(wordl$, " ")
  IF x = 0 THEN
    w$ = wordl$
    wordl$ = ""
  ELSE
    w$ = LEFT$(wordl$, x - 1)
    setword (MID$(wordl$, x + 1))
  END IF
  getword$ = w$
END FUNCTION

FUNCTION haswords
  SHARED wordl$
  haswords = (wordl$ <> "")
END FUNCTION

FUNCTION ignb$ (l$)
  DO WHILE LEFT$(l$, 1) = " "
    l$ = MID$(l$, 2)
  LOOP
  ignb$ = l$
END FUNCTION

FUNCTION isbool (t)
  REM numeric type?
  r = 0
  SELECT CASE tnodes(t).t
  CASE booltp
    r = -1
  END SELECT
  isbool = r
END FUNCTION

FUNCTION isleamov (t$)
  isleamov = (t$ = "lea" OR t$ = "mov.w")
END FUNCTION

FUNCTION isleamovas (t$)
  isleamovas = (t$ = "lea" OR t$ = "mov.w" OR t$ = "add.w" OR t$ = "sub.w")
END FUNCTION

FUNCTION isnum (t)
  REM numeric type?
  r = 0
  SELECT CASE tnodes(t).t
  CASE chartp, inttp, uchartp, uinttp
    r = -1
  END SELECT
  isnum = r
END FUNCTION

FUNCTION isnumstr (t$)
  FOR i = 1 TO LEN(t$)
    IF INSTR("0123456789", MID$(t$, i, 1)) < 1 THEN
      isnumstr = 0
      EXIT FUNCTION
    END IF
  NEXT
  isnumstr = -1
END FUNCTION

FUNCTION isptr (t)
  REM pointer type?
  r = 0
  SELECT CASE tnodes(t).t
  CASE reftp, niltp
    r = -1
  END SELECT
  isptr = r
END FUNCTION

FUNCTION isunsigned (t)
  REM unsigned type?
  r = 0
  SELECT CASE tnodes(t).t
  CASE uchartp, uinttp
    r = -1
  END SELECT
  isunsigned = r
END FUNCTION

SUB lout (t$)
  machout (t$ + ":")
END SUB

FUNCTION ltn (a, l)
  REM a longer than l chars
  IF plen(a) > l THEN
    ltn = 1
  ELSE
    ltn = 0
  END IF
END FUNCTION

SUB machout (t$)
  SHARED olcnt, ilopen
  olcnt = olcnt + 1
REM  PRINT olcnt; ":", t$
  IF ilopen THEN
    PRINT #9, t$
  ELSE
    l$ = LTRIM$(t$)
    IF LEN(l$) THEN
      IF LEFT$(l$, 1) <> ";" THEN
        PRINT "::::: "; t$
      END IF
    END IF
  END IF
END SUB

FUNCTION mcode (m$, r, l)
  IF NOT l = 0 THEN
    x = cons(l, 0)
  ELSE
    x = 0
  END IF
  mcode = cons(mkstr(m$), cons(r, x))
END FUNCTION

SUB mka86
END SUB

FUNCTION mklbl$
  STATIC lcnt
  lcnt = lcnt + 1
  mklbl$ = "L" + LTRIM$(STR$(lcnt))
END FUNCTION

FUNCTION mkop (o$, aa, bb)
  a = aa
  b = bb
  IF isnum(a) AND isnum(b) THEN
  ELSEIF o$ = "add" AND isnum(a) AND isptr(b) THEN
    t = b
    IF sizeof(a) > sizeof(t) THEN STOP
    IF sizeof(a) < sizeof(t) OR sizeof(tnodes(t).subtyp) <> 1 THEN
      cout ("swap." + siz$(t) + "." + siz$(a))
      IF sizeof(a) < sizeof(t) THEN
        cout (extsu$(a) + "." + siz$(a) + "." + siz$(t))
      END IF
      IF sizeof(tnodes(t).subtyp) <> 1 THEN
        cout ("mul." + siz$(t) + " " + siz$(tnodes(t).subtyp))
      END IF
      cout ("swap." + siz$(t) + "." + siz$(t))
    END IF
    cout (o$ + "." + siz$(t))
    mkop = t
    EXIT FUNCTION
  ELSEIF o$ = "sub" AND isptr(a) AND isptr(b) THEN
    t = inttp
    STOP
  ELSEIF o$ = "cmp" AND isptr(a) AND isptr(b) THEN
    IF NOT tnodes(a).t = niltp AND NOT tnodes(b).t = niltp AND NOT sametype(a, b) THEN
      terror ("fincomp ref types in mkop(" + o$ + ")")
    END IF
    cout (o$ + "." + siz$(a))
    t = a
REM  t = voidtp
REM  Der Typ ist falsch, aber leider wird er gebraucht fr int/uint
    mkop = t
    EXIT FUNCTION
  ELSE
    prtype (a)
    prtype (b)
    terror ("fnonnums in mkop(" + o$ + ")")
  END IF
  rs = tnodes(inttp).size
  IF sizeof(a) > rs THEN STOP
  IF sizeof(b) > rs THEN STOP
  xt = inttp
  IF isunsigned(a) OR isunsigned(b) THEN xt = uinttp
  IF sizeof(b) < rs THEN
    cout (extsu$(b) + "." + siz$(b) + "." + siz$(xt))
  END IF
  IF sizeof(a) < rs THEN
    cout ("swap." + siz$(xt) + "." + siz$(a))
    cout (extsu$(a) + "." + siz$(a) + "." + siz$(xt))
    cout ("swap." + siz$(xt) + "." + siz$(xt))
  END IF
  IF isunsigned(xt) THEN
    SELECT CASE o$
    CASE "mul", "div"
      o$ = o$ + "u"
    END SELECT
  END IF
  cout (o$ + "." + siz$(xt))
  t = xt
REM  IF o$ = "cmp" THEN t = voidtp
REM  Der Typ ist falsch, aber leider wird er gebraucht fr int/uint
  mkop = t
  REM type are not handled correctly
END FUNCTION

FUNCTION mkstr (m$)
  SHARED namecnt
  FOR i = 1 TO namecnt
    IF names$(i) = m$ THEN
      mkstr = -i
      EXIT FUNCTION
    END IF
  NEXT
  namecnt = namecnt + 1
  names$(namecnt) = m$
  nametag(namecnt) = 0
  mkstr = -namecnt
END FUNCTION

SUB modreset
  SHARED modncnt
  modncnt = 0
END SUB

FUNCTION myhex$ (h, l)
  t$ = HEX$(h)
  DO WHILE LEN(t$) < l
    t$ = "0" + t$
  LOOP
  myhex$ = t$
END FUNCTION

FUNCTION newreftnode (t)
  s = newtnode
  tnodes(s).size = 2
  tnodes(s).t = reftp
  tnodes(s).subtyp = t
  newreftnode = s
END FUNCTION

FUNCTION newsym (p, s, t)
  SHARED symcnt
  symcnt = symcnt + 1
  syms(symcnt).succ = s
  syms(symcnt).id = p
  syms(symcnt).typ = t
  syms(symcnt).offs = 0
  newsym = symcnt
END FUNCTION

FUNCTION newtnode
  SHARED tnodecnt
  tnodecnt = tnodecnt + 1
  tnodes(tnodecnt).size = 0
  tnodes(tnodecnt).t = 0
  tnodes(tnodecnt).subtyp = 0
  tnodes(tnodecnt).elems = 0
  newtnode = tnodecnt
END FUNCTION

FUNCTION newtyp (p, s, t)
  SHARED typcnt
  typcnt = typcnt + 1
  typs(typcnt).succ = s
  typs(typcnt).id = p
  typs(typcnt).typ = t
  newtyp = typcnt
END FUNCTION

FUNCTION newvectnode (t, l)
  s = newtnode
  IF t = 0 OR t = undeftp THEN
    terror ("fundefined element type in vector")
  END IF
  tnodes(s).size = tnodes(t).size * l
  tnodes(s).elems = l
  tnodes(s).t = vectp
  tnodes(s).subtyp = t
  newvectnode = s
END FUNCTION

FUNCTION noregs (t$, r1$, r2$)
  noregs = (INSTR(t$, r1$) = 0 AND INSTR(t$, r2$) = 0)
END FUNCTION

FUNCTION parlist (r)
  l = 0
  t = r
  DO WHILE t > 0
    vl = car(car(t))
    tp = gentype(car(cdr(car(t))))
    DO WHILE vl > 0
      l = newtyp(-car(vl), l, tp)
      vl = cdr(vl)
    LOOP
    t = cdr(t)
  LOOP
  parlist = l
END FUNCTION

FUNCTION pblock (t$, b$)
  SHARED currtok$, currname$, blklvl
  blklvl = blklvl + 1
  gettok
  r = 0
  WHILE NOT currtok$ = t$ AND NOT currtok$ = "$$"
    SELECT CASE currtok$
    CASE "import"
      m = 0
      DO
        gettok
        IF currtok$ = "id" THEN
          m = cons(mkstr(currname$), m)
        END IF
        checktok ("id")
      LOOP WHILE currtok$ = ","
      l = cons(mkstr("import"), revl(m))
      r = cons(l, r)
      checktok (";")
    CASE "type"
      m = 0
      DO
        gettok
        l = ptypedecl
        m = cons(l, m)
      LOOP WHILE currtok$ = ","
      l = cons(mkstr("type"), revl(m))
      r = cons(l, r)
      checktok (";")
    CASE "var"
      m = 0
      DO
        gettok
        l = pvar
        m = cons(l, m)
      LOOP WHILE currtok$ = ","
      l = cons(mkstr("var"), revl(m))
      r = cons(l, r)
      checktok (";")
    CASE "const"
      m = 0
      DO
        gettok
        l = pconst
        m = cons(l, m)
      LOOP WHILE currtok$ = ","
      l = cons(mkstr("const"), revl(m))
      r = cons(l, r)
      checktok (";")
    CASE "function"
      gettok
      n$ = currname$
      checktok ("id")
      checktok ("(")
      l = 0
      y = 0
      IF NOT currtok$ = ")" THEN
        DO
          m = pvar
          l = cons(m, l)
          IF NOT currtok$ = "," THEN EXIT DO
          gettok
        LOOP
      END IF
      checktok (")")
      IF currtok$ = ":" THEN
        gettok
        y = ptype
      ELSE
        y = cons(mkstr("void"), 0)
      END IF
      IF currtok$ = "=" THEN
        gettok
        l = cons(y, cons(revl(l), cons(pstmt, 0)))
      ELSE
        l = cons(y, cons(revl(l), 0))
        checktok (";")
      END IF
      l = cons(mkstr("function"), cons(mkstr(n$), l))
      r = cons(l, r)
    CASE ELSE
      l = pstmt
      r = cons(l, r)
    END SELECT
  WEND
  checktok (t$)
  r = cons(mkstr(b$), revl(r))
  blklvl = blklvl - 1
  pblock = r
END FUNCTION

FUNCTION pconst
  SHARED currtok$, currname$
  h = 0
  IF currtok$ = "id" THEN
    h = mkstr(currname$)
  END IF
  checktok ("id")
  checktok ("=")
  t = pexpr
  r = cons(h, cons(t, 0))
  pconst = r
END FUNCTION

FUNCTION pexand
  SHARED currtok$, currname$
  r = pexrel
  WHILE currtok$ = "and"
    op$ = currtok$
    gettok
    l = pexrel
    r = mcode(op$, r, l)
  WEND
  pexand = r
END FUNCTION

FUNCTION pexpor
  SHARED currtok$, currname$
  r = pexand
  WHILE currtok$ = "or"
    op$ = currtok$
    gettok
    l = pexand
    r = mcode(op$, r, l)
  WEND
  pexpor = r
END FUNCTION

FUNCTION pexpr
  SHARED currtok$, currname$
  r = pexpor
  WHILE currtok$ = ":="
    op$ = currtok$
    gettok
    l = pexpor
    r = mcode(op$, r, l)
  WEND
  pexpr = r
END FUNCTION

FUNCTION pexrel
  SHARED currtok$, currname$
  IF currtok$ = "not" THEN
    gettok
    r = mcode("not", pexrel, 0)
  ELSE
    r = pexsum
    WHILE currtok$ = "<" OR currtok$ = ">" OR currtok$ = "<=" OR currtok$ = ">=" OR currtok$ = "<>" OR currtok$ = "="
      op$ = currtok$
      gettok
      l = pexsum
      r = mcode(op$, r, l)
    WEND
  END IF
  pexrel = r
END FUNCTION

FUNCTION pexsum
  SHARED currtok$, currname$
  r = pterm
  WHILE currtok$ = "+" OR currtok$ = "-"
    op$ = currtok$
    gettok
    l = pterm
    r = mcode(op$, r, l)
  WEND
  pexsum = r
END FUNCTION

FUNCTION pfactor
  SHARED currtok$, currname$
  IF currtok$ = "id" THEN
    r = mkstr(currname$)
    gettok
  ELSEIF currtok$ = "num" THEN
    r = mcode("val", mkstr(currname$), 0)
    gettok
  ELSEIF currtok$ = "strval" THEN
    r = mcode("strval", mkstr(currname$), 0)
    gettok
  ELSEIF currtok$ = "nil" THEN
    r = cons(mkstr("nil"), 0)
    gettok
  ELSEIF currtok$ = "new" THEN
    gettok
    t = ptype
    r = mcode("new", t, 0)
  ELSEIF currtok$ = "(" THEN
    gettok
    r = pexpr
    r = mcode("group", r, 0)
    checktok (")")
  ELSEIF currtok$ = "@" THEN
    gettok
    r = pfactor
    r = mcode("addrof", r, 0)
  ELSEIF currtok$ = "-" THEN
    gettok
    r = pfactor
    r = mcode("neg", r, 0)
  ELSE
    terror (" pfactor")
    r = 0
  END IF
  DO
    SELECT CASE currtok$
    CASE "@"
      r = mcode("deref", r, 0)
      gettok
    CASE "."
      gettok
      IF currtok$ = "id" THEN
        r = mcode("select", r, mkstr(currname$))
      END IF
      checktok ("id")
    CASE "["
      gettok
      r = mcode("array", r, pexpr)
      checktok ("]")
    CASE "("
      l = 0
      gettok
      IF NOT currtok$ = ")" THEN
        DO
          l = cons(pexpr, l)
          IF NOT currtok$ = "," THEN EXIT DO
          gettok
        LOOP
      END IF
      checktok (")")
      r = cons(mkstr("fcall"), cons(r, l))
      REM arglist is backwards on purpose
    CASE ELSE
      EXIT DO
    END SELECT
  LOOP
  pfactor = r
END FUNCTION

FUNCTION pfname$ (u$, n)
  IF n > 0 THEN
    nn$ = RTRIM$(LTRIM$(STR$(n)))
    pfname$ = LEFT$(u$, 8 - LEN(nn$)) + nn$
  ELSE
    pfname$ = u$
  END IF
END FUNCTION

FUNCTION plen (a)
  REM printable len of a
  l = 0
  x = a
  IF x < 0 THEN
    l = LEN(names$(-x))
  ELSEIF x = 0 THEN
    l = 3
  ELSE
    l = 1
    DO WHILE x > 0 AND l < 10000
      l = l + 2 + plen(car(x))
      x = cdr(x)
    LOOP
    IF x < 0 THEN
      l = l + 1 + LEN(names$(-x))
    END IF
  END IF
  plen = l
END FUNCTION

FUNCTION pname$ (r)
  o$ = ""
  c$ = names$(-r)
  idset$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmonpqrstuvwxyz0123456789_"
  FOR ii = 1 TO LEN(c$)
    j$ = MID$(c$, ii, 1)
    jj = ASC(j$)
    IF INSTR(idset$, j$) THEN
      o$ = o$ + CHR$(jj)
    ELSE
      o$ = o$ + "\" + RIGHT$("000" + LTRIM$(OCT$(jj)), 3)
    END IF
  NEXT
  pname$ = o$
END FUNCTION

SUB pptree (x)
  DIM ind(20)
  DIM p(20)
  DIM rc(20)
  DIM mc(20)
  ci = 0
  l = 1
  ind(l) = 0
  p(l) = x
  rc(l) = 1
  mc(1) = 0
  IF x < 0 THEN
    PRINT pname$(x)
    ci = ci + LEN(pname$(x))
  ELSE
    DO WHILE l > 0
      IF mc(l) = 0 THEN
        PRINT "(";
        ci = ci + 1
        h = 1
        IF ltn(p(l), 75 - ci) = 0 THEN
          rc(l) = -1
          IF p(l) > 0 THEN
            IF car(p(l)) < 0 THEN
              SELECT CASE names$(-car(p(l)))
              CASE "var", "type", "if", "module"
                rc(l) = 2
              END SELECT
            END IF
          END IF
        ELSEIF p(l) > 0 THEN
          IF car(p(l)) < 0 THEN
            h = LEN(names$(-car(p(l)))) + 2
            IF INSTR("abcdefghijklmnopqrstuvwxyz", LEFT$(names$(-car(p(l))), 1)) THEN
              rc(l) = 2
            END IF
          ELSE
            IF ltn(car(p(l)), 75 - ci) THEN
              ind(l) = ci + 2
              rc(l) = 0
            ELSE
              rc(l) = -1
            END IF
          END IF
        END IF
      END IF
      IF l < 7 AND mc(l) > -1 AND rc(l) = 0 AND NOT p(l) = 0 THEN
        PRINT
        PRINT SPACE$(ind(l));
        ci = ind(l)
      ELSE
        IF mc(l) > 0 AND NOT p(l) = 0 THEN
          PRINT " ";
          ci = ci + 1
        END IF
        ind(l) = ci
      END IF
      IF NOT rc(l) = 0 THEN rc(l) = rc(l) - 1
      IF p(l) = 0 THEN
        PRINT ")";
        ci = ci + 1
        l = l - 1
      ELSEIF p(l) < 0 THEN
        PRINT "."; names$(-p(l)); ")";
        ci = ci + 2 + LEN(names$(-p(l)))
        l = l - 1
      ELSE
        mc(l) = mc(l) + 1
        IF car(p(l)) < 0 THEN
          PRINT pname$(car(p(l)));
          ci = ci + LEN(pname$(car(p(l))))
          p(l) = cdr(p(l))
        ELSE
          l = l + 1
          ind(l) = ind(l - 1)
          p(l) = car(p(l - 1))
          p(l - 1) = cdr(p(l - 1))
          mc(l) = 0
          rc(l) = -1
        END IF
      END IF
    LOOP
    PRINT
  END IF
END SUB

SUB pqtree (x)
  DIM ind(20)
  DIM p(20)
  DIM rc(20)
  l = 1
  ind(l) = 2
  p(l) = x
  rc(l) = 1
  IF p(l) > 0 THEN
    IF car(p(l)) < 0 THEN
      rc(l) = 2
      ind(l) = 2 + LEN(names$(-car(p(l))))
    END IF
  END IF
  IF x < 0 THEN
    PRINT names$(-x); " ";
REM  ELSEIF x = 0 THEN
REM    PRINT "( ) ";
  ELSE
    PRINT "(";
    DO
      c = p(l)
      ol = l
      IF c > 0 THEN
        REM cons cell
        IF car(c) < 0 THEN
          PRINT names$(-car(c));
          p(l) = cdr(c)
        ELSE
          PRINT "(";
          p(l) = cdr(c)
          l = l + 1
          p(l) = car(c)
          ind(l) = ind(l - 1) + 2
          rc(l) = 0
          IF l < 4 AND p(l) > 0 THEN
            IF car(p(l)) < 0 THEN
              IF INSTR("abcdefghijklmnopqrstuvwxyz", LEFT$(names$(-car(p(l))), 1)) THEN
                rc(l) = 2
                ind(l) = ind(l - 1) + 2 + LEN(names$(-car(p(l))))
              END IF
            END IF
          END IF
          ol = -1
        END IF
      ELSE
        IF c < 0 THEN PRINT "."; names$(-c);
        PRINT ")";
        IF l = 1 THEN EXIT DO
        l = l - 1
      END IF
      IF ol < 0 OR p(l) = 0 THEN
        REM nix
      ELSEIF rc(ol) = 1 THEN
        PRINT
        PRINT SPACE$(ind(l));
      ELSE
        IF rc(ol) > 1 THEN rc(ol) = rc(ol) - 1
        PRINT " ";
      END IF
    LOOP
  END IF
END SUB

FUNCTION pqualname
  REM call only with currtok$="id"
  SHARED currtok$, currname$
  r = 0
  DO
    r = cons(mkstr(currname$), r)
    gettok
    IF NOT currtok$ = "." THEN EXIT DO
    gettok
  LOOP WHILE currtok$ = "id"
  r = cons(mkstr("name"), revl(r))
  pqualname = r
END FUNCTION

SUB prtype (xx)
  SHARED prtlvl
  x = xx
  FOR i = 1 TO prtlvl
    IF x = prtarr(i) THEN
      PRINT "%" + LTRIM$(STR$(i));
      EXIT SUB
    END IF
  NEXT
  prtlvl = prtlvl + 1
  prtarr(prtlvl) = x
  PRINT "[" + LTRIM$(STR$(tnodes(x).size)) + "]";
  SELECT CASE tnodes(x).t
  CASE voidtp
    PRINT " void";
  CASE inttp
    PRINT " int";
  CASE uinttp
    PRINT " uint";
  CASE chartp
    PRINT " char";
  CASE uchartp
    PRINT " uchar";
  CASE reftp
    PRINT " ref ";
    prtype (tnodes(x).subtyp)
  CASE niltp
    PRINT " nil";
  CASE vectp
    PRINT " vec"; tnodes(x).elems; "of ";
    prtype (tnodes(x).subtyp)
  CASE rectp
    PRINT " record";
    x = tnodes(x).elems
    DO WHILE x
      PRINT
      PRINT SPACE$(4 * prtlvl); " "; names$(syms(x).id); ":"; syms(x).offs;
      prtype (syms(x).typ)
      PRINT ";";
      x = syms(x).succ
    LOOP
    PRINT " end";
  CASE functp
    PRINT " function";
    h = x
    x = tnodes(x).elems
    DO WHILE x
      PRINT
      PRINT SPACE$(4 * prtlvl); " "; names$(typs(x).id);
      prtype (typs(x).typ)
      PRINT ";";
      x = typs(x).succ
    LOOP
    PRINT " :";
    prtype (tnodes(h).subtyp)
  CASE enumtp
    PRINT " enum";
  CASE undeftp
    PRINT " UNDEF!!!";
  CASE ELSE
    PRINT " s="; tnodes(x).size;
    PRINT " t="; tnodes(x).t;
    PRINT " sub="; tnodes(x).subtyp;
    PRINT " e="; tnodes(x).elems;
  END SELECT
  prtlvl = prtlvl - 1
  IF prtlvl = 0 THEN PRINT
END SUB

FUNCTION pstmt
  SHARED currtok$, currname$
  SELECT CASE currtok$
  CASE "{"
    r = pblock("}", "blk")
    checktok (";")
  CASE "begin"
    r = pblock("end", "block")
    checktok (";")
  CASE "module"
    gettok
    n$ = currname$
    checktok ("id")
    IF currtok$ = "strval" THEN
      gettok
    END IF
    checktok ("=")
    r = mcode("module", mkstr(n$), pstmt)
  CASE "program"
    gettok
    IF currtok$ = "id" THEN
      gettok
    END IF
    IF currtok$ = "strval" THEN
      gettok
    END IF
    checktok ("=")
    r = mcode("program", pstmt, 0)
  CASE "if"
    gettok
    c = pexpr
    checktok ("then")
    t = pstmts("else", "fi")
    IF currtok$ = "else" THEN
      gettok
      e = cons(pstmts("fi", "fi"), 0)
    ELSE
      e = 0
    END IF
    r = cons(mkstr("if"), cons(c, cons(t, e)))
    checktok ("fi")
    checktok (";")
  CASE "while"
    gettok
    c = pexpr
    checktok ("do")
    r = mcode("while", c, pstmts("end", "end"))
    checktok ("end")
    skiptok ("while")
    checktok (";")
  CASE "for"
    gettok
    IF currtok$ <> ";" THEN
      i = pexpr
    ELSE
      i = 0
    END IF
    checktok (";")
    IF currtok$ <> ";" THEN
      c = pexpr
    ELSE
      c = 0
    END IF
    checktok (";")
    IF currtok$ <> "do" THEN
      s = pexpr
    ELSE
      s = 0
    END IF
    checktok ("do")
    r = pstmts("end", "end")
    r = cons(mkstr("for"), cons(i, cons(c, cons(s, cons(r, 0)))))
    checktok ("end")
    skiptok ("for")
    checktok (";")
  CASE "return"
    gettok
    IF currtok$ = ";" THEN
      r = cons(mkstr("return"), 0)
    ELSE
      r = mcode("return", pexpr, 0)
    END IF
    checktok (";")
  CASE ELSE
    r = pexpr
    r = mcode("expr", r, 0)
    checktok (";")
  END SELECT
  pstmt = r
END FUNCTION

FUNCTION pstmts (t$, u$)
  SHARED currtok$, currname$, blklvl
  blklvl = blklvl + 1
  r = 0
  l = 0
  DO WHILE NOT currtok$ = t$ AND NOT currtok$ = u$ AND NOT currtok$ = "$$"
    IF currtok$ = "end" THEN
      terror (" end instead of " + u$ + " accepted...")
      EXIT DO
    END IF
    IF NOT l = 0 THEN r = cons(l, r)
    l = pstmt
  LOOP
  IF NOT r = 0 THEN
    r = cons(l, r)
    r = revl(r)
    r = cons(mkstr("stmts"), r)
  ELSE
    r = l
  END IF
  blklvl = blklvl - 1
  pstmts = r
END FUNCTION

FUNCTION pterm
  SHARED currtok$, currname$
  r = pfactor
  WHILE currtok$ = "*" OR currtok$ = "/" OR currtok$ = "mod"
    op$ = currtok$
    gettok
    l = pfactor
    r = mcode(op$, r, l)
  WEND
  pterm = r
END FUNCTION

FUNCTION ptype
  SHARED currtok$, currname$
  SELECT CASE currtok$
  CASE "integer"
    r = cons(mkstr("int"), 0)
    gettok
  CASE "word"
    r = cons(mkstr("uint"), 0)
    gettok
  CASE "byte"
    r = cons(mkstr("uchar"), 0)
    gettok
  CASE "real", "bool", "string", "char"
    r = cons(mkstr(currtok$), 0)
    gettok
  CASE "ref"
    gettok
    r = ptype
    r = mcode("ref", r, 0)
  CASE "vector"
    gettok
    l = pexpr
    checktok ("of")
    r = ptype
    r = mcode("vector", l, r)
  CASE "enum"
    gettok
    IF currtok$ = "id" THEN
      r = mkstr(currname$)
      gettok
    ELSE
      r = 0
    END IF
    l = 0
    IF currtok$ = "(" THEN
      DO
        gettok
        IF currtok$ = "id" THEN
          l = cons(mkstr(currname$), l)
        END IF
        checktok ("id")
      LOOP WHILE currtok$ = ","
      l = cons(l, 0)
      checktok (")")
    END IF
    r = cons(mkstr("enum"), cons(r, l))
  CASE "record"
    m = 0
    gettok
    DO
      l = pvar
      m = cons(l, m)
      checktok (";")
    LOOP WHILE NOT currtok$ = "end" AND NOT currtok$ = "$$"
    r = cons(mkstr("record"), revl(m))
    checktok ("end")
    skiptok ("record")
  CASE "array"
    gettok
    terror ("scant really parse this")
  CASE "object"
    gettok
    terror ("scant really parse this")
  CASE "id"
    r = pqualname
  CASE ELSE
    checktok ("<type>")
  END SELECT
  ptype = r
END FUNCTION

FUNCTION ptypedecl
  SHARED currtok$, currname$
  IF currtok$ = "id" THEN
    nm$ = currname$
    gettok
  ELSE
    nm$ = ""
    checktok ("id")
  END IF
  checktok ("=")
  t = ptype
  r = mcode(nm$, t, 0)
  ptypedecl = r
END FUNCTION

SUB pulluses (u$)
  FOR i = 1 TO ndirs
    IF LEFT$(usedir$(i), LEN(u$) + 1) = u$ + ":" THEN
      a$ = MID$(usedir$(i), LEN(u$) + 2)
      DO
        p = INSTR(a$, ":")
        IF p < 2 THEN EXIT DO
        m$ = LEFT$(a$, p - 1)
        a$ = MID$(a$, p + 1)
        IF m$ <> u$ THEN
          forceunit (m$)
        END IF
      LOOP
      EXIT SUB
    END IF
  NEXT
REM  PRINT u$; ": no entry in use dir"
END SUB

SUB putstrings
  SHARED namecnt, globoff
  FOR i = 1 TO namecnt
    IF nametag(i) THEN
      cout ("data")
      lout ("L" + straddr$(-i))
      c$ = names$(i)
      o$ = "bytes   "
      DO WHILE LEN(c$) > 0
        IF LEN(o$) > 35 THEN
          cout (o$)
          o$ = "bytes   "
        END IF
          o$ = o$ + "&" + HEX$(ASC(LEFT$(c$, 1)))
          c$ = MID$(c$, 2)
      LOOP
      cout (o$)
      nametag(i) = 0
    END IF
  NEXT
  cout ("bss")
  cout ("bss     " + LTRIM$(STR$(globoff)))
  globoff = 0
END SUB

FUNCTION pvar
  SHARED currtok$, currname$
  h = 0
  DO
    h = cons(mkstr(currname$), h)
    checktok ("id")
    IF NOT currtok$ = "," THEN EXIT DO
    gettok
  LOOP
  h = revl(h)
  checktok (":")
  t = ptype
  r = cons(h, cons(t, 0))
  pvar = r
END FUNCTION

SUB readdir
  shexec ("dir *.n >n.dir")
  FOR i = 1 TO ndirs
    ndiro$(i) = ""
    usedir$(i) = ""
    ndirn$(i) = ""
    moddir$(i) = ""
  NEXT
REM  PRINT "readdir"
  OPEN "nc.dir" FOR INPUT AS #5
  i = 0
  WHILE NOT EOF(5)
    LINE INPUT #5, a$
    IF MID$(a$, 10, 3) = "N  " THEN
      i = i + 1
      ndiro$(i) = a$
    END IF
  WEND
  CLOSE #5
REM  PRINT "nc.dir"
  OPEN "n.dir" FOR INPUT AS #5
  i = 0
  WHILE NOT EOF(5)
    LINE INPUT #5, a$
    IF MID$(a$, 10, 8) = "N       " THEN
      i = i + 1
      ndirn$(i) = a$
    END IF
  WEND
  CLOSE #5
REM  PRINT "n.dir"
  OPEN "use.dir" FOR INPUT AS #5
  i = 0
  WHILE NOT EOF(5)
    LINE INPUT #5, a$
    IF LEN(a$) > 0 THEN
      IF existnfile(a$) THEN
        i = i + 1
        usedir$(i) = a$
      ELSE
        PRINT "reject " + a$
      END IF
    END IF
  WEND
  CLOSE #5
REM  PRINT "use.dir"
  OPEN "module.dir" FOR INPUT AS #5
  i = 0
  WHILE NOT EOF(5)
    LINE INPUT #5, a$
    IF LEN(a$) > 0 THEN
      IF existnfile(a$) THEN
        i = i + 1
        moddir$(i) = a$
      END IF
    END IF
  WEND
  CLOSE #5
REM  PRINT "module.dir"
END SUB

SUB readimp (t$)
  SHARED tnodecnt, currsymtab
  addscope (7)
  symtabs(currsymtab).modname = -mkstr(t$)
  tbase = tnodecnt
  tp = 0
  adduse (t$)
  OPEN "exp\" + t$ + ".exp" FOR INPUT AS 12
  WHILE NOT EOF(12)
    LINE INPUT #12, a$
    setword (a$)
    c$ = getword$
    IF c$ = "type" THEN
      p = -mkstr(getword$)
      z = addtype(p, tnum(getword$, tbase))
REM      PRINT getword$; " = ";
REM      prtype (tnum(getword$, tbase))
    ELSEIF c$ = "var" THEN
      p = -mkstr(getword$)
      y = addvar(p, tnum(getword$, tbase), 5)
REM      PRINT getword$; ": ";
REM      prtype (tnum(getword$, tbase))
    ELSEIF c$ = "const" THEN
      v = VAL(getword$)
      p = -mkstr(getword$)
      z = addvar(p, tnum(getword$, tbase), 4)
      syms(z).offs = v
REM      PRINT getword$; " name ";
REM      PRINT getword$; " = ";
REM      prtype (tnum(getword$, tbase))
    ELSE
      nv = VAL(c$)
      IF nv <> tp + 1 THEN
        terror ("fbad exp file")
      END IF
      tp = tp + 1
      t = newtnode
      tnodes(t).size = VAL(getword$)
      c$ = getword$
      IF c$ = "function" THEN
         tnodes(t).t = functp
         tnodes(t).subtyp = tnum(getword$, t - tp)
         WHILE haswords
           na = -mkstr(getword$)
           st = tnum(getword$, t - tp)
           tnodes(t).elems = newtyp(na, tnodes(t).elems, st)
         WEND
         h = tnodes(t).elems
         tnodes(t).elems = 0
         WHILE h
           hh = h
           h = typs(hh).succ
           typs(hh).succ = tnodes(t).elems
           tnodes(t).elems = hh
         WEND
      ELSEIF c$ = "record" THEN
         tnodes(t).t = rectp
         WHILE haswords
           of = VAL(getword$)
           na = -mkstr(getword$)
           st = tnum(getword$, t - tp)
           tnodes(t).elems = newsym(na, tnodes(t).elems, st)
           syms(tnodes(t).elems).offs = of
         WEND
         h = tnodes(t).elems
         tnodes(t).elems = 0
         WHILE h
           hh = h
           h = syms(hh).succ
           syms(hh).succ = tnodes(t).elems
           tnodes(t).elems = hh
         WEND
      ELSEIF c$ = "ref" THEN
         tnodes(t).t = reftp
         tnodes(t).subtyp = tnum(getword$, t - tp)
      ELSEIF c$ = "vec" THEN
         tnodes(t).t = vectp
         tnodes(t).elems = VAL(getword$)
         tnodes(t).subtyp = tnum(getword$, t - tp)
      ELSE
        terror ("fbad type " + c$ + " in exp file")
      END IF
    END IF
  WEND
  CLOSE #12
  remodscope
END SUB

SUB remmod
  SHARED unit$
REM  PRINT "remmod(" + unit$ + ")"
  FOR i = 1 TO ndirs
    a$ = moddir$(i)
    IF LEFT$(a$, LEN(unit$) + 1) = unit$ + ":" THEN
REM      PRINT a$
      moddir$(i) = ""
      EXIT SUB
    END IF
  NEXT
END SUB

SUB remodscope
  SHARED currsymtab, freesymtabs
  showscope (currsymtab)
  h = currsymtab
  currsymtab = symtabs(h).succ
  symtabs(h).succ = symtabs(currsymtab).modules
  symtabs(currsymtab).modules = h
  x = symtabs(currsymtab).vars
  DO WHILE x > 0
    IF symtabs(h).modname = syms(x).id THEN
      terror (" module " + names$(symtabs(h).modname) + " hides variable")
    END IF
    x = syms(x).succ
  LOOP
  x = symtabs(currsymtab).types
  DO WHILE x > 0
    IF symtabs(h).modname = typs(x).id THEN
      terror (" module " + names$(symtabs(h).modname) + " hides type name")
    END IF
    x = typs(x).succ
  LOOP
END SUB

SUB remout (t$)
  machout ("        ; " + t$)
END SUB

SUB remscope
  SHARED currsymtab, freesymtabs
  showscope (currsymtab)
  h = currsymtab
  currsymtab = symtabs(h).succ
  symtabs(h).succ = freesymtabs
  freesymtabs = h
END SUB

SUB remuses
  SHARED unit$
REM  PRINT "remuses(" + unit$ + ")"
  FOR i = 1 TO ndirs
    DO
      a$ = usedir$(i)
      p = INSTR(a$, ":" + unit$ + " ")
      IF p = 0 THEN EXIT DO
      usedir$(i) = LEFT$(a$, p) + MID$(a$, p + LEN(unit$) + 2)
    LOOP
REM    IF a$ <> "" THEN PRINT a$
  NEXT
END SUB

FUNCTION revl (x)
  a = x
  r = 0
  WHILE a > 0
    h = a
    a = cdr(h)
    cdr(h) = r
    r = h
  WEND
  IF a < 0 THEN
    terror ("frevl: lost")
    tree (a)
  END IF
  revl = r
END FUNCTION

FUNCTION sametype (a, b)
  SHARED sti
  sti = sti + 1
  sta(sti) = a
  stb(sti) = b
REM  PRINT "sametype"; a; b;
  r = 0
  IF a = b THEN
    r = -1
  ELSE
    i = sti - 1
    DO WHILE i > 0
      IF sta(i) = a AND stb(i) = b THEN
        r = -1
        EXIT DO
      END IF
      i = i - 1
    LOOP
    IF r = 0 AND tnodes(a).t = tnodes(b).t THEN
      SELECT CASE tnodes(a).t
      CASE reftp
        r = sametype(tnodes(a).subtyp, tnodes(b).subtyp)
      CASE vectp
        IF tnodes(a).elems = tnodes(b).elems THEN
          r = sametype(tnodes(a).subtyp, tnodes(b).subtyp)
        END IF
      CASE rectp
        x = tnodes(a).elems
        y = tnodes(b).elems
        r = -1
        DO WHILE x > 0 AND y > 0 AND r
          IF syms(x).id <> syms(y).id OR syms(x).offs <> syms(y).offs THEN
            r = 0
          ELSE
            r = sametype(syms(x).typ, syms(y).typ)
          END IF
          x = syms(x).succ
          y = syms(y).succ
        LOOP
        IF x <> y THEN r = 0
      CASE functp
        x = tnodes(a).elems
        y = tnodes(b).elems
        r = sametype(tnodes(a).subtyp, tnodes(b).subtyp)
        DO WHILE x > 0 AND y > 0 AND r
          IF typs(x).id <> typs(y).id THEN
            r = 0
          ELSE
            r = sametype(typs(x).typ, typs(y).typ)
          END IF
          x = typs(x).succ
          y = typs(y).succ
        LOOP
        IF x <> y THEN r = 0
      END SELECT
    END IF
  END IF
  sti = sti - 1
  sametype = r
REM  PRINT "="; r;
END FUNCTION

SUB scopeincls
  SHARED modncnt, neu
REM  PRINT "+++++++ scopeincls"
  FOR i = 1 TO modncnt
REM    PRINT "----- include  " + modules$(i)
    IF neu THEN
    ELSE
      cout ("include  " + modules$(i))
    END IF
  NEXT
END SUB

SUB score (t$)
  SHARED scorecnt
  FOR i = 1 TO scorecnt
    IF scorelist$(i) = t$ THEN
      scorecnts(i) = scorecnts(i) + 1
      EXIT SUB
    END IF
  NEXT
  scorecnt = scorecnt + 1
  scorelist$(scorecnt) = t$
  scorecnts(scorecnt) = 1
END SUB

SUB setword (a$)
  SHARED wordl$
  wordl$ = a$
  WHILE LEN(wordl$) > 0
    IF LEFT$(wordl$, 1) = " " THEN
      wordl$ = MID$(wordl$, 2)
    ELSE
      EXIT SUB
    END IF
  WEND
END SUB

SUB shexec (cmd$)
'  PRINT "<" + cmd$ + ">"
  SHELL cmd$
END SUB

SUB showscope (uu)
  EXIT SUB
  IF symtabs(uu).modname THEN
    PRINT "-- module " + names$(symtabs(uu).modname);
  END IF
  IF symtabs(uu).vars > 0 OR symtabs(uu).types > 0 OR symtabs(uu).modules > 0 THEN
    PRINT "--- scope"; uu; " strat"; symtabs(uu).strat
    x = symtabs(uu).vars
    DO WHILE x > 0
      IF syms(x).ref = 4 THEN
        PRINT "const ";
      ELSE
        PRINT "var ";
      END IF
      PRINT names$(syms(x).id); ": "; syms(x).offs;
      prtype (syms(x).typ)
      x = syms(x).succ
    LOOP
    x = symtabs(uu).types
    DO WHILE x > 0
      PRINT "type "; names$(typs(x).id); ": ";
      prtype (typs(x).typ)
      x = typs(x).succ
    LOOP
    x = symtabs(uu).modules
    DO WHILE x > 0
      PRINT "module "; names$(symtabs(x).modname)
      x = symtabs(x).succ
    LOOP
    PRINT "--- scope done"
  ELSE
    PRINT "--- empty scope", uu
  END IF
END SUB

FUNCTION siz$ (m)
  siz$ = LTRIM$(STR$(sizeof(m)))
END FUNCTION

FUNCTION sizeof (t)
  s = tnodes(t).size
  IF s = 0 THEN
    PRINT "sizeof"
    prtype (t)
    terror ("sbad type in sizeof")
  END IF
  sizeof = s
END FUNCTION

SUB skiptok (t$)
SHARED currtok$, currname$
  IF currtok$ = t$ THEN
  gettok
  END IF
END SUB

FUNCTION sname$ (r)
  o$ = ""
  c$ = names$(-r)
  FOR ii = 1 TO LEN(c$)
    jj = ASC(MID$(c$, ii, 1))
    IF jj > 32 AND jj < 127 AND jj <> ASC("\") THEN
      o$ = o$ + CHR$(jj)
    ELSE
      o$ = o$ + "\" + RIGHT$("000" + LTRIM$(OCT$(jj)), 3)
    END IF
  NEXT
  sname$ = o$
END FUNCTION

FUNCTION straddr$ (r)
  nametag(-r) = 1
  straddr$ = "S" + LTRIM$(STR$(-r))
END FUNCTION

FUNCTION strlist$ (ss$, r)
  s$ = ss$
  IF r < 0 THEN
    a$ = sname$(r)
    s$ = s$ + a$
  ELSE
    s$ = s$ + "("
    x = r
    DO WHILE x > 0 AND LEN(s$) < 50
      s$ = strlist$(s$, car(x))
      x = cdr(x)
      IF NOT x > 0 THEN EXIT DO
      s$ = s$ + " "
    LOOP
    IF x < 0 AND LEN(s$) < 50 THEN
      s$ = s$ + "." + sname$(x)
    END IF
    IF LEN(s$) < 50 THEN
      s$ = s$ + ")"
    END IF
  END IF
  strlist$ = s$
END FUNCTION

SUB terrdiag (n$)
  SHARED terrcnt, toterrs
  PRINT n$ + ": ";
  toterrs = toterrs + terrcnt
  IF terrcnt = 1 THEN
  PRINT " One Error:"
  ELSEIF terrcnt > 0 THEN
    PRINT terrcnt; "Errors:"
  ELSE
    PRINT " No Errors"
  END IF
  IF terrcnt > 0 THEN
    i = 1
    DO WHILE i <= 10 AND i <= terrcnt
    PRINT errtab$(i)
      i = i + 1
    LOOP
    IF i < terrcnt THEN
      PRINT "And more..."
    ELSE
      PRINT "That's all"
    END IF
  END IF
END SUB

SUB terror (e$)
SHARED currtok$, currname$, currfuncname$, unit$, units$
SHARED terrcnt
  m$ = ""
  IF currfuncname$ <> "" THEN
    PRINT "In Function " + currfuncname$
  END IF
  PRINT "-- ";
  IF LEFT$(e$, 1) = "f" THEN
    m$ = m$ + "Fatal "
  END IF
  m$ = m$ + "Error: " + MID$(e$, 2)
  PRINT m$
  IF currtok$ <> "$$" THEN PRINT "currtok="; currtok$
  terrcnt = terrcnt + 1
  IF terrcnt <= 10 THEN
    errtab$(terrcnt) = m$
  END IF
  PRINT unit$ + "?";
  LINE INPUT i$
  IF LEFT$(i$, 1) = "!" THEN
    SHELL MID$(i$, 2)
  ELSEIF LEFT$(i$, 1) = "-" THEN
    units$ = unit$ + "$" + units$
    PRINT units$
  ELSEIF LEFT$(i$, 1) = "." THEN
    SHELL "vi " + unit$ + ".n"
  ELSEIF LEFT$(i$, 1) = "+" THEN
    STOP
  END IF
  IF LEFT$(e$, 1) = "f" THEN
    REM STOP
  ELSEIF LEFT$(e$, 1) = "s" THEN
    REM STOP
  ELSE
    REM IF terrcnt = 1 THEN STOP
  END IF
END SUB

FUNCTION tnum (w$, b)
  IF LEFT$(w$, 1) = "*" THEN
    x = VAL(MID$(w$, 2))
  ELSE
    x = VAL(w$) + b
  END IF
  tnum = x
END FUNCTION

SUB tree (x)
  SHARED cellcnt
  IF x > cellcnt THEN
    PRINT "["; x; "]";
  ELSEIF x > 0 THEN
    xx = x
    PRINT "(";
    DO
      y = car(xx)
      z = cdr(xx)
      tree (y)
      IF NOT z > 0 THEN EXIT DO
      PRINT " ";
      xx = z
    LOOP
    IF z < 0 THEN
      PRINT " . ";
      tree (z)
    END IF
    PRINT ")";
  ELSEIF x = 0 THEN
    PRINT "()";
  ELSEIF x < 0 THEN
    PRINT names$(-x);
  ELSE
    PRINT "["; x; "]";
  END IF
END SUB

FUNCTION tyadd$ (r)
  typut (r)
  tyadd$ = tynum$(r)
END FUNCTION

SUB tydump
  SHARED tput, tget
  WHILE tget < tput
    tget = tget + 1
    x = ttab(tget)
    PRINT #11, tget; tnodes(x).size;
    SELECT CASE tnodes(x).t
    CASE voidtp
      PRINT #11, " void"
    CASE inttp
      PRINT #11, " int"
    CASE uinttp
      PRINT #11, " uint"
    CASE chartp
      PRINT #11, " char"
    CASE uchartp
      PRINT #11, " uchar"
    CASE reftp
      PRINT #11, " ref "; tyadd$(tnodes(x).subtyp)
    CASE niltp
      PRINT #11, " nil";
    CASE vectp
      PRINT #11, " vec "; tnodes(x).elems; " "; tyadd$(tnodes(x).subtyp)
    CASE rectp
      PRINT #11, " record ";
      x = tnodes(x).elems
      DO WHILE x
        PRINT #11, syms(x).offs; names$(syms(x).id); " "; tyadd$(syms(x).typ);
        x = syms(x).succ
      LOOP
      PRINT #11,
    CASE functp
      PRINT #11, " function "; tyadd$(tnodes(x).subtyp);
      x = tnodes(x).elems
      DO WHILE x
        PRINT #11, " "; names$(typs(x).id); " "; tyadd$(typs(x).typ);
        x = typs(x).succ
      LOOP
      PRINT #11,
    CASE ELSE
      PRINT #11, "!!!"; tnodes(x).t
    END SELECT
  WEND
END SUB

SUB tyinit
  SHARED tput, tget
  tput = 0
  tget = 0
END SUB

FUNCTION tynum$ (r)
  SHARED tput, tget
  IF r < reftp THEN
    tynum$ = "*" + LTRIM$(STR$(r))
    EXIT FUNCTION
  END IF
  FOR i = 1 TO tput
    IF sametype(ttab(i), r) THEN
      tynum$ = LTRIM$(STR$(i))
      EXIT FUNCTION
    END IF
  NEXT
  STOP
END FUNCTION

SUB typut (r)
  SHARED tput, tget
  IF r < reftp THEN EXIT SUB
  FOR i = 1 TO tput
    IF sametype(ttab(i), r) THEN EXIT SUB
  NEXT
  tput = tput + 1
  ttab(tput) = r
END SUB

SUB updateunit (u$)
REM  PRINT "updating unit " + u$
  n$ = UCASE$(u$) + SPACE$(8 - LEN(u$))
  i = 1
  DO WHILE i <= ndirs
    IF n$ = LEFT$(ndirn$(i), 8) THEN
      j = 1
      DO WHILE ndiro$(j) <> ""
        IF n$ = LEFT$(ndiro$(j), 8) THEN EXIT DO
        j = j + 1
      LOOP
      ndiro$(j) = ndirn$(i)
      PRINT ndirn$(i)
      EXIT SUB
    END IF
    i = i + 1
  LOOP
  PRINT u$; " not updated!!!"
END SUB

FUNCTION vectoref (t)
  IF tnodes(t).t = vectp THEN
    vectoref = newreftnode(tnodes(t).subtyp)
  ELSE
    PRINT "vectoref: other type"
    vectoref = t
  END IF
END FUNCTION

SUB writedir
  OPEN "nc.dir" FOR OUTPUT AS #5
  i = 1
  DO WHILE i <= ndirs
    IF ndiro$(i) = "" THEN EXIT DO
    PRINT #5, ndiro$(i)
    i = i + 1
  LOOP
  CLOSE #5
END SUB

SUB writemoddir
  OPEN "module.dir" FOR OUTPUT AS #5
  FOR i = 1 TO ndirs
    IF moddir$(i) <> "" THEN PRINT #5, moddir$(i)
  NEXT
  CLOSE #5
END SUB

SUB writeuse
  OPEN "use.dir" FOR OUTPUT AS #5
  FOR i = 1 TO ndirs
    IF usedir$(i) <> "" THEN
      PRINT #5, usedir$(i)
    END IF
  NEXT
  CLOSE #5
END SUB