home *** CD-ROM | disk | FTP | other *** search
/ Gold Fish 2 / goldfish_vol2_cd1.bin / files / dev / e / amiga_e / src / lang / forth.e next >
Text File  |  1992-09-02  |  4KB  |  127 lines
  1. /* TinyForth, a subset Forth interpreter
  2.    no functions *yet*, so may be used as funny calculator
  3.    with stack. exits on QUIT<cr> or <ctrlc><cr> */
  4.  
  5. CONST MAXSTACK=1000,MAXRSTACK=200
  6. ENUM NO_MES,OK,ER_UNDERFLOW,ER_OVERFLOW,ER_SYM
  7.  
  8. DEF con,stop=FALSE,error=OK,crflag=TRUE,
  9.     inp[100]:STRING,
  10.     item[50]:STRING, item2[50]:STRING,
  11.     stack[MAXSTACK]:ARRAY OF LONG, rstack[MAXRSTACK]:ARRAY OF LONG,
  12.     sp:PTR TO LONG, rsp:PTR TO LONG
  13.  
  14. RAISE "^C" IF CtrlC()=TRUE
  15.  
  16. PROC main() HANDLE
  17.   con:=Open('CON:0/11/640/100/TinyForth',1005)
  18.   IF con
  19.     stdout:=con
  20.     WriteF('TinyForth interpreter v0.1 (c) 1992 by $#%!\n')
  21.     sp:=stack; rsp:=rstack
  22.     REPEAT
  23.       IF crflag=FALSE THEN WriteF('\n')
  24.       SELECT error
  25.         CASE OK;           WriteF('Ok.\n')
  26.         CASE ER_UNDERFLOW; WriteF('STACK UNDERFLOW.\n')
  27.         CASE ER_OVERFLOW;  WriteF('STACK OVERFLOW.\n')
  28.         CASE ER_SYM;       WriteF('\s?\n',item)
  29.       ENDSELECT
  30.       WriteF('>')
  31.       ReadStr(con,inp)
  32.       CtrlC()
  33.       error:=OK; crflag:=TRUE
  34.       eval(inp)
  35.     UNTIL stop
  36.     Close(con)
  37.   ENDIF
  38. EXCEPT DO
  39.   Close(con)
  40. ENDPROC
  41.  
  42. PROC eval(c)
  43.   DEF pos,end,symlong,p,i,j,k
  44.   pos:=c; end:=c+EstrLen(c)
  45.   WHILE (pos<end) AND (error<=OK)
  46.     CtrlC()
  47.     pos:=getsym(pos)
  48.     StrCopy(item2,item,ALL)
  49.     UpperStr(item2)
  50.     StrAdd(item2,'   ',3)
  51.     symlong:=Long(item2)
  52.     SELECT symlong
  53.       CASE "DUP "; i:=pop(); push(i); push(i)
  54.       CASE "DROP"; pop()
  55.       CASE "SWAP"; i:=pop(); j:=pop(); push(i); push(j)
  56.       CASE "OVER"; i:=pop(); j:=pop(); push(j); push(i); push(j)
  57.       CASE "ROT "; i:=pop(); j:=pop(); k:=pop(); push(j); push(i); push(k)
  58.       CASE "PICK"; i:=pop(); IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE push(sp[-i])
  59.       CASE "ROLL"; i:=pop(); j:=sp[-i]; IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE FOR k:=-i TO -2 DO sp[k]:=sp[k+1]; pop(); push(j)
  60.       CASE "?DUP"; i:=pop(); push(i); IF i THEN push(i)
  61.       CASE "DEPT"; push(sp-stack/4)
  62.       CASE ">R  "; rpush(pop())
  63.       CASE "R>  "; push(rpop())
  64.       CASE "R@  "; i:=rpop(); push(i); rpush(i)
  65.  
  66.       CASE "<   "; push(Not(pop()<=pop()))
  67.       CASE "=   "; push(pop()=pop())
  68.       CASE ">   "; push(Not(pop()>=pop()))
  69.       CASE "0<  "; push(pop()<0)
  70.       CASE "0=  "; push(0=pop())
  71.       CASE "0>  "; push(pop()>0)
  72.       CASE "D<  "; push(Not(pop()<=pop()))
  73.       CASE "U<  "; push(Not(pop()<=pop()))
  74.       CASE "NOT "; push(Not(pop()))
  75.  
  76.       CASE ".   "; WriteF('\d ',pop()); crflag:=FALSE
  77.       CASE "CR  "; WriteF('\n'); crflag:=TRUE
  78.       CASE "EMIT"; WriteF('\c',pop()); crflag:=FALSE
  79.       CASE "TYPE"; i:=pop(); j:=pop(); FOR k:=1 TO i DO WriteF('\c',j[]++)
  80.       CASE "SPAC"; IF Long(item2+4)="E   " THEN i:=1 ELSE i:=pop(); FOR j:=1 TO i DO WriteF(' '); crflag:=FALSE
  81.  
  82.       CASE "+   "; push(pop()+pop())
  83.       CASE "-   "; i:=pop(); push(pop()-i)
  84.       CASE "*   "; push(Mul(pop(),pop()))
  85.       CASE "/   "; i:=pop(); push(Div(pop(),i))
  86.  
  87.       CASE "ABOR"; sp:=stack
  88.       CASE "QUIT"; stop:=TRUE
  89.       DEFAULT
  90.         IF Int(item)=$2E22      /* ." construction */
  91.           crflag:=FALSE
  92.           Write(stdout,item+2,EstrLen(item)-3)
  93.         ELSE
  94.           IF item[0]="-" THEN p:=item+1 ELSE p:=item
  95.           i:=Val(p,{j})
  96.           IF (j=0) THEN error:=ER_SYM
  97.           IF p<>item THEN i:=Mul(i,-1)
  98.           push(i)
  99.        ENDIF
  100.     ENDSELECT
  101.   ENDWHILE
  102. ENDPROC
  103.  
  104. PROC pop() RETURN IF sp<=stack THEN error:=ER_UNDERFLOW ELSE sp[]--
  105. PROC rpop() RETURN IF rsp<=rstack THEN error:=ER_UNDERFLOW ELSE rsp[]--
  106. PROC push(val); IF MAXSTACK*4+stack<=sp THEN error:=ER_OVERFLOW ELSE sp[]++:=val; ENDPROC
  107. PROC rpush(val); IF MAXRSTACK*4+rstack<=rsp THEN error:=ER_OVERFLOW ELSE rsp[]++:=val; ENDPROC
  108.  
  109. PROC getsym(p)
  110.   DEF p2
  111.   p:=TrimStr(p)
  112.   IF p[0]="("
  113.     p2:=InStr(p,')',0)
  114.     IF p2=-1 THEN p2:=1000
  115.     p:=TrimStr(p+p2+1)
  116.   ENDIF
  117.   IF p[0]="." AND p[1]=34
  118.     p2:=InStr(p,'"',2)
  119.     IF p2=-1 THEN p2:=1000 ELSE INC p2
  120.     StrCopy(item,p,p2)
  121.   ELSE
  122.     p2:=InStr(p,' ',0)
  123.     IF p2=-1 THEN p2:=1000
  124.     StrCopy(item,p,p2)
  125.   ENDIF
  126. ENDPROC p+p2+1
  127.