home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / dev / amiga_e-2.1b.lha / Amiga_E-2.1b / Sources / Projects / Yax.e < prev   
Encoding:
Text File  |  1993-10-05  |  18.4 KB  |  628 lines
  1. /* YAX (Yet Another Instruction Code Set) Interpreter v1.0
  2.    simple procedural/functional language with lisp-lookalike syntax.
  3.    eats sources with extension .yax for dinner.               */
  4.  
  5. OPT STACK=25000     /* we do heavy recursion */
  6.  
  7. OBJECT var          /* this is where we store our runtime values */
  8.   type:INT
  9.   name:LONG
  10.   value:LONG
  11. ENDOBJECT
  12.  
  13. /* intermediate codes */
  14. ENUM ENDSOURCE,VALUE,ISTRING,IDENT,LBRACKET,RBRACKET
  15.  
  16. /* keywords */
  17. ENUM FWRITE=100,FADD,FEQ,FUNEQ,FSUB,FMUL,FDIV,FAND,FORX,FNOT,FIF,FDO,
  18.      FSELECT,FSET,FFOR,FWHILE,FUNTIL,FDEFUN,FLAMBDA,FAPPLY,FREADINT,
  19.      FARRAY,FGREATER,FSMALLER,FLOCATE,FCLS,FDUMP,FWINDOW,FTELL,FTOLD,
  20.      FSEE,FSEEN,FSTRING,FREAD,FGET,FPUT,FFILELEN,FLINE,FPLOT,FBOX,
  21.      FMOUSEX,FMOUSEY,FMOUSE,FTEXT,LAST
  22.  
  23. CONST KEYWORDSIZE=8,
  24.       NRKEYWORDS=LAST-99,
  25.       IDENTNAMESPACE=30000,
  26.       VARSTACKSPACE=50000,
  27.       MAXARGS=5,
  28.       ERLEN=60
  29.  
  30. /* errors */
  31. ENUM ER_WORKSPACE=1,ER_BUF,ER_GARBAGE,ER_SYNTAX,ER_EXPKEYWORD,ER_EXPRBRACKET,
  32.      ER_EXPEXP,ER_QUOTE,ER_COMMENT,ER_INFILE,ER_SOURCEMEM,ER_EXPIDENT,
  33.      ER_ARGS,ER_TYPE,ER_EXPLBRACKET,ER_STACK,ER_ALLOC,ER_ARRAY,ER_FILE,
  34.      ER_GFXWIN,ER_VALUES
  35.  
  36. /* variable types */
  37. ENUM TINTEGER=1,TSTRING,TFUNC,TARRAY
  38.  
  39. DEF source,slen,erpos=NIL,
  40.     ilen,ibuf,ipos:PTR TO INT,p:PTR TO INT,idents,
  41.     name[100]:STRING,wfile,
  42.     inputbuf[100]:STRING,winspec[100]:STRING,
  43.     vartop,varbottom,vars,rec,globvar,
  44.     infile,outfile,oldout,oldin,stdin,gfxwindow=0
  45.  
  46. PROC main()
  47.   WriteF(''); stdin:=stdout
  48.   loadsource()
  49.   ilen:=Mul(slen,4)+1000       /* guess the needed workspace */
  50.   ibuf:=New(ilen+10)
  51.   idents:=String(IDENTNAMESPACE)
  52.   vars:=New(VARSTACKSPACE)
  53.   vartop:=vars; varbottom:=vars
  54.   IF (ibuf=NIL) OR (idents=NIL) OR (vars=NIL)
  55.     error(ER_WORKSPACE)
  56.   ELSE 
  57.     lexanalyse()               /* translate to intermediate format */
  58.     p:=ibuf
  59.     WHILE p[]<>ENDSOURCE DO eval()       /* run the code */
  60.   ENDIF
  61.   error(0)
  62. ENDPROC
  63.  
  64. PROC lexanalyse()
  65.   DEF pos,end,c,count,ident[50]:STRING,pos2,keypos,a,nr,ident2[50]:STRING
  66.   pos:=source; end:=pos+slen; ipos:=ibuf; erpos:=pos
  67.   StrCopy(idents,' ',1)
  68.   loop:
  69.   c:=pos[]++
  70.   IF c>96                          /* an identifier */
  71.     pos2:=pos-1
  72.     WHILE pos[]++>96 DO NOP; DEC pos
  73.     StrCopy(ident,pos2,pos-pos2)
  74.     StrCopy(ident2,ident,ALL)
  75.     StrAdd(ident,'..............',ALL)
  76.     keypos:={keywords}
  77.     nr:=0
  78.     FOR a:=1 TO NRKEYWORDS         /* lookup keywords */
  79.       IF StrCmp(ident,keypos,KEYWORDSIZE)
  80.         nr:=99+a
  81.         JUMP found
  82.       ENDIF
  83.       keypos:=keypos+KEYWORDSIZE
  84.     ENDFOR
  85.     found:
  86.     IF nr>0                        /* keyword */
  87.       iword(nr)
  88.     ELSE                           /* own identifier */
  89.       iword(IDENT)
  90.       StrCopy(ident,' ',1)
  91.       StrAdd(ident,ident2,ALL)
  92.       StrAdd(ident,' ',1)
  93.       pos2:=InStr(idents,ident,0)
  94.       IF pos2=-1
  95.         ilong(EstrLen(idents)+idents)
  96.         StrAdd(idents,ident2,ALL)
  97.         StrAdd(idents,' ',1)
  98.         IF EstrLen(idents)=StrMax(idents) THEN error(ER_WORKSPACE)
  99.       ELSE
  100.         ilong(pos2+idents+1)
  101.       ENDIF
  102.     ENDIF
  103.   ELSE
  104.     SELECT c                       /* anything else */
  105.       CASE " "
  106.         IF pos<end THEN JUMP loop
  107.       CASE "("
  108.         iword(LBRACKET)
  109.         erpos:=pos-1
  110.         ilong(erpos)
  111.       CASE ")"; iword(RBRACKET)
  112.       CASE "+"; iword(FADD)
  113.       CASE "-"
  114.         IF pos[]=" "
  115.           iword(FSUB)
  116.         ELSE
  117.           iword(VALUE)
  118.           ilong(-Val(pos,{c}))
  119.           IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  120.         ENDIF
  121.       CASE "*"; iword(FMUL)
  122.       CASE "/"
  123.         IF pos[]<>"*"
  124.           iword(FDIV)
  125.         ELSE                       /* comment (like this one) */
  126.           INC pos
  127.           WHILE pos-1<end
  128.             INC count
  129.             IF (pos[]++="*") AND (pos[]="/") THEN JUMP out
  130.           ENDWHILE
  131.           error(ER_COMMENT)
  132.           out:
  133.           INC pos
  134.         ENDIF
  135.       CASE "="
  136.         iword(FEQ)
  137.       CASE "?"
  138.         iword(FUNEQ)
  139.       CASE "'"                     /* string constant */
  140.         iword(ISTRING)
  141.         count:=0; pos2:=pos
  142.         WHILE pos[]++<>"'"
  143.           INC count
  144.           IF pos=end THEN error(ER_QUOTE)
  145.         ENDWHILE
  146.         iword(count)
  147.         ilong(pos2)                /* char adress */
  148.       CASE 10
  149.         IF pos<end THEN JUMP loop
  150.       CASE 0
  151.         pos:=end
  152.       CASE 9
  153.         IF pos<end THEN JUMP loop
  154.       DEFAULT
  155.         iword(VALUE)
  156.         ilong(Val(pos--,{c}))
  157.         IF c=0 THEN error(ER_GARBAGE) ELSE pos:=pos+c
  158.     ENDSELECT
  159.   ENDIF
  160.   IF pos<end THEN JUMP loop
  161.   iword(ENDSOURCE)
  162. ENDPROC
  163.  
  164. PROC checkstop()
  165.   IF FreeStack()<1000 THEN error(ER_STACK)
  166.   IF CtrlC() THEN error(-1)
  167. ENDPROC
  168.  
  169. PROC eval()                        /* main recursive evaluation function */
  170.   DEF r=0,i,ins,p2,x:PTR TO LONG,a,adr:PTR TO var
  171.   checkstop()
  172.   i:=p[]++
  173.   SELECT i
  174.     CASE VALUE
  175.       r:=^p++
  176.     CASE IDENT
  177.       r:=varvalue(^p++,TINTEGER)
  178.     CASE LBRACKET
  179.       erpos:=^p++
  180.       ins:=p[]++
  181.       IF ins=IDENT
  182.         adr:=findvar(^p++)
  183.         IF adr.type=TFUNC
  184.           r:=dofunc(adr.value)
  185.         ELSE
  186.           IF adr.type<>TARRAY THEN error(ER_TYPE)
  187.           x:=adr.value
  188.           a:=eval()
  189.           IF (a<0) OR (a>x[]) THEN error(ER_ARRAY)
  190.           r:=x[a+1]
  191.         ENDIF
  192.       ELSE
  193.         IF ins<100 THEN error(ER_EXPKEYWORD)
  194.         SELECT ins
  195.           CASE FWRITE                /* output string constants + expressions */
  196.             x:=TRUE
  197.             WHILE p[]<>RBRACKET
  198.               IF p[]=ISTRING
  199.                 Write(stdout,Long(p+4),p[1])
  200.                 IF (p[1]=0) AND (p[4]=RBRACKET) THEN x:=FALSE
  201.                 p:=p+8
  202.               ELSEIF p[]=IDENT
  203.                 IF (Int(findvar(Long(p+2)))=TSTRING)
  204.                   WriteF('\s',eatstring())
  205.                 ELSE
  206.                   WriteF('\d',eval())
  207.                 ENDIF
  208.               ELSE
  209.                 WriteF('\d',eval())
  210.               ENDIF
  211.             ENDWHILE
  212.             IF x THEN WriteF('\n')
  213.           CASE FEQ
  214.             r:=TRUE
  215.             x:=eval()
  216.             WHILE p[]<>RBRACKET DO IF x<>eval() THEN r:=FALSE
  217.           CASE FUNEQ; r:=eval()<>eval()
  218.           CASE FGREATER; r:=eval()>eval()
  219.           CASE FSMALLER; r:=eval()<eval()
  220.           CASE FADD; r:=eval(); WHILE p[]<>RBRACKET DO r:=r+eval()
  221.           CASE FSUB; r:=eval(); WHILE p[]<>RBRACKET DO r:=r-eval()
  222.           CASE FMUL; r:=eval(); WHILE p[]<>RBRACKET DO r:=Mul(r,eval())
  223.           CASE FDIV; r:=eval(); WHILE p[]<>RBRACKET DO r:=Div(r,eval())
  224.           CASE FAND; r:=eval(); WHILE p[]<>RBRACKET DO r:=r AND eval()
  225.           CASE FORX; r:=eval(); WHILE p[]<>RBRACKET DO r:=r OR eval()
  226.           CASE FNOT; r:=Not(eval())
  227.           CASE FIF
  228.             IF eval()
  229.               r:=eval()
  230.               IF p[]<>RBRACKET THEN skip()
  231.             ELSE
  232.               skip()
  233.               IF p[]<>RBRACKET THEN r:=eval()
  234.             ENDIF
  235.           CASE FDO; WHILE p[]<>RBRACKET DO r:=eval()
  236.           CASE FSELECT
  237.             x:=eval()
  238.             WHILE p[]<>RBRACKET DO IF x=eval() THEN r:=eval() ELSE skip()
  239.           CASE FSET
  240.             IF p[]=LBRACKET
  241.               p:=p+2
  242.               erpos:=^p++
  243.               x:=varvalue(eatident(),TARRAY)
  244.               a:=eval()
  245.               IF (a<0) OR (a>x[0]) THEN error(ER_ARRAY)
  246.               IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  247.               x[a+1]:=eval()
  248.             ELSE
  249.               x:=eatident()
  250.               IF (p[]=LBRACKET) AND (p[3]=FLAMBDA)
  251.                 p:=p+8
  252.                 adr:=findvar(x)
  253.                 letvar(adr,p,TFUNC)
  254.                 WHILE p[]<>RBRACKET DO skip()
  255.                 p:=p+2
  256.               ELSE
  257.                 r:=eval()
  258.                 x:=findvar(x)
  259.                 letvar(x,r,TINTEGER)
  260.               ENDIF
  261.             ENDIF
  262.           CASE FFOR
  263.             x:=eatident()
  264.             r:=eval()
  265.             adr:=findvar(x)
  266.             x:=eval()
  267.             p2:=p
  268.             IF r>x               /* downto */
  269.               FOR a:=r TO x STEP -1
  270.                 p:=p2
  271.                 letvar(adr,a,TINTEGER)
  272.                 WHILE p[]<>RBRACKET DO eval()
  273.               ENDFOR
  274.             ELSE
  275.               FOR a:=r TO x
  276.                 p:=p2
  277.                 letvar(adr,a,TINTEGER)
  278.                 WHILE p[]<>RBRACKET DO eval()
  279.               ENDFOR
  280.             ENDIF
  281.             r:=0
  282.           CASE FWHILE
  283.             p2:=p
  284.             WHILE eval()
  285.               WHILE p[]<>RBRACKET DO eval()
  286.               p:=p2
  287.             ENDWHILE
  288.             WHILE p[]<>RBRACKET DO skip()
  289.             r:=0
  290.           CASE FUNTIL
  291.             p2:=p
  292.             WHILE eval()=FALSE
  293.               WHILE p[]<>RBRACKET DO eval()
  294.               p:=p2
  295.             ENDWHILE
  296.             WHILE p[]<>RBRACKET DO skip()
  297.             r:=0
  298.           CASE FDEFUN
  299.             x:=eatident()
  300.             adr:=findvar(x)
  301.             letvar(adr,p,TFUNC)
  302.             WHILE p[]<>RBRACKET DO skip()
  303.           CASE FLAMBDA; error(ER_SYNTAX)
  304.           CASE FAPPLY
  305.             IF p[]<>IDENT
  306.               IF (p[]<>LBRACKET) OR (p[3]<>FLAMBDA) THEN error(ER_EXPIDENT)
  307.               p:=p+8; adr:=p
  308.               WHILE p[]<>RBRACKET DO skip()
  309.               p:=p+2
  310.               r:=dofunc(adr)
  311.             ELSE
  312.               p:=p+2
  313.               r:=dofunc(varvalue(^p++,TFUNC))
  314.             ENDIF
  315.           CASE FREADINT
  316.             IF ReadStr(stdin,inputbuf)=-1
  317.               r:=0
  318.             ELSE
  319.               r:=Val(inputbuf,{x})
  320.             ENDIF
  321.           CASE FARRAY
  322.             adr:=findvar(eatident())
  323.             a:=eval()
  324.             x:=New(Mul(a,4)+8)
  325.             IF x=NIL THEN error(ER_ALLOC)
  326.             letvar(adr,x,TARRAY)
  327.             x[0]:=a
  328.           CASE FLOCATE; WriteF('\e[\d;\dH',eval(),eval())
  329.           CASE FCLS; Out(stdout,12)
  330.           CASE FDUMP
  331.             adr:=varbottom
  332.             WriteF('\n')
  333.             WHILE adr<vartop
  334.               a:=adr.name
  335.               x:=a
  336.               WHILE Char(x)<>" " DO INC x
  337.               Write(stdout,a,x-a)
  338.               x:=adr.type
  339.               SELECT x
  340.                 CASE TINTEGER; WriteF(' = \d (int)\n',adr.value)
  341.                 CASE TSTRING;  WriteF(' = "\s" (string)\n',adr.value)
  342.                 CASE TFUNC;    WriteF(' (function)\n')
  343.                 CASE TARRAY;   WriteF('[\d] (array)\n',Long(adr.value))
  344.               ENDSELECT
  345.               adr:=adr+SIZEOF var
  346.             ENDWHILE
  347.             WriteF('\n')
  348.           CASE FWINDOW
  349.             StringF(winspec,'CON:\d/\d/\d/\d/',eval(),eval(),eval(),eval())
  350.             x:=eatstring()
  351.             StrAdd(winspec,x,ALL)
  352.             wfile:=Open(winspec,1006)
  353.             IF wfile=NIL THEN error(ER_FILE)
  354.             IF conout<>NIL THEN Close(conout)
  355.             stdout:=wfile
  356.             conout:=stdout
  357.             stdin:=stdout
  358.             adr:=OpenWorkBench()
  359.             Forbid()
  360.             a:=NIL
  361.             IF adr<>NIL
  362.               adr:=Long(adr+4)
  363.               WHILE (adr<>NIL) AND (a=NIL)
  364.                 IF StrCmp(x,Long(adr+32),ALL) THEN a:=adr
  365.                 adr:=^adr
  366.               ENDWHILE
  367.             ENDIF
  368.             Permit()
  369.             IF a THEN gfxwindow:=a
  370.           CASE FTELL
  371.             IF outfile<>NIL THEN Close(outfile)
  372.             outfile:=NIL
  373.             outfile:=Open(eatstring(),1006)
  374.             IF outfile=NIL THEN error(ER_FILE)
  375.             oldout:=stdout
  376.             stdout:=outfile
  377.           CASE FTOLD
  378.             IF outfile<>NIL THEN Close(outfile)
  379.             outfile:=NIL
  380.             stdout:=oldout
  381.           CASE FSEE
  382.             IF infile<>NIL THEN Close(infile)
  383.             infile:=NIL
  384.             infile:=Open(eatstring(),1005)
  385.             IF infile=NIL THEN error(ER_FILE)
  386.             oldin:=stdin
  387.             stdin:=infile
  388.           CASE FSEEN
  389.             IF infile<>NIL THEN Close(infile)
  390.             infile:=NIL
  391.             stdin:=oldin
  392.           CASE FSTRING
  393.             adr:=String(250)
  394.             IF adr=NIL THEN error(ER_ALLOC)
  395.             letvar(findvar(eatident()),adr,TSTRING)
  396.           CASE FREAD
  397.             x:=varvalue(eatident(),TSTRING)
  398.             r:=ReadStr(stdin,x)
  399.           CASE FGET; r:=Inp(stdin)
  400.           CASE FPUT; r:=eval(); IF r<>-1 THEN Out(stdout,r)
  401.           CASE FFILELEN
  402.             r:=FileLength(eatstring())
  403.             IF r=-1 THEN r:=0
  404.           CASE FLINE; getrast(); Line(eval(),eval(),eval(),eval(),eval())
  405.           CASE FPLOT; getrast(); Plot(eval(),eval(),eval())
  406.           CASE FBOX
  407.             getrast()
  408.             a:=eval(); x:=eval(); p2:=eval(); r:=eval()
  409.             IF (a>p2) OR (x>r) THEN error(ER_VALUES)
  410.             Box(a,x,p2,r,eval())
  411.             r:=0
  412.           CASE FMOUSEX; r:=MouseX(getwin())
  413.           CASE FMOUSEY; r:=MouseY(getwin())
  414.           CASE FMOUSE; r:=Mouse()
  415.           CASE FTEXT
  416.             adr:=getrast()
  417.             a:=eval(); x:=eval()
  418.             Colour(eval(),eval())
  419.             TextF(a,x,eatstring())
  420.         ENDSELECT
  421.       ENDIF
  422.       IF p[]++<>RBRACKET THEN error(ER_EXPRBRACKET)
  423.     DEFAULT
  424.       IF (i=RBRACKET) OR (i=ISTRING) THEN error(ER_EXPEXP) ELSE error(ER_SYNTAX)
  425.   ENDSELECT
  426. ENDPROC r
  427.  
  428. PROC getwin()
  429.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  430. ENDPROC gfxwindow
  431.  
  432. PROC getrast()
  433.   DEF r
  434.   IF gfxwindow=NIL THEN error(ER_GFXWIN)
  435.   r:=Long(gfxwindow+50)
  436.   SetStdRast(r)
  437. ENDPROC r
  438.  
  439. PROC eatstring()
  440.   DEF adr,x
  441.   IF p[]=ISTRING
  442.     p:=p+2; x:=p[]++; adr:=^p++
  443.     adr[x]:=0
  444.   ELSE
  445.     adr:=varvalue(eatident(),TSTRING)
  446.   ENDIF
  447. ENDPROC adr
  448.  
  449. PROC eatident()
  450.   IF p[]++<>IDENT THEN error(ER_EXPIDENT)
  451. ENDPROC ^p++
  452.  
  453. PROC dofunc(lcode)
  454.   DEF args[MAXARGS]:ARRAY OF LONG,a=0,oldvarb,oldvart,oldp,x,r=0,olderpos
  455.   checkstop()
  456.   WHILE p[]<>RBRACKET
  457.     IF a=MAXARGS THEN error(ER_ARGS)
  458.     args[a]:=eval()
  459.     INC a
  460.   ENDWHILE
  461.   IF rec=0 THEN globvar:=vartop
  462.   oldvarb:=varbottom; varbottom:=vartop; oldvart:=vartop;
  463.   oldp:=p; p:=lcode; olderpos:=erpos; INC rec
  464.   IF p[]++<>LBRACKET THEN error(ER_EXPLBRACKET)
  465.   erpos:=^p++
  466.   WHILE p[]<>RBRACKET
  467.     IF a=0 THEN error(ER_ARGS)
  468.     x:=findvar(eatident())
  469.     letvar(x,args[]++,TINTEGER)
  470.     DEC a
  471.   ENDWHILE
  472.   IF a<>0 THEN error(ER_ARGS)
  473.   p:=p+2
  474.   WHILE p[]<>RBRACKET DO r:=eval()
  475.   varbottom:=oldvarb; vartop:=oldvart; p:=oldp; erpos:=olderpos; DEC rec
  476. ENDPROC r
  477.  
  478. PROC findvar(id)
  479.   DEF loc=0:PTR TO var,a:PTR TO var
  480.   IF vartop<>varbottom
  481.     a:=varbottom                     /* check existing local vars */
  482.     WHILE (a<vartop) AND (loc=0)
  483.       IF a.name=id THEN loc:=a
  484.       a:=a+SIZEOF var
  485.     ENDWHILE
  486.   ENDIF
  487.   IF loc=0
  488.     IF (rec>0) AND (globvar>vars)    /* check global vars */
  489.       a:=vars
  490.       WHILE (a<globvar) AND (loc=0)
  491.         IF a.name=id THEN loc:=a
  492.         a:=a+SIZEOF var
  493.       ENDWHILE
  494.     ENDIF
  495.     IF loc=0                         /* create new var dynamically */
  496.       loc:=vartop
  497.       vartop:=vartop+SIZEOF var
  498.       IF vars+VARSTACKSPACE<vartop THEN error(ER_WORKSPACE)
  499.       loc.type:=TINTEGER
  500.       loc.name:=id
  501.       loc.value:=0
  502.     ENDIF
  503.   ENDIF
  504. ENDPROC loc
  505.  
  506. PROC letvar(adr:PTR TO var,value,type)
  507.   IF (adr.type<>type) AND (adr.type<>TINTEGER) THEN error(ER_TYPE)
  508.   checkstop()
  509.   adr.type:=type
  510.   adr.value:=value
  511. ENDPROC
  512.  
  513. PROC varvalue(id,type)
  514.   DEF adr:PTR TO var
  515.   checkstop()
  516.   adr:=findvar(id)
  517.   IF adr.type<>type THEN error(ER_TYPE)
  518. ENDPROC adr.value
  519.  
  520. PROC skip()                        /* skip *one* expression */
  521.   DEF deep=0,i
  522.   REPEAT
  523.     i:=p[]++
  524.     IF (i=VALUE) OR (i=LBRACKET) OR (i=IDENT) THEN p:=p+4
  525.     IF i=ISTRING THEN p:=p+6
  526.     IF i=LBRACKET THEN INC deep
  527.     IF i=RBRACKET THEN IF deep=0 THEN error(ER_EXPEXP) ELSE DEC deep
  528.     IF i=ENDSOURCE THEN error(ER_EXPRBRACKET)
  529.   UNTIL deep=0
  530. ENDPROC
  531.  
  532. PROC iword(x)
  533.   IF ibuf+ilen>ipos THEN ipos[]++:=x ELSE error(ER_BUF)
  534. ENDPROC
  535.  
  536. PROC ilong(x)
  537.   IF ibuf+ilen>ipos THEN ^ipos++:=x ELSE error(ER_BUF)
  538. ENDPROC
  539.  
  540. PROC loadsource()
  541.   DEF suxxes=FALSE,handle,read
  542.   IF StrCmp(arg,'?',ALL) OR StrCmp(arg,'',ALL)
  543.     WriteF('USAGE: Yax <source> (default ext. ".yax")\n')
  544.     error(0)
  545.   ELSE
  546.     StrCopy(name,arg,ALL)
  547.     StrAdd(name,'.yax',4)
  548.     slen:=FileLength(name)
  549.     handle:=Open(name,1005)
  550.     IF (handle=NIL) OR (slen=-1)
  551.       error(ER_INFILE)
  552.     ELSE
  553.       source:=New(slen+10)
  554.       IF source=NIL
  555.         error(ER_SOURCEMEM)
  556.       ELSE
  557.         read:=Read(handle,source,slen)
  558.         Close(handle)
  559.         IF read=slen 
  560.           suxxes:=TRUE
  561.           source[slen]:=0
  562.         ELSE
  563.           error(ER_INFILE)
  564.         ENDIF
  565.       ENDIF
  566.     ENDIF
  567.   ENDIF
  568. ENDPROC
  569.  
  570. PROC error(nr)
  571.   DEF erstr[ERLEN]:STRING,a
  572.   IF outfile<>NIL
  573.     IF stdout=outfile THEN stdout:=oldout
  574.     Close(outfile)
  575.   ENDIF
  576.   IF infile<>NIL
  577.     IF stdin=infile THEN stdin:=oldin
  578.     Close(infile)
  579.   ENDIF
  580.   WriteF('\n')
  581.   IF nr>0
  582.     WriteF('ERROR: ')
  583.     SELECT nr
  584.       CASE ER_WORKSPACE;   WriteF('Could not allocate workspace!\n')
  585.       CASE ER_BUF;         WriteF('Buffer overflow!\n')
  586.       CASE ER_GARBAGE;     WriteF('Garbage in line\n')
  587.       CASE ER_SYNTAX;      WriteF('Your syntax sucks\n')
  588.       CASE ER_EXPKEYWORD;  WriteF('Keyword identifier expected\n')
  589.       CASE ER_EXPRBRACKET; WriteF('Right bracket expected\n')
  590.       CASE ER_EXPEXP;      WriteF('Evaluateable expression expected\n')
  591.       CASE ER_QUOTE;       WriteF('Missing quote \a\n')
  592.       CASE ER_COMMENT;     WriteF('Missing "*/"\n')
  593.       CASE ER_SOURCEMEM;   WriteF('No Memory for source!\n')
  594.       CASE ER_INFILE;      WriteF('Could not open file "\s".\n',name)
  595.       CASE ER_EXPIDENT;    WriteF('Identifier expected\n')
  596.       CASE ER_ARGS;        WriteF('Illegal #of arguments\n')
  597.       CASE ER_TYPE;        WriteF('Wrong type of variable/expression\n')
  598.       CASE ER_EXPLBRACKET; WriteF('Left bracket expected\n')
  599.       CASE ER_STACK;       WriteF('Nearly stack overflow: \d deep\n',rec)
  600.       CASE ER_ALLOC;       WriteF('Dynamic allocation failed!\n')
  601.       CASE ER_ARRAY;       WriteF('Array index out of bounds\n')
  602.       CASE ER_FILE;        WriteF('File error\n')
  603.       CASE ER_GFXWIN;      WriteF('No User-window for graphics\n')
  604.       CASE ER_VALUES;      WriteF('Illegal value(s)\n')
  605.     ENDSELECT
  606.     IF erpos<>NIL
  607.       StrCopy(erstr,erpos,ALL)
  608.       FOR a:=0 TO ERLEN-1 DO IF erstr[a]=10 THEN erstr[a]:=32
  609.       WriteF('NEARBY: \s\n',erstr)
  610.     ENDIF
  611.   ELSEIF nr=-1
  612.     WriteF('*** Program halted.\n')
  613.   ENDIF
  614.   IF conout<>NIL THEN WriteF('Press <return> to continue ...\n')
  615.   CleanUp(0)
  616. ENDPROC
  617.  
  618. keywords:
  619. CHAR 'write...', 'add.....', 'eq......', 'uneq....', 'sub.....',
  620.      'mul.....', 'div.....', 'and.....', 'or......', 'not.....',
  621.      'if......', 'do......', 'select..', 'set.....', 'for.....',
  622.      'while...', 'until...', 'defun...', 'lambda..', 'apply...',
  623.      'readint.', 'array...', 'greater.', 'smaller.', 'locate..',
  624.      'cls.....', 'dump....', 'window..', 'tell....', 'told....',
  625.      'see.....', 'seen....', 'string..', 'read....', 'get.....',
  626.      'put.....', 'filelen.', 'line....', 'plot....', 'box.....',
  627.      'mousex..', 'mousey..', 'mouse...', 'text....'
  628.