/* YAX (Yet Another Instruction Code Set) Interpreter v1.0
   simple procedural/functional language with lisp-lookalike syntax.
   eats sources with extension .yax for dinner.               */

OPT STACK=25000     /* we do heavy recursion */

OBJECT var          /* this is where we store our runtime values */
  type:INT
  name:LONG
  value:LONG
ENDOBJECT

/* intermediate codes */
ENUM ENDSOURCE,VALUE,ISTRING,IDENT,LBRACKET,RBRACKET

/* keywords */
ENUM FWRITE=100,FADD,FEQ,FUNEQ,FSUB,FMUL,FDIV,FAND,FORX,FNOT,FIF,FDO,
     FSELECT,FSET,FFOR,FWHILE,FUNTIL,FDEFUN,FLAMBDA,FAPPLY,FREADINT,
     FARRAY,FGREATER,FSMALLER,FLOCATE,FCLS,FDUMP,FWINDOW,FTELL,FTOLD,
     FSEE,FSEEN,FSTRING,FREAD,FGET,FPUT,FFILELEN,FLINE,FPLOT,FBOX,
     FMOUSEX,FMOUSEY,FMOUSE,FTEXT,LAST

CONST KEYWORDSIZE=8,
      NRKEYWORDS=LAST-99,
      IDENTNAMESPACE=30000,
      VARSTACKSPACE=50000,
      MAXARGS=5,
      ERLEN=60

/* errors */
ENUM ER_WORKSPACE=1,ER_BUF,ER_GARBAGE,ER_SYNTAX,ER_EXPKEYWORD,ER_EXPRBRACKET,
     ER_EXPEXP,ER_QUOTE,ER_COMMENT,ER_INFILE,ER_SOURCEMEM,ER_EXPIDENT,
     ER_ARGS,ER_TYPE,ER_EXPLBRACKET,ER_STACK,ER_ALLOC,ER_ARRAY,ER_FILE,
     ER_GFXWIN,ER_VALUES

/* variable types */
ENUM TINTEGER=1,TSTRING,TFUNC,TARRAY

DEF source,slen,erpos=NIL,
    ilen,ibuf,ipos:PTR TO INT,p:PTR TO INT,idents,
    name[100]:STRING,wfile,
    inputbuf[100]:STRING,winspec[100]:STRING,
    vartop,varbottom,vars,rec,globvar,
    infile,outfile,oldout,oldin,stdin,gfxwindow=0

PROC main()
  WriteF(''); stdin:=stdout
  loadsource()
  ilen:=Mul(slen,4)+1000       /* guess the needed workspace */
  ibuf:=New(ilen+10)
  idents:=String(IDENTNAMESPACE)
  vars:=New(VARSTACKSPACE)
  vartop:=vars; varbottom:=vars
  IF (ibuf=NIL) OR (idents=NIL) OR (vars=NIL)
    error(ER_WORKSPACE)
  ELSE 
    lexanalyse()               /* translate to intermediate format */
    p:=ibuf
    WHILE p[]<>ENDSOURCE DO eval()       /* run the code */
  ENDIF
  error(0)
ENDPROC

PROC lexanalyse()
  DEF pos,end,c,count,ident[50]:STRING,pos2,keypos,a,nr,ident2[50]:STRING
  pos:=source; end:=pos+slen; ipos:=ibuf; erpos:=pos
  StrCopy(idents,' ',1)
  loop:
  c:=pos[]++
  IF c>96                          /* an identifier */
    pos2:=pos-1
    WHILE pos[]++>96 DO NOP; DEC pos
    StrCopy(ident,pos2,pos-pos2)
    StrCopy(ident2,ident,ALL)
    StrAdd(ident,'..............',ALL)
    keypos:={keywords}
    nr:=0
    FOR a:=1 TO NRKEYWORDS         /* lookup keywords */
      IF StrCmp(ident,keypos,KEYWORDSIZE)
        nr:=99+a
        JUMP found
      ENDIF
      keypos:=keypos+KEYWORDSIZE
    ENDFOR
    found:
    IF nr>0                        /* keyword */
      iword(nr)
    ELSE                           /* own identifier */
      iword(IDENT)
      StrCopy(ident,' ',1)
      StrAdd(ident,ident2,ALL)
      StrAdd(ident,' ',1)
      pos2:=InStr(idents,ident,0)
      IF pos2=-1
        ilong(EstrLen(idents)+idents)
        StrAdd(idents,ident2,ALL)
        StrAdd(idents,' ',1)
        IF EstrLen(idents)=StrMax(idents) THEN error(ER_WORKSPACE)
      ELSE
        ilong(pos2+idents+1)
      ENDIF
    ENDIF
  ELSE
    SELECT c                       /* anything else */
      CASE " "
        IF pos<end THEN JUMP loop
      CASE "("
        iword(LBRACKET)
        erpos:=pos-1
        ilong(erpos)
      CASE ")"; iword(RBRACKET)
      CASE "+"; iword(FADD)
      CASE "-"
        IF pos[]=" "
          iword(FSUB)
        ELSE
          iword(VALUE)
          ilong(-Val(pos,{c}))
          IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
        ENDIF
      CASE "*"; iword(FMUL)
      CASE "/"
        IF pos[]<>"*"
          iword(FDIV)
        ELSE                       /* comment (like this one) */
          INC pos
          WHILE pos-1<end
            INC count
            IF (pos[]++="*") AND (pos[]="/") THEN JUMP out
          ENDWHILE
          error(ER_COMMENT)
          out:
          INC pos
        ENDIF
      CASE "="
        iword(FEQ)
      CASE "?"
        iword(FUNEQ)
      CASE "'"                     /* string constant */
        iword(ISTRING)
        count:=0; pos2:=pos
        WHILE pos[]++<>"'"
          INC count
          IF pos=end THEN error(ER_QUOTE)
        ENDWHILE
        iword(count)
        ilong(pos2)                /* char adress */
      CASE 10
        IF pos<end THEN JUMP loop
      CASE 0
        pos:=end
      CASE 9
        IF pos<end THEN JUMP loop
      DEFAULT
        iword(VALUE)
        ilong(Val(pos--,{c}))
        IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
    ENDSELECT
  ENDIF
  IF pos<end THEN JUMP loop
  iword(ENDSOURCE)
ENDPROC

PROC checkstop()
  IF FreeStack()<1000 THEN error(ER_STACK)
  IF CtrlC() THEN error(-1)
ENDPROC

PROC eval()                        /* main recursive evaluation function */
  DEF r=0,i,ins,p2,x:PTR TO LONG,a,adr:PTR TO var
  checkstop()
  i:=p[]++
  SELECT i
    CASE VALUE
      r:=^p++
    CASE IDENT
      r:=varvalue(^p++,TINTEGER)
    CASE LBRACKET
      erpos:=^p++
      ins:=p[]++
      IF ins=IDENT
        adr:=findvar(^p++)
        IF adr.type=TFUNC
          r:=dofunc(adr.value)
        ELSE
          IF adr.type<>TARRAY THEN error(ER_TYPE)
          x:=adr.value
          a:=eval()
          IF (a<0) OR (a>x[]) THEN error(ER_ARRAY)
          r:=x[a+1]
        ENDIF
      ELSE
        IF ins<100 THEN error(ER_EXPKEYWORD)
        SELECT ins
          CASE FWRITE                /* output string constants + expressions */
            x:=TRUE
            WHILE p[]<>RBRACKET
              IF p[]=ISTRING
                Write(stdout,Long(p+4),p[1])
                IF (p[1]=0) AND (p[4]=RBRACKET) THEN x:=FALSE
                p:=p+8
              ELSEIF p[]=IDENT
                IF (Int(findvar(Long(p+2)))=TSTRING)
                  WriteF('\s',eatstring())
                ELSE
                  WriteF('\d',eval())
                ENDIF
              ELSE
                WriteF('\d',eval())
              ENDIF
            ENDWHILE
            IF x THEN WriteF('\n')
          CASE FEQ
            r:=TRUE
            x:=eval()
            WHILE p[]<>RBRACKET DO IF x<>eval() THEN r:=FALSE
          CASE FUNEQ; r:=eval()<>eval()
          CASE FGREATER; r:=eval()>eval()
          CASE FSMALLER; r:=eval()<eval()
          CASE FADD; r:=eval(); WHILE p[]<>RBRACKET DO r:=r+eval()
          CASE FSUB; r:=eval(); WHILE p[]<>RBRACKET DO r:=r-eval()
          CASE FMUL; r:=eval(); WHILE p[]<>RBRACKET DO r:=Mul(r,eval())
          CASE FDIV; r:=eval(); WHILE p[]<>RBRACKET DO r:=Div(r,eval())
          CASE FAND; r:=eval(); WHILE p[]<>RBRACKET DO r:=r AND eval()
          CASE FORX; r:=eval(); WHILE p[]<>RBRACKET DO r:=r OR eval()
          CASE FNOT; r:=Not(eval())
          CASE FIF
            IF eval()
              r:=eval()
              IF p[]<>RBRACKET THEN skip()
            ELSE
              skip()
              IF p[]<>RBRACKET THEN r:=eval()
            ENDIF
          CASE FDO; WHILE p[]<>RBRACKET DO r:=eval()
          CASE FSELECT
            x:=eval()
            WHILE p[]<>RBRACKET DO IF x=eval() THEN r:=eval() ELSE skip()
          CASE FSET
            IF p[]=LBRACKET
              p:=p+2
              erpos:=^p++
              x:=varvalue(eatident(),TARRAY)
              a:=eval()
              IF (a<0) OR (a>x[0]) THEN error(ER_ARRAY)
              IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
              x[a+1]:=eval()
            ELSE
              x:=eatident()
              IF (p[]=LBRACKET) AND (p[3]=FLAMBDA)
                p:=p+8
                adr:=findvar(x)
                letvar(adr,p,TFUNC)
                WHILE p[]<>RBRACKET DO skip()
                p:=p+2
              ELSE
                r:=eval()
                x:=findvar(x)
                letvar(x,r,TINTEGER)
              ENDIF
            ENDIF
          CASE FFOR
            x:=eatident()
            r:=eval()
            adr:=findvar(x)
            x:=eval()
            p2:=p
            IF r>x               /* downto */
              FOR a:=r TO x STEP -1
                p:=p2
                letvar(adr,a,TINTEGER)
                WHILE p[]<>RBRACKET DO eval()
              ENDFOR
            ELSE
              FOR a:=r TO x
                p:=p2
                letvar(adr,a,TINTEGER)
                WHILE p[]<>RBRACKET DO eval()
              ENDFOR
            ENDIF
            r:=0
          CASE FWHILE
            p2:=p
            WHILE eval()
              WHILE p[]<>RBRACKET DO eval()
              p:=p2
            ENDWHILE
            WHILE p[]<>RBRACKET DO skip()
            r:=0
          CASE FUNTIL
            p2:=p
            WHILE eval()=FALSE
              WHILE p[]<>RBRACKET DO eval()
              p:=p2
            ENDWHILE
            WHILE p[]<>RBRACKET DO skip()
            r:=0
          CASE FDEFUN
            x:=eatident()
            adr:=findvar(x)
            letvar(adr,p,TFUNC)
            WHILE p[]<>RBRACKET DO skip()
          CASE FLAMBDA; error(ER_SYNTAX)
          CASE FAPPLY
            IF p[]<>IDENT
              IF (p[]<>LBRACKET) OR (p[3]<>FLAMBDA) THEN error(ER_EXPIDENT)
              p:=p+8; adr:=p
              WHILE p[]<>RBRACKET DO skip()
              p:=p+2
              r:=dofunc(adr)
            ELSE
              p:=p+2
              r:=dofunc(varvalue(^p++,TFUNC))
            ENDIF
          CASE FREADINT
            IF ReadStr(stdin,inputbuf)=-1
              r:=0
            ELSE
              r:=Val(inputbuf,{x})
            ENDIF
          CASE FARRAY
            adr:=findvar(eatident())
            a:=eval()
            x:=New(Mul(a,4)+8)
            IF x=NIL THEN error(ER_ALLOC)
            letvar(adr,x,TARRAY)
            x[0]:=a
          CASE FLOCATE; WriteF('\e[\d;\dH',eval(),eval())
          CASE FCLS; Out(stdout,12)
          CASE FDUMP
            adr:=varbottom
            WriteF('\n')
            WHILE adr<vartop
              a:=adr.name
              x:=a
              WHILE Char(x)<>" " DO INC x
              Write(stdout,a,x-a)
              x:=adr.type
              SELECT x
                CASE TINTEGER; WriteF(' = \d (int)\n',adr.value)
                CASE TSTRING;  WriteF(' = "\s" (string)\n',adr.value)
                CASE TFUNC;    WriteF(' (function)\n')
                CASE TARRAY;   WriteF('[\d] (array)\n',Long(adr.value))
              ENDSELECT
              adr:=adr+SIZEOF var
            ENDWHILE
            WriteF('\n')
          CASE FWINDOW
            StringF(winspec,'CON:\d/\d/\d/\d/',eval(),eval(),eval(),eval())
            x:=eatstring()
            StrAdd(winspec,x,ALL)
            wfile:=Open(winspec,1006)
            IF wfile=NIL THEN error(ER_FILE)
            IF conout<>NIL THEN Close(conout)
            stdout:=wfile
            conout:=stdout
            stdin:=stdout
            adr:=OpenWorkBench()
            Forbid()
            a:=NIL
            IF adr<>NIL
              adr:=Long(adr+4)
              WHILE (adr<>NIL) AND (a=NIL)
                IF StrCmp(x,Long(adr+32),ALL) THEN a:=adr
                adr:=^adr
              ENDWHILE
            ENDIF
            Permit()
            IF a THEN gfxwindow:=a
          CASE FTELL
            IF outfile<>NIL THEN Close(outfile)
            outfile:=NIL
            outfile:=Open(eatstring(),1006)
            IF outfile=NIL THEN error(ER_FILE)
            oldout:=stdout
            stdout:=outfile
          CASE FTOLD
            IF outfile<>NIL THEN Close(outfile)
            outfile:=NIL
            stdout:=oldout
          CASE FSEE
            IF infile<>NIL THEN Close(infile)
            infile:=NIL
            infile:=Open(eatstring(),1005)
            IF infile=NIL THEN error(ER_FILE)
            oldin:=stdin
            stdin:=infile
          CASE FSEEN
            IF infile<>NIL THEN Close(infile)
            infile:=NIL
            stdin:=oldin
          CASE FSTRING
            adr:=String(250)
            IF adr=NIL THEN error(ER_ALLOC)
            letvar(findvar(eatident()),adr,TSTRING)
          CASE FREAD
            x:=varvalue(eatident(),TSTRING)
            r:=ReadStr(stdin,x)
          CASE FGET; r:=Inp(stdin)
          CASE FPUT; r:=eval(); IF r<>-1 THEN Out(stdout,r)
          CASE FFILELEN
            r:=FileLength(eatstring())
            IF r=-1 THEN r:=0
          CASE FLINE; getrast(); Line(eval(),eval(),eval(),eval(),eval())
          CASE FPLOT; getrast(); Plot(eval(),eval(),eval())
          CASE FBOX
            getrast()
            a:=eval(); x:=eval(); p2:=eval(); r:=eval()
            IF (a>p2) OR (x>r) THEN error(ER_VALUES)
            Box(a,x,p2,r,eval())
            r:=0
          CASE FMOUSEX; r:=MouseX(getwin())
          CASE FMOUSEY; r:=MouseY(getwin())
          CASE FMOUSE; r:=Mouse()
          CASE FTEXT
            adr:=getrast()
            a:=eval(); x:=eval()
            Colour(eval(),eval())
            TextF(a,x,eatstring())
        ENDSELECT
      ENDIF
      IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
    DEFAULT
      IF (i=RBRACKET) OR (i=ISTRING) THEN error(ER_EXPEXP) ELSE error(ER_SYNTAX)
  ENDSELECT
ENDPROC r

PROC getwin()
  IF gfxwindow=NIL THEN error(ER_GFXWIN)
ENDPROC gfxwindow

PROC getrast()
  DEF r
  IF gfxwindow=NIL THEN error(ER_GFXWIN)
  r:=Long(gfxwindow+50)
  SetStdRast(r)
ENDPROC r

PROC eatstring()
  DEF adr,x
  IF p[]=ISTRING
    p:=p+2; x:=p[]++; adr:=^p++
    adr[x]:=0
  ELSE
    adr:=varvalue(eatident(),TSTRING)
  ENDIF
ENDPROC adr

PROC eatident()
  IF p[]++<>IDENT THEN error(ER_EXPIDENT)
ENDPROC ^p++

PROC dofunc(lcode)
  DEF args[MAXARGS]:ARRAY OF LONG,a=0,oldvarb,oldvart,oldp,x,r=0,olderpos
  checkstop()
  WHILE p[]<>RBRACKET
    IF a=MAXARGS THEN error(ER_ARGS)
    args[a]:=eval()
    INC a
  ENDWHILE
  IF rec=0 THEN globvar:=vartop
  oldvarb:=varbottom; varbottom:=vartop; oldvart:=vartop;
  oldp:=p; p:=lcode; olderpos:=erpos; INC rec
  IF p[]++<>LBRACKET THEN error(ER_EXPLBRACKET)
  erpos:=^p++
  WHILE p[]<>RBRACKET
    IF a=0 THEN error(ER_ARGS)
    x:=findvar(eatident())
    letvar(x,args[]++,TINTEGER)
    DEC a
  ENDWHILE
  IF a<>0 THEN error(ER_ARGS)
  p:=p+2
  WHILE p[]<>RBRACKET DO r:=eval()
  varbottom:=oldvarb; vartop:=oldvart; p:=oldp; erpos:=olderpos; DEC rec
ENDPROC r

PROC findvar(id)
  DEF loc=0:PTR TO var,a:PTR TO var
  IF vartop<>varbottom
    a:=varbottom                     /* check existing local vars */
    WHILE (a<vartop) AND (loc=0)
      IF a.name=id THEN loc:=a
      a:=a+SIZEOF var
    ENDWHILE
  ENDIF
  IF loc=0
    IF (rec>0) AND (globvar>vars)    /* check global vars */
      a:=vars
      WHILE (a<globvar) AND (loc=0)
        IF a.name=id THEN loc:=a
        a:=a+SIZEOF var
      ENDWHILE
    ENDIF
    IF loc=0                         /* create new var dynamically */
      loc:=vartop
      vartop:=vartop+SIZEOF var
      IF vars+VARSTACKSPACE<vartop THEN error(ER_WORKSPACE)
      loc.type:=TINTEGER
      loc.name:=id
      loc.value:=0
    ENDIF
  ENDIF
ENDPROC loc

PROC letvar(adr:PTR TO var,value,type)
  IF (adr.type<>type) AND (adr.type<>TINTEGER) THEN error(ER_TYPE)
  checkstop()
  adr.type:=type
  adr.value:=value
ENDPROC

PROC varvalue(id,type)
  DEF adr:PTR TO var
  checkstop()
  adr:=findvar(id)
  IF adr.type<>type THEN error(ER_TYPE)
ENDPROC adr.value

PROC skip()                        /* skip *one* expression */
  DEF deep=0,i
  REPEAT
    i:=p[]++
    IF (i=VALUE) OR (i=LBRACKET) OR (i=IDENT) THEN p:=p+4
    IF i=ISTRING THEN p:=p+6
    IF i=LBRACKET THEN INC deep
    IF i=RBRACKET THEN IF deep=0 THEN error(ER_EXPEXP) ELSE DEC deep
    IF i=ENDSOURCE THEN error(ER_EXPRBRACKET)
  UNTIL deep=0
ENDPROC

PROC iword(x)
  IF ibuf+ilen>ipos THEN ipos[]++:=x ELSE error(ER_BUF)
ENDPROC

PROC ilong(x)
  IF ibuf+ilen>ipos THEN ^ipos++:=x ELSE error(ER_BUF)
ENDPROC

PROC loadsource()
  DEF suxxes=FALSE,handle,read
  IF StrCmp(arg,'?',ALL) OR StrCmp(arg,'',ALL)
    WriteF('USAGE: Yax <source> (default ext. ".yax")\n')
    error(0)
  ELSE
    StrCopy(name,arg,ALL)
    StrAdd(name,'.yax',4)
    slen:=FileLength(name)
    handle:=Open(name,1005)
    IF (handle=NIL) OR (slen=-1)
      error(ER_INFILE)
    ELSE
      source:=New(slen+10)
      IF source=NIL
        error(ER_SOURCEMEM)
      ELSE
        read:=Read(handle,source,slen)
        Close(handle)
        IF read=slen 
          suxxes:=TRUE
          source[slen]:=0
        ELSE
          error(ER_INFILE)
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDPROC

PROC error(nr)
  DEF erstr[ERLEN]:STRING,a
  IF outfile<>NIL
    IF stdout=outfile THEN stdout:=oldout
    Close(outfile)
  ENDIF
  IF infile<>NIL
    IF stdin=infile THEN stdin:=oldin
    Close(infile)
  ENDIF
  WriteF('\n')
  IF nr>0
    WriteF('ERROR: ')
    SELECT nr
      CASE ER_WORKSPACE;   WriteF('Could not allocate workspace!\n')
      CASE ER_BUF;         WriteF('Buffer overflow!\n')
      CASE ER_GARBAGE;     WriteF('Garbage in line\n')
      CASE ER_SYNTAX;      WriteF('Your syntax sucks\n')
      CASE ER_EXPKEYWORD;  WriteF('Keyword identifier expected\n')
      CASE ER_EXPRBRACKET; WriteF('Right bracket expected\n')
      CASE ER_EXPEXP;      WriteF('Evaluateable expression expected\n')
      CASE ER_QUOTE;       WriteF('Missing quote \a\n')
      CASE ER_COMMENT;     WriteF('Missing "*/"\n')
      CASE ER_SOURCEMEM;   WriteF('No Memory for source!\n')
      CASE ER_INFILE;      WriteF('Could not open file "\s".\n',name)
      CASE ER_EXPIDENT;    WriteF('Identifier expected\n')
      CASE ER_ARGS;        WriteF('Illegal #of arguments\n')
      CASE ER_TYPE;        WriteF('Wrong type of variable/expression\n')
      CASE ER_EXPLBRACKET; WriteF('Left bracket expected\n')
      CASE ER_STACK;       WriteF('Nearly stack overflow: \d deep\n',rec)
      CASE ER_ALLOC;       WriteF('Dynamic allocation failed!\n')
      CASE ER_ARRAY;       WriteF('Array index out of bounds\n')
      CASE ER_FILE;        WriteF('File error\n')
      CASE ER_GFXWIN;      WriteF('No User-window for graphics\n')
      CASE ER_VALUES;      WriteF('Illegal value(s)\n')
    ENDSELECT
    IF erpos<>NIL
      StrCopy(erstr,erpos,ALL)
      FOR a:=0 TO ERLEN-1 DO IF erstr[a]=10 THEN erstr[a]:=32
      WriteF('NEARBY: \s\n',erstr)
    ENDIF
  ELSEIF nr=-1
    WriteF('*** Program halted.\n')
  ENDIF
  IF conout<>NIL THEN WriteF('Press <return> to continue ...\n')
  CleanUp(0)
ENDPROC

keywords:
CHAR 'write...', 'add.....', 'eq......', 'uneq....', 'sub.....',
     'mul.....', 'div.....', 'and.....', 'or......', 'not.....',
     'if......', 'do......', 'select..', 'set.....', 'for.....',
     'while...', 'until...', 'defun...', 'lambda..', 'apply...',
     'readint.', 'array...', 'greater.', 'smaller.', 'locate..',
     'cls.....', 'dump....', 'window..', 'tell....', 'told....',
     'see.....', 'seen....', 'string..', 'read....', 'get.....',
     'put.....', 'filelen.', 'line....', 'plot....', 'box.....',
     'mousex..', 'mousey..', 'mouse...', 'text....'