%include "inc:util.imp"
%begin

! LC (Low-level compiler) for 8086
! RWT January 1981, revised January 1988

! Statement -> CONST {tag = cexpr}+
!              {WORD, BYTE} {tag { (cexpr:cexpr) }? {= {data}+ }? }*
!              SPEC tag string
!              PROC tag {string}? {tag}*
!              END
!              tag :
!              {instruction, ELSE}? {IF expr comp expr}?
!              CYCLE
!              FINISH
! Instruction -> MOVE {string opd, cexpr opd opd}
!                JUMP tag
!                REPEAT
!                RETURN {expr}?
!                opd = expr
!                tag {expr}*
! Data -> {string, cexpr { (cexpr) }? }
! Cexpr -> const {op const}*
! Expr -> {opd, const} {op {opd, const} }*
! Opd -> tag { ( {opd, const} ) }?
! Op -> + - & ! \ * / % << >>
! Comp -> = # < > <= >= [ ] [= ]=
! Comments are enclosed between { and } or | and NL.

!Calling convention: Push parms, Push CS, CALL.
!Entry:  {Push DS}, Push BP, Mov BP,SP, {Sub SP,framesize}?,
!Return: Mov SP,BP, Pop BP, {Pop DS}, Xret parmsize.

%constinteger source=1,diag=0,object=1,list=2;  !Streams

%constinteger linemax=80,atommax=50,tagmax=200,textmax=20
%constinteger codemax=3499,glamax=499
%byteintegerarray line(1:linemax)
%byteintegerarray code(0:codemax)
%byteintegerarray gla(0:glamax)
%integerarray atomtype,atomval(1:atommax)
%integerarray tag1,tag2,tagtype,tagval(1:tagmax)
%integerarray texttype,textval(1:textmax)
%integer type,val,t,v,atompos,ifpos,floc,parms
%integer oldapos,oldcpos,oldtpos,access=0,textlevel
%integer lineno=0,cloc=0,gloc=0,level=0,gpos=0,cpos=0,tagpos=1
%string(31)program = ""
%string(31)sourcefile,objectfile="",listingfile=""
%integer bools

!Atom types
%constinteger unknown=0,constant=1,string=2,label=3
%constinteger var=4, wordbit=1, glabit=2, varmask=16_fc
%constinteger proc=8,xproc=9,spec=10
%constinteger op=11,comp=12,colon=13,sep=14,bracket=15,bx=16!wordbit

! Keyword types
%constinteger kconst=17,kword=18,kbyte=19,kspec=20,kproc=21
%constinteger kend=22,kmove=23,kjump=24,kreturn=25,kprogram=26
%constinteger kelse=27,kfinish=28,kcycle=29,krepeat=30

!Operator codes
%constinteger load=1,add=2,sub=3,and=4,or=5,xor=6,cmp=7,
              mul=8,div=9,rem=10,left=11,right=12,store=13,lea=14

!Keyword tag codes (1:36 = A:Z,0:9) 1st {*37 + 2nd {*37 + 3rd}? }?
%constinteger if=339
%ownintegerarray n1(kconst:krepeat)=
  4676, 32060, 3683, 26608, 22585, 7367, 18374, 14480, 24847, 22585,
  7308,  8561, 5035, 24843
%ownintegerarray n2(kconst:krepeat)=
   723,     4,    5,     3,     3,    0,     5,    16, 29429, 10250,
     5, 13032,  449,  6902

!Fault numbers
%constinteger complex=1,atom=2,consterr=3,bfull=4,form=5,ambig=6,
     nested=7,mispdecl=8,far=9,labund=10,mispcode=11,varund=12,dfull=13,
     repexp=14,finexp=15,context=16,maxfault=16

%routine fault(%integer n)
%ownstring(21)%array s(1:maxfault)=
"Complex",
"Atom",
"Not constant",
"Buffer full",
"Form",
"Ambiguous",
"Nesting",
"Declaration misplaced",
"Too far",
"Label missing",
"Code misplaced",
"Undeclared name",
"Dictionary full",
"Repeat expected",
"Finish expected",
"Context"
%integer i,sym
   selectoutput(diag); write(lineno,1); space
   i=1
   %cycle
      sym=line(i); printsymbol(sym); i=i+1
   %repeatuntil sym=nl
   printstring(s(n)); write(atompos-1,1); newline
   selectoutput(list)
   printstring("** "); printstring(s(n))
   write(atompos-1,1); newline
   %signalevent 15
%end

%routine readline
%owninteger semi=0
%OWNINTEGER QUOTE=0
%integer sym,n1,n2,radix,i,quoted,lpos

  %routine phex(%integer x)
  %integer k,i
    %for i=12,-4,0 %cycle
      k=x>>i&15; k=k+7 %if k>9
      printsymbol(k+'0')
    %repeat
  %end

  %routine putatom(%integer t,v)
    fault(complex) %if atompos>atommax
    atomtype(atompos)=t; atomval(atompos)=v
    atompos=atompos+1
  %end

   selectoutput(list)
   %cycle
      %if semi=0 %start
        write(lineno+1,4)
        printstring(" C"); phex(cloc); printstring(" D"); phex(gloc)
        space
      %finish
      lpos=1; quoted=0
      %cycle
next:    %if lpos+quoted=linemax %start; ! line nearly too long: force end
            %if quoted=0 %then sym=nl %else sym=quote
         %else
            readsymbol(sym)
         %finish
         printsymbol(sym)
         %if quoted=0 %start
           quoted=1 %if sym='''' %or sym='"'
           quote=sym %if quoted#0
         %else
           quoted=0 %if sym=quote
         %finish
         %if quoted=0 %start
            %if sym='{' %start; ! Comment
               %cycle
                  readsymbol(sym)
                  printsymbol(sym)
                  %if sym=nl %start
                     lineno=lineno+1; spaces(18)
                  %finish
               %repeatuntil sym='}'
               ->next
            %finish
            sym=sym-32 %if 'a'<=sym<='z'; semi=0
            %if sym=';' %start
              sym=nl; lineno=lineno-1; semi=1
            %finish
            %if sym='|' %start
              readsymbol(sym) %and printsymbol(sym) %until sym=nl
            %finish
         %finish
         lineno=lineno+1 %if sym=nl
         line(lpos)=sym; lpos=lpos+1
      %repeatuntil sym=nl %and quoted=0
   %repeatuntil lpos>2; ! non-empty line

! Now decompose line into atoms

   atompos=1; ifpos=0; lpos=1
nextatom:
   %cycle
      sym=line(lpos); lpos=lpos+1
      ->tag %if 'A'<=sym<='Z'
      ->num %if '0'<=sym<='9'
      %if sym=nl %start
        putatom(sep,0); atompos=1; %return
      %finish
      %if sym=':' %start
         putatom(colon,0)
      %finishelseif sym='+' %start
        putatom(op,add)
      %finishelseif sym='-' %start
        putatom(op,sub)
      %finishelseif sym='&' %start
        putatom(op,and)
      %finishelseif sym='!' %start
        putatom(op,or)
      %finishelseif sym='\' %start
        putatom(op,xor)
      %finishelseif sym='*' %start
        putatom(op,mul)
      %finishelseif sym='%' %start
        putatom(op,rem)
      %finishelseif sym='/' %start
        putatom(op,div)
      %finishelseif sym='<' %or sym='>' %start
         %if line(lpos)=sym %start; ! '<<', '>>'
            lpos=lpos+1
            %if sym='<' %then putatom(op,left) %else putatom(op,right)
         %else; ! '<', '>', '<=', '>='
square:         !+'[', ']', '[=', ']='
            %if line(lpos)='=' %start
               lpos=lpos+1; sym=sym+128
            %finish
            putatom(comp,sym)
         %finish
      %finishelseif sym='(' %or sym=')' %start
        putatom(bracket,sym)
      %finishelseif sym='[' %or sym=']' %start
         ->square
      %finishelseif sym='=' %or sym='#' %start
         putatom(comp,sym)
      %finishelseif sym='"' %start
         putatom(string,lpos)
         lpos=lpos+1 %while line(lpos)#'"'; ! we know it's there
         lpos=lpos+1
      %finishelseif sym='''' %start
         sym=line(lpos); lpos=lpos+1 %if sym=''''
         fault(atom) %if line(lpos+1)#''''
         putatom(constant,sym); lpos=lpos+2
      %else
         fault(atom) %unless sym=' '
      %finish
   %repeat
num: i=0; radix=10; ! I accumulates number, default radix is ten
   %cycle
      %if sym='_' %start; ! change radix
         radix=i; i=0
      %finishelseif '9'<sym<'A' %start
endconst: putatom(constant,i); lpos=lpos-1; ->nextatom
      %else
         sym=sym-7 %if sym>'9'; sym=sym-'0'
         ->endconst %unless 0<=sym<radix
         i=i*radix+sym
      %finish
      sym=line(lpos); lpos=lpos+1
   %repeat
tag: n1=sym-'A'+1; n2=0; i=1; ! I counts name length
   %cycle
      sym=line(lpos)
      %if 'A'<=sym<='Z' %start
         sym=sym-'A'+1
      %finishelseif '0'<=sym<='9' %start
         sym=sym-'0'+27
      %else
         %if n1=if %start
            fault(form) %unless ifpos=0
            ifpos=atompos; putatom(sep,0)
         %else; ! Look up in dictionary
            %for i=tagpos-1,-1,1 %cycle
               %if tag1(i)=n1 %and tag2(i)=n2 %start
                  n1=tagtype(i); n2=tagval(i)
                  n2=i %if n1=unknown
                  putatom(n1,n2)
                  ->nextatom
               %finish
            %repeat
! Not found: enter name and details
            tag1(tagpos)=n1; tag2(tagpos)=n2
            tagtype(tagpos)=unknown; tagval(tagpos)=0
            putatom(unknown,tagpos)
            %if tagpos>tagmax %then fault(dfull) %else tagpos=tagpos+1
         %finish
         ->nextatom
      %finish
      %if i<3 %start
         n1=n1*37+sym
      %finishelseif i<6 %start
         n2=n2*37+sym
      %finish
      i=i+1; lpos=lpos+1
   %repeat
%end

%routine nextatom
   type=atomtype(atompos); val=atomval(atompos)
   atompos=atompos+1 %unless type=sep
%end

%predicate open bracket
  %falseunless atomtype(atompos)=bracket %and atomval(atompos)='('
  atompos=atompos+1; %true
%end

%routine close bracket
  fault(form) %unless atomtype(atompos)=bracket %and atomval(atompos)=')'
  atompos=atompos+1
%end

%predicate equal sign
  %falseunless atomtype(atompos)=comp %and atomval(atompos)='='
  atompos=atompos+1; %true
%end

%routinespec unary

%integerfn cexpr(%integer must)
%integer value,oper
%switch s(add:right)
   nextatom; unary
   value=val; fault(consterr) %unless type=constant
   %cycle
      %result=value %unless atomtype(atompos)=op
      %if must=0 %start
         %result=value %unless atomtype(atompos+1)=constant
      %finish
      oper=atomval(atompos); atompos=atompos+1
      nextatom; fault(consterr) %unless type=constant
      ->s(oper)
s(add):  value=value+val; %continue
s(sub):  value=value-val; %continue
s(and):  value=value&val; %continue
s(or):   value=value!val; %continue
s(xor):  value=value!!val; %continue
s(rem):  value=value-value//val*val; %continue
s(div):  value=value//val; %continue
s(mul):  value=value*val; %continue
s(left): value=value<<val; %continue
s(right):value=value>>val
   %repeat
%end

%routine unary
%integername v
  %returnunless type=op %and atomtype(atompos)=constant
  %returnunless val=sub %or val=xor
  v==atomval(atompos)
  v=\v; v=v+1 %if val=sub
  val=cexpr(0); type=constant
%end

%routine gbyte(%integer b)
  fault(bfull) %if gpos>glamax
  gla(gpos)=b&255; gpos=gpos+1; gloc=gloc+1
%end

%routine gword(%integer x)
  gbyte(x); gbyte(x>>8)
%end

%routine gflush
%integer i
  %returnif gpos=0
  selectoutput(object); printsymbol(2)
  printsymbol(3); i = gloc-gpos; printsymbol(i&255); printsymbol(i>>8)
  printsymbol(4)
  printsymbol(gpos&255); printsymbol(gpos>>8&255)
  printsymbol(gla(i)) %for i=0,1,gpos-1
  gpos=0
%end

%routine dumpstring(%integer p)
%integer l
  l=0
  l=l+1 %and p=p+1 %while line(p)#'"'
  gbyte(l); p=p-l
  gbyte(line(p)) %and p=p+1 %and l=l-1 %while l>0
%end

%routine dump(%integer byte)
   fault(bfull) %if cpos>codemax
   code(cpos)=byte&255; cpos=cpos+1; cloc=cloc+1
%end

%routine flush
%integer i
   %returnif cpos=0
   selectoutput(object); printsymbol(1); printsymbol(4)
   printsymbol(cpos&255); printsymbol(cpos>>8&255)
   printsymbol(code(i)) %for i=0,1,cpos-1
   cpos=0
%end

%routine satrefs(%integer ref,val)
%integer abs,rel,disp
   %while ref#0 %cycle
     rel=ref; abs=rel-cloc+cpos; disp=val-rel-2
     ref=code(abs+1)<<8+code(abs)
     code(abs)=disp&255; code(abs+1)=disp>>8&255
   %repeat
%end

%routine labelref(%integer type,val)
%integer tvv
   %if type=label %start
      val=val-(cloc+2)
      dump(val); dump(val>>8)
   %else
      fault(form) %unless type=unknown
      tvv=tagval(val)
      dump(tvv); dump(tvv>>8)
      tagval(val)=cloc-2
   %finish
%end

%routine pushtext(%integer t,v)
  textlevel=textlevel+1
  fault(complex) %if textlevel>textmax
  texttype(textlevel)=t; textval(textlevel)=v
%end

%routine poptext
  fault(context) %if textlevel=0
  type=texttype(textlevel); val=textval(textlevel)
  textlevel=textlevel-1
%end

%routinespec expr

%constinteger pushax=16_50,popax=16_58

%routine call(%integer t,v)
  type=atomtype(atompos)
  %if type#op %start
    %cycle
      %exitif type=sep %or type=comp
      expr; dump(pushax); type=atomtype(atompos)
    %repeat
  %finish
  dump(16_0e); dump(16_e8); labelref(label,v);      !PushCs, Call
%end

%routine immediate(%integer op,val)
%switch s(load:right)
  ->s(op)
s(load): dump(16_b8); ->imm
s(add):  dump(16_05); ->imm
s(sub):  dump(16_2d); ->imm
s(and):  dump(16_25); ->imm
s(or):   dump(16_0d); ->imm
s(xor):  dump(16_35); ->imm
s(cmp):  dump(16_3d)
imm: dump(val); dump(val>>8); %return
s(left):
s(right):
  %if val=1 %start
    val=16_d1
  %else
    dump(16_b1); dump(val&15);  !Mov CL,nn
    val=16_d3
  %finish
  dump(val)
  %if op=left %then dump(16_e0) %else dump(16_e8)
  %return
s(mul):s(div):s(rem):
  dump(16_b9); dump(val); dump(val>>8);  !Mov CX,nn
  dump(16_99) %unless op=mul;            !Cwd
  dump(16_f7)
  %if op=mul %then dump(16_e9) %else dump(16_f9)
  %returnunless op=rem
  dump(16_8b); dump(16_c2);  !Mov ax,dx
%end

%routine direct(%integer op,type,val,index)
%ownintegerarray code(load:lea)=
  16_8a, 16_02, 16_2a, 16_22, 16_0a,
  16_32, 16_3a, 16_28, 16_38, 16_30,
  16_e0, 16_e8, 16_88, 16_8d
%integer oper,extra
  immediate(op,val) %andreturnif type=constant
  oper=code(op)
  ->shift %if op=left %or op=right
  extra=0; extra=oper %and oper=16_f6 %if op=mul
  %if op=div %or op=rem %start
    %if type&wordbit#0 %then dump(16_99) %else dump(16_98)
    extra=oper; oper=16_f6
  %finish
  oper=oper+1 %if type&wordbit#0
  dump(oper)
  %if type=bx %then dump(16_c3+extra) %andreturn
  %if type=unknown %start
    tagtype(val)=var+wordbit
    tagval(val)=-2
    fault(varund)
  %finish
  fault(form) %unless type&varmask=var
  %if type&glabit=0 %start
    %if -128<=val<=127 %then oper=16_42 %else oper=16_82
    oper=oper+4 %if index=0
  %else
    %if index=0 %start
      oper=6
    %finishelseif -128<=val<=127 %start
      oper=16_44
    %else
      oper=16_84
    %finish
  %finish
  dump(oper+extra); dump(val)
  dump(val>>8) %if oper&16_40=0
  dump(16_8B) %and dump(16_C2) %if op=rem
  %if type&wordbit=0 %and op=load %then dump(16_32) %and dump(16_e4)
  %return
shift: dump(pushax)
  direct(load,type,val,index); dump(16_89); dump(16_c1); !Mov Cx,Ax
  dump(popax)
  %if type&wordbit=0 %then dump(16_d2) %else dump(16_d3)
  dump(oper)
%end

%routine double(%integer t); ! index for word arrays
  %returnif t&wordbit=0
  dump(16_03); dump(16_c0); !Add ax,ax
%end

%routine expr
%integer oper,t,v,index
  oper=load
  %cycle
    nextatom; unary
    %if type=constant %start
      atompos=atompos-1 %and val=cexpr(0) %if oper=load
      immediate(oper,val)
    %finishelseif type&varmask=var %start
      t=type; v=val
      %if open bracket %start
        dump(pushax) %unless oper=load
        expr; double(t)
        dump(16_8b); dump(16_f0);  !Mov si,ax
        dump(popax) %unless oper=load
        close bracket
        index=1
      %finishelse index=0
      direct(oper,t,v,index)
    %finishelseif type=proc %or type=xproc %or type=spec %start
      %if oper=load %start
        call(type,val)
      %else
        dump(pushax); call(type,val); dump(16_8b); dump(16_d8);!mov bx,ax
        dump(popax); direct(oper,bx,0,0)
      %finish
    %else
      fault(form)
    %finish
    %returnunless atomtype(atompos)=op
    nextatom
    oper=val
  %repeat
%end

%routine return
  dump(16_8b); dump(16_e5); !Mov SP,BP
  dump(16_5d);              !Pop BP
  dump(16_1f) %unless program=""; !Pop DS
  %if parms=0 %then dump(16_cb) %elsestart; !Xret <n>?
    dump(16_ca)
    dump(parms); dump(parms>>8)
  %finish
  access=0
%end

%routine terminate declarations
%integer i
  fault(mispcode) %if level=0
  %if level=1 %start
    level=2; i=-floc
    %if i>127 %start
      dump(16_81); dump(16_ec); dump(i); dump(i>>8); !Sub sp,nn
    %finishelseunless i=0 %start
      dump(16_83); dump(16_ec); dump(i); !sub sp,n
    %finish
    floc=floc-2
  %finish
%end

%routine constdef
%integer c
  %cycle
    nextatom; %returnif type=sep
    fault(ambig) %unless type=unknown; c=val
    fault(form) %unless equal sign
    tagtype(c)=constant; tagval(c)=cexpr(1)
  %repeat
%end

%routine vardef(%integer key)
%integer t,lb,ub,c,r
%integername v
  %cycle
    nextatom
next: %returnif type=sep
    fault(ambig) %unless type=unknown
    t=var
    t=t+wordbit %if key=kword
    t=t+glabit %if level=0
    tagtype(val)=t; v==tagval(val)
    %if open bracket %start
      lb=cexpr(1); nextatom; fault(form) %unless type=colon
      ub=cexpr(1)+1; close bracket
    %finishelse lb=0 %and ub=1
    lb=lb+lb %and ub=ub+ub %if key=kword
    %if level=0 %start
      v=gloc-lb; t=v+ub
      %if equal sign %start
        %cycle
          nextatom
          %if gloc>=t %start
            gflush; ->next
          %finish
          %if type=string %start
            dumpstring(val)
          %finishelseif type=sep %start
            readline
          %finishelsestart
            atompos=atompos-1; c=Cexpr(1); r=1
            %if open bracket %start
              r=cexpr(1); close bracket
            %finish
            %while r>0 %cycle
              r=r-1; %if key=kword %then gword(c) %else gbyte(c)
            %repeat
          %finish
        %repeat
      %else
        gloc=t
      %finish
    %else
      fault(mispdecl) %if level=2
      floc=floc-ub+lb; v=floc-lb
    %finish
  %repeat
%end

%routine procdef(%integer key)
%integer p,sym
%string(31)s

  %routine getstring
    s=""
    %cycle
      sym=line(val); %returnif sym='"'; val=val+1; s=s.tostring(sym)
    %repeat
  %end

  nextatom; fault(ambig) %unless type=unknown
  %if key=kspec %start
    tagtype(val)=spec; tagval(val)=cloc
    nextatom; fault(form) %unless type=string
    fault(mispdecl) %unless access=0
    getstring; p=length(s)
    dump(16_ea); flush; selectoutput(object); ! Xjump
    printsymbol(8); printsymbol(p); printstring(s)
    printsymbol(7); printsymbol(0)
    cloc = cloc+4
    %return
  %finish
  fault(nested) %unless level=0; level=1; access=1; textlevel=0
  v=val; t=proc; nextatom
  %if type=string %start
    getstring
    selectoutput(object); printsymbol(1); printsymbol(6)
    printsymbol(length(s)); printstring(s)
    t=xproc; nextatom
  %finish
  tagtype(v)=t; tagval(v)=cloc
  dump(16_1e) %unless program=""; !Push DS
  dump(16_55);                    !Push BP
  dump(16_8b); dump(16_ec);       !Mov BP,SP
  %if t=xproc %and program#"" %start
    dump(16_b8); flush;           !Mov AX,nn=dseg
    printsymbol(7); printsymbol(length(program)); printstring(program)
    cloc=cloc+2
    dump(16_8E); dump(16_D8);     !Mov DS,AX
  %finish
  parms=0; oldtpos=v+1
  %while type#sep %cycle
    fault(ambig) %unless type=unknown
    tagtype(val)=var+wordbit
    parms=parms+1; nextatom
  %repeat
  p=tagpos-parms; parms=parms+parms; sym=parms+4
  sym = sym+2 %unless program=""
  %while p<tagpos %cycle
    tagval(p)=sym; sym=sym-2; p=p+1
  %repeat
  floc=0
%end

%routine instruction
%integer t,v,i,oper,st,sv,si,dt,dv
  nextatom
  %if type=kmove %start
    nextatom; oper=16_a4; !Movb
    %if type=string %start
      st=var+glabit; sv=gloc; si=0
      dumpstring(val); val=gloc-sv; gflush
      %if val&1=0 %start
        val=val>>1; oper=16_a5; !Movw
      %finish
      immediate(load,val); dump(pushax)
    %else
      expr; dump(pushax)
      nextatom; st=type; sv=val; si=0
      fault(form) %unless st&varmask=var
      %if openbracket %start
        expr; double(st); si=1; dump(pushax)
        closebracket
      %finish
      oper=16_a5 %if st&wordbit#0; !Movw
    %finish
    nextatom; dt=type; dv=val
    fault(form) %unless dt&varmask=var
    %if openbracket %start
      expr; double(dt); dump(16_8b); dump(16_f8); !Mov di,ax
      direct(lea,dt,dv,0); dump(16_03); dump(16_f8); !add di,ax
      closebracket
    %else
      direct(lea,dt,dv,0); dump(16_8b); dump(16_f8); !Mov di,ax
    %finish
    direct(lea,st,sv,0); dump(16_8b); dump(16_f0); !Mov si,ax
    %if si#0 %Start
      dump(popax); dump(16_03); dump(16_f0); !add,si,ax
    %finish
    %if dt&glabit=0 %then dump(16_16) %else dump(16_1e); !Push SS/DS
    dump(16_07);  !Pop ES
    %if st&glabit=0 %start
      dump(16_1e); dump(16_16); dump(16_1f); !Push DS,SS, Pop DS
    %finish
    dump(16_59); dump(16_F2); dump(oper); !Pop cx, rep
    dump(16_1f) %if st&glabit=0; !Pop DS
  %finishelseif type=krepeat %start
    poptext; fault(type) %unless type=repexp
    dump(16_E9); labelref(label,val)
  %finishelseif type=kjump %start
    nextatom; dump(16_e9); labelref(type,val)
  %finishelseif type=kreturn %start
    expr %unless atomtype(atompos)=sep
    return
  %finishelseif type&varmask=var %start
    t=type; v=val; i=0
    %if open bracket %start
      expr; double(t); dump(pushax)
      close bracket
      i=1
    %finish
    fault(form) %unless equal sign
    expr; dump(16_5e) %unless i=0; !pop si
    direct(store,t,v,i)
  %finishelseif type=proc %or type=xproc %or type=spec %start
    call(type,val)
  %else
    atompos=atompos-1
  %finish
%end

%integerfn cond; !Evaluate condition, return value of jump opcode
  expr; nextatom; fault(form) %unless type=comp
  v=val; nextatom; unary
  %if atomtype(atompos)#sep %or (type#constant %and type&varmask#var) %start
    dump(pushax); atompos=atompos-1; expr
    dump(16_8B); dump(16_D8); dump(popax); !Mov bx,ax
    type=bx
  %finish
  direct(cmp,type,val,0)
  %result=16_72 %if v=']'+128
  %result=16_73 %if v='['
  %result=16_74 %if v='#'
  %result=16_75 %if v='='
  %result=16_76 %if v=']'
  %result=16_77 %if v='['+128
  %result=16_7c %if v='>'+128
  %result=16_7d %if v='<'
  %result=16_7e %if v='>'
  %result=16_7f; ! %if v='<'+128
%end

! Main Program

%onevent 9,15 %start
  ->eof %if event_event=9
%finish

%if tagpos=1 %start; ! (not via event: first time)
  bools = 16_80000000
  defineparam("Source.LC",sourcefile,pamnodefault)
  defineparam("Object.IOB",objectfile,pamnewgroup)
  defineparam("Listing.LIS",listingfile,0)
  definebooleanparams("Obj,Lis",bools,0)
  processparameters(cliparam)
  objectfile = sourcefile %if objectfile=""
  listingfile = sourcefile %if listingfile=""
  %if bools<0 %then objectfile = objectfile.".IOB" %else objectfile = ":N"
  %if bools<<1<0 %then listingfile = listingfile.".LIS" %else listingfile = ":N"
  openinput(source,sourcefile.".LC")
  openoutput(object,objectfile)
  openoutput(list,listingfile)
  selectoutput(list)
  %for type=kconst,1,krepeat %cycle
    tag1(tagpos)=n1(type); tag2(tagpos)=n2(type)
    tagtype(tagpos)=type; tagval(tagpos)=-1
    tagpos=tagpos+1
  %repeat
  selectinput(source)
%finish

%cycle
   readline
   %cycle;  !Deal with labels
      nextatom
      %exitunless type=unknown %and atomtype(atompos)=colon
      terminate declarations
      tagtype(val)=label; satrefs(tagval(val),cloc)
      tagval(val)=cloc; atompos=atompos+1
      access=1
   %repeat
   %continueif type=sep %and ifpos=0
   %if type=kconst %start
      constdef
   %finishelseif type=kbyte %or type=kword %start
      vardef(type)
   %finishelseif type=kspec %or type=kproc %start
      procdef(type)
   %finishelseif type=kend %start
      %exitif level=0; level=0
      return %unless access=0; flush
      val=oldtpos; oldtpos=tagpos; tagpos=val; ! Reset tagpos before moaning
      %while oldtpos>tagpos %cycle
         oldtpos=oldtpos-1; fault(labund) %if tagtype(oldtpos)=unknown
      %repeat
      %unless textlevel=0 %start
         poptext; textlevel=0; fault(type)
      %finish
   %finishelseif type=kprogram %start
      fault(ambig) %unless program=""
      nextatom; fault(form) %unless type=string
      fault(form) %if val='"'; !Null name not allowed
      v=line(val)
      %cycle
         val=val+1; program=program.tostring(v); v=line(val)
      %repeatuntil v='"'
      program=program."_" %unless charno(program,length(program))='_'
      selectoutput(object); printsymbol(2); printsymbol(6)
      printsymbol(length(program)); printstring(program)
   %finishelseif type=kcycle %start
      terminate declarations
      pushtext(repexp,cloc)
   %finishelseif type=kelse %start
      poptext; fault(type) %unless type=finexp
      satrefs(val,cloc+3)
      poptext;  fault(type) %unless type=finexp
      dump(16_e9); dump(val); dump(val>>8)
      %if ifpos=0 %start
        pushtext(context,0)
      %else
        pushtext(finexp,cloc-2)
        atompos=ifpos+1; dump(cond!!1); dump(3)
        dump(16_E9); dump(0); dump(0)
        atompos=ifpos %and fault(form) %unless ifpos=2
        IFPOS=0
      %finish
      pushtext(finexp,cloc-2)
   %finishelseif type=kfinish %start
      poptext; fault(type) %unless type=finexp %or type=context
      satrefs(val,cloc)
      poptext; satrefs(val,cloc); access=1
   %else
      fault(varund) %if type=unknown
      terminate declarations
      %if ifpos=0 %start;  !  Statement
         atompos=atompos-1; instruction
      %finishelseif type=sep %start;  ! IF condition
         fault(form) %unless ifpos=atompos
         atompos=ifpos+1
         dump(cond!!1); dump(3); dump(16_E9); dump(0); dump(0)
         pushtext(finexp,0); pushtext(finexp,cloc-2)
      %else;   ! Statement IF condition
         oldapos=atompos-1; atompos=ifpos+1
         dump(cond)
         oldcpos=cpos; dump(0)
         atompos=oldapos; instruction
         v=cpos-oldcpos-1; fault(far) %if v>127
         code(oldcpos)=v
         access=1
      %finish
      ifpos=0
   %finish
  nextatom; fault(form) %unless type=sep %and ifpos=0
%repeat
eof:
selectoutput(object); printsymbol(10)
selectoutput(list); newline

%endofprogram