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 4 of 7) Message-ID: <645@aplvax.UUCP> Date: Fri, 8-Jun-84 15:56:18 EDT Article-I.D.: aplvax.645 Posted: Fri Jun 8 15:56:18 1984 Date-Received: Sun, 10-Jun-84 00:26:07 EDT Organization: JHU/Applied Physics Lab, Laurel, MD Lines: 877 Here is part 4 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 - os.as cat >os.as <<'+E+O+F' / / FORTH operating system in assembler format / / System variables and constants / / The upper case labels are so that assembly language routines can refer / to the values of these variables / TIB .byte 3;exor-6 tib: jsr iar,*$con inbuf / SP0 .byte 3; tib-6 sp0: jsr iar,*$con pstack / DP0 .byte 3; sp0-6 dp0: jsr iar,*$con dict / WRN .byte 3; dp0-6 wrn: jsr iar,*$var .byte -1,-1 / DP .byte 2; wrn-6 dp: jsr iar,*$var DP: .byte 0,0 / >IN .byte 3; <\>IN> dp-6 in: jsr iar,*$var IN: .byte 0,0 / STATE .byte 5; in-6 state: jsr iar,*$var .byte 0,0 / BASE .byte 4; state-6 base: jsr iar,*$var BASE: .byte 0,0 / INITVOCAB ( intial vocabulary - will be FORTH ) .byte 11; base-6 initvocab: jsr iar,*$var INITVOCAB: .byte 0,0 / CONTXT ( context vocabulary ) .byte 6; initvocab-6 context: jsr iar,*$var INITVOCAB / CURRENT ( current vocabulary ) .byte 7; context-6 current: jsr iar,*$var INITVOCAB / CLUE .byte 4; current-6 clue: jsr iar,*$var .byte 0,0 / STDIN .byte 5; clue-6 stdin: jsr iar,*$con .byte 0,0 / STDOUT .byte 6; stdin-6 stdout: jsr iar,*$con .byte 1,0 / EOL .byte 3; stdout-6 eol: jsr iar,*$con .byte 12,0 / TRUE .byte 4; eol-6 true: jsr iar,*$con .byte -1,-1 / FALSE .byte 5; true-6 false: jsr iar,*$con .byte 0,0 / Code extensions / ?DUP .byte 4; false-6 qdup: jsr iar,*$next dup; zbranch; 1f; dup; 1: return / -ROT .byte 4; <-RO> qdup-6 mrot: jsr iar,*$next rot; rot; return / * .byte 1; <* > mrot-6 star: jsr iar,*$next umstar; drop; return / 2DUP .byte 4; <2DU> star-6 twodup: jsr iar,*$next over; over; return / S->D .byte 4; > twodup-6 stod: jsr iar,*$next dup; zeroless; return / +- .byte 2; <+- > stod-6 plusminus: jsr iar,*$next zeroless; zbranch; 1f; negate; 1: return / D+- .byte 3; plusminus-6 dplusminus: jsr iar,*$next zeroless; zbranch; 1f; dnegate; 1: return / ABS .byte 3; dplusminus-6 abs: jsr iar,*$next dup; plusminus; return / DABS .byte 4; abs-6 dabs: jsr iar,*$next dup; dplusminus; return / 2DROP .byte 5; <2DR> dabs-6 twodrop: jsr iar,*$next drop; drop; return / UM*M ( ul uh mul --- ul' uh' ) .byte 4; twodrop-6 umstarm: jsr iar,*$next swap; over; umstar; drop; tor; umstar; zero; fromr; dplus; return / M/MMOD .byte 6; umstarm-6 mslashmmod: jsr iar,*$next tor; zero; rat; umslash; fromr; swap; tor; umslash; fromr; return / FILL .byte 4; mslashmmod-6 fill: jsr iar,*$next mrot; qdup; zbranch; 2f over; plus; swap; pdo; 1: dup; i; cstore; ploop; 1b; branch; 3f 2: drop 3: drop; return / TOGGLE .byte 6; fill-6 toggle: jsr iar,*$next over; at; exor; swap; store; return / <> .byte 2; <<\> > toggle-6 nequal: jsr iar,*$next equal; not; return / MAX .byte 3; nequal-6 max: jsr iar,*$next twodup; less; zbranch; 1f; swap; 1: drop; return / HEX .byte 3; max-6 hex: jsr iar,*$next lit; .byte 16.,0; base; store; return / DECIMAL .byte 7; hex-6 decimal: jsr iar,*$next lit; .byte 10.,0; base; store; return / OCTAL .byte 5; decimal-6 octal: jsr iar,*$next lit; .byte 8.,0; base; store; return / 2! ( n1 n2 addr --- ) .byte 2; <2! > octal-6 twostore: jsr iar,*$next swap; over; store; twoplus; store; return / Compiling words / HERE .byte 4; twostore-6 here: jsr iar,*$next dp; at; return / PAD .byte 3; here-6 pad: jsr iar,*$next here; lit; .byte 80.,0; plus; return / LATEST .byte 6; pad-6 latest: jsr iar,*$next current; at; at; return / ALLOT .byte 5; latest-6 allot: jsr iar,*$next dp; plusstore; return / , .byte 1; <, > allot-6 comma: jsr iar,*$next here; store; two; allot; return / IMMEDIATE .byte 11; comma-6 immediate: jsr iar,*$next latest; lit; .byte 200,0; toggle; return / SMUDGE .byte 6; immediate-6 smudge: jsr iar,*$next latest; lit; .byte 100,0; toggle; return / COMPILE .byte 7; smudge-6 compile: jsr iar,*$next fromr; dup; at; comma; two; plus; tor; return / IF .byte 202; / immediate word compile-6 if: jsr iar,*$next compile; zbranch; here; two; allot; return / THEN .byte 204; if-6 then: jsr iar,*$next here; swap; store; return / ELSE .byte 204; then-6 else: jsr iar,*$next compile; branch; here; two; allot; here; rot; store; return / BEGIN .byte 205; else-6 begin: jsr iar,*$next here; return / UNTIL .byte 205; begin-6 until: jsr iar,*$next compile; zbranch; comma; return / AGAIN .byte 205; until-6 again: jsr iar,*$next compile; branch; comma; return / WHILE .byte 205; again-6 while: jsr iar,*$next compile; zbranch; here; two; allot; return / REPEAT .byte 206; while-6 repeat: jsr iar,*$next compile; branch; swap; comma; here; swap; store; return / DO .byte 202; repeat-6 do: jsr iar,*$next compile; pdo; clue; at; zero; clue; store; here; return / LOOP .byte 204; do-6 loop: jsr iar,*$next compile; ploop; comma; clue; at; qdup; zbranch; 1f here; swap; store 1: clue; store; return / +LOOP .byte 205; <+LO> loop-6 plusloop: jsr iar,*$next compile; pploop; comma; clue; at; qdup; zbranch; 1f here; swap; store 1: clue; store; return / LEAVE .byte 205; plusloop-6 leave: jsr iar,*$next compile; pleave; here; clue; store; two; allot; return / [ .byte 201; <[ > leave-6 lbracket: jsr iar,*$next zero; state; store; return / ] .byte 1; <] > lbracket-6 rbracket: jsr iar,*$next one; state; store; return / ( .byte 201; <( > rbracket-6 paren: jsr iar,*$next lit; .byte 051,0; word; drop; return / I/O words / TYPE ( addr count --- ) .byte 4; paren-6 type: jsr iar,*$next stdout; write; drop; return / EMIT ( chr --- ) .byte 4; type-6 emit: jsr iar,*$next atsp; one; type; drop; return / CR .byte 2; emit-6 cr: jsr iar,*$next eol; emit; return / FQUERY ( fd --- actcount ) .byte 6; cr-6 fquery: jsr iar,*$next zero; in; store; tib; lit; .byte 120.,0; fexpect; return / COUNT .byte 5; fquery-6 count: jsr iar,*$next dup; oneplus; swap; cat; return / ALIGN .byte 5; count-6 align: jsr iar,*$next oneplus; twoslash; twostar; return / (.") .byte 4; <(."> align-6 pdotquote: jsr iar,*$next fromr; count; twodup; type; plus; align; tor; return / ,WORD .byte 5; <,WO> pdotquote-6 commaword: jsr iar,*$next word; cat; oneplus; align; allot; return / ." .byte 202; <." > commaword-6 dotquote: jsr iar,*$next compile; pdotquote; lit; .byte 42,0; commaword; return / SPACE .byte 5; dotquote-6 space: jsr iar,*$next lit; .byte 40,0; emit; return / SPACES .byte 6; space-6 spaces: jsr iar,*$next qdup; zbranch; 2f zero; pdo; 1: space; ploop; 1b 2: return / STRING ( adr[counted_string] --- adr[string] ) .byte 6; spaces-6 string: jsr iar,*$next count; dup; tor; pad; swap; cmove; zero; pad; fromr; plus; cstore; pad; return / " ( --- adr[string] ) .byte 1; <" > string-6 quote: jsr iar,*$next lit; .byte 042,0; word; string; return / ("") ( --- adr[string] ) .byte 4; <(""> quote-6 pdquote: jsr iar,*$next fromr; dup; count; plus; align; tor; string; return / "" .byte 202; <"" > pdquote-6 dquote: jsr iar,*$next compile; pdquote; lit; .byte 042,0; commaword; return; / Defining words / CFIELD .byte 6; dquote-6 cfield: jsr iar,*$next lit; .byte 6,0; plus; return / NFIELD .byte 6; cfield-6 nfield: jsr iar,*$next lit; .byte 6,0; minus; return / -IMM ( nfa --- cfa n ) .byte 4; <-IM> nfield-6 notimm: jsr iar,*$next dup; cfield; minusone; rot; cat; lit; .byte 0200,0; and zbranch; 1f; negate; 1: return / FIND ( addr[name] --- addr2 n ) .byte 4; notimm-6 find: jsr iar,*$next dup; context; at; at; pfind qdup; zbranch; 1f; swap; drop; notimm; branch; 3f 1: dup; latest; pfind qdup; zbranch; 2f; swap; drop; notimm; branch; 3f 2: zero 3: return / ' .byte 1; <' > find-6 tic: jsr iar,*$next here; lit; .byte 4,0; lit; .byte 40,0; fill lit; .byte 40,0; word find; zeroeq; zbranch; 1f; drop; zero; 1: return / HEADER .byte 6; tic-6 header: jsr iar,*$next tic; zbranch; 1f wrn; at; zbranch; 1f here; count; type pdotquote; .byte 15; < isn't unique>; .even; cr 1: here; lit; .byte 4,0; allot; latest; comma; current; at; store; return / CALL .byte 4; header-6 call: jsr iar,*$next lit; .byte 037,9; comma; return / : .byte 1; <: > call-6 colon: jsr iar,*$next current; at; context; store; header; call; compile; next; rbracket; smudge; return / ; .byte 201; <; > colon-6 semicolon: jsr iar,*$next compile; return; smudge; zero; state; store; return / VARIABLE .byte 10; semicolon-6 variable: jsr iar,*$next header; call; compile; var; zero; comma; return / CONSTANT .byte 10; variable-6 constant: jsr iar,*$next header; call; compile; con; comma; return / 2VARIABLE .byte 11; <2VA> constant-6 twovar: jsr iar,*$next variable; zero; comma; return / DOES> .byte 5; twovar-6 does: jsr iar,*$next fromr; latest; cfield; lit; .byte 4,0; plus; store; return / CREATE .byte 6; does-6 create: jsr iar,*$next header; call; compile; pdoes; zero; comma; does; return / VOCABULARY .byte 12; create-6 vocabulary: jsr iar,*$next create; here; twoplus; comma; latest; comma does; at; context; store; return / DEFINITIONS .byte 13; vocabulary-6 definitions: jsr iar,*$next context; at; current; store; return / FORTH FORTH vocabulary .byte 205; definitions-6 forth: jsr iar,*$next initvocab; context; store; return / numeric output words / HLD .byte 3; forth-6 hld: jsr iar,*$var .byte 0,0 / HOLD .byte 4; hld-6 hold: jsr iar,*$next minusone; hld; plusstore; hld; at; cstore; return / <# .byte 2; <<# > hold-6 lnum: jsr iar,*$next pad; hld; store; return / #> .byte 2; <#\> > lnum-6 gnum: jsr iar,*$next twodrop; hld; at; pad; over; minus; return / SIGN .byte 4; gnum-6 sign: jsr iar,*$next zeroless; zbranch; 1f; lit; .byte 055,0; hold; 1: return / # .byte 1; <# > sign-6 num: jsr iar,*$next base; at; mslashmmod; rot; lit; .byte 11,0; over; less zbranch; 1f; lit; .byte 7,0; plus; 1: lit; .byte 060,0; plus; hold; return / #S .byte 2; <#S > num-6 nums: jsr iar,*$next 1: num; twodup; or; zeroeq; zbranch; 1b; return / D.R .byte 3; nums-6 ddotr: jsr iar,*$next tor; swap; over; dabs; lnum; nums; rot; sign; gnum; fromr; over; minus; zero; max; spaces; type; return / ZEROES .byte 6; ddotr-6 zeroes: jsr iar,*$next zero; max; qdup; zbranch; 2f; zero; pdo; 1: lit; .byte 060,0; emit; ploop; 1b 2: return / D.LZ .byte 4; zeroes-6 ddotlz: jsr iar,*$next tor; swap; over; dabs; lnum; nums; rot; sign; gnum fromr; over; minus; zeroes; type; return / D. .byte 2; ddotlz-6 ddot: jsr iar,*$next zero; ddotr; space; return / .R .byte 2; <.R > ddot-6 dotr: jsr iar,*$next tor; stod; fromr; ddotr; return / . .byte 1; <. > dotr-6 dot: jsr iar,*$next stod; ddot; return / U.R .byte 3; dot-6 udotr: jsr iar,*$next zero; swap; ddotr; return / U.LZ .byte 4; udotr-6 udotlz: jsr iar,*$next zero; swap; ddotlz; return / utilities / [COMPILE] .byte 211; <[CO> udotlz-6 bcompile: jsr iar,*$next tic; comma; return / DUMP ( addr bytes --- ) .byte 4; bcompile-6 dump: jsr iar,*$next cr; over; plus; swap; pdo; 1: i; lit; .byte 4,0; udotlz; pdotquote; .byte 1; <:>; .even space i; lit; .byte 8,0; plus; i; pdo; 2: i; cat; two; udotlz; space; ploop; 2b i; lit; .byte 8,0; plus; i; pdo; 3: i; cat; dup; lit; .byte 040,0; less; over; lit; .byte 177,0; equal; or zbranch; 4f; drop; lit; .byte 056,0; 4: emit; ploop; 3b cr; lit; .byte 8,0; pploop; 1b return / operating system support words / DIGIT ( char --- n true false ) .byte 5; dump-6 digit: jsr iar,*$next lit; .byte 60,0; minus dup; lit; .byte 11,0; greater; over; lit; .byte 21,0; less; and zbranch; 1f drop; false; branch; 4f 1: dup; lit; .byte 11,0; ugreater; zbranch; 2f lit; .byte 7,0; minus 2: dup; base; at; oneminus; ugreater; zbranch; 3f drop; false; branch; 4f 3: true 4: return / CONVERT ( dl dh addr1 --- dl' dh' addr2 ) .byte 7; digit-6 convert: jsr iar,*$next tor; 1: fromr; oneplus; dup; tor; cat; digit; zbranch; 2f; tor; base; at; umstarm; fromr; zero; dplus branch; 1b 2: fromr; return / NUMBER ( ADDR --- N TRUE FALSE ) .byte 6; convert-6 number: jsr iar,*$next dup; oneplus; cat; lit; .byte 055,0; equal; dup; tor; minus zero; zero; rot; convert cat; lit; .byte 040,0; equal; zbranch; 1f drop; fromr; plusminus; true; branch; 2f 1: twodrop; fromr; drop; false 2: return / ?STACK ( --- T/F ) ( returns true if stack underflow ) .byte 6; number-6 qstack: jsr iar,*$next atsp; sp0; greater; return / CHUCKBUF ( chuck rest of input buffer ) .byte 10; qstack-6 chuckbuf: jsr iar,*$next tib; in; at; plus 1: dup; cat; eol; nequal; zbranch; 2f; oneplus branch; 1b 2: tib; minus; in; store; return / ENDINTERP ( --- ) ( flush reset of input buffer ) .byte 11; chuckbuf-6 endinterp: jsr iar,*$next sp0; storesp; / reset stack pointer chuckbuf; return / INTERPRET .byte 11; endinterp-6 interpret: jsr iar,*$next 1: here; lit; .byte 4,0; lit; .byte 040,0; fill lit; .byte 040,0; word; cat; zbranch; 9f here; find; qdup; zbranch; 4f state; at; plus zbranch; 2f; execute; branch; 3f; 2: comma; 3: branch; 7f 4: number; zbranch; 6f state; at; zbranch; 5f; compile; lit; comma; 5: branch; 7f 6: here; count; type; pdotquote; .byte 2; < ?>; .even; cr endinterp 7: qstack; zbranch; 8f; pdotquote; .byte 14; < Stack empty>; .even; cr endinterp; 8: branch; 1b; 9: return / FLOAD ( adr[string] --- ) .byte 5; interpret-6 fload: jsr iar,*$next zero; open; dup; zeroless; zbranch; 0f drop; pdotquote; .byte 13; < can't open>; .even; cr; branch; 3f 0: tor 1: rat; fquery; zbranch; 2f; interpret; branch; 1b 2: fromr; close; chuckbuf 3: return / QUIT .byte 4; fload-6 quit: jsr iar,*$next zero; state; store; sp0; storesp cr; pdotquote; .byte 23.; ; .even 1: cr; stdin; fquery; zbranch; 3f interpret state; at; zeroeq; zbranch; 2f; pdotquote; .byte 3; < OK>; .even 2: branch; 1b 3: cr; terminate; return / the reset of the dictionary dict: .=.+20000. / TEST +E+O+F