title FORTH for Oz comment $ Yes, that's right, yet ANOTHER version of the memorable classic. Yep. Break in each new machine by writing a FORTH for it. This may take a little imagination, I left my FORTH-11 sources at school... By John Wilson, started 21-Dec-85. $ .decsav ; ps.len= 1000 ;length of parameter stack rs.len= 1000 ;length of return stack ; lptr= 14 ;pointer into line buffer dp= 15 ;dictionary pointer psp= 16 ;parameter stack ptr rsp= 17 ;return stack ptr ; cr= ^M ;carriage return lf= ^J ;line feed blank= 40 ;blank ; call== pushj rsp, ;subroutine call ret== popj rsp, ;subroutine return ; nif== 0 ;IF-ELSE-THEN token ndo== 1 ;DO-LOOP, DO-+LOOP nbegin==2 ;BEGIN-WHILE-REPEAT, BEGIN-UNTIL, BEGIN-AGAIN nwhile==3 ;WHILE (within BEGIN-WHILE-REPEAT) ; define word &name,:cfa,imm word1 \,\label,name,cfa,imm label= label+1 termin ; define word1 m,n,&name,:cfa,imm=comp lab!m: asciz name imm,,lab!n cfa termin ; define err &text jsp 2,error asciz text termin ; forth: reset ;reset i/o ; hrroi 1,[asciz 'FORTH/Oz v1 (JohnW) '] ;print ID psout ;yep movei dp,dict ;init DP ; abort$: move psp,[-ps.len,,pstack-1] ;init pstack quit: move rsp,[-rs.len,,rstack-1] ;clear rstack move lptr,[440700,,tib] ;autoindex to first byte setzm tib ;poke a zero setzm state ;interpreting ; next: ;handle next word movei 1,blank ;words delimited by blanks call gtword ;get next word jrst nextl ;nothing left on line, get another ; convert to upper case move 2,1 ;copy addr move 4,3 ;and len uc1: ildb 0,2 ;get a char cail 0,"a ;lower case? caile 0,"z jrst uc2 ;no subi 0,40 ;yes, convert dpb 0,2 ;and save uc2: sojn 4,uc1 ;repeat for all chars ; call find ;look for the word jrst num ;undefined, could be a number ; seto 1, ;load ones tdne 1,state ;compiling? jrst compil ;yes call @1(3) ;call CFA jrst next ;do next word ; compil: hlr 1,(3) ;get compiling address call (1) ;call it jrst next ;do next word ; num: ; it's not a word; see if it's a number move 2,1 ;copy address ldb 3,1 ;length setz 4, ;init sign flag setz 5, ;init accumulator num1: ildb 0,2 ;get a byte caie 0,"- ;minus sign? jrst num2 ;no aos 4 ;flip low bit of flag jrst num4 ;handle next char num2: cain 0,"+ ;plus sign? jrst num4 ;yes, ignore subi 0,"0 ;convert to binary jumpl 0,notnum ;invalid char, gag caig 0,9. ;digit? jrst num3 ;yes subi 0,7 ;no, assume letter caige 0,10. ;was it a letter? jrst notnum ;no, ack! num3: caml 0,base ;valid? jrst notnum ;no, gag imul 5,base ;make space for new digit add 5,0 ;add it in num4: sojn 3,num1 ;loop trne 4,1 ;odd # of "-"s? movn 5,5 ;yes, negate seto 1, ;load ones tdne 1,state ;compiling? jrst num5 ;yes push psp,5 ;no, stack the number jrst next ;loop num5: hllz 0,5 ;is left half zero? jumpe 0,num6 ;yes, goody move 1,[jsp 1,push1] ;code to push call comma ;compile it move 1,5 ;value call comma ;compile it jrst next ;do next word num6: movsi 1,(movei 1,) ;instruction to use hrr 1,5 ;immediate data call comma ;compile move 1,[push psp,1] ;push instruction call comma ;compile jrst next ;do next word ; push1: ; push one inline word to the pstack ; must be called with "jsp 1,push1" push psp,(1) ;push the word jrst 1(1) ;skip over it, return ; notnum: ; not a single precision number; see if double-precision setz 2, ;sign=+ initially setz 4, ;init AC setz 5, ;(double-precision) move 0,base ;get base movem 0,dbase+1 ;save dp1: ildb 0,1 ;get (next) char caie 0,"- ;negative? jrst dp2 ;no aos 2 ;flip sign jrst dp4 ;skip dp2: cain 0,"+ ;positive? jrst dp4 ;yes (redundant, but...) cain 0,". ;check for DP characters... jrst dp4 ;"." cain 0,"/ jrst dp4 ;"/" subi 0,"0 ;cvt to binary jumpl 0,undef ;nope, undef'ed word caig 0,9. ;digit? jrst dp3 ;yes subi 0,7 ;no, assume letter caige 0,10. ;was it a letter? jrst undef ;nupe, complain dp3: caml 0,base ;valid? jrst undef ;nope, complain dmul 4,dbase ;*base move 4,6 ;move back into ac4 and ac5 move 5,7 move 7,0 ;copy new digit setz 6, ;zero-extend dadd 4,6 ;add it in dp4: sojn 3,dp1 ;loop until out of chars trnn 2,1 ;negative? dmovn 4,4 ;yes, DNEGATE ;;; it was a number ;;; Whee! hrroi 1,[asciz 'Whee! Double number! '] psout push psp,5 ;push LSW (this is backwards!!!) push psp,4 ;push MSW jrst next ;yep... ;;;;;;; dbase: 0 ;BASE, zero-extended 0 ;(base goes here) ; undef: err 'undefined word' ;print message ; nextl: ;get next line seto 1, ;load ones ; tdne 1,redir ;redirecting input? ; jrst nprmpt ;yep, don't prompt tdne 1,state ;compiling? jrst nprmpt ;yep, don't prompt tdne 1,notok ;error last time around? jrst nprmpt ;yes, don't prompt hrroi 1,[asciz "ok "] ;prompt psout ;print it nprmpt: setzm notok ;prompt next time, anyway call query ;read a line jrst next ;try again ; cpopj: ret ;find an appropriate place for this ; error: ;print error message, QUIT ;called with jsp 2,error with asciz msg inline ; get >IN and space/tab out to proper column move 3,[350700,,tib] ;point at buffer move 4,errptr ;get ptr to begn of word movei 1,blank ;load blank err1: camn 3,4 ;there yet? jrst err2 ;yes ibp 3 ;inc ptr pbout ;write a blank jrst err1 ;loop err2: hrroi 1,[asciz "^ "] ;point at the offending word psout ;yep hrro 1,2 ;copy, ones to high half psout ;print it call crlf ;print crlf setom notok ;no prompt (things aren't OK) seto 1, ;load ones tdnn 1,state ;compiling? jrst quit ;no, just die move dp,smudg1 ;get old dp move 1,smudg2 ;get old value movem 1,@currnt ;re-aim CURRENT vocab to old word jrst quit ;buy it notok: 0 ;don't prompt if nonzero errptr: 0 ;ptr to begn of word (set by WORD) smudg1: 0 ;value of DP before current definition smudg2: 0 ;pointer to word before current one ; comp: ; compiles a call to the word pointed to by ac3 hrrz 2,1(3) ;get CFA move 0,3 ;copy addi 0,2 ;point at PFA camn 0,2 ;same? jrst comp1 ;yes, don't compile the MOVEI hrli 1,(movei 3,) ;load ptr hrr 1,3 ;value to use call comma ;put in dictionary comp1: hrli 1,(call 0) ;call CFA hrr 1,1(3) ;get CFA jrst comma ;put in dictionary, return ; const: ; push (PFA) to pstack push psp,2(3) ;push the value ret ; vari: ; push PFA to pstack addi 3,2 ;get PFA push psp,3 ;save ret ; vocab: ; set CONTEXT to this vocabulary addi 3,2 ;get pointer to head movem 3,contxt ;save ret ; nest: ; handle nesting of control structures ; check token in ac1, return address in ac1 pop psp,2 ;get token came 1,2 ;match? jrst nsterr ;no, nesting error pop psp,1 ;get addr ret nsterr: err "nesting error" ;print message, die ; ; Dictionary ; label= 0 ;start link labels at LAB0 ; lab0: asciz "FORTH" ;FORTH vocabulary frtlfa: vocab,,0 ;no previous word, vocab vocab ;vocab vocptr: head ;point at head of vocab ; word "WORD",.+1 ; ( c -- addr ) gets a word delimited by c ; returns addr of counted 7-bit string pop psp,1 ;get c call gtword ;get a word push psp,1 ;save addr ret ; gtword: ;get word delimited by char in ac1 ;skip-return if input stream is not empty ildb 0,lptr ;get a char jumpe 0,cpopj ;bag out if end of line camn 0,1 ;leading delimiter? jrst gtword ;yes, ignore move 2,[350700,,wrdbuf] ;pnt into word buffer setz 3, ;init counter movem lptr,errptr ;save for "^" in case of error jrst gtw2 ;jump into loop gtw1: ildb 0,lptr ;get a char jumpe 0,gtw3 ;end of line camn 0,1 ;delimiter? jrst gtw3 ;yes, end of word gtw2: cail 3,32. ;len<=32.? jrst gtw1 ;no, don't save idpb 0,2 ;put in buffer aos 3 ;bump count jrst gtw1 ;loop gtw3: ;end of word seto 1, ;load -1 adjbp 1,lptr ;decrement lptr move lptr,1 ;save result move 1,[350700,,wrdbuf] ;pnt at buffer dpb 3,1 ;save length movei 0,blank ;blank idpb 0,2 ;put at end of string aos (rsp) ;skip-return ret ; word "WHILE",cmponl,while$ ; ( ff -- ) in BEGIN-WHILE-REPEAT; exits loop if ff=0 while$: movei 1,nbegin ;look for starting BEGIN call nest move 2,1 ;save address move 1,[pop psp,1] ;instruction to get ff call comma ;compile push psp,dp ;save HERE movsi 1,(jumpe 1,) ;instruction to exit loop call comma ;compile push psp,2 ;save looping address movei 1,nwhile ;WHILE token push psp,1 ;push ret ; word "VLIST",.+1 ; ( -- ) list all words in the CONTEXT vocab move 2,@contxt ;get pointer to head of vocab setz 3, ;current column vlist1: hrli 2,440700 ;point to before first byte vlist2: ildb 1,2 ;get a char jumpe 1,vlist3 ;end of string, skip pbout ;print the char aos 3 ;bump column jrst vlist2 ;loop vlist3: cail 3,40. ;can we fit another? jrst vlist4 ;no movei 1,blank ;yes, print a blank pbout aos 3 ;and bump col jrst vlist5 ;skip vlist4: call crlf ;print a crlf setz 3, ;update col vlist5: aos 2 ;get LFA hrrz 2,(2) ;follow link jumpn 2,vlist1 ;loop if not end jumpe 3,cpopj ;return if at left marg call crlf ;crlf ret ; word "UNTIL",cmponl,until$ ; ( ff -- ) used in BEGIN-UNTIL; loop back to BEGIN if ff=0 until$: move 1,[pop psp,1] ;code to get ff call comma ;compile movei 1,nbegin ;token for BEGIN call nest ;get looping addr hrli 1,(jumpe 1,0) ;make looping jump jrst comma ;compile, return ; word "U.",.+1 ; ( n -- ) prints n, unsigned pop psp,0 ;get the number udot: ; print unsigned number in AC0, followed by a blanka call udot1 ;print number movei 1,blank ;trailing blank pbout ;yep ret ; udot1: push rsp,1 ;save rem move 1,0 ;copy low order setz 0, ;SXT tlze 1,400000 ;high bit set? aos 0 ;yep, link to high word div 0,base ;divide skipe 0 ;zero, don't recurse call udot1 ;recurse udot2: addi 1,"0 ;cvt to ascii caile 1,"9 ;digit? addi 1,7 ;no, convert to letter pbout ;print pop rsp,1 ;restore ret ; word "TIB",vari tib: block 21 ;80. chars +null wrdbuf: block 21 ;likewise... ; word "THEN",cmponl,then$ ; ( -- ) close an IF-THEN or IF-ELSE-THEN statement then$: movei 1,nif ;token for IF call nest ;check nesting hrrm dp,(1) ;poke jump destination ret ; word "SWAP",.+1 ; ( a b -- b a ) swap top two stack items pop psp,1 ;get a pop psp,2 ;b push psp,1 ;push a push psp,2 ;b ret ; word "STATE",vari ; ( -- addr ) variable containing non-zero value iff compiling state: 0 ; word "ROT",.+1 ; ( a b c -- b c a ) pull third stack item to top pop psp,3 ;get c pop psp,2 ;b pop psp,1 ;a push psp,2 ;push b push psp,3 ;c push psp,1 ;a ret ; word "REPEAT",cmponl,rep$ ; ( -- ) loop back to matching BEGIN in BEGIN-WHILE-REPEAT rep$: movei 1,nwhile ;look for WHILE call nest hrli 1,(jrst) ;make looping JRST call comma ;compile it pop psp,1 ;get address of JUMPE hrrm dp,(1) ;poke exiting addr ret ; word "QUIT",quit ; ( -- ) clears return stack and aborts ; word "QUERY",.+1 ; ( -- ) reads a line into TIB query: move lptr,[440700,,tib] ;init ptr move 1,lptr ;copy to ac1 movei 2,80. ;TIB is 80. bytes long jrst expect ;read line, return ; word "OCTAL",.+1 ; ( -- ) sets BASE to 8 movei 1,10 ;load 8. movem 1,base ;save ret ; word "LOOP",cmponl,loop$ ; ( -- ) add 1 to index (on rstack), loop if index0 (IF-THEN or IF-ELSE-THEN) if$: move 1,[pop psp,1] ;code to retrieve ff call comma ;compile it push psp,dp ;save dp movs 1,(jumpe 1,0) ;code to jump to false code if ff=0 call comma ;compile movei 1,nif ;token push psp,1 ;push it ret ; word "I",.+1 ; ( -- ind ) retrieves index of innermost DO-LOOP or DO-+LOOP structure pop rsp,1 ;return addr pop rsp,2 ;loop index push rsp,2 ;restore push psp,2 ;put on pstack jrst (1) ;return ; word "HEX",.+1 ; ( -- ) sets BASE to 16. movei 1,20 ;load 16. movem 1,base ;save ret ; word "FIND",.+1 ; ( addr1 -- addr2 n ) looks up word at addr1, returning compilation ; address and a flag: n=0 - not found, n=1 - found, n=-1 - found, immediate pop psp,1 ;get addr call find ;find the string jrst fnd2 ;not found hlrz 1,(3) ;get compiling CFA camn 1,1(3) ;=interpreting CFA? jrst fnd1 ;yes, word is immediate movei 1,1 ;load 1 skipa ;skip fnd1: seto 1, ;load -1 aos 3 ;point at CFA push psp,3 ;push push psp,1 ;save flag ret fnd2: push psp,1 ;save the passed address setz 1, ;load 0 push psp,1 ;save that too ret ; find: ; look up counted string, addr in ac1 ; skip if found, ac3 points to dictionary entry ldb 2,1 ;get length move 3,@contxt ;get ptr to CONTEXT vocabulary find1: move 4,1 ;copy move 5,2 hrli 3,350700 ;set up byte ptr find2: ldb 0,3 ;get (next) char jumpe 0,find4 ;end of string, no match ildb 6,4 ;get (next) char came 0,6 ;equal? jrst find3 ;no... ibp 3 ;yes, bump ptr sojn 5,find2 ;loop ldb 0,3 ;get next char from dict jumpe 0,find5 ;end, goody find3: ; skip to end of ASCIZ string ildb 0,3 ;get next char jumpn 0,find3 ;loop if not zero find4: aos 3 ;skip to link field hrrz 3,(3) ;defer jumpn 3,find1 ;more to check, loop ret ;not found, bag find5: aos 3 ;skip past aos (rsp) ;skip-return ret ; word "EXPECT",.+1 ; ( addr n -- ) read up to n bytes into addr (byte ptr) ; (this shouldn't be returning .ASCIZ strings, move that to QUERY) pop psp,2 ;get length pop psp,1 ;and addr hrro 1,1 ;ones to left half expect: hrroi 3,[0] ;reprompt with blank line rdtty ;get the line erjmp exp2 ;error, gag hrli lptr,440700 ;set up byte ptr (point 7,lptr) move 1,lptr ;copy to ac1 exp1: ildb 0,1 ;get a char caie 0,cr ;look for cr cain 0,lf ;or lf skipa ;got one, exit jumpn 0,exp1 ;loop if not null setz 0, ;clear ac0 [again] dpb 0,1 ;drop a 0 at the end ret ;see you around exp2: err "read error in EXPECT" ; word "EMIT",.+1 ; ( c -- ) print character whose ascii value is c on the terminal pop psp,1 ;get char pbout ;print it ret ; word "ELSE",cmponl,else$ ; ( -- ) starts false code in IF-ELSE-THEN statement else$: movei 1,nif ;IF token call nest ;look for IF push psp,dp ;push HERE move 2,dp ;get HERE aos 2 ;point at false code hrrm 2,(1) ;poke address move 1,[jumpa 0] ;get jump instruction call comma ;compile movei 1,nif ;IF token push psp,1 ;fake another IF ret ; word "DUP",.+1 ; ( n -- n n ) duplicate top of stack pop psp,1 ;get n push psp,1 ;push it back push psp,1 ;... twice ret ; word "DROP",.+1 ; ( n -- ) lose top of stack pop psp,1 ;get n ret ; word "DO",cmponl,do$ ; ( lim ind -- ) start DO-LOOP or DO-+LOOP do$: move 1,[pop psp,1] ;code to get index call comma move 1,[pop psp,2] ;code to get limit call comma push psp,dp ;save HERE move 1,[push rsp,2] ;save limit [again] call comma move 1,[push rsp,1] ;save index [again] call comma movei 1,ndo ;DO token push psp,1 ;push to stack ret ; word "DECIMAL",.+1 ; ( -- ) set BASE to decimal movei 1,10. ;load 10. movem 1,base ;save ret ; word "CURRENT",vari ; ( -- addr ) variable containing ptr to current vocab ; [where new definitions are entered] currnt: vocptr ;FORTH, initially ; ; word "CREATE",.+1 ;;;;; groan... create: ; create word header; link to CURRENT movei 1,blank ;delimiter=" " call gtword ;eat a word jrst noname ;no name given, complain movem dp,smudg1 ;save dp hrli 1,350700 ;make byte ptr ldb 2,1 ;get length hrrz 3,dp ;get HERE hrli dp,440700 ;convert to byte ptr crt1: ildb 0,1 ;get a char cail 0,"a ;lower case? caile 0,"z skipa ;no subi 0,40 ;yes, convert idpb 0,dp ;put in dict sojn 2,crt1 ;loop setz 0, ;get a idpb 0,dp ;mark end of string aos dp ;point at LFA move 2,currnt ;get ptr to CURRENT vocab hrrz 1,(2) ;get pointer movem 1,smudg2 ;save in case of error movem 3,(2) ;update ptr setom state ;set state to 'compile' ret noname: err "name must be given" ;no name - complain ; word "CR",.+1 ; ( -- ) print crlf on terminal crlf: hrroi 1,[asciz " "] ;point at crlf psout ;print it ret ; word "CONTEXT",vari ; ( -- addr ) variable containing ptr to context vocabulary ; [ first in search order ] contxt: vocptr ;FORTH, initially ; word "BYE",.+1 ; ( -- ) halts the fork; CONTINUE returns haltf ;buy it ret ;they typed CONTINUE ; word "BEGIN",cmponl,begin$ ; ( -- ) start BEGIN-WHILE-REPEAT, BEGIN-UNTIL, and BEGIN-AGAIN begin$: push psp,dp ;save HERE movei 1,nbegin ;BEGIN token push psp,1 ;save ret ; word "BASE",vari ; ( -- addr ) contains current radix base: 10. ;default radix is decimal ; word "AGAIN",cmponl,again$ ; ( -- ) terminates BEGIN-AGAIN; endless loop again$: movei 1,nbegin ;token for BEGIN call nest ;get looping address hrli 1,(jrst) ;make looping JRST jrst comma ;compile, return ; word "ABORT",abort$ ; ( -- ) clears both stacks and aborts ; word "@",.+1 ; ( addr -- n ) fetches word at (addr) pop psp,1 ;get addr push psp,(1) ;save contents ret ; word "?COMP",qcomp ; ( -- ) punt if not in compile state qcomp: move 1,state ;get STATE jumpn cpopj ;hoopy, return cmponl: err "compile-only word" ;complain ; word "><",.+1 ; ( n -- bsw(n) ) swap bytes pop psp,1 ;get n movs 1,1 ;BSW 1 push psp,1 ;save ret ; word ">",.+1 ; ( a b -- ff ) ff=ones if a>b, otherwise ff=zeroes pop psp,1 ;get b pop psp,2 ;a setz 3, ;assume false camle 2,1 ;>? seto 3, ;yes, ones push psp,3 ;push ff ret ; word "=",.+1 ; ( a b -- ff ) ff=ones if a=b, otherwise ff=zeroes pop psp,1 ;get b pop psp,2 ;a setz 3, ;assume false camn 1,2 ;skip if not equal seto 3, ;equal, ones push psp,3 ;push ret ; word "<",.+1 ; ( a b -- ff ) ff=ones if a idpb 1,dp move 1,(dp) ;get last word jrst comma ;inc dp, see if out of core, return ; dotq0: ; print in-line string ; called with jsp 1,dotq0 hrro 1,1 ;ones to left half psout ;print the string hrli 1,440700 ;make into byte ptr dq1: ildb 0,1 ;get a char jumpn 0,dq1 ;loop until end of string jrst 1(1) ;skip to next word, return ; word ".",.+1 ; ( n -- ) print number on top of stack pop psp,0 ;get number dot: jumpge 0,udot ;positive? movei 1,"- ;no, print "-" sign pbout ;yep movn 0,0 ;make positive jrst udot ;print the number, return ; word "-",.+1 ; ( n1 n2 -- diff ) returns n1-n2 pop psp,2 ;get n2 pop psp,1 ;and n1 sub 1,2 ;find difference push psp,1 ;save result ret ; word ",",.+1 ; ( nn -- ) compiles nn into dictionary pop psp,1 ;get value from stack comma: movem 1,(dp) ;poke aobjp dp,cpopj ;bump ptr, return err "dictionary full" ;print message, die ; pstack: block ps.len ;reserve space for parm stack rstack: block rs.len ;and for return stack ; word "+LOOP",cmponl,ploop$ ; ( n -- ) same as LOOP, but increments by n instead of 1 ploop$: move 2,[-5,,[pop rsp,1 ? pop rsp,2 ? pop psp,3 add 1,3 ? camge 1,2]] ;init ptr and ctr plp1: move 1,(2) ;get next instruction call comma ;compile it aobjn 2,plp1 ;loop movei 1,ndo ;DO token call nest ;get looping address hrli 1,(jrst) ;make looping JRST jrst comma ;compile, return ; word "+",.+1 ; ( n1 n2 -- sum ) returns n1+n2 pop psp,2 ;get n2 pop psp,1 ;and n1 add 1,2 ;find sum push psp,1 ;save result ret ; word "*",.+1 ; ( n1 n2 -- prod ) returns n1*n2 pop psp,2 ;get n2 pop psp,1 ;and n1 imul 1,2 ;find product push psp,1 ;and save it ret ; word "(",cmnt,cmnt ; ( -- ) ignore text to next ")" (not necessarily on current line) cmnt: ildb 0,lptr ;get a char jumpe 0,cmnt1 ;end of line caie 0,") ;got the ")"? jrst cmnt ;ignore if not ret ;got it, bag cmnt1: call query ;read a new line jrst cmnt ;use it ; head: word "!",.+1 ; ( n addr -- ) deposit n at (addr) pop psp,1 ;get addr pop psp,2 ;and n movem 2,(1) ;deposit ret ; constants ;dump literal pool ; dict: block 10000 ;4K, for now ; end forth