/ / Data types / / There are three types of s-expressions: / pairs / symbols / numbers / symbols and numbers are atoms. / symbols and pairs are cons cells and take up two words of memory. / the first word is called the car. / the second word is called the cdr. / a symbol is a cons whose car is 7777. / / / Memory / / numbers are stored in the number storage area, one word per number. / pairs and symbols are stored in the cons storage area, two words per cons. / the type is determined by the address, and car if it's a cons. / for garbage collection we have a bit table to mark numbers and conses. / the lower 8 bits of a mark word mark conses, so 16 cons words can be marked. / the upper 4 bits of a makr word mark numbers, so 4 number words can be marked. / any word below cons storage will stop the GC, so smaller numbers or / pointers to other data or code can be stored in cons cells directly. / / / Atom structure / / symbol: / [ 7777 | ]--> [ name | prop ] / / name: / [ /AB/ | ]--> [ /CD/ | NIL ] / / prop: / [ VAL | sexp ] / [ SUBR | ]--> [ n | code ] / [ FSUBR | code ] / [ EXPR | ]--> [ n | sexp ] / [ FEXPR | sexp ] / / the characters in 'name' must not be seen by the GC. / 'n' and 'code' are guaranteed to be below cons storage so they're GC safe. / / / definitions / tls=6046 tsf=6041 ksf=6031 krb=6036 pdlsz=100 / size of push down list / for the mark bit table we use of every word / the upper 4 bits for numbers -> 4 words / and the lower 8 bits for cons cells -> 16 words cst.sz=1000 / size of cons storage in words (two words per cons cell) nst.sz=200 / size of number storage, must be <= cst.sz>>2 mbt.sz=40 / must have enough room for the above (usually cst.sz>>4) fixtab / zero page - important stuff / auto increment *10 x1, 0 x=x1 x2, 0 x3, 0 *20 t, 0 / very temporary t2, 0 a, 0 b, 0 c, 0 d, 0 p, 0 / pointer q, 0 pdp, 0 / push down pointer / cons and number free list cflst, 0 nflst, 0 / jump to subroutine, push return address on pdl pushj, 0 dca a / save ac tad pushj / return address iac jms i (push) tad i pushj / load jump target dca pushj tad a / restore ac jmp i pushj / pop return address and jump there 0 popj, jms i (pop) dca popj-1 jmp i popj-1 / skip return if AC and word after jms are not equal / clear AC eq, 0 cia tad i eq sza cla isz eq isz eq jmp i eq / skip return if AC is not between two words after jms / that is, don't skip if A <= AC < B / clear AC twixt, 0 cia / first calculate A - AC stl tad i twixt snl sza / skip if A - AC <= 0 jmp twixt1 / outside cia / -(-(A-AC) + A) = -AC tad i twixt cia isz twixt / go to B stl tad i twixt / calculate B - AC isz twixt / go to return address 10 snl sza cla / skip if B - AC > 0 isz twixt / outside, skip return jmp i twixt twixt1, cla isz twixt isz twixt isz twixt jmp i twixt *200 start, cla tad (pdl) dca pdp / jms gcgo jms i (read) dca a jms i (newln) tad a jms pushj; print hlt / hlt / tad (subr@) / dca a / tad (expr@) / dca b / jms i (cons) / jms pushj; print / tad (3344) / hlt / jms i (consn) / jms pushj; print / tad (bar2) / jms pushj; print hlt / run the GC, most registers are used by gcmk, so be careful gcgo, 0 jms regsv / 1st step: clear mark bits jms i (gcclr) / 2nd step: mark temlist sta tad (temlis) dca x gcgo2, tad i x / get item on temlist sna jmp gcgo3 / end of temlist dca t tad i t / indirection jms pushj; gcmk jmp gcgo2 / 3rd step: mark oblist gcgo3, tad (oblis@) jms pushj; gcmk / 4th step: sweep jms i (gcswp) jms regrst jmp i gcgo / save x-q registers regsv, 0 cla tad x1 / save x1 and x2 dca regsv1 tad x2 dca regsv1+1 tad (x1+1) / src dca x1 tad (regsv1+1) / dst dca x2 tad (-16) / counter dca regsv2 regsv3, tad i x1 dca i x2 isz regsv2 jmp regsv3 jmp i regsv / and restore regrst, 0 cla tad (regsv1+1) / src dca x1 tad (x1+1) / dst dca x2 tad (-16) / counter dca regsv2 rgrst3, tad i x1 dca i x2 isz regsv2 jmp rgrst3 tad regsv1 dca x1 / restore x1 and x2 tad regsv1+1 dca x2 jmp i regrst regsv2, 0 regsv1, *.+20 / push ac onto push down list / halt on overflow push, 0 dca t tad pdp / increment first iac dca pdp cll tad pdp / check for overflow tad (-pdlend) szl cla hlt / overflow, halt tad t dca i pdp / then store jmp i push / pop from push down list and return in ac / halt on underflow pop, 0 cla tad i pdp / load dca t cma / decrement tad pdp dca pdp cll tad pdp / check for underflow tad (-pdl) snl cla hlt / underflow, halt tad t jmp i pop / return t if ac is nil, otherwise nil null, 0 sna cla tad [true@] / ac is nil jmp i null pagbrk / return car of cons cell car, 0 sna jmp i car dca t tad i t jmp i car / return cdr of cons cell cdr, 0 sna jmp i cdr iac dca t tad i t jmp i cdr / numberp, skip return if it's not a number, clear ac nump, 0 cll tad [-nst.s] snl jmp nump1 / below nst.s -> not a number tad (nst.s-nst.e) szl cla jmp i nump / below cst.s -> number nump1, cla isz nump jmp i nump / atom, skip return if it's an atom, clear ac atom, 0 sna / common case: nil is an atom jmp i atom dca t / store ptr tad t cll tad [-cst.s] snl jmp atom1 / below cons area -> atom tad (cst.s-cst.e) snl jmp atom1 / above cons area -> atom cla / get car tad i t iac / if car == -1 -> atom sza isz atom atom1, cla jmp i atom / / output / pagbrk / print ascii char in ac on tty, clear ac putc, 0 tls tsf jmp .-1 cla jmp i putc newln, 0 cla tad (215) jms putc tad (212) jms putc jmp i newln / print zero terminated ascii string puts, 0 cia; cma / decrement address dca x puts1, cla tad i x sna jmp i puts jms putc jmp puts1 / print sixbit word, stop at space putsxw, 0 dca t tad t rtr; rtr; rtr and [77] dca asc / store first char tad t and [77] dca asc+1 / store second char tad asc sna jmp i putsxw / stop at space tad [240] / to ascii jms putc cla tad asc+1 sna jmp i putsxw / stop at space tad [240] / to ascii jms putc jmp i putsxw asc, 0; 0 / -(p) <- ac pshdec, 0 dca t tad p cia; cma dca p tad t dca i p jmp i pshdec / print a number putn, 0 sna jmp put0 / special case 0 dca a / store the number in a tad (buf+4) dca p / string pointer tad a putn1, dca a / store number tad a / get number and [7] / next digit tad [260] / to ascii jms pshdec / add to string tad a / shift number right 3 places rtr; rar and (777) sza jmp putn1 / loop until zero tad p / print string jms puts jmp i putn put0, tad ("0) jms putc jmp i putn / print the name of a symbol, ac = list containing name prsym, 0 sna jmp i prsym / nil, return dca a tad i a / get first two chars jms putsxw cla isz a / get cdr tad i a jmp prsym+1 pagbrk / print an s-exp print, sna jmp prnil dca a tad a jms i (nump) jmp prnum / print number tad a jms i (atom) jmp pratm / print atom tad a jmp prnlis prnum, tad i a / load number jms i (putn) jmp popj pratm, isz a / get cdr tad i a dca a / get car tad i a jms i (prsym) jmp popj prnil, tad (nilstr) jms i (puts) jmp popj nilstr, asciz /nil/ / print list prnlis, dca a tad ("() jms i [putc] prls2, tad a jms i [push] / push current list tad i a / get car jms pushj; print jms i [pop] / pop list dca a isz a / get cdr tad i a sza jmp prls1 prls3, tad (")) / end of list jms i [putc] jmp popj prls1, dca a / list continues tad (" ) jms i [putc] tad a jms i (atom) skp jmp prls2 / cdr is not an atom tad (".) / cdr is an atom, print dotted list jms i [putc] tad (" ) jms i [putc] tad a jms pushj; print jmp prls3 / / input / / read one ascii char into AC getc, 0 ksf jmp .-1 krb jmp i getc / get ascii character, echo, map CR to LF peekc, 4000 ch, 0 cll cla tad peekc sma cla jmp ch1 jms getc dca t ch3, tad t jms i [putc] tad t jms eq; 215 / if CR, print and return LF jmp ch2 tad t jmp i ch ch2, tad (212) / got CR dca t jmp ch3 ch1, / get peeked char tad peekc dca t stl cla rar / set sign dca peekc tad t jmp i ch / like ch, but skip over space chsp, 0 jms ch dca t tad t tad [-" ] / make sixbit spa / fold all controls chars to 0 cla sna cla jmp chsp+1 / is space, loop tad t / get ascii char jmp i chsp / skip return if AC is a symbol character / accept everything that isn't space or parens symcp, 0 dca t tad t jms twixt; 200; 241 jmp i symcp / space, not a symbol char tad t jms eq; "( jmp i symcp tad t jms eq; ") jmp i symcp isz symcp jmp i symcp pagbrk / convert in place an ascii string in buf to sixbit sixstr, 0 sta tad (buf) dca x1 tad x1 dca x2 sxstr1, tad i x1 / get ascii char sna jmp sxstr2 / got a zero tad [-" ] / convert to sixbit spa cla cll; rtl; rtl; rtl / move up dca t / store tad i x1 / get next ascii char sna jmp sxstr3 / got a zero, store half word tad [-" ] / convert to sixbit spa cla tad t / add upper char dca i x2 / store sixbit word jmp sxstr1 sxstr3, tad t / get half filled word dca i x2 / store last word sxstr2, dca i x2 / zero word jmp i sixstr / read an s-expression read, 0 jms i (chsp) dca a / check for ')' tad a jms eq; ") hlt / this can't happen / check for '(' tad a jms eq; "( hlt / start of list tad a jms twixt; "0; "9+1 jmp rdnum / number / must be a symbol then tad a dca i (peekc) / read symbol, ascii string left in buf sta / set up buffer tad (buf) dca x rdsym1, jms i (ch) / get character dca a tad a jms i (symcp) jmp rdsym2 / not a symbol char tad a dca i x / store in buffer jmp rdsym1 rdsym2, dca i x / end string tad a dca i (peekc) / unget char jms i (sixstr) / make sixbit string jms i (intern) / intern symbol and return jmp i read / read number, number left in B rdnum, tad a dca i (peekc) dca b / clear number rdnum1, jms i (ch) / get character dca a tad a jms twixt; "0; "9+1 skp / it's a digit jmp rdnum2 / not a digit tad a tad (-"0) / get numeric value dca a tad b cll ral; cll ral; cll ral / shift left 3 bits tad a / combine with previous number dca b jmp rdnum1 / get next digit rdnum2, tad a dca i (peekc) / unget char tad b jms i (consn) jmp i read / garbage collector pagbrk / mark an object gcmk, sna jmp popj / stop at nil dca a tad a / test for number jms i (nump) jmp gcmn / mark number / we should be inside the cons storage now, but possibly below tad a / set up mark info jms gcmbc jmp popj / we're below cons storage, no need to mark anything jms gcmtst jmp popj / marked already dca t2 / store rotated word tad a / test for atom (symbol) jms i (atom) jmp gcma / mark atom / mark list tad t2 / rotated mark word stl / mark jms i (gcstm) / store mark tad a / push current list jms i [push] tad i a / get car jms pushj; gcmk / mark car jms i [pop] / pop list dca a isz a / get cdr tad i a jmp gcmk / mark cdr gcmn, tad a / mark number jms gcmbn / get mark bit info for number jms gcmtst jmp popj / already marked stl / mark jms i (gcstm) / store mark jmp popj / mark atom gcma, / first cons: [ -1 | -> ] mark bit info already set up tad t2 / rotated mark word stl / mark jms i (gcstm) / store mark / we don't mark the car because it's -1 isz a / get cdr tad i a / second cons: [ name | sexp ] sna jmp popj / stop at nil dca a tad a jms gcmbc / set up mark info, we assume it's a proper cons! hlt / this shouldn't happen jms gcmtst jmp popj / marked already stl / mark jms i (gcstm) / store mark tad a dca d / store in D because A-C are clobbered tad i d / get car jms gcmd / mark character list, only cdrs isz d / get cdr tad i d jmp gcmk / mark the rest normally / mark cdrs of a list, this assumes a proper list! gcmd, 0 sna jmp i gcmd / stop at nil dca a tad a jms gcmbc / set up mark info, we assume it's a proper cons! hlt / this shouldn't happen jms gcmtst jmp i gcmd / marked already stl / mark jms i (gcstm) / store mark isz a / get cdr tad i a jmp gcmd+1 / mark rest / store word address and bit position of cons cell (list or atom) mark bit / skip return unless we're below cons storage / B=word address; C=complement of bit position / address is in AC, don't clobber A gcmbc, 0 cll tad [-cst.s] snl jmp i gcmbc / below cons area dca t / calculate offset into cons storage tad t rar szl / some sanity checking: bit 11 of an address cannot be 1 hlt / bit 11 was 1 and [7] / mask out bit position cma / set up shift counter dca c tad t / reload offset rtr; rtr and [377] / mask out word number tad (mbt.s) / get address of word dca b isz gcmbc / skip return jmp i gcmbc / same but for numbers gcmbn, 0 tad [-nst.s] dca t / calculate offset into number storage tad t and [3] / mask out bit position tad [10] / bit is at the top cma / set up shift counter dca c tad t / reload offset rtr and [1777] / mask out word number tad (mbt.s) / get address of word dca b jmp i gcmbn / test if cons cell (list or atom) is marked, skip return if not marked / mark bit info must have been set up by the above functions before / leave AC in place so it can be rotated back and stored again gcmtst, 0 tad c dca t / set up shift count tad i b / load the word with the bit in it gcmt1, rar isz t / rotate nth bit into L jmp gcmt1 snl / skip return if not marked isz gcmtst jmp i gcmtst pagbrk / reverse of the above, mark bit is in L, rotate back and store gcstm, 0 dca t2 tad c dca t / set up shift count tad t2 gcstm1, ral isz t / L back into nth bit jmp gcstm1 dca i b / store marked word jmp i gcstm / clear bit table gcclr, 0 sta tad (mbt.s) dca x / store pointer tad (-mbt.sz) dca a / store counter gcclr1, dca i x isz a jmp gcclr1 jmp i gcclr / sweep up unused objects, construct the two free lists gcswp, 0 cla dca cflst dca nflst / init both lists sta tad (mbt.s) dca x1 / store pointer to mark words sta tad (cst.s) dca x2 / store pointer to conses sta tad (nst.s) dca x3 / store pointer to numbers tad (-mbt.sz) dca a / store counter of mark words gcswp1, / mark word loop cla tad (-10) dca b / cons counter tad i x1 / get mark word gcswp2, / cons loop rar / rotate current bit into L snl jmp gcfrcs / bit is clear, free cons isz x2 / cons is used, advance isz x2 gcswp3, isz b jmp gcswp2 / end cons loop dca t / save mark word tad (-4) dca b / number counter tad t / restore mark word gcswp4, / number loop rar / rotate current bit into L snl jmp gcfrn / bit is clear, free number isz x3 / number is used, advance gcswp5, isz b jmp gcswp4 / end number loop isz a jmp gcswp1 / end mark word loop jmp i gcswp / free a cons, don't clobber AC, A, B gcfrcs, dca t / save AC tad cflst / get free list dca t2 / save it tad x2 / get current cons iac dca cflst / make it new head of free list dca i x2 / clear car, go to cdr tad t2 / get old free list dca i x2 / store in cdr tad t / restore AC jmp gcswp3 / back into cons loop / free number, like above gcfrn, dca t / save AC tad nflst / get free list dca t2 / save it tad x3 / get current number iac dca nflst / make it new head of free list tad t2 / get old free list dca i x3 / store in number tad t / restore AC jmp gcswp5 pagbrk / Construct cell, arguments are in A and B / returned cons is in AC cons, 0 cla tad cflst / get free word sna jmp consgc / nil, run gc cons1, dca t / save it so we can return it tad t dca t2 / and again so we can store tad a dca i t2 / store car isz t2 tad i t2 / get new free list dca cflst tad b dca i t2 / store cdr tad t / return original address jmp i cons consgc, / free list was empty, so run GC and retry tad a / make arguments save for GC dca conssv tad b dca conssv+1 jms i (gcgo) tad cflst sna cla hlt / still no more words, panic dca conssv dca conssv+1 tad cflst jmp cons1 conssv, 0; 0 / Construct number, argument is in AC / return number in AC consn, 0 dca a / save our number tad nflst / get free word sna jmp cnsngc consn1, dca t / save it tad i nflst / remove from free list dca nflst tad a / get the number dca i t / store tad t jmp i consn cnsngc, / free list was empty, so run GC and retry jms i (gcgo) tad nflst sna hlt / still no more words, panic jmp consn1 / find symbol in oblis by name finsym, 0 cla tad i (oblis) dca p fnsym1, tad p sna cla jmp i finsym / end of list, return nil / get name of atom tad i p / car, this should be an atom dca t iac tad i t / car of atom, should be 7777 sza hlt / it wasn't, this shouldn't happen isz t tad i t / cdr sna hlt / we're were expecting a name here.... dca t tad i t / car, this is the name list now dca t / compare it against string sta tad (buf) dca x fnsym2, tad t / current cell sna cla jmp fnsym4 / end of list, now check if string has ended too tad i x / get string char cia tad i t / compute difference to car sza cla jmp fnsym3 / not equal isz t tad i t / cdr dca t jmp fnsym2 / loop fnsym4, tad i x / get string char sna jmp fnsym5 / equal, we found the atom! fnsym3, isz p tad i p / cdr dca p jmp fnsym1 / loop fnsym5, tad i p / this is the atom jmp i finsym pagbrk / intern a symbol, name in buf intern, 0 jms i (finsym) sza jmp i intern / we have the symbol already / create empty cons dca a dca b jms i [cons] dca intrsv sta dca i intrsv / mark as atom tad intrsv iac dca p / cdr / next cons, with pointer to name in car jms i [cons] dca i p / store in cdr tad i p dca p / car sta / set up string pointer tad (buf) dca x intrn1, tad i x / get char sna jmp intrn2 / stop at nil dca c / save jms i [cons] dca t tad c dca i t / save char to car tad t dca i p / append to list tad t / cdr iac dca p jmp intrn1 intrn2, tad intrsv dca a dca intrsv tad i (oblis) dca b jms i [cons] / cons onto beginning of oblis dca i (oblis) tad a jmp i intern intrsv, 0 / / list of temporary objects that need to be saved from the GC / temlis, conssv conssv+1 intrsv 0 / / storage space / pagbrk / temp buffer for strings buf, *.+20 / push down list pdl, *pdl+pdlsz pdlend, / mark bit table mbt.s, mbt.e=mbt.s+mbt.sz *mbt.e / / number storage area, one word per number / nst.s, nst.e=nst.s+nst.sz nu1, 123 nu2, 234 nu3, 4444 nu4, 42 *nst.e / / cons storage area, two words per cell / cst.s, cst.e=cst.s+cst.sz oblis@, -1; .+1 .+2; .+7 text /ob/; .+1 text /li/; .+1 text /s/; 0 val@ oblis, .+1 oblis@; .+1 true@; .+1 val@; .+1 subr@; .+1 expr@; .+1 foo; 0 true@, -1; .+1 .+2; 0 text /t/; 0 val@, -1; .+1 .+2; 0 text /va/; .+1 text /l/; 0 subr@, -1; .+1 .+2; 0 text /su/; .+1 text /br/; 0 expr@, -1; .+1 .+2; 0 text /ex/; .+1 text /pr/; 0 foo, -1; .+1 .+2; .+5 text /fo/; .+1 text /o/; 0 val@; nu4 quux, -1; .+1 .+2; 0 text /qu/; .+1 text /ux/; 0 bar, foo; .+1 quux; .+1 foo; nu1 bar2, quux; .+1 bar; .+1 nu2; 0 *cst.e $start