AMIGA PD 1/AMIGA-PD-1.iso/Programme_zum_Heft/Programmieren/Kurztests/ACE/archive/ACEPRGS.LHA/lang/TinyBasic.lha/TinyBASIC.b

Text File | 1994-01-21 | 15KB | 872 lines

{ ** Tiny BASIC Interpreter **

  Author: David Benn
    Date: 21st,22nd March 1992,
        26th-29th January 1993,
      25th March 1993,
      10th June 1993 }

version$="$VER: TinyBASIC 1.1 10 06 1993"

library exec

declare function AllocMem& library exec
declare function FreeMem library exec

'..memory constants
const MEMF_PUBLIC=1&
const MEMF_CLEAR=65536
const NULL=0&

'..boolean constants
const true=-1&
const false=0&

'..stack
const maxstack=100
dim stack(maxstack)
shortint stacktop

'..intrinsic functions
const maxfunc=8
dim funcs$(maxfunc)

for i%=1 to maxfunc
  read funcs$(i%)
next

data "SIN","COS","TAN","LOG","SQR","FIX","INT","RND"

{ * tokens * }
const maxsym=34

'..special symbols
const alpha=1
const number=2
const stringliteral=3
const plus=4
const minus=5
const mult=6
const div=7
const pow=8
const lparen=9
const rparen=10
const eq=11
const lt=12
const gt=13
const ltoreq=14
const gtoreq=15
const noteq=16
const comma=17
const colon=18
const eos=19

'..reserved words
const clssym=20
const elsesym=21
const gotosym=22
const ifsym=23
const inputsym=24
const letsym=25
const listsym=26
const loadsym=27
const newsym=28
const printsym=29
const runsym=30
const savesym=31
const stopsym=32
const thensym=33

const undef=maxsym

'..token strings
dim sym.name$(maxsym)
{for i%=1 to maxsym
 read sym.name$(i%)
next
data alpha,number,stringliteral
data "+","-","*","/","^"
data "(",")","=","<",">","<=",">=","<>",",",":",eos
data "cls","else","goto","if","input","let","list","load"
data "new","print ","run","save","stop","then"
data undef}

'..reserved words
const maxword=14
dim word$(maxword)

for i%=1 to maxword
  read word$(i%)
next

data "CLS","ELSE","GOTO","IF","INPUT","LET","LIST"
data "LOAD","NEW","PRINT","RUN","SAVE","STOP","THEN"

'..errors
longint bad
const DIVBYZERO=1
const SYNTAX=2
const STKOVFL=3
const STKUFL=4
const LINEOUTOFRANGE=5
const NOSUCHLINE=6
const OUTOFMEMORY=7
const CANNOTOPENFILE=8
const FILENOTFOUND=9

'..program lines
const maxlines=1000
dim code_ptr&(maxlines)

for i%=0 to maxlines
  code_ptr&(i%)=NULL
next
shortint topline

'..program counter
shortint pc,old_pc

'..miscellaneous globals
shortint n,length
longint halt_requested
ch$=""
ut_ch$=""
buf$=""
ut_buf$=""
obj$=""
sym=undef

'..variables
dim var(25)
for i%=0 to 25
 var(i%)=0
next

'..forward references
declare SUB expr
declare SUB statement
declare SUB parse_line

'..enable CTRL-C breaks
ON BREAK GOTO start
BREAK ON

{SUB show.sym(n)
shared sym.name$
  print sym.name$(n)
END SUB}

SUB er(n)
shared bad,pc,old_pc
  if bad then exit sub    '..report only 1 error per line
  case
    n=DIVBYZERO     : print "DIVISION BY ZERO";
    n=SYNTAX        : print "SYNTAX ERROR";
    n=STKOVFL        : print "STACK OVERFLOW";
    n=STKUFL        : print "STACK UNDERFLOW";
    n=LINEOUTOFRANGE    : print "LINE OUT OF RANGE 1 TO";str$(maxlines);
    n=NOSUCHLINE    : print "LINE DOES NOT EXIST";
    n=OUTOFMEMORY    : print "OUT OF MEMORY";
    n=CANNOTOPENFILE    : print "CAN'T OPEN FILE FOR WRITING";
    n=FILENOTFOUND    : print "FILE NOT FOUND";
  end case
  if pc<>0 then print " IN LINE";old_pc else print
  bad=true
END SUB

SUB nextch
shared ch$,ut_ch$,buf$,ut_buf$,n,length

  if n<=length then
    ch$=mid$(buf$,n,1)
    ut_ch$=mid$(ut_buf$,n,1)
    ++n
  else
    ch$=""
  end if
END SUB

SUB rsvd.wd%(x$)
shared word$
shortint i,num

  i=1
  while i<=maxword and num=0
    if x$ = word$(i) then num=i
    ++i
  wend

  if num=0 then rsvd.wd%=alpha else rsvd.wd%=num+eos
END SUB

SUB insymbol
shared ch$,ut_ch$,sym,obj$
shortint periods

 obj$=""
 sym=undef

 '...skip whitespace
 if ch$<=" " and ch$<>"" then
   repeat
     nextch
   until ch$>" " or ch$=""
 end if

 '..end of string?
 if ch$="" then sym=eos:exit sub

 '...characters
 if ch$>="A" and ch$<="Z" then
   while ch$>="A" and ch$<="Z"
     obj$=obj$+ch$
     nextch
   wend
   sym=rsvd.wd%(obj$)
 else
   '...unsigned numeric constant
   if (ch$>="0" and ch$<="9") or ch$="." then
     sym=number
     while (ch$>="0" and ch$<="9") or ch$="."
       if ch$="." then ++periods
       obj$=obj$+ch$
       nextch
     wend
     if periods > 1 then
       sym=undef
       er(SYNTAX)
     end if
   else
     '..string literal
     if ch$=chr$(34) then
       sym=stringliteral
       nextch
       while ch$<>chr$(34) and ch$<>""
     obj$=obj$+ut_ch$
         nextch
       wend
       if ch$<>chr$(34) then call er(SYNTAX):sym=undef:exit sub
       nextch
     else
       '...single character
       obj$=ch$
       case
         obj$="+" : sym=plus
         obj$="-" : sym=minus
         obj$="*" : sym=mult
         obj$="/" : sym=div
         obj$="^" : sym=pow
         obj$="(" : sym=lparen
         obj$=")" : sym=rparen
         obj$="=" : sym=eq
         obj$="<" : sym=lt
         obj$=">" : sym=gt
     obj$="," : sym=comma
     obj$=":" : sym=colon
       end case

       nextch

       '..<= <> >= ?
       if sym=lt and ch$="=" then
         sym=ltoreq:nextch
       else
         if sym=lt and ch$=">" then
           sym=noteq:nextch
         else
           if sym=gt and ch$="=" then
             sym=gtoreq:nextch
           end if
         end if
       end if

       if sym=undef then call er(SYNTAX)
     end if
   end if
 end if

 'show.sym(sym)
END SUB

SUB push(x)
shared stacktop,stack

  if stacktop>maxstack then
    er(STKOVFL)
  else
    stack(stacktop)=x
    ++stacktop
  end if
END SUB

SUB pop
shared stacktop,stack

  --stacktop
  if stacktop<0 then
    er(STKUFL)
  else
    pop=stack(stacktop)
  end if
END SUB

SUB func
shared funcs$,obj$,sym,bad
longint found
shortint funct

  '..search for the function.
  found=false
  i=1
  while i<=maxfunc and not found
    if funcs$(i) = obj$ then funct=i:found=true else ++i
  wend

  if funct then
    '..function
    fun$=funcs$(funct)
  else
    '..variable
    func=0
    exit sub
  end if

  '...push the argument
  if funct<8 then
    insymbol
    if sym<>lparen then
      er(SYNTAX)
      funct=0
    else
      insymbol
      expr
      if bad then func=0:exit sub
      if sym<>rparen then call er(SYNTAX):funct=0
    end if
  end if

  '...execute function
  case
    funct=1 : push(sin(pop))
    funct=2 : push(cos(pop))
    funct=3 : push(tan(pop))
    funct=4 : push(log(pop))
    funct=5 : push(sqr(pop))
    funct=6 : push(fix(pop))
    funct=7 : push(clng(pop))
    funct=8 : push(rnd)
  end case

  func=-1
END SUB

SUB var_index%(x$)
  var_index% = asc(x$)-asc("A")
END SUB

SUB factor
shared sym,obj$,bad,var

  if sym=number then
    '..numeric literal
    push(val(obj$))
  else
    '..parenthesised expression?
    if sym=lparen then
      insymbol
      if sym=eos then call er(SYNTAX):exit sub
      expr
      if bad then exit sub
      if sym<>rparen then call er(SYNTAX):exit sub
    else
      '..function or variable?
      if not func then
        if sym=alpha then
          push(var(var_index%(obj$)))
        else
          '..unknown
          er(SYNTAX)
    end if
      end if
    end if
  end if

  insymbol
END SUB

SUB expterm
shared sym,bad
  factor
  while sym=pow
    insymbol
    factor
    if bad then exit sub
    op2=pop
    op1=pop
    push(op1^op2)
  wend
END SUB

SUB negterm
shared sym,bad
longint negate
  negate=false
  if sym=minus then
    negate=true
    insymbol
  else
    if sym=plus then
      insymbol
    end if
  end if
  expterm
  if bad then exit sub
  if negate then call push(-pop)
END SUB

SUB term
shared sym,bad
shortint op
  negterm
  while sym=mult or sym=div
    op=sym
    insymbol
    negterm
    if bad then exit sub
    op2=pop
    op1=pop
    if op=mult then
      push(op1*op2)
    else
      if op2<>0 then
        push(op1/op2)
      else
        er(DIVBYZERO)
      end if
    end if
  wend
END SUB

SUB simple_expr
shared sym,bad
shortint op
  term
  while sym=plus or sym=minus
    op=sym
    insymbol
    term
    if bad then exit sub
    op2=pop
    op1=pop
    if op=plus then
      push(op1+op2)
    else
      push(op1-op2)
    end if
  wend
END SUB

SUB expr
shared sym,bad
shortint op
  simple_expr
  while sym=eq or sym=lt or sym=gt or sym=ltoreq or sym=gtoreq or sym=noteq
    op=sym
    insymbol
    simple_expr
    if bad then exit sub
    op2=pop
    op1=pop
    case
      op=eq     : push(op1=op2)
      op=lt     : push(op1<op2)
      op=gt     : push(op1>op2)
      op=ltoreq : push(op1<=op2)
      op=gtoreq : push(op1>=op2)
      op=noteq  : push(op1<>op2)
    end case
  wend
END SUB

SUB assign_to_variable
shared sym,bad,obj$,var

 '..variable assignment
 insymbol
 if sym<>alpha then
   er(SYNTAX)
   exit sub
 end if
 variable$=obj$
 insymbol
 if sym=eq then
   insymbol
   if sym=eos then call er(SYNTAX):exit sub
   expr
   if bad then exit sub else var(var_index%(variable$))=pop
 end if
END SUB

SUB if_statement
shared sym,bad

  '..IF-THEN-ELSE
  insymbol
  expr
  if bad then exit sub
  '..THEN
  if sym=thensym then
    if pop=-1 then
      insymbol
      statement
      while sym<>eos:insymbol:wend
    else
      while sym<>elsesym and sym<>eos
        insymbol
      wend
      '..ELSE (optional)
      if sym=elsesym then
        insymbol
     statement
      end if
    end if
  else
    er(SYNTAX)
  end if
END SUB

SUB modify_program(num%)
shared sym,buf$,ut_buf$,code_ptr&
shared n,length,topline
longint strptr

 { kill or modify a program line }

 '..free memory associated with line num%?
 '..(have to do this whether we are
 '...killing OR replacing a line).

 if num%<1 or num%>maxlines then call er(LINEOUTOFRANGE):exit sub

 strptr=code_ptr&(num%)
 if strptr then
   FreeMem(strptr,len(cstr(strptr))+1&)
   code_ptr&(num%)=NULL
 end if

 if n<=length then
   '..** replace line num% if in range **
   if num%>=1 and num%<=maxlines then
     x$=mid$(ut_buf$,n)
     '..check for string literals and don't
     '..change the case of their characters.
     y$=""
     i%=1
     ln%=len(x$)
     while i%<=ln%
       c$=mid$(x$,i%,1)
       if c$=chr$(34) then
         y$=y$+c$
         repeat
           ++i%
           c$=mid$(x$,i%,1)
           if c$<>chr$(34) then y$=y$+c$
         until c$=chr$(34) or i%=ln%
         y$=y$+c$
         ++i%
       else
         y$=y$+ucase$(c$)
         ++i%
       end if
     wend
     x$=y$

     '..allocate memory for line and store it.
     strptr=AllocMem(len(x$)+1&,MEMF_PUBLIC or MEMF_CLEAR)
     if strptr=NULL then call er(OUTOFMEMORY):exit sub
     string basic_line address strptr
     basic_line=x$
     code_ptr&(num%)=strptr
     if num%>topline then topline=num%
   else
     er(LINEOUTOFRANGE)
   end if
 else
   '..find next lowest non-null line
   '..after removal of highest line.
   if num%=topline then
     repeat
       --num%
     until code_ptr&(num%)<>NULL or num%<1
     topline=num%  '..code_ptr&(0) is sentinel.
   end if
 end if
END SUB

SUB list_program
shared code_ptr&,topline
longint strptr

  { list current program }

  i%=1
  while i%<=topline
    num$=str$(i%)
    num$=right$(num$,len(num$)-1&)
    strptr=code_ptr&(i%)
    if strptr then print num$;" ";cstr(strptr)
    ++i%
  wend
END SUB

SUB clear_program
shared code_ptr&,topline
longint strptr

  { clear program memory }

  for i%=0 to maxlines
    strptr=code_ptr&(i%)
    if strptr then
      FreeMem(strptr,len(cstr(strptr))+1&)
      code_ptr&(i%)=NULL
    end if
  next

  topline=0
END SUB

SUB run_program
shared code_ptr&,pc,old_pc,buf$,ut_buf$
shared bad,topline,halt_requested
longint strptr

 { execute current program }

 if topline<1 then exit sub

 pc=1
 repeat
   strptr=code_ptr&(pc)
   old_pc=pc
   ++pc
   if strptr then
     buf$=cstr(strptr)
     ut_buf$=buf$
     parse_line
   end if
 until bad or halt_requested or pc>topline
END SUB

SUB load_program
shared sym,obj$,code_ptr&
shared topline
longint strptr

 { load program from file }

 insymbol
 if sym=stringliteral then
   open "I",#2,obj$
   if handle(2)<>NULL then
     clear_program
     print "LOADING ";obj$;".. ";
     while not eof(2)
       input #2,num%
       line input #2,x$
       strptr=AllocMem(len(x$)+1&,MEMF_PUBLIC or MEMF_CLEAR)
       if strptr=NULL then call er(OUTOFMEMORY):close #2:exit sub
       string basic_line address strptr
       basic_line=x$
       code_ptr&(num%)=strptr
       if num%>topline then topline=num%
     wend
     close #2
     print "PROGRAM LOADED."
   else
     er(FILENOTFOUND)
   end if
 else
   er(SYNTAX)
 end if
END SUB

SUB save_program
shared sym,obj$,code_ptr&
shared topline
longint strptr

 { store current program in file }

 if topline<1 then exit sub

 insymbol
 if sym=stringliteral then
   open "O",#3,obj$
   if handle(3)<>NULL then
     print "SAVING ";obj$;".. ";
     for i%=1 to topline
       strptr=code_ptr&(i%)
       if strptr then print #3,i%;cstr(strptr)
     next
     print "PROGRAM SAVED."
     close #3
   else
     er(CANNOTOPENFILE)
   end if
 else
   er(SYNTAX)
 end if
END SUB

SUB statement
shared sym,bad,obj$,var,pc,code_ptr&
shared halt_requested

 '..EMPTY STATEMENT
 if sym=eos then exit sub

 '..NUMBER
 if sym=number then
   modify_program(fix(val(obj$)))
   exit sub
 end if

 '..CLS
 if sym=clssym then cls:exit sub

 '..GOTO
 if sym=gotosym then
   insymbol
   if sym=eos then call er(SYNTAX):exit sub
   expr
   if not bad then pc=pop else exit sub
   if pc<1 or pc>maxlines then call er(LINEOUTOFRANGE)
   if code_ptr&(pc)=NULL then call er(NOSUCHLINE)
   exit sub
 end if

 '..IF
 if sym=ifsym then
   if_statement
   exit sub
 end if

 '..INPUT
 if sym=inputsym then
   insymbol
   if sym=alpha then
     input var(var_index%(obj$))
   else
     er(SYNTAX)
   end if
   exit sub
 end if

 '..LET
 if sym=letsym then
   assign_to_variable
   exit sub
 end if

 '..LIST
 if sym=listsym then
   list_program
   exit sub
 end if

 '..LOAD
 if sym=loadsym then
   load_program
   exit sub
 end if

 '..NEW
 if sym=newsym then
   clear_program
   exit sub
 end if

 '..PRINT
 if sym=printsym then
   repeat
     insymbol
     if sym=eos then call er(SYNTAX):exit sub
     if sym=stringliteral then
       print obj$;
       insymbol
     else
       expr
       if not bad then print pop;
     end if
   until sym<>comma
   print
   exit sub
 end if

 '..RUN
 if sym=runsym then
   run_program
   exit sub
 end if

 '..SAVE
 if sym=savesym then
   save_program
   exit sub
 end if

 '..STOP
 if sym=stopsym then
   halt_requested=true
   exit sub    '..see run_program
 end if

 '..UNKNOWN
 er(SYNTAX)
END SUB

SUB parse_line
shared sym,bad,buf$
shared ch$,n,length,stacktop
shared halt_requested
  ch$=" "
  n=1
  length=len(buf$)
  bad=false
  halt_requested=false
  stacktop=1
  repeat
    insymbol
    statement
    if sym<>colon and sym<>eos then call insymbol
  until sym<>colon
END SUB

SUB finished
shared buf$

 '..Quit,Exit?
 if instr(buf$,"QUIT") or instr(buf$,"EXIT") or instr(buf$,"SYSTEM") then
   finished=true
 else
   finished=false
 end if
END SUB

{ ** MAIN ** }
window 1,"** Tiny BASIC Interpreter © 1993 David Benn **",(0,0)-(640,200)

repeat
 start:
  pc=0
  input ,ut_buf$
  buf$=ucase$(ut_buf$)
  if not finished then call parse_line
until finished

window close 1

clear_program
library close exec