Relay-Version: version B 2.10 5/3/83; site utzoo.UUCP Posting-Version: version B 2.10 5/3/83; site aplvax.UUCP Path: utzoo!watmath!clyde!burl!hou3c!hocda!houxm!houxz!vax135!floyd!cmcl2!seismo!rlgvax!cvl!umcp-cs!aplvax!lwt1 From: lwt1@aplvax.UUCP Newsgroups: net.sources Subject: UNIX FORTH for the PDP11 (part 3 of 7) Message-ID: <644@aplvax.UUCP> Date: Fri, 8-Jun-84 15:56:03 EDT Article-I.D.: aplvax.644 Posted: Fri Jun 8 15:56:03 1984 Date-Received: Sun, 10-Jun-84 00:24:37 EDT Organization: JHU/Applied Physics Lab, Laurel, MD Lines: 857 Here is part 3 of the source for FORTH for the PDP-11. Delete everything thru the "-- cut here --" line, and extract with 'sh': sh part1 part2 ... part7 where 'part?' are whatever you've named the files. Note the copyright notice at the end of README. Please let us know how things go. While we can't support this software, we'll be posting bug fixes/upgrades to net.sources as time permits. VAX-FORTH should be 'forth'-coming {yuk-yuk} within a couple of weeks. Have fun! -Lloyd W. Taylor ... seismo!umcp-cs!aplvax!lwt1 ---I will have had been there before, soon--- ---------------------------------- cut here ---------------------------------- echo x - prim.as cat >prim.as <<'+E+O+F' / Copyright 1984 by The Johns Hopkins University/Applied Physics Lab. / Free non-commercial distribution is *encouraged*, provided that: / / 1. This copyright notice is included in any distribution, and / 2. You let us know that you're using it. / / Please notify: / / Lloyd W. Taylor / JHU/Applied Physics Lab / Johns Hopkins Road / Laurel, MD 20707 / (301) 953-5000 / / Usenet: ... seismo!umcp-cs!aplvax!lwt1 / / / Unix-FORTH was developed under NASA contract NAS5-27000 for the / Hopkins Ultraviolet Telescope, a March 1986 Space Shuttle mission. (we / hope to take a peek at Halley's comet!) / / Written entirely by Wizard-In-Residence John R. Hayes. / / * Unix is a trademark of Bell Labs. / / / FORTH PDP-11 inner interpreter and code primitives / iar =r4 psp =r5 nl =012 / newline tab =011 / tab EOF =-1 / end of file BLKSIZE=512. / disk block size / start-up code mov $pstack,psp / TEST mov $dict,DP mov $16.,BASE / base is hex mov $quit-6,INITVOCAB mov $quit+4,iar / point to high level QUIT code jmp *(iar)+ / parameter stack .=.+256. / 256 byte stack TEST pstack: / text input buffer inbuf: .=.+120. / 120 characters / (:) Code for next is thing at bottom of dictionary .byte 3; <(:)> .byte 0,0 / end of dictionary next: jmp *(iar)+ / The code for call is compiled in-line for colon definitions. / / call: jsr iar,*$next / / (;) .byte 3; <(;)> next-6 return: mov (sp)+,iar jmp *(iar)+ / / This is tricky code. All words defined by VARIABLE, CONSTANT, or /words will have similar code fields. Therefore the / code for (VARIABLE), (CONSTANT), and (DOES>) is shown below. / Code compiled by VARIABLE will be: / jsr iar,*$var / (VARIABLE) .byte 12; <(VA> return-6 var: mov iar,-(psp) mov (sp)+,iar jmp *(iar)+ / (CONSTANT) .byte 12; <(CO> var-6 con: mov (iar),-(psp) mov (sp)+,iar jmp *(iar)+ / (DOES>) .byte 7; <(DO> con-6 pdoes: mov (iar)+,r0 mov iar,-(psp) mov r0,iar jmp *(iar)+ / branching primitives / (LITERAL) .byte 11; <(LI> pdoes-6 lit: mov (iar)+,-(psp) jmp *(iar)+ / BRANCH .byte 6; lit-6 branch: mov (iar),iar jmp *(iar)+ / ?BRANCH .byte 7; branch-6 zbranch: mov (psp)+,r0 beq branch add $2,iar jmp *(iar)+ / EXECUTE .byte 7; zbranch-6 execute: jmp *(psp)+ / FORTH-83 do loops / (DO) .byte 4; <(DO> execute-6 pdo: mov (psp)+,r1 mov (psp)+,r0 add $100000,r0 / limit' := limit + 8000 mov r0,-(sp) sub r0,r1 / imit' := init - limit' mov r1,-(sp) jmp *(iar)+ / (LOOP) .byte 6; <(LO> pdo-6 ploop: inc (sp) bvs exitloop mov (iar),iar / loop back jmp *(iar)+ exitloop: add $4,sp / pop return stack add $2,iar / skip loop address jmp *(iar)+ / (+LOOP) .byte 7; <(+L> ploop-6 pploop: add (psp)+,(sp) bvs exitloop mov (iar),iar / loop back jmp *(iar)+ / I .byte 1; pploop-6 i: mov (sp),r0 add 2(sp),r0 / i := i' + limit' mov r0,-(psp) jmp *(iar)+ / J .byte 1; i-6 j: mov 4(sp),r0 add 6(sp),r0 mov r0,-(psp) jmp *(iar)+ / (LEAVE) .byte 7; <(LE> j-6 pleave: add $4,sp / pop return stack mov (iar),iar / branch past loop jmp *(iar)+ / basic unix system interface routines / buffer for holding indirect system calls sysbuf: .byte 0,0 / trap instruction .byte 0,0 / argument 1 .byte 0,0 / argument 2 .byte 0,0 / argument 3 / I/O buffer and control variables block: .=.+BLKSIZE; .even size: .byte 0,0 / size in bytes index: .byte 0,0 / current offset into block fd: .byte -1,-1 / file descriptor of file this block belongs to / file position table: each slot has a 32 bit file offset. file descriptor / is index into table. There are 15 slots. filepos: .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 .byte 0,0,0,0 / subroutine getc: handles all input and does buffering / input: file descriptor in r0 / output: character or EOF in r0 / side effects: r0 and r1 getc: cmp r0,fd / is this file in buffer? beq 0f / if so, do not need to seek mov r0,fd / save new fd in buffer descriptor mov size,index / indicate that buffer is empty mov $104423,sysbuf / move lseek trap instruction to sysbuf asl r0; asl r0 / multiply by 4 to index into table mov filepos(r0),sysbuf+2 / high offset word mov filepos+2(r0),sysbuf+4 / low offset word clr sysbuf+6 / offset from beginning of file mov fd,r0 / file descriptor in r0 sys 0;sysbuf / seek sytem call mov fd,r0 / restore fd since call destroyed r0,r1 0: mov r2,-(sp) / save r2 mov *$index,r2 / r2 is index cmp r2,*$size blt 1f / if there is still data in buffer, use it sys 3;block;BLKSIZE / read up to BLKSIZE bytes bcs 2f / branch if error mov r0,*$size / save size of block beq 2f / branch if eof clr r2 / reset index 1: movb block(r2),r0 / get next character bic $17400,r0 / mask off high byte inc r2 mov r2,*$index / update index mov fd,r2 / reuse r2 to hold file descriptor asl r2; asl r2 / multiply by 4 to index into table add $1,filepos+2(r2) / add one to current file position adc filepos(r2) br 3f 2: mov $EOF,r0 / return EOF on error condition 3: mov (sp)+,r2 / restore r2 rts pc / OPEN ( addr[string] mode --- fd ) .byte 4; pleave-6 open: mov $104405,sysbuf / move trap 5 instruction to indir area mov (psp)+,sysbuf+4 / mode mov (psp),sysbuf+2 / addr[filename] sys 0;sysbuf bcc 1f mov $-1,(psp) / error, negative file descriptor returned br 2f 1: mov r0,(psp) / return file descriptor asl r0; asl r0 / multiply by 4 to index into table clr filepos(r0) / initialize file position to zero clr filepos+2(r0) 2: jmp *(iar)+ / CREAT ( addr[string] pmode --- fd/-1 ) .byte 5; open-6 creat: mov $104410,sysbuf / move trap 8 instruction to indir area mov (psp)+,sysbuf+4 / move mode mov (psp),sysbuf+2 / move address of file name sys 0;sysbuf / creat system call bcc 1f mov $-1,(psp) / error, negative file descriptor returned br 2f 1: mov r0,(psp) / return file descriptor asl r0; asl r0 / multiply by 4 to index into position table clr filepos(r0) / initialize file position to zero clr filepos+2(r0) 2: jmp *(iar)+ / CLOSE ( fd --- ) .byte 5; creat-6 close: mov $104406,sysbuf / move trap 6 instruction to indir area mov (psp)+,r0 / file descriptor sys 0;sysbuf jmp *(iar)+ / KEY ( fd --- char/EOF ) .byte 3; close-6 key: mov (psp),r0 / file descriptor jsr pc,getc / get next character mov r0,(psp) / return character jmp *(iar)+ / FEXPECT ( fd addr count --- actcount) .byte 7; key-6 fexpect: mov 2(psp),r2 / buffer address mov (psp)+,r3 / count beq 3f / do nothing if count is zero 1: mov 2(psp),r0 / file descriptor jsr pc,getc / get next character cmp r0,$EOF beq 3f / leave loop on EOF cmpb r0,$tab bne 2f movb $040,r0 / change tabs to blanks 2: movb r0,(r2)+ / save character cmpb r0,$nl beq 3f / leave loop on newline sob r3,1b / decrement count and continue if non-zero 3: sub (psp)+,r2 / compute actual number of characters read mov r2,(psp) / return actual number jmp *(iar)+ / READ ( fd addr count --- actcount ) ( like expect ) / ( that tabs are not stripped and newlines are ) / ( not significant. ) .byte 4; fexpect-6 read: mov 2(psp),r2 / buffer address mov (psp)+,r3 / count beq 3f / do nothing if count is zero 1: mov 2(psp),r0 / file descriptor jsr pc,getc / get next character cmp r0,$EOF beq 3f / leave loop on EOF movb r0,(r2)+ / save character sob r3,1b / decrement count and continue if non-zero 3: sub (psp)+,r2 / compute actual number of characters read mov r2,(psp) / return actual number jmp *(iar)+ / WRITE ( addr count fd --- actcount ) .byte 5; read-6 write: mov $104404,sysbuf / move trap 4 instruction to indir area mov (psp)+,r0 / file descriptor mov (psp)+,sysbuf+4 / count mov (psp),sysbuf+2 / address sys 0; sysbuf / indirect system call bcc 1f mov $-1,r0 / error flag 1: mov r0,(psp) / return actual count ) jmp *(iar)+ / SEEK ( fd offsetl offseth --- ) .byte 4; write-6 seek: mov 4(psp),r0 / file descriptor cmp r0,fd / if seek on currently buffered file bne 1f mov $-1,fd / flag buffer as invalid 1: asl r0; asl r0 / multiply by 4 to index into file pos. table mov (psp),filepos(r0) / high offset into file position table mov 2(psp),filepos+2(r0) / low offset into file position table mov $104423,sysbuf / move seek trap instruction to sysbuf mov (psp)+,sysbuf+2 / move high offset mov (psp)+,sysbuf+4 / move low offset clr sysbuf+6 / offset from beginning of file mov (psp)+,r0 / file descriptor in r0 sys 0;sysbuf / seek jmp *(iar)+ / TERMINATE .byte 11; seek-6 terminate: clr r0 / return good status sys 1 jmp *(iar)+ / this should not be executed TEST / high level utilities written in assembly language for speed / (FIND) ( addr[name] addr[vocab] --- 0 nfa ) .byte 6; <(FI> terminate-6 pfind: mov (psp)+,r0 beq 3f / empty vocabulary? mov (psp),r3 mov (r3)+,r2 / name ls mov (r3),r3 / name ms 1: mov (r0),r1 bic $200,r1 / clear immediate bit cmp r1,r2 / compare ls bne 2f cmp 2(r0),r3 / compare ms beq 3f 2: mov 4(r0),r0 / next link bne 1b / zero link? 3: mov r0,(psp) jmp *(iar)+ / WORD ( del --- addr ) .byte 4; pfind-6 word: mov (psp),r0 / delimiter mov *$IN,r1 / >IN add $inbuf,r1 mov *$DP,r2 / HERE mov r2,(psp) / return HERE 1: cmpb r0,(r1)+ / skip delimiters beq 1b dec r1 / back up one mov r1,r3 2: cmpb r0,(r3) / delimiter? beq 3f cmpb $nl,(r3) / newline? beq 3f inc r3 / skip until end of word br 2b 3: sub r1,r3 / r3 has length movb r3,(r2)+ / save count beq 5f / skip if eol 4: movb (r1)+,(r2)+ / move characters to here sob r3,4b 5: cmpb $nl,(r1) / if not newline beq 6f inc r1 / skip delimiter 6: sub $inbuf,r1 mov r1,*$IN / update >IN scanner movb $040,(r2) / put blank at end of word jmp *(iar)+ / FORTH nucleus primitives / ! .byte 1; word-6 store: mov (psp)+,r0 mov (psp)+,(r0) jmp *(iar)+ / !SP .byte 3; store-6 storesp: mov (psp),psp jmp *(iar)+ / + .byte 1; <+ > storesp-6 plus: add (psp)+,(psp) jmp *(iar)+ / +! .byte 2; <+! > plus-6 plusstore: mov (psp)+,r0 add (psp)+,(r0) jmp *(iar)+ / - .byte 1; <- > plusstore-6 minus: sub (psp)+,(psp) jmp *(iar)+ / -1 .byte 2; <-1 > minus-6 minusone: mov $-1,-(psp) jmp *(iar)+ / 0 .byte 1; <0 > minusone-6 zero: clr -(psp) jmp *(iar)+ / 0< .byte 2; <0< > zero-6 zeroless: clr r0 tst (psp) bpl 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / 0= .byte 2; <0= > zeroless-6 zeroeq: clr r0 tst (psp) bne 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / 1 .byte 1; <1 > zeroeq-6 one: mov $1,-(psp) jmp *(iar)+ / 1+ .byte 2; <1+ > one-6 oneplus: inc (psp) jmp *(iar)+ / 1- .byte 2; <1- > oneplus-6 oneminus: dec (psp) jmp *(iar)+ / 2 .byte 1; <2 > oneminus-6 two: mov $2,-(psp) jmp *(iar)+ / 2+ .byte 2; <2+ > two-6 twoplus: add $2,(psp) jmp *(iar)+ / 2- .byte 2; <2- > twoplus-6 twominus: sub $2,(psp) jmp *(iar)+ / 2* .byte 2; <2* > twominus-6 twostar: asl (psp) jmp *(iar)+ / 2/ .byte 2; <2/ > twostar-6 twoslash: asr (psp) jmp *(iar)+ / < .byte 1; << > twoslash-6 less: clr r0 cmp (psp)+,(psp) ble 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / = .byte 1; <= > less-6 equal: clr r0 cmp (psp)+,(psp) bne 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / > .byte 1; <\> > equal-6 greater: clr r0 cmp (psp)+,(psp) bge 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / >R .byte 2; <\>R > greater-6 tor: mov (psp)+,-(sp) jmp *(iar)+ / @ .byte 1; <@ > tor-6 at: mov *(psp),(psp) jmp *(iar)+ / @SP .byte 3; <@SP> at-6 atsp: mov psp,r1 mov r1,-(psp) jmp *(iar)+ / AND .byte 3; atsp-6 and: mov (psp)+,r0 com r0 / there is no direct and in PDP-11 assembly lang. bic r0,(psp) jmp *(iar)+ / C! .byte 2; and-6 cstore: mov (psp)+,r0 mov (psp)+,r1 movb r1,(r0) jmp *(iar)+ / C@ .byte 2; cstore-6 cat: movb *(psp),r0 bic $177400,r0 mov r0,(psp) jmp *(iar)+ / CMOVE ( src dest ucount --- ) .byte 5; cat-6 cmove: mov (psp)+,r2 beq 2f mov (psp)+,r0 / destination mov (psp)+,r1 / source 1: movb (r1)+,(r0)+ sob r2,1b br 3f 2: add $4,psp / pop two stack args 3: jmp *(iar)+ / D+ .byte 2; cmove-6 dplus: mov (psp)+,r0 add (psp)+,2(psp) adc (psp) add r0,(psp) jmp *(iar)+ / DNEGATE .byte 7; dplus-6 dnegate: com (psp) com 2(psp) add $1,2(psp) adc (psp) jmp *(iar)+ / DROP .byte 4; dnegate-6 drop: add $2,psp jmp *(iar)+ / DUP .byte 3; drop-6 dup: mov (psp),-(psp) jmp *(iar)+ / M* .byte 2; dup-6 mstar: mov (psp),r0 mul 2(psp),r0 mov r1,2(psp) / low result mov r0,(psp) / high result jmp *(iar)+ / M/ .byte 2; mstar-6 mslash: mov (psp)+,r2 / r2 has divisor mov (psp),r0 / r0 has high dividend mov 2(psp),r1 / r1 has low dividend mov r2,r3 xor r0,r3 / r3 has sign div r2,r0 / divide by r2 tst r3 bpl 1f / skip if sign is not negative tst r1 beq 1f / skip if remainder is zero dec r0 / subtract one from quotient add r2,r1 / add divisor to remainder 1: mov r1,2(psp) / remainder mov r0,(psp) / quotient jmp *(iar)+ / NEGATE .byte 6; mslash-6 negate: neg (psp) jmp *(iar)+ / NOT .byte 3; negate-6 not: com (psp) jmp *(iar)+ / OR .byte 2; not-6 or: bis (psp)+,(psp) jmp *(iar)+ / OVER .byte 4; or-6 over: mov 2(psp),-(psp) jmp *(iar)+ / R> .byte 2; > over-6 fromr: mov (sp)+,-(psp) jmp *(iar)+ / R@ .byte 2; fromr-6 rat: mov (sp),-(psp) jmp *(iar)+ / ROT .byte 3; rat-6 rot: mov 4(psp),r0 mov 2(psp),4(psp) mov (psp),2(psp) mov r0,(psp) jmp *(iar)+ / ROTATE ( word nbits --- word' ) .byte 6; rot-6 rotate: mov (psp)+,r1 / loop counter bic $0177760,r1 / mask off all but lower four bits beq 3f mov (psp),r0 1: tst r0 / test sign bit; clear carry bpl 2f sec / set carry 2: rol r0 / rotate sob r1,1b mov r0,(psp) 3: jmp *(iar)+ / SWAP .byte 4; rotate-6 swap: mov 2(psp),r0 mov (psp),2(psp) mov r0,(psp) jmp *(iar)+ / UM* .byte 3; swap-6 umstar: clr r0 mov $20,r1 / r1 := 16 mov (psp),r2 mov 2(psp),r3 / multiplier ror r3 / get ls bit 1: bcc 2f add r2,r0 / accumulate 2: ror r0 / shift carry into r0 ror r3 / shift into r3; get ls bit sob r1,1b mov r3,2(psp) / save ls word mov r0,(psp) / save ms word jmp *(iar)+ / UM/ ( dl dh divisor --- rem quot ) / dividend is 31 bits .byte 3; umstar-6 umslash: mov $20,r0 / 16 bits mov (psp)+,r1 / divisor mov (psp),r2 / ms word mov 2(psp),r3 / ls word 1: asl r3 rol r2 cmp r1,r2 bhi 2f sub r1,r2 inc r3 2: sob r0,1b mov r2,2(psp) / remainder mov r3,(psp) / quotient jmp *(iar)+ / U< .byte 2; umslash-6 uless: clr r0 cmp (psp)+,(psp) blos 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / U> .byte 2; > uless-6 ugreater: clr r0 cmp (psp)+,(psp) bhis 1f mov $-1,r0 1: mov r0,(psp) jmp *(iar)+ / XOR .byte 3; ugreater-6 exor: mov (psp)+,r0 xor r0,(psp) jmp *(iar)+ +E+O+F