! ! Back to a scheme interpreter, now in Fortran 95 ! Closely following minischeme and tinyscheme ! Mini-Scheme is the work of Atsushi Moriwaki and Akira Kida, following Matsuda ! and Saigo Programming of LISP, archive No 5 (1987) 6 - 42 ! Tinyscheme is written by Dimitrios Souflis (dsouflis@acm.org) ! ! Output stream ! module outstream integer, parameter :: INSTRM=3, OSTRM=7, STDIN=5, STDOUT=6, OSTR2=8, OSTR3=9 integer :: outstr integer :: outfp, infp integer :: nports = 0 integer, dimension(2) :: portaddress = (/4, 10/) character (len=512) :: filnam = ' ', outfil = 'fscheme.out' character (len=3) :: prompt = '>> ' end module outstream ! ! Lisp pairs ! module cell_class use outstream implicit none integer, parameter :: T_FREE=0, T_STRING=1, T_NUMBER=2, T_SYMBOL=4, T_SYNTAX=8, & T_PROC=16, T_PAIR=32, T_CLOSURE=64, T_CONTINUATION=128, & T_MACRO=256, T_PROMISE=512, T_VECTOR=1024, T_PORT=2048, & T_ATOM=16384, T_CLRATOM=49151, T_MARK=32768, T_UNMARK=32767, & T_MOVED=-1 integer :: cell_segment = 1000 type cell integer :: iflag integer :: numtyp integer :: ivalue double precision :: value integer :: slength character, dimension(:), allocatable :: svalue integer :: keynum integer :: car integer :: cdr end type cell ! ! Registers: args arguments of function ! envir stack register for current environment ! code current code ! dump stack register for next evaluation ! integer :: args integer :: code integer :: dump integer :: envir ! pointer to symbol table integer :: oblist ! ! Special addresses ! integer :: nil ! special cell representing empty cell integer :: t ! special cell representing #t integer :: f ! special cell representing #f integer :: global_env ! pointer to global environment integer :: lambda ! pointer to syntax lambda integer :: quote ! pointer to syntax quote integer :: qquote ! pointer to syntax quasiquote integer :: unquote ! pointer to syntax unquote integer :: unquotesp ! pointer to syntax unquote-splicing ! ! Evaluator globals ! integer :: oper ! current operation integer :: tok ! current token integer :: print_flag ! print level integer :: value ! value of current expression ! input line buffer character (len=1024) :: lin=' ' integer :: currentline=0, eol=0 ! ! Operators, tokens ! integer, parameter :: TOK_LPAREN=0, TOK_RPAREN=1, TOK_DOT=2, TOK_ATOM=3, TOK_QUOTE=4, & TOK_COMMENT=5, TOK_DQUOTE=6, TOK_BQUOTE=7, TOK_COMMA=8, TOK_ATMARK=9, & TOK_SHARP=10 integer, parameter :: OP_LOAD=0, OP_T0LVL=1, OP_T1LVL=2, OP_READ=3, OP_VALUEPRINT=4, & OP_EVAL=5, OP_E0ARGS=6, OP_E1ARGS=7, OP_APPLY=8, OP_DOMACRO=9 integer, parameter :: OP_LAMBDA=10, OP_QUOTE=11, OP_DEF0=12, OP_DEF1=13, OP_BEGIN=14, & OP_IF0=15, OP_IF1=16, OP_SET0=17, OP_SET1=18, OP_LET0=19, OP_LET1=20, & OP_LET2=21, OP_LET0AST=22, OP_LET1AST=23, OP_LET2AST=24, OP_LET0REC=25, & OP_LET1REC=26, OP_LET2REC=27, OP_COND0=28, OP_COND1=29, OP_DELAY=30, & OP_AND0=31, OP_AND1=32, OP_OR0=33, OP_OR1=34, OP_C0STREAM=35, OP_C1STREAM=36, & OP_0MACRO=37, OP_1MACRO=38, OP_CASE0=39, OP_CASE1=40, OP_CASE2=41 integer, parameter :: OP_PEVAL=42, OP_PAPPLY=43, OP_CONTINUATION=44, OP_ADD=45, & OP_SUB=46, OP_MUL=47, OP_DIV=48, OP_INTDIV=49, OP_REM=50, OP_MOD=51, & OP_CAR=52, OP_CDR=53, OP_CONS=54, OP_SETCAR=55, & OP_SETCDR=56, OP_NOT=57, OP_BOOL=58, OP_ISINT=59, OP_NULL=60, OP_ZEROP=61, OP_POSP=62, & OP_NEGP=63, OP_NUMEQ=64, OP_LESS=65, OP_GRE=66, OP_LEQ=67, OP_GEQ=68, OP_SYMBOL=69, & OP_NUMBER=70, OP_STRING=71, OP_PROC=72, OP_PAIR=73, OP_EQ=74, OP_EQV=75, & OP_FORCE=76, OP_WRITE=77, OP_DISPLAY=78, OP_NEWLINE=79, OP_ERR0=80, & OP_ERR1=81, OP_REVERSE=82, OP_APPEND=83, OP_PUT=84, OP_GET=85, OP_QUIT=86, & OP_GC=87, OP_GCVERB=88, OP_NEWSEGMENT=89 integer, parameter :: OP_RDSEXPR=90, OP_RDLIST=91, OP_RDDOT=92, OP_RDQUOTE=93, OP_RDQQUOTE=94, & OP_RDUNQUOTE=95, OP_RDUQTSP=96 integer, parameter :: OP_P0LIST=97, OP_P1LIST=98, OP_LIST_LENGTH=99, OP_ASSQ=100, OP_PRINT_WIDTH=101, & OP_P0_WIDTH=102, OP_P1_WIDTH=103, OP_GET_CLOSURE=104, OP_CLOSUREP=105, & OP_MACROP=106 integer, parameter :: OP_EXP=107, OP_LOG=108, OP_SIN=109, OP_COS=110, & OP_TAN=111, OP_ASIN=112, OP_ACOS=113, OP_ATAN=114, & OP_SQRT=115, OP_TRUNCATE=116, OP_ROUND=117, & OP_ABS=118, OP_EXPT=119 integer, parameter :: OP_MIN=120, OP_MAX=121 integer, parameter :: OP_MKSTRING=122, OP_STRLEN=123, OP_STRSET=124, & OP_SUBSTR=125, OP_STRAPPEND=126, OP_STR2NUM=127, & OP_NUM2STR=128, OP_SYM2STR=129, OP_STR2SYM=130, & OP_VECTOR=131, OP_MKVECTOR=132, & OP_VECLEN=133, OP_VECSET=134, OP_PVECFROM=135, & OP_VECREF=136, OP_VECTORP=137 integer, parameter :: OP_SYSTEM=138, OP_TRANSON=139, OP_TRANSOFF=140, & OP_APROPOS=141, OP_MKPORT=142, OP_CLPORT=143, OP_RDLINE=144 #if DEBUG character (len=6), dimension(0:10), parameter :: strtok = & (/'lparen', 'rparen', 'dot ', 'atom ', 'quote ', 'commen', & 'dquote', 'bquote', 'comma ', 'atmark', 'sharp ' /) character (len=6), dimension(0:125), parameter :: strop = & (/'load ', & 't0lvl ', 't1lvl ', 'read ', 'printv', 'eval ', 'e0args', & 'e1args', 'apply ', 'domac ', 'lambda', 'quote ', 'def0 ', & 'def1 ', 'begin ', 'if0 ', 'if1 ', 'set0 ', 'set1 ', & 'let0 ', 'let1 ', 'let2 ', 'let0as', 'let1as', 'let2as', & 'let0re', 'let1re', 'let2re', 'cond0 ', 'cond1 ', 'delay ', & 'and0 ', 'and1 ', 'op0 ', 'or1 ', 'c0str ', 'c1str ', & '0macro', '1macro', 'case0 ', 'case1 ', 'case2 ', 'peval ', & 'papply', 'cont ', 'add ', 'sub ', 'mul ', 'div ', 'intdiv', & 'rem ', 'modulo', 'car ', 'cdr ', 'cons ', 'setcar', 'setcdr', & 'not ', 'bool ', 'isint ', 'null ', 'zerop ', 'posp ', 'negp ', & 'ne ', 'lt ', 'gt ', 'le ', 'ge ', 'symbol', & 'number', 'string', 'proc ', 'pair ', 'eq ', 'eqv ', & 'force ', 'write ', 'disply', 'newlin', 'err0 ', 'err1 ', & 'revers', 'append', 'put ', 'get ', 'quit ', 'gc ', & 'gcverb', 'newseg', 'rdsexp', 'rdlist', 'rddot ', 'rdquot', & 'rdqquo', 'rdunq ', 'rduqts', 'p0list', 'p1list', & 'lislen', 'assq ', 'pwidth', 'p0wid ', 'p1wid ', 'getclo', & 'closep', 'macrop', 'exp ', 'log ', 'sin ', 'cos ', & 'tan ', 'asin ', 'acos ', 'atan ', 'sqrt ', 'trunc ', & 'round ', 'abs ', 'expt ', 'min ', 'max ', & 'mkstr ', 'strlen', 'strset', 'substr' /) #endif ! ! Memory is memsiz array of cells: mem(memsiz) ! ! memsiz = current maximum allocatable cells ! nextfree= address of next free cell ! fcell = number of free cells ! integer :: memsiz type (cell), dimension(:), allocatable :: mem integer :: nextfree integer :: fcells contains ! Memory management subroutine setup_mem(siz) integer, intent(in) :: siz type (cell), dimension(:), allocatable :: tmpmem integer :: j, slen if (.not.allocated(mem)) then nil=1 t=2 f=3 args=nil code=nil dump=nil envir=nil oblist=nil global_env=nil lambda=nil quote=nil qquote=nil unquote=nil unquotesp=nil value=nil memsiz=siz allocate(mem(memsiz)) do j=1, siz mem(j)%iflag=T_FREE mem(j)%numtyp=0 mem(j)%ivalue=0 mem(j)%value=0.0d0 mem(j)%slength=0 mem(j)%keynum=-1 mem(j)%car=nil mem(j)%cdr=nil end do mem(nil)%iflag=ior(T_ATOM, T_MARK) mem(nil)%slength=3 allocate(mem(nil)%svalue(3)) mem(nil)%svalue(1)='N' mem(nil)%svalue(2)='I' mem(nil)%svalue(3)='L' mem(t)%iflag=ior(T_ATOM, T_MARK) mem(t)%slength=4 allocate(mem(t)%svalue(4)) mem(t)%svalue(1)='T' mem(t)%svalue(2)='R' mem(t)%svalue(3)='U' mem(t)%svalue(4)='E' mem(f)%iflag=ior(T_ATOM, T_MARK) mem(f)%slength=5 allocate(mem(f)%svalue(5)) mem(f)%svalue(1)='F' mem(f)%svalue(2)='A' mem(f)%svalue(3)='L' mem(f)%svalue(4)='S' mem(f)%svalue(5)='E' nextfree=4 fcells=memsiz-4 write(*,*) 'Allocated ', memsiz, ' cells.' else if (siz > memsiz) then allocate(tmpmem(memsiz)) do j=1, memsiz tmpmem(j)%iflag=mem(j)%iflag tmpmem(j)%numtyp=mem(j)%numtyp tmpmem(j)%ivalue=mem(j)%ivalue tmpmem(j)%value=mem(j)%value slen=mem(j)%slength tmpmem(j)%slength=slen if (slen > 0) then allocate(tmpmem(j)%svalue(slen)) tmpmem(j)%svalue=mem(j)%svalue end if tmpmem(j)%keynum=mem(j)%keynum tmpmem(j)%car=mem(j)%car tmpmem(j)%cdr=mem(j)%cdr end do call cleanup_mem() allocate(mem(siz)) #if DEBUG write(*,*) 'New memory ', size(mem) #endif !write(*,*) 'At ', trim(lin(1:currentline)), '^', & ! trim(lin(currentline+1:eol)) , '"' do j=1, memsiz mem(j)%iflag=tmpmem(j)%iflag mem(j)%numtyp=tmpmem(j)%numtyp mem(j)%ivalue=tmpmem(j)%ivalue mem(j)%value=tmpmem(j)%value slen=tmpmem(j)%slength mem(j)%slength=slen if (slen > 0) then allocate(mem(j)%svalue(slen)) mem(j)%svalue=tmpmem(j)%svalue deallocate(tmpmem(j)%svalue) end if mem(j)%keynum=tmpmem(j)%keynum mem(j)%car=tmpmem(j)%car mem(j)%cdr=tmpmem(j)%cdr end do do j=memsiz+1, siz mem(j)%iflag=T_FREE mem(j)%numtyp=0 mem(j)%ivalue=0 mem(j)%value=0.0d0 mem(j)%slength=0 mem(j)%car=nil mem(j)%cdr=nil mem(j)%keynum=-1 end do deallocate(tmpmem) if (nextfree == nil) then nextfree=memsiz+1 fcells=siz-memsiz end if memsiz=siz end if end subroutine setup_mem ! ! Clean up memory arrays ! ! Zero a block of cells, including deallocating strings ! subroutine cleanup_bank(sta, fin) integer, intent(in) :: fin, sta integer :: j do j=sta, fin if (allocated(mem(j)%svalue)) then mem(j)%slength=0 deallocate(mem(j)%svalue) end if mem(j)%iflag=T_FREE mem(j)%numtyp=0 mem(j)%ivalue=0 mem(j)%value=0.0d0 mem(j)%keynum=-1 mem(j)%car=nil mem(j)%cdr=nil end do end subroutine cleanup_bank ! ! Free all memory ! subroutine cleanup_mem() call cleanup_bank(1, memsiz) deallocate(mem) end subroutine cleanup_mem #if DEBUG ! ! Display memory ! subroutine show_mem( sta, fin) integer, intent(in) :: fin, sta integer :: j, poi write(*,*) 'nil = ', nil write(*,*) 'oblist = ', oblist write(*,*) 'global = ', global_env write(*,*) 'envir = ', envir write(*,*) 'args = ', args write(*,*) 'code = ', code write(*,*) 'dump = ', dump write(*,*) 'nextfree= ', nextfree do j=max(1,sta), min(memsiz, fin) write(*,'(i5,1x)', advance='no') j call wrclass(mem(j)%iflag) write(*,'(1x,i5,1x,f9.4,1x,i3)',advance='no') & mem(j)%ivalue, mem(j)%value, mem(j)%slength if (mem(j)%slength > 0) then write(*,'(a,a6,a)',advance='no') & ' "', string(mem(j)%slength, mem(j)%svalue), '"' else write(*,'(a)',advance='no') ' ' end if write(*,'(a,i4,a,i4,a)', advance='no') & ' (', mem(j)%car, ') (', mem(j)%cdr, ') ' write(*,'(i5)', advance='no') mem(j)%keynum if (j==nil) then write(*,*) '[nil]' else if (j==oblist) then write(*,*) '[oblist]' else if (j==envir) then write(*,*) '[envir]' else if (j==global_env) then write(*,*) '[global_env]' else if (j==args) then write(*,*) '[args]' else if (j==dump) then write(*,*) '[dump]' else if (j==code) then write(*,*) '[code]' else if (j==nextfree) then write(*,*) '[nextfree]' else if (mem(j)%iflag /= T_MOVED .and. & iand(mem(j)%iflag, T_PROC) /= 0) then write(*,*) '[',trim(strop(mem(j)%ivalue)),']' else if (mem(j)%iflag /= T_MOVED .and. & iand(mem(j)%iflag, T_SYMBOL) /= 0) then poi=mem(j)%car write(*,*) '[', string(mem(poi)%slength, & mem(poi)%svalue), ']' else if (mem(j)%keynum > 0) then write(*,*) '[',trim(strop(mem(j)%keynum)),']' else write(*,*) end if end do end subroutine show_mem ! function string(nc, svalue) integer, intent(in) :: nc character (len=nc) :: string character, dimension(:), intent(in) :: svalue integer :: i string=' ' do i=1, nc string(i:i)=svalue(i) end do end function string #endif ! ! Mark-sweep garbage collector ! ! Mark cells to be saved ! recursive subroutine mark(a) integer, intent(in) :: a integer :: i, n, p, q, t t=nil p=a 20 continue call setmark(p) ! vectors handled recursively if (isvector(p)) then n=get_ivalue(p) n=n/2 + mod(p,2) do i=p+1, p+n call mark(i) end do end if if (isatom(p)) goto 60 q=car(p) if (q /= nil .and. .not.ismark(q)) then call setatom(p) call set_car(p, t) t=p p=q goto 20 end if 50 continue q=cdr(p) if (q /= nil .and. .not.ismark(q)) then call set_cdr(p, t) t=p p=q goto 20 end if 60 continue if (t == nil) return q=t if (isatom(q)) then call clratom(q) t=car(q) call set_car(q, p) p=q goto 50 else t=cdr(q) call set_cdr(q, p) p=q goto 60 end if end subroutine mark ! ! Copy all registers to free memory ! Reset pointers from old addresses to new addresses ! subroutine gc(a, b, plevel) integer :: a, b integer, intent(in) :: plevel integer :: i call mark(envir) #if DEBUG write(*,*) 'ENVIR:' call show_mem(1, memsiz) #endif call mark(global_env) call mark(nil) call mark(t) call mark(f) call mark(oblist) call mark(args) call mark(code) call mark(dump) call mark(a) call mark(b) call clrmark(nil) #if DEBUG call show_mem(1, memsiz) #endif fcells=0 nextfree=nil do i=1, memsiz if (ismark(i)) then call clrmark(i) else call cleanup_bank(i, i) call set_cdr(i, nextfree) nextfree = i fcells=fcells+1 end if end do if (plevel > 0) then write(*,*) 'GC recovered ', fcells, ' cells.' end if #if DEBUG call show_mem(1, memsiz) #endif end subroutine gc ! ! Get next free cell ! function getcell(a, b) integer :: getcell integer, intent(in) :: a, b integer :: newsiz, x if (nextfree == nil) then call gc(a, b, 0) if (nextfree == nil) then newsiz=memsiz+cell_segment call setup_mem(newsiz) call gc(a, b, 0) end if end if x=nextfree nextfree=cdr(x) fcells=fcells-1 call set_car(x, nil) call set_cdr(x, nil) getcell=x end function getcell ! ! Get contiguous space for a vector ! function findvcells(vsize) integer :: findvcells integer, intent(in) :: vsize integer :: i, j, n, last i=nextfree last=i do while (i /= nil) n=1 j=i do while (cdr(j)+1 == j) j=cdr(j) n=n+1 if (n > vsize) then if (last==nextfree) then nextfree=cdr(j) else call set_cdr(last, cdr(j)) end if findvcells=j fcells=fcells-n return end if end do last=i i=cdr(j) end do findvcells=-1 end function findvcells ! function getvcells(vsize) integer :: getvcells integer, intent(in) :: vsize integer :: iadd, incsiz, siz iadd=findvcells(vsize) if (iadd == -1) then call gc(nil, nil, 0) iadd=findvcells(vsize) if (iadd == -1) then incsiz=cell_segment*(1+vsize/cell_segment) siz=memsiz+incsiz call setup_mem(siz) call gc(nil, nil, 0) iadd=findvcells(vsize) if (iadd == -1) then write(*,*) 'Fatal error: unable to allocate ', vsize, & ' cells for a vector!' write(*,*) 'Memsiz=', memsiz, ' cells, fcells=', fcells, ' cells.' stop end if end if end if getvcells=iadd end function getvcells ! subroutine fill_vec(p, obj) integer, intent(in) :: p integer, intent(in) :: obj integer :: i, idx, n n=get_ivalue(p) n=n/2 + mod(n,2) idx=p do i=1, n idx=idx+1 call set_type(idx, T_PAIR) call set_car(idx, obj) call set_cdr(idx, obj) end do end subroutine fill_vec ! ! Cell type operations ! ! Setting values subroutine set_type(p, iflag) integer, intent(in) :: p integer, intent(in) :: iflag mem(p)%iflag=iflag end subroutine set_type subroutine set_ivalue(p, ivalue) integer, intent(in) :: p integer, intent(in) :: ivalue mem(p)%ivalue=ivalue end subroutine set_ivalue subroutine set_value(p, val) integer, intent(in) :: p double precision, intent(in) :: val mem(p)%numtyp=1 mem(p)%value=val end subroutine set_value subroutine set_string(p, str) integer, intent(in) :: p character (len=*), intent(in) :: str integer :: i, slen if (mem(p)%slength > 0) then deallocate(mem(p)%svalue) end if slen=len(str) mem(p)%slength=slen allocate(mem(p)%svalue(slen)) do i=1, slen mem(p)%svalue(i)=str(i:i) end do end subroutine set_string subroutine set_substring(p, sta, fin, str) integer, intent(in) :: p integer, intent(in) :: fin, sta character (len=*), intent(in) :: str integer :: i, pos pos=0 do i=sta, min(mem(p)%slength, fin) pos=pos+1 mem(p)%svalue(i)=str(pos:pos) end do end subroutine set_substring subroutine set_vec(p, idx, a) integer :: a, idx, p integer :: n n=1+idx/2 if (mod(idx,2)==0) then call set_car(p+n, a) else call set_cdr(p+n, a) end if end subroutine set_vec ! subroutine set_car(p, icar) integer, intent(in) :: icar, p mem(p)%car=icar end subroutine set_car subroutine set_cdr(p, icdr) integer, intent(in) :: icdr, p mem(p)%cdr=icdr end subroutine set_cdr subroutine set_caar(p, icaar) integer, intent(in) :: icaar, p mem(mem(p)%car)%car=icaar end subroutine set_caar subroutine set_cdar(p, icdar) integer, intent(in) :: icdar, p mem(mem(p)%car)%cdr=icdar end subroutine set_cdar subroutine set_syntaxnum(p, op) integer :: op, p mem(p)%keynum=op end subroutine set_syntaxnum ! ! Getting values ! function get_ivalue(p) integer :: get_ivalue integer, intent(in) :: p get_ivalue=mem(p)%ivalue end function get_ivalue function get_value(p) double precision :: get_value integer, intent(in) :: p get_value=mem(p)%value end function get_value function rvalue(p) double precision :: rvalue integer, intent(in) :: p if (mem(p)%numtyp==1) then rvalue=mem(p)%value else rvalue=dfloat(mem(p)%ivalue) end if end function rvalue ! ! Strings ! function get_string(p) integer, intent(in) :: p character (len=mem(p)%slength) :: get_string integer :: i get_string=' ' if (mem(p)%slength > 0) then do i=1, mem(p)%slength get_string(i:i)=mem(p)%svalue(i) end do end if end function get_string ! Substring function get_substr(p, sta, fin) integer, intent(in) :: p, sta, fin character (len=(fin-sta+1)) :: get_substr integer :: i, j get_substr=' ' if (mem(p)%slength > 0) then j=0 do i=sta, fin j=j+1 get_substr(j:j)=mem(p)%svalue(i) end do end if end function get_substr ! String length function get_strlen(p) integer :: get_strlen integer, intent(in) :: p get_strlen=mem(p)%slength end function get_strlen ! Vectors function get_vec(p, idx) integer :: get_vec integer :: idx, p integer :: n n=1+idx/2 if (mod(idx,2)==0) then get_vec=mem(p+n)%car else get_vec=mem(p+n)%cdr end if end function get_vec function get_veclen(p) integer :: get_veclen integer, intent(in) :: p get_veclen=get_ivalue(p) end function get_veclen ! function get_listlen(p) integer :: get_listlen integer :: p integer :: l, x l=0 x=p do while (ispair(x)) l=l+1 x=cdr(x) end do if (x/=nil) l=-1 get_listlen=l end function get_listlen ! function procnum(p) integer :: procnum integer :: p procnum=mem(p)%ivalue end function procnum function syntaxnum(p) integer :: syntaxnum integer :: p syntaxnum=mem(p)%keynum end function syntaxnum ! ! Underlying primitives for Scheme ! function typeof(p) integer :: typeof integer, intent(in) :: p typeof=mem(p)%iflag end function typeof function isstring(p) logical :: isstring integer, intent(in) :: p isstring=(iand(typeof(p), T_STRING) /= 0) end function isstring function isnumber(p) logical :: isnumber integer, intent(in) :: p isnumber=(iand(typeof(p), T_NUMBER) /= 0) end function isnumber function ispair(p) logical :: ispair integer, intent(in) :: p ispair=(iand(typeof(p), T_PAIR) /= 0) end function ispair ! ! car, cdr etc ! function car(p) integer :: car integer, intent(in) :: p car = mem(p)%car end function car function cdr(p) integer :: cdr integer, intent(in) :: p cdr = mem(p)%cdr end function cdr ! function caar(p) integer :: caar integer, intent(in) :: p caar = mem(p)%car caar = mem(caar)%car end function caar function cadr(p) integer :: cadr integer, intent(in) :: p cadr = mem(p)%cdr cadr = mem(cadr)%car end function cadr function cdar(p) integer :: cdar integer, intent(in) :: p cdar = mem(p)%car cdar = mem(cdar)%cdr end function cdar function cddr(p) integer :: cddr integer, intent(in) :: p cddr = mem(p)%cdr cddr = mem(cddr)%cdr end function cddr function cadar(p) integer :: cadar integer, intent(in) :: p cadar = mem(p)%car cadar = mem(cadar)%cdr cadar = mem(cadar)%car end function cadar function caddr(p) integer :: caddr integer, intent(in) :: p caddr = mem(p)%cdr caddr = mem(caddr)%cdr caddr = mem(caddr)%car end function caddr function cadaar(p) integer :: cadaar integer, intent(in) :: p cadaar = mem(p)%car cadaar = mem(cadaar)%car cadaar = mem(cadaar)%cdr cadaar = mem(cadaar)%car end function cadaar function cadddr(p) integer :: cadddr integer, intent(in) :: p cadddr = mem(p)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%cdr cadddr = mem(cadddr)%car end function cadddr function cddddr(p) integer :: cddddr integer, intent(in) :: p cddddr = mem(p)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr cddddr = mem(cddddr)%cdr end function cddddr ! function issymbol(p) logical :: issymbol integer, intent(in) :: p issymbol=(iand(typeof(p), T_SYMBOL) /= 0) end function issymbol function issyntax(p) logical :: issyntax integer, intent(in) :: p issyntax=(iand(typeof(p), T_SYNTAX) /= 0) end function issyntax function isproc(p) logical :: isproc integer, intent(in) :: p isproc=(iand(typeof(p), T_PROC) /= 0) end function isproc function ismacro(p) logical :: ismacro integer, intent(in) :: p ismacro=(iand(typeof(p), T_MACRO) /= 0) end function ismacro function isclosure(p) logical :: isclosure integer, intent(in) :: p isclosure=(iand(typeof(p), T_CLOSURE) /= 0) end function isclosure function iscontinuation(p) logical :: iscontinuation integer, intent(in) :: p iscontinuation=(iand(typeof(p), T_CONTINUATION) /= 0) end function iscontinuation function ispromise(p) logical :: ispromise integer, intent(in) :: p ispromise=(iand(typeof(p), T_PROMISE) /= 0) end function ispromise function isvector(p) logical :: isvector integer, intent(in) :: p isvector=(iand(typeof(p), T_VECTOR) /= 0) end function isvector ! true or false value functions function istrue(p) logical :: istrue integer :: p istrue=(p /= nil .and. p /= f) end function istrue function isfalse(p) logical :: isfalse integer :: p isfalse=(p /= nil .and. p == f) end function isfalse ! tower of numbers function isint(p) logical :: isint integer :: p isint=(isnumber(p) .and. mem(p)%numtyp == 0) end function isint function isfloat(p) logical :: isfloat integer :: p isfloat=(isnumber(p) .and. mem(p)%numtyp == 1) end function isfloat ! ! Garbage collection ! function isatom(p) logical :: isatom integer, intent(in) :: p isatom=(iand(typeof(p), T_ATOM) /= 0) end function isatom subroutine setatom(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_ATOM)) end subroutine setatom subroutine clratom(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_CLRATOM)) end subroutine clratom function ismark(p) logical :: ismark integer, intent(in) :: p ismark=(iand(typeof(p), T_MARK) /= 0) end function ismark subroutine setmark(p) integer, intent(in) :: p call set_type(p, ior(typeof(p), T_MARK)) end subroutine setmark subroutine clrmark(p) integer, intent(in) :: p call set_type(p, iand(typeof(p), T_UNMARK)) end subroutine clrmark #if DEBUG ! ! Print list ! subroutine wrclass(iflag) integer, intent(in) :: iflag character (len=6), dimension(12), parameter :: ctyp = (/ & 'free ', 'string', 'number', 'symbol', 'syntax', 'proc ', & 'pair ', 'closur', 'cont ', 'macro ', 'promis', 'atom ' /) character (len=13) :: str if (iflag == T_MOVED) then write(*,'(a)',advance='no') 'moved* ' return end if if (iflag == T_FREE) then write(*,'(a)',advance='no') 'free ' return end if str=' ' if (iand(iflag, T_STRING) /= 0) str=trim(str) // ctyp(2) if (iand(iflag, T_NUMBER) /= 0) str=trim(str) // ctyp(3) if (iand(iflag, T_SYMBOL) /= 0) str=trim(str) // ctyp(4) if (iand(iflag, T_SYNTAX) /= 0) str=trim(str) // ctyp(5) if (iand(iflag, T_PROC) /= 0) str=trim(str) // ctyp(6) if (iand(iflag, T_PAIR) /= 0) str=trim(str) // ctyp(7) if (iand(iflag, T_CLOSURE) /= 0) str=trim(str) // ctyp(8) if (iand(iflag, T_CONTINUATION) /= 0) str=trim(str) // ctyp(9) if (iand(iflag, T_MACRO) /= 0) str=trim(str) // ctyp(10) if (iand(iflag, T_PROMISE) /= 0) str=trim(str) // ctyp(11) if (iand(iflag, T_ATOM) /= 0) str=trim(str) // ctyp(12) if (iand(iflag, T_MARK) /= 0) str=trim(str) // '*' write(*,'(a)',advance='no') str end subroutine wrclass recursive subroutine plist(reg) integer, intent(in) :: reg integer :: flag flag=mem( reg)%iflag write(*,'(a,i4,a)', advance='no') '[', reg, '] ' call wrclass(flag) write(*,'(1x,i5,1x,f9.4,1x,i3)',advance='no') & get_ivalue(reg), get_value(reg), mem(reg)%slength if (mem(reg)%slength > 0) then write(*,'(a12)',advance='no') ' "' // get_string(reg) // '" ' else write(*,'(a12)',advance='no') ' ' end if write(*,*) ' (', car(reg), ') (', cdr(reg), ')' if (car(reg) /= nil) then call plist(car(reg)) end if if (cdr(reg) /= nil) then call plist(cdr(reg)) end if end subroutine plist ! ! Delete contents of register ! recursive subroutine freelist(reg) integer :: reg if (car(reg) /= nil) then call freelist(car(reg)) end if if (car(reg) /= nil) then call freelist(cdr(reg)) end if if (allocated(mem(reg)%svalue)) then deallocate(mem(reg)%svalue) end if mem(reg)%slength=0 mem(reg)%car=nil mem(reg)%cdr=nil mem(reg)%numtyp=0 mem(reg)%ivalue=0 mem(reg)%value=0.0d0 mem(reg)%iflag=T_FREE end subroutine freelist #endif ! ! Cons ! function cons(reg1, reg2) integer cons integer :: reg1, reg2 cons=getcell(reg1, reg2) call set_type(cons, T_PAIR) mem(cons)%car = reg1 mem(cons)%cdr = reg2 end function cons ! ! Contents of a Lisp string cell equal to a Fortran string ! function ceqstr(cstr, reg) logical :: ceqstr character (len=*) :: cstr integer, intent(in) :: reg integer :: i ceqstr=.true. if (mem(reg)%slength /= len(cstr)) then ceqstr=.false. return else do i=1, len(cstr) if (cstr(i:i) /= mem(reg)%svalue(i)) then ceqstr=.false. return end if end do end if end function ceqstr ! ! Contents of a Lisp string equal to a Lisp string ! function streq(a, b) logical :: streq integer, intent(in) :: a, b integer :: i, slen streq=.true. slen=mem(a)%slength if (slen /= mem(b)%slength) then streq=.false. else do i=1, slen if (mem(a)%svalue(i) /= mem(b)%svalue(i)) then streq=.false. return end if end do end if end function streq ! ! Declare a number ! function mk_number(num) integer :: mk_number integer, intent(in) :: num integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_ivalue(tmp, num) mk_number=tmp end function mk_number ! ! Declare a real ! function mk_real(num) integer :: mk_real double precision, intent(in) :: num integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_NUMBER, T_ATOM)) call set_value(tmp, num) mk_real=tmp end function mk_real ! ! Declare a string ! function mk_string(nam) integer :: mk_string character (len=*), intent(in) :: nam integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_STRING, T_ATOM)) call set_string(tmp, nam) mk_string=tmp end function mk_string ! ! Declare a symbol ! function mk_symbol(nam) integer :: mk_symbol character (len=*), intent(in) :: nam integer :: tmp tmp=oblist do while (tmp /= nil) if (ceqstr(trim(nam), caar(tmp))) then mk_symbol=car(tmp) return end if tmp=cdr(tmp) end do tmp=cons(mk_string(nam), nil) call set_type(tmp, T_SYMBOL) ! write(*,*) 'Adding ', tmp, car(tmp), ' "', trim(get_string(car(tmp))), '"' oblist=cons(tmp, oblist) mk_symbol=tmp end function mk_symbol ! ! make symbol or number atom from string ! function mk_atom(str) integer :: mk_atom character (len=*), intent(in) :: str integer :: i, ich, slen logical :: hasdot, isnum ! functions integer :: ival double precision :: fval slen=len(str) hasdot=.false. isnum=.true. do i=1, slen ich = ichar(str(i:i)) if (ich < 48 .or. ich > 57) then if ((ich == 43 .or. ich == 45) .and. i==1 .and. slen>1) then continue else if (ich == 46 .and. .not.hasdot) then hasdot=.true. else isnum=.false. exit end if end if end do if (isnum) then if (hasdot) then mk_atom=mk_real(fval(str)) else mk_atom=mk_number(ival(str)) end if else mk_atom=mk_symbol(str) end if end function mk_atom ! ! Make a constant ! function mk_const(nam) integer :: mk_const character (len=*) :: nam integer :: x if (nam == 't') then mk_const=t else if (nam == 'f') then mk_const=f else if (nam(1:1) == 'd') then read(nam, '(i20)') x mk_const=mk_number(x) end if end function mk_const ! ! Make a vector ! function mk_vector(vsize) integer :: mk_vector integer, intent(in) :: vsize integer :: tmp tmp = getvcells(vsize) call set_type(tmp, ior(T_VECTOR, T_ATOM)) call set_ivalue(tmp, vsize) call fill_vec(tmp, nil) mk_vector=tmp end function mk_vector ! ! make closure, c is code, e is environment ! function mk_closure(c, e) integer :: mk_closure integer :: c, e integer :: x x=getcell(c, e) call set_type(x, T_CLOSURE) call set_car(x, c) call set_cdr(x, e) mk_closure=x end function mk_closure ! ! make continuation ! function mk_continuation(d) integer :: mk_continuation integer :: d integer :: x x=getcell(nil, d) call set_type(x, T_CONTINUATION) call set_cdr(x, d) mk_continuation=x end function mk_continuation ! ! make a port ! function mk_port(iport) integer :: mk_port integer, intent(in) :: iport integer :: tmp tmp=getcell(nil, nil) call set_type(tmp, ior(T_PORT, T_ATOM)) call set_ivalue(tmp, iport) mk_port=tmp end function mk_port ! ! Reverse list ! function reverse(a) integer :: reverse integer, intent(in) :: a integer :: p, tmp integer :: i p=nil tmp=a i=0 do while (ispair(tmp)) i=i+1 p=cons(car(tmp), p) tmp=cdr(tmp) end do reverse=p end function reverse ! ! Reverse list -- no new cell generated ! function non_alloc_rev(term, list) integer :: non_alloc_rev integer, intent(in) :: term, list integer :: i, p, res, q i=0 p=list res=term do while (p /= nil) i=i+1 q=cdr(p) call set_cdr(p, res) res=p p=q end do non_alloc_rev=res end function non_alloc_rev ! ! append list -- make new cells ! function append(a, b) integer :: append integer, intent(in) :: a, b integer :: p, q, tmp p=b tmp=a if (tmp /= nil) then tmp = reverse(tmp) do while (tmp /= nil) q = cdr(tmp) call set_cdr(tmp, p) p = tmp tmp = q end do end if append=p end function append ! ! equivalence of atoms ! function eqv(a, b) logical :: eqv integer, intent(in) :: a, b eqv=.false. if (isstring(a)) then if (isstring(b)) then eqv=streq(a, b) end if else if (isint(a)) then if (isint(b)) then eqv=(get_ivalue(a) == get_ivalue(b)) end if else if (isfloat(a)) then if (isfloat(b)) then eqv=(get_value(a) == get_value(b)) end if else eqv=(a == b) end if end function eqv ! ! get a new character from input file or stdin ! subroutine inchar(ch) character (len=1) :: ch integer :: ios if (eol==0 .or. currentline > eol) then read(infp, '(a)', iostat=ios) lin if (ios /= 0) then if (infp /= STDIN) then write(outstr,'(2a)') 'Closing ', trim(filnam) close(infp, status='keep') infp=STDIN write(outstr, '(a)', advance='no') prompt read(infp, '(a)') lin else write(*, '(a)') 'Exiting!' stop end if end if currentline=0 eol=len_trim(lin) if (outstr /= STDOUT) then write(outstr, '(2a)') prompt, trim(lin) end if ! write(*,*) '-> ' , trim(lin) end if currentline=currentline+1 if (currentline > eol) then ch=' ' else ch=lin(currentline:currentline) end if ! write(*,*) 'Read character "', ch, '" "', trim(lin(1:currentline)), '^', & ! trim(lin(currentline+1:eol)) , '"' end subroutine inchar ! ! clear input buffer ! subroutine clearinput() currentline=eol end subroutine clearinput ! ! back to standard input ! subroutine flushinput() if (infp /= STDIN) then close(infp, status='keep') infp=STDIN end if call clearinput() end subroutine flushinput ! ! backstep one character in input buffer ! subroutine backchar() currentline=currentline-1 end subroutine backchar ! ! skip whitespace ! subroutine skipspace() do currentline=currentline+1 if (currentline > eol) exit if (lin(currentline:currentline)/=' ' .or. & lin(currentline:currentline)/='\t') then exit end if end do currentline=currentline-1 end subroutine skipspace ! ! get next token ! function token() integer :: token character (len=1) :: ch integer :: ich do call skipspace() call inchar(ch) if (ch /= ' ' .and. ch /= '\t') exit end do ich = ichar(ch) if (ch == '(') then token=TOK_LPAREN else if (ch == ')') then token=TOK_RPAREN else if (ch == '.') then token=TOK_DOT else if (ich == 39) then token=TOK_QUOTE else if (ch == ';') then token=TOK_COMMENT else if (ch == '"') then token=TOK_DQUOTE else if (ch == '`') then token=TOK_BQUOTE else if (ch == ',') then call inchar(ch) if (ch == '@') then token=TOK_ATMARK else call backchar() token=TOK_COMMA end if else if (ch == '#') then token=TOK_SHARP else call backchar() token=TOK_ATOM end if ! write(*,*) 'Read token ', token end function token ! ! read characters to delimiter */ ! function scheme_delim(ch) logical :: scheme_delim character(len=1) :: ch integer :: ich ! functions integer :: ichar ich=ichar(ch) scheme_delim=(ich == 9 .or. ich == 10 .or. & ich == 32 .or. ich== 40 .or. ich == 41) end function scheme_delim ! subroutine readstr(res) character (len=*) :: res integer :: pos, reslen character (len=1) :: ch reslen=len(res) res=' ' pos=0 rdloop: do call inchar(ch) if (currentline > eol) exit rdloop if (scheme_delim(ch)) exit rdloop pos=pos+1 if (pos <= reslen) res(pos:pos)=ch end do rdloop call backchar() end subroutine readstr ! ! read rest of a quoted string ! subroutine readstrexp(res, reslen) character (len=*) :: res character (len=1) :: ch integer, intent(out) :: reslen integer :: pos reslen=len(res) res=' ' pos=0 do call inchar(ch) if (ch == '"') exit pos=pos+1 if (pos <= reslen) res(pos:pos)=ch end do reslen=min(pos, reslen) end subroutine readstrexp ! ! print an atom ! subroutine printatom(l) integer :: l character (len=128) :: str if (l == nil) then write(outstr, '(a)', advance='no') '()' else if (l == t) then write(outstr, '(a)', advance='no') '#t' else if (l == f) then write(outstr, '(a)', advance='no') '#f' else if (isnumber(l)) then if (isint(l)) then write(str, '(i20)') get_ivalue(l) else if (isfloat(l)) then write(str, '(f15.6)') get_value(l) end if write(outstr, '(a)', advance='no') trim(adjustl(str)) else if (isstring(l)) then write(outstr,'(a)',advance='no') get_string(l) else if (issymbol(l)) then write(outstr,'(a)',advance='no') get_string(car(l)) // ' ' else if (isproc(l)) then write(outstr,'(a,i4,a)', advance='no') '#' else if (ismacro(l)) then write(outstr,'(a)',advance='no') '#' else if (isclosure(l)) then write(outstr,'(a)',advance='no') '#' else if (iscontinuation(l)) then write(outstr,'(a)',advance='no') '#' end if end subroutine printatom ! ! print width of an atom ! function lenatom(l) integer :: lenatom integer :: l lenatom=0 if (l == nil .or. l == t .or. l == f) then lenatom=2 else if (isint(l)) then lenatom=10 else if (isfloat(l)) then lenatom=15 else if (isstring(l) .or. issymbol(l)) then lenatom=len(get_string(l)) else if (isproc(l) .or. iscontinuation(l)) then lenatom=15 else if (ismacro(l)) then lenatom=8 else if (isclosure(l)) then lenatom=10 end if end function lenatom ! function ok_abbrev(x) logical :: ok_abbrev integer :: x ok_abbrev=(ispair(x) .and. cdr(x) /= nil) end function ok_abbrev ! subroutine s_save(a, b, c) integer :: a, b, c dump = cons(envir, cons(c, dump)) dump = cons(b, dump) dump = cons(mk_number(a), dump) end subroutine s_save subroutine s_return(a) integer :: a value = a oper = get_ivalue(car(dump)) args = cadr(dump) envir = caddr(dump) code = cadddr(dump) dump = cddddr(dump) end subroutine s_return subroutine s_retbool(tf) logical :: tf if (tf) then call s_return(t) else call s_return(f) end if end subroutine s_retbool subroutine opexe0(op) integer :: op integer :: x, y logical :: ios ! load if (op == OP_LOAD) then if (.not.isstring(car(args))) then call error0('load -- argument is not string') return else filnam=trim(get_string(car(args))) inquire(file=trim(filnam), exist=ios) if (.not.ios) then filnam=' ' call error1('Unable to open', car(args)) return else infp=INSTRM open(infp, file=trim(filnam), status='old') write(outstr, '(2a)') 'Loading ', trim(filnam) end if end if oper=OP_T0LVL ! top level else if (op == OP_T0LVL) then write(outstr,*) dump = nil envir = global_env call s_save(OP_VALUEPRINT, nil, nil); call s_save(OP_T1LVL, nil, nil); if (infp == STDIN) then write(*, '(a)', advance='no') prompt end if oper=OP_READ else if (op == OP_T1LVL) then code=value oper=OP_EVAL ! read else if (op == OP_READ) then tok=token() oper=OP_RDSEXPR ! print evaluation result else if (op == OP_VALUEPRINT) then print_flag=1 args=value call s_save(OP_T0LVL, nil, nil) oper=OP_P0LIST ! main part of evaluation else if (op == OP_EVAL) then ! symbol if (issymbol(code)) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call s_return(cdar(y)) else call error1('Unbound variable', code) end if else if (ispair(code)) then ! syntax x = car(code) if (issyntax(x)) then code = cdr(code); oper=syntaxnum(x) ! first, eval top element and eval arguments else call s_save(OP_E0ARGS, nil, code) code = car(code) oper=OP_EVAL end if else call s_return(code) end if ! eval arguments else if (op == OP_E0ARGS) then ! macro expansion if (ismacro(value)) then call s_save(OP_DOMACRO, nil, nil) args=cons(code, nil) code=value oper=OP_APPLY else code=cdr(code) oper=OP_E1ARGS end if else if (op == OP_E1ARGS) then args=cons(value, args) ! continue if (ispair(code)) then call s_save(OP_E1ARGS, args, cdr(code)) code=car(code) args=nil oper=OP_EVAL ! end else args=reverse(args) code=car(args) args=cdr(args) oper=OP_APPLY end if ! apply code to args else if (op == OP_APPLY) then if (isproc(code)) then oper=procnum(code) else if (isclosure(code)) then envir= cons(nil, cdr(code)) x=car(car(code)) y=args do while (ispair(x)) if (y == nil) then call error0('Too few arguments') return else call set_car(envir, cons(cons(car(x), car(y)), car(envir))) end if x=cdr(x) y=cdr(y) end do if (x == nil) then continue else if (issymbol(x)) then call set_car(envir, cons(cons(x,y), car(envir))) else call error0('Syntax error in closure') return end if code=cdar(code) args=nil oper=OP_BEGIN ! continuation else if (iscontinuation(code)) then dump=cdr(code) if (args /= nil) then call s_return(car(args)) else call s_return(nil) end if else call error0('Illegal function') return end if ! do macro else if (op == OP_DOMACRO) then code=value oper=OP_EVAL ! lambda else if (op == OP_LAMBDA) then call s_return(mk_closure(code, envir)) ! quote else if (op == OP_QUOTE) then call s_return(car(code)) ! define else if (op == OP_DEF0) then if (ispair(car(code))) then x=caar(code) code=cons(lambda, cons(cdar(code), cdr(code))) else x=car(code) code=cadr(code) end if if (.not.issymbol(x)) then call error0('Variable is not symbol') return end if call s_save(OP_DEF1, nil, x) oper=OP_EVAL ! define else if (op == OP_DEF1) then x=car(envir) do while (x /= nil) if (caar(x) == code) exit x=cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) end if call s_return(code) ! set! else if (op == OP_SET0) then call s_save(OP_SET1, nil, car(code)) code=cadr(code) oper=OP_EVAL ! set! else if (op == OP_SET1) then x=envir do while (x /= nil) y=car(x) do while (y /= nil) if (caar(y) == code) exit y=cdr(y) end do if (y /= nil) exit x=cdr(x) end do if (x /= nil) then call set_cdar(y, value) call s_return(value) else call error1('Unbound variable', code) end if ! begin else if (op == OP_BEGIN) then if (.not.ispair(code)) then call s_return(code) end if if (cdr(code) /= nil) then call s_save(OP_BEGIN, nil, cdr(code)) end if code = car(code) oper=OP_EVAL ! if else if (op == OP_IF0) then call s_save(OP_IF1, nil, cdr(code)) code = car(code) oper=OP_EVAL else if (op == OP_IF1) then if (istrue(value)) then code=car(code) else code=cadr(code) end if oper=OP_EVAL ! let else if (op == OP_LET0) then args=nil value=code if (issymbol(car(code))) then code=cadr(code) else code=car(code) end if oper=OP_LET1 ! let (calculate parameters) else if (op == OP_LET1) then args=cons(value, args) if (ispair(code)) then call s_save(OP_LET1, args, cdr(code)) code=cadar(code) args=nil oper=OP_EVAL else args=reverse(args) code=car(args) args=cdr(args) oper=OP_LET2 end if else if (op == OP_LET2) then envir=cons(nil, envir) if (issymbol(car(code))) then x=cadr(code) else x=car(code) end if y=args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do ! named let if (issymbol(car(code))) then x=cadr(code) args=nil do while (x /= nil) args=cons(caar(x), args) x=cdr(x) end do x=mk_closure(cons(reverse(args), cddr(code)), envir) call set_car(envir, cons(cons(car(code), x), car(envir))) code=cddr(code) args=nil else code=cdr(code) args=nil end if oper=OP_BEGIN ! let* else if (op == OP_LET0AST) then if (car(code) == nil) then envir = cons(nil, envir) code=cdr(code) oper=OP_BEGIN end if call s_save(OP_LET1AST, cdr(code), car(code)) code=cadaar(code) oper=OP_EVAL ! let* (make new frame) else if (op == OP_LET1AST) then envir=cons(nil, envir) oper=OP_LET2AST ! let* (calculate parameters) else if (op == OP_LET2AST) then call set_car(envir, cons(cons(caar(code), value), car(envir))) code = cdr(code) ! continue if (ispair(code)) then call s_save(OP_LET2AST, args, code) code = cadar(code) args = nil oper=OP_EVAL ! end else code = args args = nil oper=OP_BEGIN end if else write(*, '(i3,a)') oper, ' is an illegal operator' end if end subroutine opexe0 subroutine opexe1(op) integer :: op integer :: x, y ! letrec if (op == OP_LET0REC) then envir = cons(nil, envir) args = nil value = code code = car(code) oper=OP_LET1REC ! letrec calculate parameters else if (op == OP_LET1REC) then args = cons(value, args) if (ispair(code)) then ! continue call s_save(OP_LET1REC, args, cdr(code)) code=cadar(code) args=nil oper=OP_EVAL else ! end args = reverse(args) code = car(args) args = cdr(args) oper=OP_LET2REC end if ! letrec else if (op == OP_LET2REC) then x=car(code) y=args do while (y /= nil) call set_car(envir, cons(cons(caar(x), car(y)), car(envir))) x=cdr(x) y=cdr(y) end do code=cdr(code) args=nil oper=OP_BEGIN ! cond else if (op == OP_COND0) then if (.not.ispair(code)) then call error0('Syntax error in cond') return end if call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL else if (op == OP_COND1) then if (istrue(value)) then code= cdar(code) if (code == nil) then call s_return(value) end if oper=OP_BEGIN else code=cdr(code) if (code == nil) then call s_return(nil) else call s_save(OP_COND1, nil, code) code=caar(code) oper=OP_EVAL end if end if ! delay else if (op == OP_DELAY) then x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(x) ! and else if (op == OP_AND0) then if (code==nil) then call s_return(t) end if call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! and else if (op == OP_AND1) then if (isfalse(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_AND1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! or else if (op == OP_OR0) then if (code==nil) then call s_return(f) end if call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! or else if (op == OP_OR1) then if (istrue(value)) then call s_return(value) else if (code == nil) then call s_return(value) else call s_save(OP_OR1, nil, cdr(code)) code=car(code) oper=OP_EVAL end if ! cons-stream else if (op == OP_C0STREAM) then call s_save(OP_C1STREAM, nil, cdr(code)) code=car(code) oper=OP_EVAL ! cons-stream else if (op == OP_C1STREAM) then args=value x=mk_closure(cons(nil, code), envir) call set_type(x, ior(T_PROMISE, typeof(x))) call s_return(cons(args, x)) ! macro else if (op == OP_0MACRO) then x=car(code) code=cadr(code) if (.not.issymbol(x)) then call error0('Variable is not symbol') return end if call s_save(OP_1MACRO, nil, x) oper=OP_EVAL ! macro else if (op == OP_1MACRO) then call set_type(value, ior(T_MACRO, typeof(value))) x=car(envir) do while (x /= nil) if (caar(x) == code) exit x=cdr(x) end do if (x /= nil) then call set_cdar(x, value) else call set_car(envir, cons(cons(code, value), car(envir))) end if call s_return(code) ! case else if (op == OP_CASE0) then call s_save(OP_CASE1, nil, cdr(code)) code=car(code) oper=OP_EVAL ! case else if (op == OP_CASE1) then x=code do while (x /= nil) y=caar(x) if (.not.ispair(y)) then exit end if do while (y /= nil) if (eqv(car(y), value)) then exit end if y=cdr(y) end do if (y /= nil) exit x = cdr(x) end do if (x /= nil) then if (ispair(caar(x))) then code = cdar(x) oper=OP_BEGIN ! else else call s_save(OP_CASE2, nil, cdar(x)) code=caar(x) oper=OP_EVAL end if else call s_return(nil) end if ! case else if (op == OP_CASE2) then if (istrue(value)) then oper=OP_BEGIN else call s_return(nil) end if ! apply else if (op == OP_PAPPLY) then code=car(args) args=cadr(args) oper=OP_APPLY ! eval else if (op == OP_PEVAL) then code=car(args) args=nil oper=OP_EVAL ! call-with-current-continuation else if (op == OP_CONTINUATION) then code=car(args) args=cons(mk_continuation(dump), nil) oper=OP_APPLY else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe1 ! subroutine opexe2(op) integer :: op integer :: d, x, v integer :: i logical :: int_op double precision :: rv int_op=.true. ! + if (op == OP_ADD) then x = args v = 0 rv = 0.0d0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dfloat(v) end if rv=rv+get_value(car(x)) else if (int_op) then v=v+get_ivalue(car(x)) else rv=rv+dfloat(get_ivalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! - else if (op == OP_SUB) then x = cdr(args) if (.not.isnumber(car(args))) then call error1('Argument is not a number: ', car(args)) return else if (isfloat(car(args))) then int_op=.false. rv = get_value(car(args)) else v = get_ivalue(car(args)) end if i = 1 do while (x /= nil) i=i+1 if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dfloat(v) end if rv=rv-get_value(car(x)) else if (int_op) then v=v-get_ivalue(car(x)) else rv=rv-dfloat(get_ivalue(car(x))) end if x=cdr(x) end do if (i==1) then if (int_op) then v=-v else rv=-rv end if end if if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! * else if (op == OP_MUL) then x = args v = 1 rv = 1.0d0 do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dfloat(v) end if rv=rv*get_value(car(x)) else if (int_op) then v=v*get_ivalue(car(x)) else rv=rv*dfloat(get_ivalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! / else if (op == OP_DIV) then x = cdr(args) if (.not.isnumber(car(args))) then call error1('Argument is not a number: ', car(args)) return else if (isfloat(car(args))) then int_op=.false. rv = get_value(car(args)) else v = get_ivalue(car(args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dfloat(v) end if if (get_value(car(x)) /= 0.0d0) then rv=rv/get_value(car(x)) else call error0('Divided by zero!') return end if else if (int_op) then if (get_ivalue(car(x)) /= 0) then v=v/get_ivalue(car(x)) else call error0('Divided by zero!') return end if else if (get_ivalue(car(x)) /= 0) then rv=rv/dfloat(get_ivalue(car(x))) else call error0('Divided by zero!') return end if end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! quotient else if (op == OP_INTDIV) then x = cdr(args) if (.not.isnumber(car(args))) then call error1('Argument is not a number: ', car(args)) return else if (isfloat(car(args))) then v = int(get_value(car(args))) else v = get_ivalue(car(args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then d=int(get_value(car(x))) else d=get_ivalue(car(x)) end if if (d /= 0) then v=v/d else call error0('Divided by zero!') return end if x=cdr(x) end do call s_return(mk_number(v)) ! remainder else if (op == OP_REM) then x = cdr(args) if (.not.isnumber(car(args))) then call error1('Argument is not a number: ', car(args)) return else if (isfloat(car(args))) then int_op=.false. rv = get_value(car(args)) else v = get_ivalue(car(args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (isfloat(car(x))) then if (int_op) then int_op=.false. rv=dfloat(v) end if if (get_value(car(x)) /= 0) then rv=mod(rv, get_value(car(x))) else call error0('Divided by zero!') return end if else if (int_op) then if (get_ivalue(car(x)) /= 0) then v=mod(v,get_ivalue(car(x))) else call error0('Divided by zero!') return end if else if (get_ivalue(car(x)) /= 0) then rv=mod(rv, dfloat(get_ivalue(car(x)))) else call error0('Divided by zero!') return end if end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if ! modulo else if (op == OP_MOD) then if (isint(car(args)) .and. isint(cadr(args))) then i = get_ivalue(cadr(args)) if (i /= 0) then v = mod(get_ivalue(car(args)), i) if (v*i < 0) then i=abs(i) if (v > 0) then v=v-i else v=v+i end if end if call s_return(mk_number(v)) else call error0('Modulo x 0 not allowed!') end if else call error0('Arguments must be integer!') end if ! car else if (op == OP_CAR) then if (ispair(car(args))) then call s_return(caar(args)) else call error0('Unable to car for a non-cons cell!') end if ! cdr else if (op == OP_CDR) then if (ispair(car(args))) then call s_return(cdar(args)) else call error0('Unable to cdr for a non-cons cell!') end if ! cons else if (op == OP_CONS) then call set_cdr(args, cadr(args)) call s_return(args) ! set-car! else if (op == OP_SETCAR) then if (ispair(car(args))) then call set_caar(args, cadr(args)) call s_return(car(args)) else call error0('Unable to set-car! for a non-cons cell!') end if ! set-cdr! else if (op == OP_SETCDR) then if (ispair(car(args))) then call set_cdar(args, cadr(args)) call s_return(car(args)) else call error0('Unable to set-cdr! for a non-cons cell!') end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe2 ! subroutine opexe3(op) integer :: op integer :: x, v logical :: comp ! not if (op == OP_NOT) then call s_retbool(isfalse(car(args))) ! boolean? else if (op == OP_BOOL) then call s_retbool(car(args) == f .or. car(args) == t) ! integer? else if (op == OP_ISINT) then call s_retbool(isint(car(args))) ! null else if (op == OP_NULL) then call s_retbool(car(args) == nil) ! zero? else if (op == OP_ZEROP) then call s_retbool(get_ivalue(car(args)) == 0) ! positive? else if (op == OP_POSP) then call s_retbool(get_ivalue(car(args)) > 0) ! negative? else if (op == OP_NEGP) then call s_retbool(get_ivalue(car(args)) < 0) ! =, <, >, <=, >= else if (op >= OP_NUMEQ .and. op <= OP_GEQ) then x = cdr(args) if (.not.isnumber(car(args))) then call error1('Argument is not a number: ', car(args)) return else v = get_ivalue(car(args)) end if do while (x /= nil) if (.not.isnumber(car(x))) then call error1('Argument is not a number: ', car(x)) return else if (op == OP_NUMEQ) then comp=(v==get_ivalue(car(x))) else if (op == OP_LESS) then comp=(vget_ivalue(car(x))) else if (op == OP_LEQ) then comp=(v<=get_ivalue(car(x))) else if (op == OP_GEQ) then comp=(v>=get_ivalue(car(x))) end if if (.not.comp) exit end if x=cdr(x) end do call s_retbool(comp) ! symbol? else if (op == OP_SYMBOL) then call s_retbool(issymbol(car(args))) ! number? else if (op == OP_NUMBER) then call s_retbool(isnumber(car(args))) ! string? else if (op == OP_STRING) then call s_retbool(isstring(car(args))) ! procedure? else if (op == OP_PROC) then call s_retbool(isproc(car(args)) .or. isclosure(car(args)) .or. & iscontinuation(car(args))) ! pair? else if (op == OP_PAIR) then call s_retbool(ispair(car(args))) ! eq? else if (op == OP_EQ) then call s_retbool(car(args) == cadr(args)) ! eqv? else if (op == OP_EQV) then call s_retbool(eqv(car(args),cadr(args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe3 ! subroutine opexe4(op) integer :: op integer :: x, y ! force if (op == OP_FORCE) then code = car(args) if (ispromise(code)) then args=nil oper=OP_APPLY else call s_return(code) end if ! write else if (op == OP_WRITE) then print_flag=1 args=car(args) oper=OP_P0LIST ! display else if (op == OP_DISPLAY) then print_flag=1 args=car(args) oper=OP_P0LIST ! newline else if (op == OP_NEWLINE) then write(outstr,*) call s_return(t) ! error else if (op == OP_ERR0) then if (.not.isstring(car(args))) then call error0('Error -- first argument must be a string') end if write(outstr, '(2a)', advance='no') 'Error: ', get_string(car(args)) args=cdr(args) oper=OP_ERR1 ! error else if (op == OP_ERR1) then write(outstr, '(a)', advance='no') ' ' if (args /= nil) then call s_save(OP_ERR1, cdr(args), nil) args=car(args) print_flag=1 oper=OP_P0LIST else write(outstr,*) call flushinput() oper=OP_T0LVL end if ! reverse else if (op == OP_REVERSE) then call s_return(reverse(car(args))) ! append else if (op == OP_APPEND) then call s_return(append(car(args), cadr(args))) ! put else if (op == OP_PUT) then if (.not.issymbol(car(args)) .or. .not.issymbol(cadr(args))) then call error0('Illegal use of put') return end if x=cdr(car(args)) y=cadr(args) do while (x /= nil) if (caar(x) == y) exit x=cdr(x) end do if (x /= nil) then call set_cdar(x, caddr(args)) else call set_cdr(car(args), cons(cons(y, caddr(args)), cdr(car(args)))) end if call s_return(t) ! get else if (op == OP_GET) then if (.not.issymbol(car(args)) .or. .not.issymbol(cadr(args))) then call error0('Illegal use of get') return end if x=cdr(car(args)) y=cadr(args) do while (x /= nil) if (caar(x) == y) exit x=cdr(x) end do if (x /= nil) then call s_return(cdar(x)) else call s_return(nil) end if ! quit else if (op == OP_QUIT) then stop ! gc else if (op == OP_GC) then call gc(nil, nil, 1) call s_return(t) ! gc-verbose else if (op == OP_GCVERB) then continue ! new segment size else if (op == OP_NEWSEGMENT) then if (.not.isint(car(args))) then call error0('new segment -- argument must be a number!') return end if cell_segment=get_ivalue(car(args)) write(outstr, '(a,i4,a)') & 'Allocation of new memory in increments of ', cell_segment, ' cells' call s_return(t) end if end subroutine opexe4 ! subroutine opexe5(op) integer :: op integer :: x integer :: strlen character (len=128) :: str character (len=1) :: ch if (op == OP_RDSEXPR) then ! write(*,*) 'At OP_RDSEXPR tok=', tok if (tok == TOK_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() oper=OP_RDSEXPR else if (tok == TOK_LPAREN) then tok = token() if (tok == TOK_RPAREN) then call s_return(nil) else if (tok == TOK_DOT) then call error0('Syntax error -- illegal dot expression') else call s_save(OP_RDLIST, nil, nil) oper=OP_RDSEXPR end if else if (tok == TOK_QUOTE) then call s_save(OP_RDQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == TOK_BQUOTE) then call s_save(OP_RDQQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == TOK_COMMA) then call s_save(OP_RDUNQUOTE, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == TOK_ATMARK) then call s_save(OP_RDUQTSP, nil, nil) tok=token() oper=OP_RDSEXPR else if (tok == TOK_ATOM) then call readstr(str) call s_return(mk_atom(trim(str))) else if (tok == TOK_DQUOTE) then call readstrexp(str, strlen) call s_return(mk_string(str(1:strlen))) else if (tok == TOK_SHARP) then call readstr(str) x=mk_const(str) if (x == nil) then call error0('Undefined sharp expression') else call s_return(x) end if else write(*,*) 'bad tok=', tok call error0('syntax error -- illegal token') end if else if (op == OP_RDLIST) then args = cons(value, args) tok = token() ! write(*,*) 'At OP_RDLIST tok=', tok, lin(1:currentline),'^',lin(currentline+1:eol) if (tok == TOK_COMMENT) then do call inchar(ch) if (currentline > eol) exit end do tok = token() ! write(*,*) 'At OP_RDLIST COMMENT tok=', tok end if if (tok == TOK_RPAREN) then call s_return(non_alloc_rev(nil, args) ) else if (tok == TOK_DOT) then call s_save(OP_RDDOT, args, nil) tok=token() oper=OP_RDSEXPR else call s_save(OP_RDLIST, args, nil) oper=OP_RDSEXPR end if else if (op == OP_RDDOT) then if (token() /= TOK_RPAREN) then call error0('syntax error -- illegal dot expression') end if call s_return(non_alloc_rev(value, args)) else if (op == OP_RDQUOTE) then call s_return(cons(quote, cons(value, nil))) else if (op == OP_RDQQUOTE) then call s_return(cons(qquote, cons(value, nil))) else if (op == OP_RDUNQUOTE) then call s_return(cons(unquote, cons(value, nil))) else if (op == OP_RDUQTSP) then call s_return(cons(unquotesp, cons(value, nil))) else if (op == OP_P0LIST) then if (isvector(args)) then write(outstr, '(a)', advance='no') '#(' args=cons(args, mk_number(0)) oper=OP_PVECFROM else if (.not.ispair(args)) then if (print_flag == 1) call printatom(args) call s_return(t) else if (car(args) == quote .and. ok_abbrev(cdr(args))) then write(outstr, '(a)', advance='no') '"' args=cadr(args) oper=OP_P0LIST else if (car(args) == qquote .and. ok_abbrev(cdr(args))) then write(outstr, '(a)', advance='no') '`' args=cadr(args) oper=OP_P0LIST else if (car(args) == unquote .and. ok_abbrev(cdr(args))) then write(outstr, '(a)', advance='no') ',' args=cadr(args) oper=OP_P0LIST else if (car(args) == unquotesp .and. ok_abbrev(cdr(args))) then write(outstr, '(a)', advance='no') ',@' args=cadr(args) oper=OP_P0LIST else write(outstr, '(a)', advance='no') '(' call s_save(OP_P1LIST, cdr(args), nil) args=car(args) oper=OP_P0LIST end if else if (op == OP_P1LIST) then if (ispair(args)) then call s_save(OP_P1LIST, cdr(args), nil) write(outstr, '(a)', advance='no') ' ' args=car(args) oper=OP_P0LIST else if (args /= nil) then write(outstr, '(a)', advance='no') ' . ' if (print_flag==1) call printatom(args) end if write(outstr, '(a)', advance='no') ')' call s_return(t) end if else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe5 ! subroutine opexe6(op) integer :: op integer :: w, x, y ! list-length if (op == OP_LIST_LENGTH) then w=get_listlen(car(args)) if (w < 0) then call error1('Not a list:', car(args)) else call s_return(mk_number(w)) end if ! assq else if (op == OP_ASSQ) then x=car(args) y=cadr(args) do while (ispair(y)) if (.not.ispair(car(y))) then call error0('Unable to handle non-pair element') return end if if (x == caar(y)) exit y=cdr(y) end do if (ispair(y)) then call s_return(car(y)) else call s_return(f) end if ! print-width else if (op == OP_PRINT_WIDTH) then w=0 args=car(args) print_flag=-1 oper=OP_P0_WIDTH else if (op == OP_P0_WIDTH) then if (.not.ispair(args)) then w=w+lenatom(args) call s_return(mk_number(w)) else if (car(args) == quote .and. ok_abbrev(cdr(args))) then w=w+1 args=cadr(args) oper=OP_P0_WIDTH else if (car(args) == qquote .and. ok_abbrev(cdr(args))) then w=w+1 args=cadr(args) oper=OP_P0_WIDTH else if (car(args) == unquote .and. ok_abbrev(cdr(args))) then w=w+1 args=cadr(args) oper=OP_P0_WIDTH else if (car(args) == unquotesp .and. ok_abbrev(cdr(args))) then w=w+2 args=cadr(args) oper=OP_P0_WIDTH else w=w+1 call s_save(OP_P1_WIDTH, cdr(args), nil) args=car(args) oper=OP_P0_WIDTH end if else if (op == OP_P1_WIDTH) then if (ispair(args)) then call s_save(OP_P1_WIDTH, cdr(args), nil) w=w+1 args=car(args) oper=OP_P0_WIDTH else if (args /= nil) then w=w+3+lenatom(args) end if w=w+1 call s_return(mk_number(w)) end if ! get-closure-code else if (op == OP_GET_CLOSURE) then args=car(args) if (args == nil) then call s_return(f) else if (isclosure(args)) then call s_return(cons(lambda, car(value))) else if (ismacro(args)) then call s_return(cons(lambda, car(value))) else call s_return(f) end if ! closure? else if (op == OP_CLOSUREP) then if (car(args) == nil) then call s_return(f) end if call s_retbool(isclosure(car(args))) ! macro? else if (op == OP_MACROP) then if (car(args) == nil) then call s_return(f) end if call s_retbool(ismacro(car(args))) else write(outstr, '(2a)') oper, 'is an illegal operator!' end if end subroutine opexe6 ! ! Mathematical functions ! subroutine opexe7(op) integer :: op integer :: x, v double precision :: rv ! exponentiation if (op == OP_EXP) then x = car(args) rv=exp(rvalue(x)) call s_return(mk_real(rv)) ! natural log else if (op == OP_LOG) then x = car(args) rv = log(rvalue(x)) call s_return(mk_real(rv)) ! sine else if (op == OP_SIN) then x = car(args) rv = sin(rvalue(x)) call s_return(mk_real(rv)) ! cosine else if (op == OP_COS) then x = car(args) rv = cos(rvalue(x)) call s_return(mk_real(rv)) ! tan else if (op == OP_TAN) then x = car(args) rv = tan(rvalue(x)) call s_return(mk_real(rv)) ! arcsine else if (op == OP_ASIN) then x = car(args) rv = asin(rvalue(x)) call s_return(mk_real(rv)) ! arcosine else if (op == OP_ACOS) then x = car(args) rv = acos(rvalue(x)) call s_return(mk_real(rv)) ! arctan else if (op == OP_ATAN) then x = car(args) rv = atan(rvalue(x)) call s_return(mk_real(rv)) ! sqrt else if (op == OP_SQRT) then x = car(args) rv = sqrt(rvalue(x)) call s_return(mk_real(rv)) ! truncate else if (op == OP_TRUNCATE) then x = car(args) rv = int(rvalue(x)) call s_return(mk_real(rv)) ! round else if (op == OP_ROUND) then x = car(args) rv = anint(rvalue(x)) call s_return(mk_real(rv)) ! abs else if (op == OP_ABS) then x = car(args) if (isint(x)) then v=abs(get_ivalue(x)) call s_return(mk_number(v)) else rv = abs(rvalue(x)) call s_return(mk_real(rv)) end if else if (op == OP_EXPT) then x = car(args) v = cadr(args) if (isint(x) .and. isint(v) .and. get_ivalue(v) >= 0) then v = get_ivalue(x) ** get_ivalue(v) call s_return(mk_number(v)) else rv = rvalue(x) ** rvalue(v) call s_return(mk_real(rv)) end if end if end subroutine opexe7 ! ! A few other library functions eg min, max ! subroutine opexe8(op) integer :: op integer :: x, v logical :: int_op double precision :: rv int_op=.true. ! min if (op == OP_MIN) then if (isnumber(car(args))) then int_op=isint(car(args)) if (int_op) then v=get_ivalue(car(args)) else rv=get_value(car(args)) end if x = cdr(args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. end if rv=min(rv,rvalue(car(x))) else if (int_op) then v=min(v,get_ivalue(car(x))) else rv=min(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Min needs at least one argument!') end if ! max else if (op == OP_MAX) then if (isnumber(car(args))) then int_op=isint(car(args)) if (int_op) then v=get_ivalue(car(args)) else rv=get_value(car(args)) end if x = cdr(args) do while (x /= nil) if (isfloat(car(x))) then if (int_op) then int_op=.false. end if rv=max(rv,rvalue(car(x))) else if (int_op) then v=max(v,get_ivalue(car(x))) else rv=max(rv,rvalue(car(x))) end if x=cdr(x) end do if (int_op) then call s_return(mk_number(v)) else call s_return(mk_real(rv)) end if else call error0('Max needs at least one argument!') end if end if end subroutine opexe8 ! ! string functions ! subroutine opexe9(op) integer :: op integer :: el, i, j, l, v, x character (len=1) :: ch character (len=20) :: str ch=' ' ! make-string if (op == OP_MKSTRING) then l=get_ivalue(car(args)) if (cdr(args) /= nil) then ch=get_substr(cadr(args), 1, 1) end if call s_return(mk_string(repeat(ch,l))) ! string-length else if (op == OP_STRLEN) then call s_return(mk_number(get_strlen(car(args)))) ! string-set! else if (op == OP_STRSET) then i=get_ivalue(cadr(args)) if (i > get_strlen(car(args))) then call error1('ERROR: string-set! out of bounds:', cadr(args)) return end if call set_substring(car(args), i, i, get_substr(caddr(args), 1, 1)) call s_return(car(args)) ! substring else if (op == OP_SUBSTR) then l=get_strlen(car(args)) i=get_ivalue(cadr(args)) if (i > l) then call error1('substring start out of bounds:', cadr(args)) return end if if (cddr(args) /= nil) then j=get_ivalue(caddr(args)) if (j > l) then call error1('substring end out of bounds:', caddr(args)) return end if else j=l end if call s_return(mk_string(get_substr(car(args), i, j))) ! string-append else if (op == OP_STRAPPEND) then l=0 x=args do while (x /= nil) l=l+get_strlen(car(x)) x=cdr(x) end do v=mk_string(repeat(' ',l)) i=0 l=0 x=args do while (x /= nil) l=l+get_strlen(car(x)) call set_substring(v, i+1, l, get_string(car(x))) i=l x=cdr(x) end do call s_return(v) ! string->symbol else if (op == OP_STR2SYM) then call s_return(mk_symbol(get_string(car(args)))) ! symbol->string else if (op == OP_SYM2STR) then call s_return(mk_string(get_string(car(args)))) ! string->number else if (op == OP_STR2NUM) then str=get_string(car(args)) read(str,'(i20)') i call s_return(mk_number(i)) ! number->string else if (op == OP_NUM2STR) then write(str,'(i20)') get_ivalue(car(args)) call s_return(mk_string(trim(adjustl(str)))) ! vector else if (op == OP_VECTOR) then l=get_listlen(args) if (l < 0) then call error1('vector not a proper list: ', args) else v=mk_vector(l) x=args i=0 do while (ispair(x)) call set_vec(v, i, car(x)) i=i+1 x=cdr(x) end do call s_return(v) end if ! make-vector else if (op == OP_MKVECTOR) then l=get_ivalue(car(args)) v=mk_vector(l) i=cadr(args) if (i /= nil) call fill_vec(v, i) call s_return(v) ! vector-length else if (op == OP_VECLEN) then call s_return(mk_number(get_veclen(car(args)))) ! vector-set! else if (op == OP_VECSET) then i=get_ivalue(cadr(args)) if (i >= get_veclen(car(args))) then call error1('vector-set! out of bounds: ', cadr(args)) else call set_vec(car(args), i, caddr(args)) call s_return(car(args)) end if ! traverse a vector else if (op == OP_PVECFROM) then i=get_ivalue(cdr(args)) v=car(args) l=get_veclen(v) if (i==l) then write(outstr,'(a)', advance='no') ')' call s_return(t) else el=get_vec(v, i) write(outstr,'(a)', advance='no') ' ' call set_ivalue(cdr(args), i+1) call s_save(OP_PVECFROM, args, nil) args=el oper=OP_P0LIST end if else if (op == OP_VECREF) then i=get_ivalue(cadr(args)) if (i >= get_veclen(car(args))) then call error1('vector-ref out of bounds: ', cadr(args)) else call s_return(get_vec(car(args), i)) end if else if (op == OP_VECTORP) then call s_retbool(isvector(car(args))) end if end subroutine opexe9 ! ! Nonstandard library additions for system interface such as system, readline ! subroutine opexe10(op) integer :: ioerr, iport, op, tmp character (len=256) :: buff logical :: strfind if (op == OP_SYSTEM) then if (.not.isstring(car(args))) then call error0('Error -- first argument must be a string') call s_return(f) else call system(get_string(car(args))) call s_return(t) end if else if (op == OP_TRANSON) then if (isstring(car(args))) then outfil=get_string(car(args)) end if write(outstr, '(2a)') 'Transcript to be written to ', trim(outfil) outstr=OSTRM open(outstr, file=trim(outfil)) oper=OP_T0LVL else if (op == OP_TRANSOFF) then if (outstr /= OSTRM) then call error0('Transcript file not open!') return else close(outstr, status='keep') outstr=STDOUT end if else if (op == OP_APROPOS) then buff=' ' if (isstring(car(args))) then buff='*' // trim(get_string(car(args))) // '*' end if tmp=oblist do while (tmp /= nil) if (strfind(trim(buff), get_string(caar(tmp)), 1)) then write(outstr, '(a)') get_string(caar(tmp)) end if tmp=cdr(tmp) end do call s_return(t) else if (op == OP_MKPORT) then if (isstring(car(args))) then outfil=get_string(car(args)) end if write(outstr, '(2a)') 'Opening ', trim(outfil) if (nports < 2) then nports=nports+1 iport=portaddress(nports) open(iport, file=trim(outfil), status='unknown') call s_return(mk_port(iport)) else call error0('Too many open files!') call s_return(f) end if else if (op == OP_CLPORT) then iport=get_ivalue(cdr(args)) close(iport) nports=nports-1 call s_return(t) else if (op == OP_RDLINE) then iport=get_ivalue(car(args)) read(iport, '(a)', iostat=ioerr) buff if (ioerr==0) then call s_return(mk_string(buff)) else call s_return(f) end if end if end subroutine opexe10 ! ! Initialization of internal keywords ! subroutine mk_syntax(op, nam) integer :: op character (len=*) :: nam integer :: x x=cons(mk_string(nam), nil) call set_type(x, ior(T_SYNTAX, T_SYMBOL)) call set_syntaxnum(x, op) oblist=cons(x, oblist) end subroutine mk_syntax ! subroutine mk_proc(op, nam) integer :: op character (len=*) :: nam integer :: x, y x=mk_symbol(nam) y=getcell(nil, nil) call set_type(y, ior(T_PROC, T_ATOM)) call set_ivalue(y, op) call set_car(global_env, cons(cons(x, y), car(global_env))) end subroutine mk_proc ! ! Initiate global environment ! subroutine init_vars_global() integer :: x infp=STDIN outstr=STDOUT global_env=cons(nil, nil) x=mk_symbol('else') call set_car(global_env, cons(cons(x, t), car(global_env))) end subroutine init_vars_global ! ! Initiate syntax ! subroutine init_syntax() call mk_syntax(OP_LAMBDA, 'lambda') call mk_syntax(OP_QUOTE, 'quote') call mk_syntax(OP_DEF0, 'define') call mk_syntax(OP_IF0, 'if') call mk_syntax(OP_BEGIN, 'begin') call mk_syntax(OP_SET0, 'set!') call mk_syntax(OP_LET0, 'let') call mk_syntax(OP_LET0AST, 'let*') call mk_syntax(OP_LET0REC, 'letrec') call mk_syntax(OP_COND0, 'cond') call mk_syntax(OP_DELAY, 'delay') call mk_syntax(OP_AND0, 'and') call mk_syntax(OP_OR0, 'or') call mk_syntax(OP_C0STREAM, 'cons-stream') call mk_syntax(OP_0MACRO, 'macro') call mk_syntax(OP_CASE0, 'case') end subroutine init_syntax ! ! Initiate procedures ! subroutine init_procs() call mk_proc(OP_PEVAL, 'eval') call mk_proc(OP_PAPPLY, 'apply') call mk_proc(OP_CONTINUATION, 'call-with-current-continuation') call mk_proc(OP_FORCE, 'force') call mk_proc(OP_CAR, 'car') call mk_proc(OP_CDR, 'cdr') call mk_proc(OP_CONS, 'cons') call mk_proc(OP_SETCAR, 'set-car!') call mk_proc(OP_SETCDR, 'set-cdr!') call mk_proc(OP_ADD, '+') call mk_proc(OP_SUB, '-') call mk_proc(OP_MUL, '*') call mk_proc(OP_DIV, '/') call mk_proc(OP_INTDIV, 'quotient') call mk_proc(OP_REM, 'remainder') call mk_proc(OP_MOD, 'modulo') call mk_proc(OP_NOT, 'not') call mk_proc(OP_BOOL, 'boolean?') call mk_proc(OP_ISINT, 'integer?') call mk_proc(OP_SYMBOL, 'symbol?') call mk_proc(OP_NUMBER, 'number?') call mk_proc(OP_STRING, 'string?') call mk_proc(OP_PROC, 'procedure?') call mk_proc(OP_PAIR, 'pair?') call mk_proc(OP_EQV, 'eqv?') call mk_proc(OP_EQ, 'eq?') call mk_proc(OP_NULL, 'null?') call mk_proc(OP_ZEROP, 'zero?') call mk_proc(OP_POSP, 'positive?') call mk_proc(OP_NEGP, 'negative?') call mk_proc(OP_NUMEQ, '=') call mk_proc(OP_LESS, '<') call mk_proc(OP_GRE, '>') call mk_proc(OP_LEQ, '<=') call mk_proc(OP_GEQ, '>=') call mk_proc(OP_READ, 'read') call mk_proc(OP_WRITE, 'write') call mk_proc(OP_DISPLAY, 'display') call mk_proc(OP_NEWLINE, 'newline') call mk_proc(OP_LOAD, 'load') call mk_proc(OP_ERR0, 'error') call mk_proc(OP_REVERSE, 'reverse') call mk_proc(OP_APPEND, 'append') call mk_proc(OP_PUT, 'put') call mk_proc(OP_GET, 'get') call mk_proc(OP_GC, 'gc') call mk_proc(OP_GCVERB, 'gc-verbose') call mk_proc(OP_NEWSEGMENT, 'new-segment') call mk_proc(OP_LIST_LENGTH, 'length') call mk_proc(OP_ASSQ, 'assq') call mk_proc(OP_PRINT_WIDTH, 'print-width') call mk_proc(OP_GET_CLOSURE, 'get-closure-code') call mk_proc(OP_CLOSUREP, 'closure?') call mk_proc(OP_MACROP, 'macro?') call mk_proc(OP_QUIT, 'quit') call mk_proc(OP_EXP, 'exp') call mk_proc(OP_LOG, 'log') call mk_proc(OP_SIN, 'sin') call mk_proc(OP_COS, 'cos') call mk_proc(OP_TAN, 'tan') call mk_proc(OP_ASIN, 'asin') call mk_proc(OP_ACOS, 'acos') call mk_proc(OP_ATAN, 'atan') call mk_proc(OP_SQRT, 'sqrt') call mk_proc(OP_TRUNCATE, 'truncate') call mk_proc(OP_ROUND, 'round') call mk_proc(OP_ABS, 'abs') call mk_proc(OP_EXPT, 'expt') call mk_proc(OP_MIN, 'min') call mk_proc(OP_MAX, 'max') call mk_proc(OP_MKSTRING, 'make-string') call mk_proc(OP_STRLEN, 'string-length') call mk_proc(OP_STRSET, 'string-set!') call mk_proc(OP_SUBSTR, 'substring') call mk_proc(OP_STRAPPEND, 'string-append') call mk_proc(OP_STR2NUM, 'string->number') call mk_proc(OP_NUM2STR, 'number->string') call mk_proc(OP_STR2SYM, 'string->symbol') call mk_proc(OP_SYM2STR, 'symbol->string') call mk_proc(OP_VECTOR, 'vector') call mk_proc(OP_MKVECTOR, 'make-vector') call mk_proc(OP_VECLEN, 'vector-length') call mk_proc(OP_VECSET, 'vector-set!') call mk_proc(OP_VECREF, 'vector-ref') call mk_proc(OP_VECTORP, 'vector?') call mk_proc(OP_SYSTEM, 'system') call mk_proc(OP_TRANSON, 'transcript-on') call mk_proc(OP_TRANSOFF, 'transcript-off') call mk_proc(OP_APROPOS, 'apropos') call mk_proc(OP_MKPORT, 'open-input-file') call mk_proc(OP_CLPORT, 'close-input-port') call mk_proc(OP_RDLINE, 'read-line') end subroutine init_procs ! ! Initiate procedures ! subroutine init_globals() call init_vars_global() call init_syntax() call init_procs() ! init global pointers to special symbols lambda=mk_symbol('lambda') quote=mk_symbol('quote') qquote=mk_symbol('quasiquote') unquote=mk_symbol('unquote') unquotesp=mk_symbol('unquote-splicing') end subroutine init_globals ! ! Error handling ! subroutine error0(s) character (len=*) :: s args=cons(mk_string(s), nil) oper=OP_ERR0 write(*,'(/5a)') ' At: "', lin(1:currentline), '^', & trim(lin(currentline+1:eol)) , '"' end subroutine error0 ! subroutine error1(s, a) integer :: a character (len=*) :: s args=cons(a, nil) args=cons(mk_string(s), args) oper=OP_ERR0 write(*,'(/5a)') ' At: "', lin(1:currentline), '^', & trim(lin(currentline+1:eol)) , '"' end subroutine error1 ! end module cell_class ! ! Main program ! program fscheme use cell_class integer :: it, op character (len=8) :: initfile = 'init.scm' write(outstr, '(a)') 'Hello, This is the fscheme interpreter Version 0.01' it=0 print_flag=1 call setup_mem(1000) call init_globals() args = cons(mk_string(initfile), nil) oper = OP_LOAD do it=it+1 op=oper if (op == OP_QUIT) then write(*, '(a)') 'Goodbye!' exit else if (op >= OP_LOAD .and. op <= OP_LET2AST) then call opexe0(op) else if (op >= OP_LET0REC .and. op <= OP_CONTINUATION) then call opexe1(op) else if (op >= OP_ADD .and. op <= OP_SETCDR) then call opexe2(op) else if (op >= OP_NOT .and. op <= OP_EQV) then call opexe3(op) else if (op >= OP_FORCE .and. op <= OP_NEWSEGMENT) then call opexe4(op) else if (op >= OP_RDSEXPR .and. op <= OP_P1LIST) then call opexe5(op) else if (op >= OP_LIST_LENGTH .and. op <= OP_MACROP) then call opexe6(op) else if (op >= OP_EXP .and. op <= OP_EXPT) then call opexe7(op) else if (op >= OP_MIN .and. op <= OP_MAX) then call opexe8(op) else if (op >= OP_MKSTRING .and. op <= OP_VECTORP) then call opexe9(op) else if (op >= OP_SYSTEM .and. op <= OP_RDLINE) then call opexe10(op) else write(*, '(a)') 'Bad op code! Exiting!' exit end if end do call cleanup_mem() end program fscheme ! ! character to integer conversion via internal read ! function ival(string) use outstream integer :: ival character (len=*), intent(in) :: string integer :: i, ioerr if (string.eq.' ') then ival=0 else read(string, '(i20)', iostat=ioerr) i if (ioerr==0) then ival=i else write(outstr,'(2a/)') 'ERROR: Unable to read integer ', string ival=0 end if end if end function ival ! ! character to float conversion via internal read ! function fval(string) use outstream double precision :: fval character(len=*), intent(in) :: string integer :: ioerr double precision :: v if (string.eq.' ') then fval=0.0d0 else read(string, '(f20.0)', iostat=ioerr) v if (ioerr==0) then fval=v else write(outstr,'(2a/)') 'ERROR: Unable to read double precision number ', string fval=0.0d0 end if end if end function fval ! ! Compare string to a search string, allowing wildcards '*.', and case ! matching ! function strfind(regexp, targt, nocase) logical :: strfind character (len=*), intent(in) :: regexp character (len=*), intent(in) :: targt integer, intent(in) :: nocase ! 1=respect 2=ignore integer :: i, ich1, ich2, lenr, lent, pos, wpos logical :: looking, wild lenr=len_trim(regexp) lent=len_trim(targt) ! while regexp and target not exhausted i=1 pos=1 wpos=0 wild=.false. looking=.true. strfind=.true. do while (looking) if (regexp(pos:pos) == '*') then wild=.true. wpos=pos pos=pos+1 looking=(pos <= lenr) else ! this character matches? if (regexp(pos:pos) == '.' .and. .not.wild) then strfind=.true. else if (nocase == 2) then ich1=ichar(regexp(pos:pos)) ich2=ichar(targt(i:i)) if (ich1 >= 65 .and. ich1 <= 90) ich1=ich1+32 if (ich2 >= 65 .and. ich2 <= 90) ich2=ich2+32 strfind=(ich1 == ich2) else strfind=(regexp(pos:pos) == targt(i:i)) end if looking=strfind if (wild) then looking=.true. if (strfind) then wild=.false. else pos=wpos end if end if pos=pos+1 i=i+1 ! target exhausted? If regexp ends in wild card, then found if (i > lent) then looking=.false. if (regexp(pos:pos) == '*' .and. pos == lenr) wild=.true. if (pos <= lenr .and. .not.wild) strfind=.false. end if ! regexp exhausted? if regexp doesn't end in wild card, then not found ! so recycle completely if (pos > lenr) then if (i <= lent) then if (wild) then looking=.false. strfind=.true. else looking=.true. pos=1 end if end if ! if not exhausted and only partial match and previous wild card, then recycle else if (.not.strfind .and. wpos /= 0 .and. i <= lent) then looking=.true. pos=wpos+1 end if end if end do end function strfind