Usenet 1994 January

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 52 < prev next >

Wrap

Internet Message Format | 1990-07-13 | 49.9 KB

From: vandys@lindy.stanford.edu (Andy Valencia) Newsgroups: comp.sources.misc Subject: Forth interpreter in 68000 assembler Message-ID: <2931@ncoast.UUCP> Date: 18 Jul 87 00:29:03 GMT Sender: allbery@ncoast.UUCP Lines: 2148 Approved: allbery@ncoast.UUCP X-Archive: comp.sources.misc/8707/52 [68000 assembler, yes. Motorola format, not UN*X format; you'll have to change all "bar.l"-type opcodes to "barl" (i.e. "move.l" to "movl") to use it on a Sun or Plexus box. ++bsa] Since I'm on the warpath, here's a hand-coded 68000 forth interpreter which conforms to the Forth-83 standard. As I recollect, it actually deviates from it in two areas: first, words are 32 bits. Second, I didn't do Forth- standard I/O; I just use a pushdown stack of file descriptors, and read and write streams. I don't know what the policy is concerning machine-dependent code (especially a monstrosity like this :-)), but it sure isn't doing anyone any good sitting around here, and I'm sure you'll know what to do with it. Thanks, Andy Valencia vandys@lindy.stanford.edu #!/bin/sh-----cut here-----cut here-----cut here-----cut here----- # This is a shell archive. # Run the following text with /bin/sh to extract. cat - << \Funky!Stuff! > Makefile forth: forth.o ld -N -o forth -e init forth.o -l881 -lm @size forth @echo "Forth done" forth.o: forth.s as -o forth.o forth.s Funky!Stuff! cat - << \Funky!Stuff! > forth.s ; ; forth.s--a 68K forth interpreter ; ; Register allocation: ; A7--68K stack pointer ; A6--IP ; A5--SP ; A4--RSP ; A3..A0--General ; D7--Here ; D6--Input line pointer ; D5..D0--General ; ; ; Flag bits in status field ; Priority equ 1 Smudged equ 2 ; ; control structure checking flags ; FlgDef equ 1 ; : .. ; FlgBeg equ 2 ; begin .. again, while, repeat FlgWhi equ 5 ; the "while" part flag FlgIf equ 3 ; if .. endif FlgDo equ 4 ; do .. loop, +loop ; ; Other constants/offsets ; stacksize equ 100 umem equ 96 ; K of dict. space for user rstack ds.l stacksize ; 100 Words for return stack stack ds.l stacksize ; and 100 for user's stack mstack ds.l stacksize ; and 100 for the 68K processor stack Inbufsize equ 1024+4*3 ; Input buffer record InUnit equ 1024+1 ; Unix file descriptor number InbufIdx equ 1024+4 ; Holds index into it for nesting of units InbufPrev equ 1024+8 ; Pointer to previous input unit (nesting) MaxIn equ 4 ; Max # open input units MaxOut equ MaxIn ; and output units inbufs ds.b 1024 ; Input buffer dc.b 0,0 ; <NULL>, <STDIN> ds.b 2 ; two bytes wasted ds.l 1 ; holds index dc.l 0 ; ptr to prev--is NULL for first ds.b Inbufsize*(MaxIn-1) ; The rest of the input units End_inbufs outfds dc.l 1 ; <STDOUT> ds.l MaxOut-1 ; The rest of the output units ounit dc.l outfds ; Current output unit iunit dc.l inbufs ; and current input unit ; ; init--start up forth. Set up our dictionary & use ABORT ; globl init init move.l #udict,d7 ; Set up HERE ; ; abort--clear I/O, reset stacks, clear state, enter INTERP ; abort move.l #rstack+stacksize,a4 ; Initialize return stack move.l #stack+stacksize,a5 ; and user stack move.l #mstack+stacksize,a7 ; and processor stack clr.l state1 ; Set state back to interpretive move.l #interp,a6 ; Set IP to top of INTERP move.l #inbufs,a0 ; Set up & clear input buffer clr.b (a0) clr.b 1024(a0) move.l a0,d6 move.l d6,iunit clr.b InUnit(a0) move.l #outfds,a0 ; Set up & clear output buffer move.l #1,(a0) move.l a0,ounit move.l #3,-(a7) ; Close all open files clr.l -(a7) ; Dummy place holder move.l #20,d3 ; How many units to close abor1 moveq #6,d0 ; UNIX "close" system call trap #0 addq.l #1,4(a7) ; Move to next file descriptor dbra d3,abor1 add.l #8,a7 ; Remove arguments from stack ; Fall into... ; V ; ; Next--the "fetch/execute" code of FORTH ; next move.l (a6)+,a0 ; Get CFA's addr, advance IP next2 move.l (a0)+,a1 ; Get contents of CFA jmp (a1) ; Jump to that address ; ; interp--a high level definition ; : interp ; getword lookup if ; state @ 0= or if execute else [compile] (lit) , endif ; else ; number if ; state @ if , endif ; else notfound abort endif ; endif ; ; ; interp dc.l ckstack,getword,lookup,zbranch,inter1 dc.l state,fetch,zeq,l_or,zbranch,inter2 dc.l execute,branch,interp inter2 dc.l comma,branch,interp inter1 dc.l number,zbranch,inter3 dc.l state,fetch,zbranch,interp dc.l plit,plit,comma,comma,branch,interp inter3 dc.l notfound ; ; or--bitwise "or" ; l_or2 dc.l 0 l_or dc.l l_or1,l_or1,0 dc.b 'or ' l_or1 move.l (a5)+,d0 or.l d0,(a5) jmp next ; ; and--logical bit-wise AND ; l_and2 dc.l l_or2,l_and1,l_and1,0 dc.b 'and ' l_and1 move.l (a5)+,d0 and.l d0,(a5) jmp next ; ; 0<--push whether top is less than 0 ; zlt2 dc.l l_and2,zlt1,zlt1,0 dc.b '0< ' zlt1 tst.l (a5) blt puttrue bra putfalse ; ; 0>--push whether top is greater than 0 ; zgt2 dc.l zlt2,zgt1,zgt1,0 dc.b '0> ' zgt1 tst.l (a5) bgt puttrue bra putfalse ; ; u<--unsigned version of "less than" ; ult2 dc.l zgt2,ult1,ult1,0 dc.b 'u< ' ult1 move.l (a5)+,d0 cmp.l (a5),d0 beq putfalse bcc puttrue bra putfalse ; ; 0=--a logical "not" ; zeq2 dc.l ult2 zeq dc.l zeq1,zeq1,0 dc.b '0= ' zeq1 tst.l (a5) bne putfalse puttrue move.l #-1,(a5) jmp next putfalse clr.l (a5) jmp next ; ; <--less than. Push whether second is less than top ; lt2 dc.l zeq2,lt1,lt1,0 dc.b '< ' lt1 move.l (a5)+,d0 cmp.l (a5),d0 bgt puttrue bra putfalse ; ; >--greater than. Push whether second is greater than top ; gt2 dc.l lt2,gt1,gt1,0 dc.b '> ' gt1 move.l (a5)+,d0 cmp.l (a5),d0 blt puttrue bra putfalse ; ; =--push whether top and second are equal ; equal2 dc.l gt2,equal1,equal1,0 dc.b '= ' equal1 move.l (a5)+,d0 cmp.l (a5),d0 beq puttrue bra putfalse ; ; ccomma--store a byte into the next location ; ccomma2 dc.l equal2,ccomma1,ccomma1,0 dc.b 'c, ' ccomma1 move.l d7,a0 move.l (a5)+,d0 ; Get word off stack move.b d0,(a0) ; Store its low byte addq.l #1,d7 ; Advance HERE jmp next ; ; comma--store a word into the next free location, advancing the ; current location pointer ; comma2 dc.l ccomma2 comma dc.l comma1,comma1,0 dc.b ', ' comma1 addq.l #3,d7 ; Word-align data and.l #0xFFFFFFFC,d7 move.l d7,a0 move.l (a5)+,(a0)+ move.l a0,d7 jmp next ; ; !--store second at address pointed to by top ; store2 dc.l comma2 store dc.l store1,store1,0 dc.b '! ' store1 move.l (a5)+,a0 move.l (a5)+,(a0) jmp next ; ; @--replace top of stack with what it pointed to ; fetch2 dc.l store2 fetch dc.l fetch1,fetch1,0 dc.b '@ ' fetch1 move.l (a5),a0 move.l (a0),(a5) jmp next ; ; branch--replace IP with next sequential word in execution ; branch2 dc.l fetch2 branch dc.l branch1,branch1,0 dc.b 'branch ' branch1 move.l (a6),a6 jmp next ; ; zbranch--"branch" if top of stack is zero ; zbran2 dc.l branch2 zbranch dc.l zbran1,zbran1,0 dc.b 'zbranch ' zbran1 move.l (a6)+,d0 ; Get the conditional destination tst.l (a5)+ ; Should we take it? beq zbran3 jmp next zbran3 move.l d0,a6 ; Take the branch jmp next ; ; run-time code to push the PFA to stack ; getpfa move.l (a0),-(a5) jmp next ; ; state--variable which holds the state: 0 == interp, <>0 == compiling ; state2 dc.l zbran2 state dc.l getpfa,state1,0 dc.b 'state ' state1 dc.l 0 ; ; getword--get the next word from the input stream, put it in "pad". ; getw2 dc.l state2 getword dc.l getwo1,getwo1,0 dc.b 'getword ' getwo1 jsr getw1 jmp next getw1 move.l d6,a0 ; A0 will be our line pointer jsr skipwhite ; Skip leading white space move.l #pad1,a1 ; Build into "pad" via A1 clr.b 8(a1) ; Put in Null-termination move.l #8,d1 ; Count # chars stored getw3 move.b (a0)+,(a1)+ ; Get next char bne.s getw10 ; Need to read in a new buffer? subq.l #1,a1 ; Back up destination ptr getw20 movem.l a1/d1,-(a7) ; Save registers jsr getline ; Get new line movem.l (a7)+,a1/d1 ; Restore registers move.l d6,a0 ; Update input line pointer bra.s getw4 getw10 subq.l #1,d1 ; Decrement character count beq getw5 ; If run out, truncate rest of word getw4 jsr iswhite ; See if at end of word bne getw3 tst.b (a0) ; At end of buffer? beq.s getw20 tst.l d1 ; Blank-fill word beq getw6 getw7 move.b #32,(a1)+ subq.l #1,d1 bne getw7 getw6 move.l a0,d6 ; Save input pointer rts getw5 tst.b (a0) ; Get new buffer at end of current bne.s getw11 jsr getline move.l d6,a0 bra.s getw5 getw11 jsr iswhite ; Quit when get white space beq.s getw6 addq.l #1,a0 ; Skip over characters bra.s getw5 ; ; skipwhite--skip over white space. For a number of bizarre reasons, ; this is also the best place to read in a new buffer if we run ; off the end of the current one. It is expected that all input lines ; will end in NEWLINE--if they don't, you're taking a chance. ; skipwhite jsr iswhite ; Check next char: bne skipw2 ; No white space, return tst.b (a0)+ ; At end of input buffer? bne skipwhite ; No--continue jsr getline ; Yes--get a fresh buffer move.l d6,a0 ; update our line buffer pointer bra skipwhite skipw2 rts ; ; iswhite--return via the Z flag whether the char pointed to by A0 ; is a white space character. Uses D3 to hold the char. ; iswhite move.b (a0),d3 ; Get the char cmp.b #32,d3 ; Check space beq iswh2 cmp.b #9,d3 ; ..Tab beq iswh2 cmp.b #10,d3 ; ..Newline beq iswh2 tst.b d3 ; ..NULL iswh2 rts ; ; getline--get another buffer-full from the current input unit. If no ; more input is available on it, pop back a level. If there are ; no more levels (i.e., the user typed ^D), exit. If the input is ; TTY, prompt. ; ok_msg dc.b 'Ok',10,'> ',0 even getline move.l iunit,a0 ; Get ptr to head of current input record cmp.l #inbufs,a0 ; See if it's the TTY bne getl9 move.l #ok_msg,a0 ; Print "Ok" jsr prstr move.l iunit,a0 ; restore A0 getl9 move.l a0,d6 ; Set up our input line pointer getl4 move.b InUnit(a0),d0 ; Get file descriptor ext.w d0 ext.l d0 ; Turn file descriptor into longword move.l #1024,-(a7) ; Third arg: # bytes move.l a0,-(a7) ; Second: store buffer move.l d0,-(a7) ; First arg is file descriptor clr.l -(a7) ; Dummy space holder moveq #3,d0 ; UNIX READ syscall trap #0 bcc getl2 ; On carry set, abort on an I/O error jmp io_err getl2 add.l #16,a7 ; Pop off arguments tst.l d0 ; Zero bytes read means EOF--pop up a unit! beq.s getl3 add.l d0,a0 ; Tack on the trailing NULL clr.b (a0) rts ; and return getl3 ; Hit EOF--pop back a unit, or exit move.l InbufPrev(a0),d0 ; Get previous record beq leave ; STDIN at EOF--exit move.l d0,a0 move.l a0,iunit ; Update current unit move.l InbufIdx(a0),d6 ; Get the old line index rts ; ; leave--do an "exit" syscall ; leave move.l #1,d0 ; Request 1 means "exit" clr.l -(a7) ; We will give a return code of 0 clr.l -(a7) trap #0 trap #1 ; Shouldn't reach here! ; ; pad--an area of storage to use ; pad2 dc.l getw2 pad dc.l getpfa,pad1,0 dc.b 'pad ' pad1 ds.b 84 ; ; lookup--search for the word represented by the first 8 bytes of PAD ; in the dictionary. If it's not found, push FALSE. Otherwise, ; push the CFA, the priority, and TRUE. ; look2 dc.l pad2 lookup dc.l look1,look1,0 dc.b 'lookup ' look1 jsr look99 jmp next look99 move.l latest+4,a0 ; Get pointer to latest definition move.l pad1,d3 ; Get search string move.l pad1+4,d4 look5 cmp.l 16(a0),d3 ; Compare first 4 bytes bne look3 cmp.l 20(a0),d4 ; Compare second 4 bytes bne look3 move.l 12(a0),d5 ; See if smudged and.l #Smudged,d5 bne look3 add.l #4,a0 ; turn A0 into CFA addr and push move.l a0,-(a5) move.l 8(a0),d0 ; Get status field and.l #Priority,d0 ; Push flag for priority move.l d0,-(a5) move.l #-1,-(a5) ; Push true flag--word found rts look3 move.l (a0),d0 ; Move to next entry tst.l d0 ; Check null ptr (end of chain) beq look4 move.l d0,a0 ; Move back to A0 bra look5 look4 clr.l -(a5) ; Not found--push false rts ; ; execute--pop a CFA off the stack & invoke that word ; exec2 dc.l look2 execute dc.l exec1,exec1,0 dc.b 'execute ' exec1 move.l (a5)+,a0 jmp next2 ; ; number--if the string in PAD is not a legal number, push FALSE. ; If it is, push the value and TRUE. ; num2 dc.l exec2 number dc.l num1,num1,0 dc.b 'number ' num1 move.l #pad1,a0 ; This is where our number is jsr num99 jmp next num99 clr.l d0 ; D0 accumulates the result move.l base,d5 ; D5 is the current base cmp.b #45,(a0) ; Flag negation if leading '-' there seq d3 bne num3 add.l #1,a0 num3 move.b (a0)+,d1 ; Get next char tst.b d1 ; At end of string? beq num4 cmp.b #32,d1 ; At the trailing blanks? beq num4 jsr isdig ; Legal numeric digit? bne num6 ; No, this isn't a number muls d5,d0 ; Yes, shift and add add.l d1,d0 ; ("isdigit" converts it) bra num3 num4 tst.b d3 ; See if it should be negated beq num5 neg.l d0 num5 move.l d0,-(a5) ; Push number move.l #-1,-(a5) ; and true flag rts num6 clr.l -(a5) ; Not number, push false rts ; ; isdig--check whether the character in D1 is a legal digit. If it is, ; return its value in D2, and Z set. Otherwise, return with ; Z cleared. We assume that BASE has already been put in D5, ; isdig sub.l #48,d1 ; Shift '0' down to 0 blt isdi1 ; Was lower than '0'--can't be a digit cmp.b #10,d1 ; Was it 0..9? blt isdi2 sub.b #7,d1 ; Map 'A'..'F' down to 10..15 blt isdi1 cmp.b #16,d1 ; Was it in range 10..15? blt isdi2 sub.b #32,d1 ; Finally, map 'a'..'f' down to 10..15 blt isdi1 cmp.b #16,d1 ; Was it in range 10..15? bge isdi1 isdi2 ext.w d1 ; Turn the number into a longword ext.l d1 cmp.l d5,d1 ; See if it's within the base bge isdi1 ori #4,ccr ; Set Z--we have a legal number rts isdi1 andi #0xFB,ccr ; Clear Z--not a digit! rts ; ; (lit)--run-time word to push a literal onto the stack ; plit2 dc.l num2 plit dc.l plit1,plit1,0 dc.b '(lit) ' plit1 move.l (a6)+,-(a5) jmp next base2 dc.l plit2,getpfa ; Current base for numbers dc.l base,0 dc.b 'base ' base dc.l 10 ; ; prstr--print a string to the current output unit. No management of the ; TTY is implied here--it just writes to the current output unit. ; The string to print is pointed to by A0. ; prstr clr.l d0 ; String length counter move.l a0,a1 ; Local copy of the pointer prst1 tst.b (a1)+ ; At end of string? beq prst2 add.l #1,d0 ; No, increment count bra prst1 ; and loop prst2 move.l ounit,a1 ; Build syscall parameters move.l d0,-(a7) ; Number of bytes move.l a0,-(a7) ; Buffer move.l (a1),-(a7) ; File descriptor clr.l -(a7) ; Dummy place holder move.l #4,d0 ; A write syscall trap #0 ; Do the call add.l #16,a7 ; Remove the arguments bcc prst3 jmp io_err ; Complain if the I/O failed prst3 rts ; ; io_err--complain about an I/O error ; io_err move.l #io_err_msg,a0 ; The error message jsr prstr jmp abort io_err_msg dc.b 10,'I/O error!',10,0 even ; ; notfound--routine to call when the compiler gets a word it ; doesn't know. ; notf2 dc.l base2 notfound dc.l notf1,notf1,0 dc.b 'notfound' notf1 move.l #pad1,a0 ; Print the word jsr prstr move.l #notf_msg,a0 ; Print ": not found" jsr prstr jmp abort notf_msg dc.b ': not found',10,0 even ; ; The match primitives--+, -, *, / ; plus2 dc.l notf2,plus1,plus1,0 dc.b '+ ' plus1 move.l (a5)+,d0 add.l d0,(a5) jmp next sub2 dc.l plus2,sub1,sub1,0 dc.b '- ' sub1 move.l (a5)+,d0 sub.l d0,(a5) jmp next globl _lrem mod2 dc.l sub2,mod1,mod1,0 dc.b 'mod ' mod1 move.l (a5)+,-(sp) move.l (a5),-(sp) jbsr _lrem addq.l #8,sp move.l d0,(a5) jmp next globl _ldiv div2 dc.l mod2,div1,div1,0 dc.b '/ ' div1 move.l (a5)+,-(sp) ; Divisor move.l (a5),-(sp) ; Dividend jbsr _ldiv addq #8,sp move.l d0,(a5) jmp next tdm2 dc.l div2,tdm1,tdm1,0 dc.b '*/mod ' tdm1 move.l (a5)+,d0 ; Hold divisor move.l (a5)+,d1 ; Get two multipliers move.l (a5),d2 muls d1,d2 divs d0,d2 ; Divide into the product move.l d2,d3 ; push remainder swap d3 ext.l d3 move.l d3,(a5) ext.l d2 ; now push quotient move.l d2,-(a5) jmp next td2 dc.l tdm2,td1,td1,0 dc.b '*/ ' td1 move.l (a5)+,d0 ; Divisor move.l (a5)+,d1 ; Two multipliers move.l (a5),d2 muls d1,d2 divs d0,d2 ; divide into product ext.l d2 ; Extend quotient to longword and push move.l d2,(a5) jmp next divmod2 dc.l td2,divmod1,divmod1,0 dc.b '/mod ' divmod1 move.l (a5)+,d0 ; Divisor move.l (a5),d1 ; Dividend divs d0,d1 move.l d1,d0 swap d0 ; Put remainder in low word ext.l d0 ; fill remainder to longword quantity move.l d0,(a5) ext.l d1 ; Now fill quotient to longword move.l d1,-(a5) jmp next mul2 dc.l divmod2,mul1,mul1,0 dc.b '* ' mul1 move.l (a5)+,d0 move.w d0,d1 move.w (a5)+,d0 tst.l d0 beq.s timesl1 move.w d1,a0 mulu d0,d1 swap d0 mulu (a5),d0 add.w d1,d0 swap d0 clr.w d0 move.w a0,d1 mulu (a5)+,d1 add.l d1,d0 bra.s timesl2 timesl1 move.w (a5)+,d0 mulu d1,d0 timesl2 move.l d0,-(a5) jmp next ; ; u.--due to the stupidity of the 68K divide instructions, this has ; to be just an alias for ".". ; udot2 dc.l mul2,dot1,dot1,0 dc.b 'u. ' ; ; .--pop and print the top of stack in the current base ; dot2 dc.l udot2,dot1,dot1,0 dc.b '. ' dot1 move.l (a5)+,d0 ; The number to print move.l base,d2 ; In this base move.l #pad1+20,a0 ; Where to build the number clr.b (a0) ; A terminating NULL move.b #32,-(a0) ; Add a trailing blank tst.l d0 ; Handle negative numbers slt d1 ; Flag a negative move.l d1,-(sp) bge dot3 neg.l d0 ; Negate a negative dot3 move.l d2,-(sp) move.l d0,-(sp) jbsr _lrem ; divide, getting the next digit addq.l #8,sp add.b #48,d0 ; Move 0..9 to '0'..'9' cmp.b #58,d0 ; Hex digit? blt dot4 addq.b #7,d0 dot4 move.b d0,-(a0) ; Store the digit move.l d1,d0 ; Get quotient tst.l d0 ; All of the number printed? bne dot3 move.l (sp)+,d2 tst.b d2 ; Tack on a leading '-' if it's needed beq dot7 move.b #45,-(a0) dot7 jsr prstr dot9 jmp next ; ; ckstack--check the user's stack for underflow ; cks_msg dc.b '? Stack empty',10,0 even cks2 dc.l dot2 ckstack dc.l cks1,cks1,0 dc.b '?stack ' cks1 cmp.l #stack+stacksize,a5 ble dot9 move.l #cks_msg,a0 ; Underflowed--complain jsr prstr jmp abort ; ; words--list contents of dictionary ; wrdpad dc.b ' ' word2 dc.l cks2,word1,word1,0 dc.b 'words ' word1 move.l late1,a2 ; For following the dictionary chain word3 move.l #pad1,a1 ; Set up for next line moveq #6,d0 ; Number of entries per line word4 cmp.l #0,a2 ; See if at end of chain beq word5 move.l 16(a2),(a1)+ ; Copy string move.l 20(a2),(a1)+ move.l wrdpad,(a1)+ ; Pad with 4 spaces move.l (a2),a2 ; Advance to next entry subq.l #1,d0 bne word4 word5 move.b #10,(a1)+ ; Trailing newline clr.b (a1) ; and NULL move.l #pad1,a0 ; Write it jsr prstr cmp.l #0,a2 ; All done? bne word3 jmp next ; ; make_head--build a FORTH header, return its address in ; register A0. ; make_head move.l d7,a0 ; For returning it move.l d7,a1 ; For storing sequentially move.l late1,(a1)+ ; Build this def into the chain move.l d7,late1 clr.l (a1)+ ; Empty CFA lea 24(a0),a2 ; Point PFA to the def body move.l a2,(a1)+ clr.l (a1)+ movem.l a0/a1,-(a5) ; Stash our work reg jsr getw1 ; Build the name in-line movem.l (a5)+,a0/a1 ; Stash our work reg move.l pad1,(a1)+ move.l pad1+4,(a1)+ move.l a1,d7 ; Reset D7 rts ; ; variable--allocate a variable in the dictionary ; var2 dc.l word2,var1,var1,0 dc.b 'variable' var1 addq.l #3,d7 ; Word-align HERE and.l #0xFFFFFFFC,d7 jsr make_head ; Build a header move.l #getpfa,4(a0) ; Our run-time code will push the PFA addq.l #4,d7 ; Our body starts with one word jmp next ; ; constant--allocate a constant in the dictionary ; const2 dc.l var2,const1,const1,0 dc.b 'constant' const1 addq.l #3,d7 ; Word-align HERE and.l #0xFFFFFFFC,d7 jsr make_head ; Build header move.l #getpfa,4(a0) ; run-time code pushes PFA move.l (a5)+,8(a0) ; Our PFA is the number on-stack jmp next ; ; colon--go into compilation mode ; colon2 dc.l const2,colon1,colon1,0 dc.b ': ' colon1 addq.l #3,d7 ; Word-align definitions and.l #0xFFFFFFFC,d7 move.l #1,state1 ; Go into compilation state jsr make_head ; Build our header move.l #hilev,4(a0) ; our CFA invokes a high-level def move.l #Smudged,12(a0) ; and we start Smudged move.l #FlgDef,-(a5) ; Push our flag for a definition jmp next ; ; semicolon--come out of compilation mode ; semi_msg dc.b 'control structure not matched',10,0 even semi2 dc.l colon2,semi1,semi1,Priority dc.b 59,' ' semi1 clr.l state1 ; Back to interpretive state move.l late1,a0 ; Turn off the smudge bit clr.l 12(a0) move.l d7,a0 ; Compile in a trailing ';s' move.l #popup,(a0)+ move.l a0,d7 cmp.l #FlgDef,(a5)+ ; See if control structures matched bne semi3 jmp next semi3 move.l #semi_msg,a0 ; Complain jsr prstr jmp abort ; ; hilev--the machine code which sets off a high-level definition ; hilev move.l a6,-(a4) ; Save old IP move.l (a0),a6 ; Get new IP jmp next ; ; popup--aka ';s'. Pop the IP from the return stack. For exiting ; a high-level word. ; pop2 dc.l semi2 popup dc.l pop1,pop1,0 dc.b 59,'s ' pop1 move.l (a4)+,a6 jmp next ; ; do--build the opening part of a do..loop ; do2 dc.l pop2,do1,do1,Priority dc.b 'do ' do1 move.l d7,a0 move.l #pushr,(a0)+ ; Generate code to get the loop parameters move.l #pushr,(a0)+ move.l a0,-(a4) ; Save this place for backbranching move.l #pdo,(a0)+ ; compile (do) clr.l (a0)+ ; Leave room for our forward branch move.l #FlgDo,-(a5) ; Flag our control structure move.l a0,d7 do3 jmp next ; ; (do)--run-time word to set off a do..loop ; pdo2 dc.l do2 pdo dc.l pdo1,pdo1,0 dc.b '(do) ' pdo1 move.l 4(a4),d0 ; Check for exit condition cmp.l (a4),d0 ; Check for exit condition blt pdo3 addq.l #8,a4 ; Clear the loop parameters move.l (a6),a6 ; Jump out of loop jmp next pdo3 addq.l #4,a6 ; Loop's not done--advance IP jmp next ; and continue ; ; loop--compile in the closing part of a loop ; loop2 dc.l pdo2,loop1,loop1,Priority dc.b 'loop ' loop1 cmp.l #FlgDo,(a5) ; See if they botched bne loop3 addq.l #4,a5 ; Free the flag move.l d7,a0 move.l #ploop,(a0)+ ; Compile (loop) move.l (a4)+,a1 ; Get address of "loop" move.l a1,(a0)+ ; This is our backbranch address move.l a0,4(a1) ; Give them the forward branch address move.l a0,d7 ; Restore HERE jmp next loop3 move.l #loop_msg,a0 jsr prstr jmp abort loop_msg dc.b 10,'do not matched by loop',10,0 even ; ; +loop--compile in the closing part of a loop ; aloop2 dc.l loop2,aloop1,aloop1,Priority dc.b '+loop ' aloop1 cmp.l #FlgDo,(a5) ; See if they botched bne aloop3 addq.l #4,a5 ; Free the flag move.l d7,a0 move.l #paloop,(a0)+ ; Compile (loop) move.l (a4)+,a1 ; Get address of "loop" move.l a1,(a0)+ ; This is our backbranch address move.l a0,4(a1) ; Give them the forward branch address move.l a0,d7 ; Restore HERE jmp next aloop3 move.l #loop_msg,a0 jsr prstr jmp abort aloop_msg dc.b 10,'do not matched by +loop',10,0 even ; ; (+loop)--run-time loop execution ; paloop2 dc.l aloop2 paloop dc.l paloop1,paloop1,0 dc.b '(+loop) ' paloop1 move.l (a5)+,d0 ; Add on number from user's stack add.l d0,4(a4) move.l (a6),a6 ; branch back jmp next ; ; (loop)--run-time loop execution ; ploop2 dc.l paloop2 ploop dc.l ploop1,ploop1,0 dc.b '(loop) ' ploop1 addq.l #1,4(a4) ; Increment the run-time index move.l (a6),a6 ; branch back jmp next ; ; >r--pop top of operand stack & push on return stack ; pushr2 dc.l ploop2 pushr dc.l pushr1,pushr1,0 dc.b '>r ' pushr1 move.l (a5)+,-(a4) jmp next ; ; r>--pop top of return stack & push on operand stack ; popr2 dc.l pushr2 popr dc.l popr1,popr1,0 dc.b 'r> ' popr1 move.l (a4)+,-(a5) jmp next ; ; r@--copy top of return stack to user stack ; rget2 dc.l popr2,rget1,rget1,0 dc.b 'r@ ' rget1 move.l (a4),-(a5) jmp next ; ; depth--tell how many elements are on user stack ; depth2 dc.l rget2,depth1,depth1,0 dc.b 'depth ' depth1 move.l #stack+stacksize,d0 sub.l a5,d0 asr.l #2,d0 move.l d0,-(a5) jmp next ; ; i--push index of innermost do..loop context ; push_i2 dc.l depth2,push_i1,push_i1,0 dc.b 'i ' push_i1 move.l 4(a4),-(a5) jmp next ; ; j--like i, but second most-innermost ; push_j2 dc.l push_i2,push_j1,push_j1,0 dc.b 'j ' push_j1 move.l 12(a4),-(a5) jmp next ; ; leave--jump out of the innermost loop structure. Note that control ; structure matching isn't done here, since we will probably be ; inside of multiple if..endif contexts--meaningful error checking ; would be very difficult to provide. ; leave2 dc.l push_j2,leave1,leave1,Priority dc.b 'leave ' leave1 move.l (a4),a1 ; This is the address of the (do) part move.l d7,a0 ; We will be compiling some stuff in: move.l #pleave,(a0)+ ; (leave) addq.l #4,a1 ; addr of the exit location--(do)+1 move.l a1,(a0)+ move.l a0,d7 jmp next ; ; (leave)--fetch via the word which follows us, and make that the IP ; pleave2 dc.l leave2 pleave dc.l pleave1,pleave1,0 dc.b '(leave) ' pleave1 move.l (a6),a0 ; Addr of exit address move.l (a0),a6 ; Set IP to it addq.l #8,a4 ; Clear the do..loop's parameters of rstack jmp next ; ; if--starting part of a conditional ; if2 dc.l pleave2,if1,if1,Priority dc.b 'if ' if1 move.l d7,a0 move.l #zbranch,(a0)+ ; If false, branch around move.l a0,-(a5) ; save this place for back-branch clr.l (a0)+ ; leave room for it move.l a0,d7 move.l #FlgIf,-(a5) ; Flag the control structure jmp next ; ; else--optional middle part of a conditional ; else2 dc.l if2,else1,else1,Priority dc.b 'else ' else1 cmp.l #FlgIf,(a5) ; Check control structure bne else3 move.l d7,a0 move.l 4(a5),a1 ; Save location to backpatch move.l #branch,(a0)+ ; Patch in a branch out of the conditional move.l a0,4(a5) ; the new back-patch location clr.l (a0)+ move.l a0,(a1) ; Now patch in address of false part of cond. move.l a0,d7 jmp next else3 move.l #else_msg,a0 ; Complain about bad control structure jsr prstr jmp abort else_msg dc.b 10,'else does not match an if',10,0 even ; ; endif--ending part of a conditional ; endif2 dc.l else2,endif1,endif1,Priority dc.b 'endif ' endif1 cmp.l #FlgIf,(a5) ; Check control strucure bne endif3 addq.l #4,a5 ; Pop off flag move.l (a5)+,a0 ; Get address to back-patch move.l d7,(a0) ; backpatch it jmp next endif3 move.l #endif_msg,a0 ; complain jsr prstr jmp abort endif_msg dc.b 10,'endif does not match if/else',10,0 even ; ; stack manipulation words--dup, swap, rot, -rot, drop, over ; over2 dc.l endif2,over1,over1,0 dc.b 'over ' over1 move.l 4(a5),-(a5) jmp next pick2 dc.l over2,pick1,pick1,0 dc.b 'pick ' pick1 move.l (a5)+,d0 asl.l #2,d0 ; Scale D0 for a word offset move.l 0(a5,d0.l),-(a5) jmp next roll2 dc.l pick2,roll1,roll1,0 dc.b 'roll ' roll1 move.l (a5)+,d0 asl.l #2,d0 move.l 0(a5,d0.l),d1 ; Save word rolling into roll3 tst.l d0 ; While not to top of stack... beq roll4 move.l -4(a5,d0.l),0(a5,d0.l) ; Copy down a word subq.l #4,d0 ; Advance a word bra roll3 roll4 move.l d1,(a5) ; Replace top with word jmp next dup2 dc.l roll2,dup1,dup1,0 dc.b 'dup ' dup1 move.l (a5),-(a5) jmp next qdup2 dc.l dup2,qdup1,qdup1,0 dc.b '?dup ' qdup1 move.l (a5),d0 beq qdup3 move.l d0,-(a5) qdup3 jmp next swap2 dc.l qdup2,swap1,swap1,0 dc.b 'swap ' swap1 move.l (a5)+,d0 move.l (a5),d1 move.l d0,(a5) move.l d1,-(a5) jmp next rot2 dc.l swap2,rot1,rot1,0 dc.b 'rot ' rot1 move.l (a5)+,d0 move.l (a5)+,d1 move.l (a5),d2 move.l d1,(a5) move.l d0,-(a5) move.l d2,-(a5) jmp next drot2 dc.l rot2,drot1,drot1,0 dc.b '-rot ' drot1 move.l (a5)+,d0 move.l (a5)+,d1 move.l (a5),d2 move.l d0,(a5) move.l d2,-(a5) move.l d1,-(a5) jmp next drop2 dc.l drot2,drop1,drop1,0 dc.b 'drop ' drop1 addq.l #4,a5 jmp next ; ; begin--start a structured loop ; beg2 dc.l drop2,beg1,beg1,Priority dc.b 'begin ' beg1 move.l d7,-(a5) move.l #FlgBeg,-(a5) jmp next ; ; again--unconditional branch back; an infinite loop ; again2 dc.l beg2,again1,again1,Priority dc.b 'again ' again1 cmp.l #FlgBeg,(a5) bne again3 addq.l #4,a5 move.l d7,a0 move.l #branch,(a0)+ move.l (a5)+,(a0)+ move.l a0,d7 jmp next again3 move.l #again_msg,a0 jsr prstr jmp abort again_msg dc.b 10,'again does not match a begin',10,0 even ; ; until--branch back until condition becomes true ; until2 dc.l again2,until1,until1,Priority dc.b 'until ' until1 cmp.l #FlgBeg,(a5) bne until3 addq.l #4,a5 move.l d7,a0 move.l #zbranch,(a0)+ move.l (a5)+,(a0)+ move.l a0,d7 jmp next until3 move.l #until_msg,a0 jsr prstr jmp abort until_msg dc.b 10,'until does not match a begin',10,0 even ; ; while..repeat: loop with exit check up front ; while2 dc.l until2,while1,while1,Priority dc.b 'while ' while1 cmp.l #FlgBeg,(a5) ; Check control structure bne while3 move.l d7,a0 move.l #zbranch,(a0)+ ; Branch out on false move.l a0,(a5) ; save where to backpatch clr.l (a0)+ move.l a0,d7 move.l #FlgWhi,-(a5) ; And place our own flag jmp next while3 move.l #while_msg,a0 ; Complain jsr prstr jmp abort while_msg dc.b 10,'while does not match a begin',10,0 even ; ; repeat--the closing part of a begin..while..repeat structure ; rep2 dc.l while2,rep1,rep1,Priority dc.b 'repeat ' rep1 cmp.l #FlgWhi,(a5) ; Check control structure bne rep3 addq.l #4,a5 move.l (a5)+,a1 ; Save where to backpatch move.l d7,a0 move.l #branch,(a0)+ ; Generate a backbranch move.l (a5)+,(a0)+ ; to top of loop move.l a0,d7 move.l d7,(a1) ; Backpatch exit location, HERE jmp next rep3 move.l #rep_msg,a0 ; Complain jsr prstr jmp abort rep_msg dc.b 10,'repeat does not match a while',10,0 even ; ; xor--exclusive OR ; xor2 dc.l rep2,xor1,xor1,0 dc.b 'xor ' xor1 move.l (a5)+,d0 eor d0,(a5) jmp next ; ; not--one's complement ; not2 dc.l xor2,not1,not1,0 dc.b 'not ' not1 eor #0xFFFFFFFF,(a5) jmp next ; ; 1+, 1-, 2+, 2-, 2*, 2/--common, quick math operations ; onep2 dc.l not2,onep1,onep1,0 dc.b '1+ ' onep1 addq.l #1,(a5) jmp next onem2 dc.l onep2,onem1,onem1,0 dc.b '1- ' onem1 subq.l #1,(a5) jmp next twop2 dc.l onem2,twop1,twop1,0 dc.b '2+ ' twop1 addq.l #2,(a5) jmp next twom2 dc.l twop2,twom1,twom1,0 dc.b '2- ' twom1 subq.l #2,(a5) jmp next twot2 dc.l twom2,twot1,twot1,0 dc.b '2* ' twot1 move.l (a5),d0 asl.l #1,d0 move.l d0,(a5) jmp next twod2 dc.l twot2,twod1,twod1,0 dc.b '2/ ' twod1 move.l (a5),d0 asr.l #1,d0 move.l d0,(a5) jmp next ; ; c@, c!--character fetch/store ; cfetch2 dc.l twod2,cfetch1,cfetch1,0 dc.b 'c@ ' cfetch1 move.l (a5),a0 move.b (a0),d0 ext.w d0 ext.l d0 move.l d0,(a5) jmp next cstore2 dc.l cfetch2,cstore1,cstore1,0 dc.b 'c! ' cstore1 move.l (a5)+,a0 move.l (a5)+,d0 move.b d0,(a0) jmp next pstore2 dc.l cstore2,pstore1,pstore1,0 dc.b '+! ' pstore1 move.l (a5)+,a0 move.l (a5)+,d0 add.l d0,(a0) jmp next ; ; min and max--push greater or less of two numbers ; min2 dc.l pstore2,min1,min1,0 dc.b 'min ' min1 move.l (a5)+,d0 cmp.l (a5),d0 bge min3 min4 move.l d0,(a5) min3 jmp next max2 dc.l min2,max1,max1,0 dc.b 'max ' max1 move.l (a5)+,d0 cmp.l (a5),d0 ble min3 bra min4 ; ; abs, negate--replace number with its absolute value or negation ; abs2 dc.l max2,abs1,abs1,0 dc.b 'abs ' abs1 move.l (a5),d0 bge min3 neg.l (a5) jmp next neg2 dc.l abs2,neg1,neg1,0 dc.b 'negate ' neg1 neg.l (a5) jmp next ; ; cmove--move a range of bytes ; cmov2 dc.l neg2,cmov1,cmov1,0 dc.b 'cmove ' cmov1 move.l (a5)+,d0 ; Count move.l (a5)+,a0 ; Destination move.l (a5)+,a1 ; Source tst.l d0 ; Catch case of zero-length beq cmov4 cmov3 move.b (a1)+,(a0)+ ; Move bytes dbra d0,cmov3 cmov4 jmp next ; ; cmove>--like cmove, but set up to guard against the "ripple" effect ; cmovu2 dc.l cmov2,cmovu1,cmovu1,0 dc.b 'cmove> ' cmovu1 move.l (a5)+,d0 ; Count move.l (a5)+,a0 ; Destination move.l (a5)+,a1 ; Source tst.l d0 ; Zero-length? beq cmov4 add.l d0,a0 ; Point to end of destination add.l d0,a1 ; same for source cmovu3 move.b -(a1),-(a0) ; Move bytes dbra d0,cmovu3 jmp next ; ; fill--fill a range of bytes with a constant ; fill2 dc.l cmovu2,fill1,fill1,0 dc.b 'fill ' fill1 move.l (a5)+,d0 ; Get byte constant to use move.l (a5)+,d1 ; # Bytes to fill move.l (a5)+,a0 ; Where to start tst.l d0 ; Avoid zero-length beq cmov4 fill3 move.b d0,(a0)+ ; Fill bytes subq.l #1,d1 bne fill3 jmp next ; ; count--get byte at addr, advance addr ; count2 dc.l fill2,count1,count1,0 dc.b 'count ' count1 move.l (a5),a0 ; Get addr move.b (a0)+,d0 ; Get byte at addr, advance move.l a0,(a5) ; Store back addr ext.w d0 ; and extended byte ext.l d0 move.l d0,-(a5) jmp next ; ; -trailing--trim trailing spaces ; dtrail2 dc.l count2,dtrail1,dtrail1,0 dc.b '-trailin' dtrail1 move.l (a5)+,d0 ; Current count beq dtrail4 ; handle zero-length move.l (a5),a0 ; Address of string add.l d0,a0 ; Get address of current end of string dtrail3 cmp.b #32,-(a0) ; Check next char beq dtrail4 subq.l #1,d0 bne dtrail3 dtrail4 move.l d0,-(a5) ; Push back count jmp next ; ; decimal, hex, octal--set BASE ; deci2 dc.l dtrail2,deci1,deci1,0 dc.b 'decimal ' deci1 move.l #10,base jmp next hexa2 dc.l deci2,hexa1,hexa1,0 dc.b 'hex ' hexa1 move.l #16,base jmp next octa2 dc.l hexa2,octa1,octa1,0 dc.b 'octal ' octa1 move.l #8,base jmp next ; ; The number printing words--<# # #> #s hold sign ; lsh_pos ds.l 1 ; Position in output buffer lsh2 dc.l octa2,lsh1,lsh1,0 dc.b '<# ' ; Prepare for conversion lsh1 move.l #pad1+70,lsh_pos jmp next sh2 dc.l lsh2,sh1,sh1,0 dc.b '# ' ; Convert next digit sh1 jsr sh99 jmp next sh99 move.l base,-(sp) ; get BASE--format is wrong in mem. move.l (a5),-(sp) jbsr _lrem move.l d1,(a5) ; put quotient back to stack add.l #48,d0 ; Remainder: map 0 to '0' cmp.l #58,d0 ; Check for HEX digits blt sh3 addq.l #7,d0 ; Map 10 to 'A' sh3 move.l lsh_pos,a0 ; Store character into PAD, advance move.b d0,-(a0) move.l a0,lsh_pos rts shg2 dc.l sh2,shg1,shg1,0 dc.b '#> ' ; End conversion shg1 move.l lsh_pos,d0 move.l d0,(a5) ; Push address move.l #pad1+70,d1 ; Calculate count sub.l d0,d1 move.l d1,-(a5) ; Push count jmp next shs2 dc.l shg2,shs1,shs1,0 dc.b '#s ' ; Convert all remaining digits shs1 jsr sh99 ; Do a digit tst.l (a5) ; See if done bne shs1 jmp next hold2 dc.l shs2,hold1,hold1,0 dc.b 'hold ' ; Put a char into the string hold1 move.l lsh_pos,a0 move.l (a5)+,d0 move.b d0,-(a0) move.l a0,lsh_pos hold3 jmp next sign2 dc.l hold2,sign1,sign1,0 dc.b 'sign ' ; Add a '-' if sign negative sign1 tst.l (a5)+ bge hold3 move.l #45,-(a5) bra hold1 ; ; ."--generate code to print a string at run-time ; dotq2 dc.l sign2,dotq1,dotq1,Priority dc.b '." ' dotq1 move.l d7,a0 move.l #pdotq,(a0)+ ; Compile (.") move.l d6,a1 ; Get line pointer addq.l #1,a1 ; advance past current word delimiter dotq3 move.b (a1)+,d0 ; Get next char beq dotq5 ; read a new buffer if we run out cmp.b #34,d0 ; End when we find the closing " beq dotq4 move.b d0,(a0)+ ; Add the character bra dotq3 dotq5 move.l a0,-(sp) jsr getline ; Get new buffer move.l (sp)+,a0 move.l d6,a1 bra dotq3 dotq4 clr.b (a0)+ ; Terminating NULL move.l a1,d6 ; Update line pointer move.l a0,d7 addq.l #3,d7 ; Longword-align DP and.l #0xFFFFFFFC,d7 jmp next ; ; (.")--run-time word to print a string ; pdotq2 dc.l dotq2 pdotq dc.l pdotq1,pdotq1,0 dc.b '(.") ' pdotq1 move.l a6,a0 jsr prstr pdotq3 tst.b (a6)+ ; Skip past text bne pdotq3 move.l a6,d0 addq.l #3,d0 ; Align IP and.l #0xFFFFFFFC,d0 move.l d0,a6 jmp next ; ; .(--print a message to the terminal from the input stream ; dotp2 dc.l pdotq2,dotp1,dotp1,Priority dc.b '.( ' dotp1 move.l d6,a1 ; Get line pointer addq.l #1,a1 ; advance past current word delimiter move.l #pad1,a0 ; Build message into PAD dotp3 move.b (a1)+,d0 ; Get next char beq dotp5 ; read a new buffer if we run out cmp.b #41,d0 ; End when we find the closing " beq dotp4 move.b d0,(a0)+ ; Add the character bra dotp3 dotp5 jsr getline ; Get new buffer move.l d6,a1 bra dotp3 dotp4 clr.b (a0)+ ; Terminating NULL move.l a1,d6 ; Update line pointer move.l #pad1,a0 ; Print the message jsr prstr jmp next ; ; cr--print newline ; cr_msg dc.b 10,0 cr2 dc.l dotp2,cr1,cr1,0 dc.b 'cr ' cr1 move.l #cr_msg,a0 jsr prstr jmp next ; ; emit--print out a character ; emit_buf ds.b 1 dc.b 0,0,0 ; Terminating NULL, 2 wasted emit2 dc.l cr2,emit1,emit1,0 dc.b 'emit ' emit1 move.l (a5)+,d0 move.b d0,emit_buf move.l #emit_buf,a0 jsr prstr jmp next ; ; type--print out a string given a count & a pointer ; type2 dc.l emit2,type1,type1,0 dc.b 'type ' type1 move.l (a5)+,d0 ; Count move.l (a5)+,a0 ; Addr move.l #pad1,a1 ; Where to buffer to type3 tst.l d0 ; Out of chars? beq type4 move.b (a0)+,(a1)+ ; Store a char subq.l #1,d0 ; Decrement count bra type3 type4 clr.b (a1) ; Terminating NULL move.l #pad1,a0 jsr prstr jmp next ; ; space--emit a space ; space2 dc.l type2,space1,space1,0 dc.b 'space ' space1 move.l #32,-(a5) bra emit1 ; ; spaces--emit N spaces ; spac_buf ; A printable space dc.b 32,0,0,0 spaces2 dc.l space2,spaces1,spaces1,0 dc.b 'spaces ' spaces1 tst.l (a5) ; Enough spaces? beq spaces3 move.l #spac_buf,a0 jsr prstr sub.l #1,(a5) ; Decrement count bra spaces1 spaces3 addq.l #4,a5 ; Pop count jmp next ; ; key--get a key from STDIN. Normally, this will block until a whole ; line is entered. However, if the TTY is put into RAW mode, ; this will respond on a key-by-key basis. ; keybuf ds.l 1 ; Holds the keystroke key2 dc.l spaces2,key1,key1,0 dc.b 'key ' key1 move.l #1,-(a7) ; Build READ syscall parameters--1 byte move.l #keybuf,-(a7) ; buffer address clr.l -(a7) ; 0--STDIN clr.l -(a7) ; dummy moveq #3,d0 ; UNIX READ syscall trap #0 add.l #16,a7 ; Remove the parameters from stack move.b keybuf,d0 ; Push byte ext.w d0 ext.l d0 move.l d0,-(a5) jmp next ; ; expect--read a number of chars from the terminal ; expect2 dc.l key2,expect1,expect1,0 dc.b 'expect ' expect1 move.l (a5)+,-(a7) ; UNIX syscall: N bytes move.l (a5)+,-(a7) ; to buffer clr.l -(a7) ; STDIN clr.l -(a7) ; dummy moveq #3,d0 ; UNIX READ syscall trap #0 move.l d0,span ; Store # bytes read add.l #16,a7 ; Remove the parameters from stack jmp next span2 dc.l expect2,getpfa,span,0 dc.b 'span ' span ds.l 1 ; ; abort--jump to abort ; abort2 dc.l span2 do_abort dc.l abort,abort,0 dc.b 'abort ' ; ; abort"--if top is true, print a message and abort ; qabort2 dc.l abort2,qabort1,qabort1,Priority dc.b 'abort" ' qabort1 move.l d7,a0 move.l #zbranch,(a0)+ ; Skip the whole shebang on false move.l a0,a2 ; Mark where to backpatch clr.l (a0)+ ; Leave room for the branch address move.l #pdotq,(a0)+ ; Compile (.") move.l d6,a1 ; Get line pointer addq.l #1,a1 ; advance past current word delimiter qabort3 move.b (a1)+,d0 ; Get next char beq qabort5 ; read a new buffer if we run out cmp.b #34,d0 ; End when we find the closing " beq qabort4 move.b d0,(a0)+ ; Add the character bra qabort3 qabort5 jsr getline ; Get new buffer move.l d6,a1 bra qabort3 qabort4 clr.b (a0)+ ; Terminating NULL move.l a1,d6 ; Update line pointer move.l a0,d7 addq.l #3,d7 ; Longword-align DP and.l #0xFFFFFFFC,d7 move.l d7,a0 move.l #do_abort,(a0)+ ; Put in ABORT move.l a0,d7 move.l d7,(a2) ; Backpatch false case jmp next ; ; quit--leave parameter stack alone, but return to INTERP ; quit2 dc.l qabort2,quit1,quit1,0 dc.b 'quit ' quit1 move.l #rstack+stacksize,a4 ; Clear return stack move.l #interp,a6 jmp next ; ; here--push address of next free location ; here2 dc.l quit2,here1,here1,0 dc.b 'here ' here1 move.l d7,-(a5); jmp next ; ; tib--address of text input buffer ; tib2 dc.l here2,tib1,tib1,0 dc.b 'tib ' tib1 move.l iunit,-(a5) jmp next ; ; >body--turn pointer to CFA field into pointer to parameter field ; gbod2 dc.l tib2,gbod1,gbod1,0 dc.b '>body ' gbod1 move.l (a5),a0 move.l 4(a0),(a5) jmp next ; ; (--start a forth comment ) ; paren2 dc.l gbod2,paren1,paren1,Priority dc.b '( ' ; ) paren1 move.l d6,a0 paren4 move.b (a0)+,d0 ; Get next char cmp.b #41,d0 ; End on closing paren beq paren3 tst.b d0 ; Get new buffer on end of current bne paren4 jsr getline bra paren1 paren3 move.l a0,d6 ; Restore line pointer jmp next ; ; allot--allocate N bytes off end of dictionary ; allot2 dc.l paren2,allot1,allot1,0 dc.b 'allot ' allot1 move.l (a5)+,d0 add.l d0,d7 jmp next ; ; does>--terminate execution of word which calls this, but also set it up ; so that the LATEST word has its PFA directed to after this word. ; : definer create ...1... does> ...2... ; ; Will be used as: definer <word> ; <word> will be added to the dictionary, and ...1... may do any ; actions it wishes. When <word> is later executed, it will run ; the code ...2... ; does2 dc.l allot2,does1,does1,Priority dc.b 'does> ' does1 move.l d7,a0 move.l #pdoes,(a0)+ ; Compile in (does) move.l a0,d7 jmp next pdoes2 dc.l does2 pdoes dc.l pdoes1,pdoes1,0 dc.b '(does) ' pdoes1 move.l late1,a0 ; Get LFA of latest definition move.l #hilev,4(a0) ; Make this execute as a high-level def move.l a6,8(a0) ; Fill in PFA with rest of this word's body move.l (a4)+,a6 ; Return from this word jmp next ; ; immediate--set the Priority bit of the latest definition ; immed2 dc.l pdoes2,immed1,immed1,0 dc.b 'immediat' immed1 move.l late1,a0 or.l #Priority,12(a0) ; Set Priority in SFA word jmp next ; ; [compile], compile--immediate & non-immediate versions of compile ; bcomp2 dc.l immed2,bcomp1,bcomp1,Priority dc.b '[compile' bcomp1 jsr getw1 ; Fetch next word from stream jsr look99 ; See if it can be found tst.l (a5)+ ; Error if it couldn't beq bcomp3 addq.l #4,a5 ; Drop the priority field move.l d7,a0 ; Compile in CFA move.l (a5)+,(a0)+ move.l a0,d7 jmp next bcomp3 jmp notf1 ; Not found: complain comp2 dc.l bcomp2,bcomp1,bcomp1,0 dc.b 'compile ' ; ; literal--compile a literal ; lit2 dc.l comp2,lit1,lit1,Priority dc.b 'literal ' lit1 move.l d7,a0 move.l #plit,(a0)+ move.l (a5)+,(a0)+ move.l a0,d7 jmp next ; ; [, ]--turn compilation off & on, respectively ; compon2 dc.l lit2,compon1,compon1,0 dc.b '] ' compon1 move.l #-1,state1 jmp next compof2 dc.l compon2,compof1,compof1,Priority dc.b '[ ' compof1 clr.l state1 jmp next ; ; word--get a word from the input stream, put in string ; word_buf ds.b 84 gword2 dc.l compof2,gword1,gword1,0 dc.b 'word ' gword1 move.l (a5)+,d0 ; Delimiter char move.l #word_buf+1,a0 ; Where to put the chars move.l d6,a1 ; Input line buffer clr.l d2 ; Count # chars received gword3 move.b (a1)+,d1 ; Get next char beq gword4 ; get new bufferfull if current empty cmp.b d0,d1 ; Found delimiter? beq gword5 move.b d1,(a0)+ ; Store char addq.l #1,d2 ; Increment count bra gword3 gword4 movem.l d0/a0,-(a7) ; Save d0 and a0 jsr getline ; Get next line movem.l (a7)+,d0/a0 move.l d6,a1 bra gword3 gword5 clr.b (a0) ; Add NULL termination move.b d2,word_buf ; Store count in first byte move.l a1,d6 ; Update line pointer move.l #word_buf,-(a5) ; Return pointer to it jmp next ; ; >in--give a byte offset into current buffer ; to_in2 dc.l gword2,to_in1,to_in1,0 dc.b '>in ' to_in1 move.l d6,d0 sub.l iunit,d0 move.l d0,-(a5) jmp next ; ; #tib--length of current input buffer ; ntib2 dc.l to_in2,ntib1,ntib1,0 dc.b '#tib ' ntib1 move.l iunit,a0 ; Ptr into buf clr.l d1 ; Counter of # chars ntib3 tst.b (a0)+ ; Check next byte beq ntib4 addq.l #1,d1 bra ntib3 ntib4 move.l d1,-(a5) ; Push count jmp next ; ; create--create a dictionary entry ; creat2 dc.l ntib2,creat1,creat1,0 dc.b 'create ' creat1 jsr make_head ; Build the header move.l #getpfa,4(a0) ; Set it up to be variable/constant jmp next ; ; '--push address of CFA ; tick2 dc.l creat2,tick1,tick1,0 dc.b 39,' ' tick1 jsr getw1 ; Get word jsr look99 ; Look up word tst.l (a5)+ ; Abort on error beq tick3 addq.l #4,a5 ; Drop priority flag jmp next tick3 jmp notf1 ; ; [']--for compiling in a compilation address as a literal ; btick2 dc.l tick2,btick1,btick1,Priority dc.b '[',39,'] ' btick1 jsr getw1 ; Get word jsr look99 ; Look up word tst.l (a5)+ ; Abort on error beq tick3 addq.l #4,a5 ; Drop priority flag move.l d7,a0 ; Compile in (lit) move.l #plit,(a0)+ move.l (a5)+,(a0)+ ; <compilation addr> move.l a0,d7 jmp next ; ; find--find a string in the dictionary ; find2 dc.l btick2,find1,find1,0 dc.b 'find ' find1 move.l latest+4,a0 ; Get pointer to latest definition move.l (a5),a1 ; Get search string move.l (a1),d3 move.l 4(a1),d4 jsr look5 ; Go find the string tst.l (a5) ; See if it was found beq find3 ; wasn't, can just return addq.l #4,a5 ; Was, pop boolean flag tst.l (a5)+ ; Change priority flag bne find4 move.l (a5),4(a5) ; Move comp addr over string addr move.l #-1,(a5) ; not priority, flag -1 bra find3 find4 move.l (a5),4(a5) ; Move comp addr over string addr move.l #1,(a5) ; was priority, flag 1 find3 jmp next ; ; forget--find a word in the dictionary, and remove it ; forg2 dc.l find2,forg1,forg1,0 dc.b 'forget ' forg1 jsr getw1 ; Get the name to forget jsr look99 ; Find it in the dictionary tst.l (a5)+ ; Found it? beq forg3 ; nope... addq.l #4,a5 ; Drop priority flag move.l (a5)+,a0 ; Put CFA into A0 subq.l #4,a0 ; Put A0 back to LFA move.l (a0),late1 ; Point LATEST to previous word move.l a0,d7 ; Free memory back to here jmp next forg3 jmp notf1 ; Forget WHO? ; ; input <file>--redirect input from a file ; input2 dc.l forg2,input1,input1,0 dc.b 'input ' input1 move.l iunit,a0 ; Room for more nesting? add.l #Inbufsize,a0 cmp.l #End_inbufs,a0 beq input4 move.l a0,-(a7) ; Save address of new buffer move.l d6,a0 ; Read in until end of word jsr skipwhite lea pad1,a1 ; Where to build into input10 jsr iswhite ; While not at end of word bne.s input11 tst.b (a0) ; At end of input buffer? bne.s input12 move.l a1,-(a7) ; Get new buffer-full jsr getline move.l (a7)+,a1 move.l d6,a0 bra.s input10 input11 move.b (a0)+,(a1)+ ; Store next char bra.s input10 input12 clr.b (a1) ; Trailing NULL move.l a0,d6 ; update input pointer clr.l -(a7) ; Mode 0=read pea pad1 ; Pointer to file name clr.l -(a7) ; dummy space moveq #5,d0 ; Open request trap #0 bcs input3 add.l #12,a7 ; Get rid of parameters move.l (a7)+,a0 ; Get new buffer addr again move.l iunit,a1 ; Get previous move.l a1,InbufPrev(a0) ; Save move.l d6,InbufIdx(a1) ; Save index into old buffer move.l a0,InbufIdx(a0) ; Clear the buffer move.b d0,InUnit(a0) ; Save UNIX FD to use clr.b (a0) move.l a0,d6 move.l a0,iunit ; Update current input unit jmp next input3 lea input_msg,a0 input5 jsr prstr jmp abort input4 lea input_msg2,a0 bra.s input5 input_msg asciz 'Could not open file for input' input_msg2 asciz 'Too many files nested' even ; ; exit--return from the current high-level word ; exit2 dc.l input2,pop1,pop1,0 dc.b 'exit ' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Insert new definitions above here ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; latest--pointer to most current LFA defined ; late2 dc.l exit2 latest dc.l getpfa,late1,0 dc.b 'latest ' late1 dc.l late2 ; ; The user dictionary space ; comm udict,umem*1024 ; User dictionary space ; ; The End! ; Funky!Stuff! cat - << \Funky!Stuff! > primes.fth : isprime ( n -- b | Return whether 'n' is prime ) ( dup 2 mod 0= if drop 0 exit endif ) -1 swap dup 2/ 1+ 3 do dup i mod 0= if swap drop 0 swap leave endif 2 +loop drop ; : primes 2001 5 do i isprime if i . cr endif 2 +loop ; Funky!Stuff!