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!mgnetp!ihnp4!houxm!houxz!vax135!cornell!uw-beaver!tektronix!hplabs!hao!seismo!rlgvax!cvl!umcp-cs!aplvax!lwt1 From: lwt1@aplvax.UUCP Newsgroups: net.sources Subject: UNIX FORTH for the VAX (part 7 of 8) Message-ID: <676@aplvax.UUCP> Date: Fri, 22-Jun-84 14:45:46 EDT Article-I.D.: aplvax.676 Posted: Fri Jun 22 14:45:46 1984 Date-Received: Wed, 27-Jun-84 09:39:50 EDT Organization: JHU/Applied Physics Lab, Laurel, MD Lines: 957 Here is part 7 of 8 of the source for FORTH for the VAX. 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. Have fun! -John Hayes Johns Hopkins University Applied Physics Laboratory ... seismo!umcp-cs!aplvax!lwt1 ---------------------------------- 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; .ascii "TIB " .word exor-8 tib: .word con+2 .word inbuf /* SP0 */ .byte 3; .ascii "SP0 " .word tib-8 sp0: .word con+2 .word pstack /* DP0 */ .byte 3; .ascii "DP0 " .word sp0-8 dp0: .word con+2 .word dict /* WRN */ .byte 3; .ascii "WRN " .word dp0-8 wrn: .word var+2 .word -1 /* DP */ .byte 2; .ascii "DP " .word wrn-8 dp: .word var+2 DP: .word 0 /* >IN */ .byte 3; .ascii ">IN " .word dp-8 in: .word var+2 IN: .word 0 /* STATE */ .byte 5; .ascii "STATE" .word in-8 state: .word var+2 .word 0 /* BASE */ .byte 4; .ascii "BASE " .word state-8 base: .word var+2 BASE: .word 0 /* INITVOCAB ( intial vocabulary - will be FORTH ) */ .byte 11; .ascii "INITV" .word base-8 initvocab: .word var+2 INITVOCAB: .word 0 /* CONTXT ( context vocabulary ) */ .byte 6; .ascii "CONTX" .word initvocab-8 context: .word var+2 .word INITVOCAB /* CURRENT ( current vocabulary ) */ .byte 7; .ascii "CURRE" .word context-8 current: .word var+2 .word INITVOCAB /* CLUE */ .byte 4; .ascii "CLUE " .word current-8 clue: .word var+2 .word 0 /* STDIN */ .byte 5; .ascii "STDIN" .word clue-8 stdin: .word con+2 .word 0 /* STDOUT */ .byte 6; .ascii "STDOU" .word stdin-8 stdout: .word con+2 .word 1 /* EOL */ .byte 3; .ascii "EOL " .word stdout-8 eol: .word con+2 .word 012 /* TRUE */ .byte 4; .ascii "TRUE " .word eol-8 true: .word con+2 .word -1 /* FALSE */ .byte 5; .ascii "FALSE" .word true-8 false: .word con+2 .word 0 /* Code extensions */ /* ?DUP */ .byte 4; .ascii "?DUP " .word false-8 qdup: .word call .word dup, zbranch, 1f, dup; 1: .word return /* -ROT */ .byte 4; .ascii "-ROT " .word qdup-8 mrot: .word call .word rot, rot, return /* * */ .byte 1; .ascii "* " .word mrot-8 star: .word call .word umstar, drop, return /* 2DUP */ .byte 4; .ascii "2DUP " .word star-8 twodup: .word call .word over, over, return /* S->D */ .byte 4; .ascii "S->D " .word twodup-8 stod: .word call .word dup, zeroless, return /* +- */ .byte 2; .ascii "+- " .word stod-8 plusminus: .word call .word zeroless, zbranch, 1f, negate; 1: .word return /* D+- */ .byte 3; .ascii "D+- " .word plusminus-8 dplusminus: .word call .word zeroless, zbranch, 1f, dnegate; 1: .word return /* ABS */ .byte 3; .ascii "ABS " .word dplusminus-8 abs: .word call .word dup, plusminus, return /* DABS */ .byte 4; .ascii "DABS " .word abs-8 dabs: .word call .word dup, dplusminus, return /* 2DROP */ .byte 5; .ascii "2DROP" .word dabs-8 twodrop: .word call .word drop, drop, return /* UM*M ( ul uh mul --- ul' uh' ) */ .byte 4; .ascii "UM*M " .word twodrop-8 umstarm: .word call .word swap, over, umstar, drop, tor, umstar, zero, fromr, dplus .word return /* M/MMOD */ .byte 6; .ascii "M/MMO" .word umstarm-8 mslashmmod: .word call .word tor, zero, rat, umslash, fromr, swap, tor, umslash, fromr .word return /* FILL */ .byte 4; .ascii "FILL " .word mslashmmod-8 fill: .word call .word mrot, qdup, zbranch, 2f .word over, plus, swap, pdo; 1: .word dup, i, cstore, ploop, 1b, branch, 3f 2: .word drop 3: .word drop, return /* TOGGLE */ .byte 6; .ascii "TOGGL" .word fill-8 toggle: .word call .word over, at, exor, swap, store, return /* <> */ .byte 2; .ascii "<> " .word toggle-8 nequal: .word call .word equal, not, return /* MAX */ .byte 3; .ascii "MAX " .word nequal-8 max: .word call .word twodup, less, zbranch, 1f, swap; 1: .word drop, return /* HEX */ .byte 3; .ascii "HEX " .word max-8 hex: .word call .word lit, 16, base, store, return /* DECIMAL */ .byte 7; .ascii "DECIM" .word hex-8 decimal: .word call .word lit, 10, base, store, return /* OCTAL */ .byte 5; .ascii "OCTAL" .word decimal-8 octal: .word call .word lit, 8, base, store, return /* 2! ( n1 n2 addr --- ) */ .byte 2; .ascii "2! " .word octal-8 twostore: .word call .word swap, over, store, twoplus, store, return /* Compiling words */ /* HERE */ .byte 4; .ascii "HERE " .word twostore-8 here: .word call .word dp, at, return /* PAD */ .byte 3; .ascii "PAD " .word here-8 pad: .word call .word here, lit, 80, plus, return /* LATEST */ .byte 6; .ascii "LATES" .word pad-8 latest: .word call .word current, at, at, return /* ALLOT */ .byte 5; .ascii "ALLOT" .word latest-8 allot: .word call .word dp, plusstore, return /* , */ .byte 1; .ascii ", " .word allot-8 comma: .word call .word here, store, two, allot, return /* IMMEDIATE */ .byte 9; .ascii "IMMED" .word comma-8 immediate: .word call .word latest, lit, 0200, toggle, return /* SMUDGE */ .byte 6; .ascii "SMUDG" .word immediate-8 smudge: .word call .word latest, lit, 0100, toggle, return /* COMPILE */ .byte 7; .ascii "COMPI" .word smudge-8 compile: .word call .word fromr, dup, at, comma, two, plus, tor, return /* IF */ .byte 2+128; .ascii "IF " .word compile-8 if: .word call .word compile, zbranch, here, two, allot, return /* THEN */ .byte 4+128; .ascii "THEN " .word if-8 then: .word call .word here, swap, store, return /* ELSE */ .byte 4+128; .ascii "ELSE " .word then-8 else: .word call .word compile, branch, here, two, allot, here, rot, store, return /* BEGIN */ .byte 5+128; .ascii "BEGIN" .word else-8 begin: .word call .word here, return /* UNTIL */ .byte 5+128; .ascii "UNTIL" .word begin-8 until: .word call .word compile, zbranch, comma, return /* AGAIN */ .byte 5+128; .ascii "AGAIN" .word until-8 again: .word call .word compile, branch, comma, return /* WHILE */ .byte 5+128; .ascii "WHILE" .word again-8 while: .word call .word compile, zbranch, here, two, allot, return /* REPEAT */ .byte 6+128; .ascii "REPEA" .word while-8 repeat: .word call .word compile, branch, swap, comma, here, swap, store, return /* DO */ .byte 2+128; .ascii "DO " .word repeat-8 do: .word call .word compile, pdo, clue, at, zero, clue, store, here, return /* LOOP */ .byte 4+128; .ascii "LOOP " .word do-8 loop: .word call .word compile, ploop, comma, clue, at, qdup, zbranch, 1f .word here, swap, store 1: .word clue, store, return /* +LOOP */ .byte 5+128; .ascii "+LOOP" .word loop-8 plusloop: .word call .word compile, pploop, comma, clue, at, qdup, zbranch, 1f .word here, swap, store 1: .word clue, store, return /* LEAVE */ .byte 5+128; .ascii "LEAVE" .word plusloop-8 leave: .word call .word compile, pleave, here, clue, store, two, allot, return /* [ */ .byte 1+128; .ascii "[ " .word leave-8 lbracket: .word call .word zero, state, store, return /* ] */ .byte 1; .ascii "] " .word lbracket-8 rbracket: .word call .word one, state, store, return /* ( */ .byte 1+128; .ascii "( " .word rbracket-8 paren: .word call .word lit, 051, word, drop, return /* I/O words */ /* TYPE ( addr count --- ) */ .byte 4; .ascii "TYPE " .word paren-8 type: .word call .word stdout, write, drop, return /* EMIT ( chr --- ) */ .byte 4; .ascii "EMIT " .word type-8 emit: .word call .word atsp, one, type, drop, return /* CR */ .byte 2; .ascii "CR " .word emit-8 cr: .word call .word eol, emit, return /* FQUERY ( fd --- actcount ) */ .byte 6; .ascii "FQUER" .word cr-8 fquery: .word call .word zero, in, store .word tib, lit, 120, fexpect, return /* COUNT */ .byte 5; .ascii "COUNT" .word fquery-8 count: .word call .word dup, oneplus, swap, cat, return /* (.") */ .byte 4; .ascii "(.\") " .word count-8 pdotquote: .word call .word fromr, count, twodup, type, plus, tor, return /* ,WORD */ .byte 5; .ascii "WORD" .word pdotquote-8 commaword: .word call .word word, cat, oneplus, allot, return /* ." */ .byte 2+128; .ascii ".\" " .word commaword-8 dotquote: .word call .word compile, pdotquote, lit, 042, commaword, return /* SPACE */ .byte 5; .ascii "SPACE" .word dotquote-8 space: .word call .word lit, 040, emit, return /* SPACES */ .byte 6; .ascii "SPACE" .word space-8 spaces: .word call .word zero, max, qdup, zbranch, 2f .word zero, pdo; 1: .word space, ploop, 1b 2: .word return /* STRING ( adr[counted_string] --- adr[string] ) */ .byte 6; .ascii "STRIN" .word spaces-8 string: .word call .word count, dup, tor, pad, swap, cmove, zero, pad, fromr, plus .word cstore, pad, return /* " ( --- adr[string] ) */ .byte 1; .ascii "\" " .word string-8 quote: .word call .word lit, 042, word, string, return /* ("") ( --- adr[string] ) */ .byte 4; .ascii "(\"\") " .word quote-8 pdquote: .word call .word fromr, dup, count, plus, tor, string, return /* "" */ .byte 2; .ascii "\"\" " .word pdquote-8 dquote: .word call .word compile, pdquote, lit, 042, commaword, return /* Defining words */ /* CFIELD */ .byte 6; .ascii "CFIEL" .word dquote-8 cfield: .word call .word lit, 8, plus, return /* NFIELD */ .byte 6; .ascii "NFIEL" .word cfield-8 nfield: .word call .word lit, 8, minus, return /* -IMM ( nfa --- cfa n ) */ .byte 4; .ascii "-IMM " .word nfield-8 notimm: .word call .word dup, cfield, minusone, rot, cat, lit, 0200, and .word zbranch, 1f, negate; 1: .word return /* FIND ( addr[name] --- addr2 n ) */ .byte 4; .ascii "FIND " .word notimm-8 find: .word call .word dup, context, at, at, pfind .word qdup, zbranch, 1f, swap, drop, notimm, branch, 3f 1: .word dup, latest, pfind .word qdup, zbranch, 2f, swap, drop, notimm, branch, 3f 2: .word zero 3: .word return /* ' */ .byte 1; .ascii "' " .word find-8 tic: .word call .word here, lit, 6, lit, 040, fill .word lit, 040, word .word find, zeroeq, zbranch, 1f, drop, zero; 1: .word return /* HEADER */ .byte 6; .ascii "HEADE" .word tic-8 cheader: .word call .word tic, zbranch, 1f .word wrn, at, zbranch, 1f .word here, count, type .word pdotquote; .byte 13; .ascii " isn't unique" .word cr 1: .word here, lit, 6, allot, latest, comma, current, at, store .word return /* : */ .byte 1; .ascii ": " .word cheader-8 colon: .word call .word current, at, context, store .word cheader, compile, call, rbracket, smudge, return /* ; */ .byte 1+128; .ascii "; " .word colon-8 semicolon: .word call .word compile, return, smudge, zero, state, store, return /* VARIABLE */ .byte 8; .ascii "VARIA" .word semicolon-8 variable: .word call .word cheader, compile, var+2, zero, comma, return /* CONSTANT */ .byte 8; .ascii "CONST" .word variable-8 constant: .word call .word cheader, compile, con+2, comma, return /* 2VARIABLE */ .byte 9; .ascii "2VARI" .word constant-8 twovar: .word call .word variable, zero, comma, return /* DOES> */ .byte 5; .ascii "DOES>" .word twovar-8 does: .word call .word fromr, latest, cfield, twoplus, store, return /* CREATE */ .byte 6; .ascii "CREAT" .word does-8 create: .word call .word cheader, compile, pdoes+2, zero, comma, does, return /* VOCABULARY */ .byte 10; .ascii "VOCAB" .word create-8 vocabulary: .word call .word create, here, twoplus, comma, latest, comma .word does, at, context, store, return /* DEFINITIONS */ .byte 11; .ascii "DEFIN" .word vocabulary-8 definitions: .word call .word context, at, current, store, return /* FORTH FORTH vocabulary */ .byte 5+128; .ascii "FORTH" .word definitions-8 forth: .word call .word initvocab, context, store, return /* numeric output words */ /* HLD */ .byte 3; .ascii "HLD " .word forth-8 hld: .word var+2 .word 0 /* HOLD */ .byte 4; .ascii "HOLD " .word hld-8 hold: .word call .word minusone, hld, plusstore, hld, at, cstore, return /* <# */ .byte 2; .ascii "<# " .word hold-8 lnum: .word call .word pad, hld, store, return /* #> */ .byte 2; .ascii "#> " .word lnum-8 gnum: .word call .word twodrop, hld, at, pad, over, minus, return /* SIGN */ .byte 4; .ascii "SIGN " .word gnum-8 sign: .word call .word zeroless, zbranch, 1f, lit, 055, hold; 1: .word return /* # */ .byte 1; .ascii "# " .word sign-8 num: .word call .word base, at, mslashmmod, rot, lit, 011, over, less .word zbranch, 1f, lit, 7, plus; 1: .word lit, 060, plus, hold, return /* #S */ .byte 2; .ascii "#S " .word num-8 nums: .word call 1: .word num, twodup, or, zeroeq, zbranch, 1b, return /* D.R */ .byte 3; .ascii "D.R " .word nums-8 ddotr: .word call .word tor, swap, over, dabs, lnum, nums, rot, sign, gnum .word fromr, over, minus, spaces, type, return /* ZEROES */ .byte 6; .ascii "ZEROE" .word ddotr-8 zeroes: .word call .word zero, max, qdup, zbranch, 2f, zero, pdo; 1: .word lit, 060, emit, ploop, 1b 2: .word return /* D.LZ */ .byte 4; .ascii "D.LZ " .word zeroes-8 ddotlz: .word call .word tor, swap, over, dabs, lnum, nums, rot, sign, gnum .word fromr, over, minus, zeroes, type, return /* D. */ .byte 2; .ascii "D. " .word ddotlz-8 ddot: .word call .word zero, ddotr, space, return /* .R */ .byte 2; .ascii ".R " .word ddot-8 dotr: .word call .word tor, stod, fromr, ddotr, return /* . */ .byte 1; .ascii ". " .word dotr-8 dot: .word call .word stod, ddot, return /* U.R */ .byte 3; .ascii "U.R " .word dot-8 udotr: .word call .word zero, swap, ddotr, return /* U.LZ */ .byte 4; .ascii "U.LZ " .word udotr-8 udotlz: .word call .word zero, swap, ddotlz, return /* utilities */ /* [COMPILE] */ .byte 9+128; .ascii "[COMP" .word udotlz-8 bcompile: .word call .word tic, comma, return /* DUMP ( addr bytes --- ) */ .byte 4; .ascii "DUMP " .word bcompile-8 dump: .word call .word cr, over, plus, swap, pdo; 1: .word i, lit, 4, udotlz, pdotquote; .byte 1; .ascii ":" .word space .word i, lit, 8, plus, i, pdo; 2: .word i, cat, two, udotlz, space, ploop, 2b .word i, lit, 8, plus, i, pdo; 3: .word i, cat, dup, lit, 040, less .word over, lit, 0177, equal, or .word zbranch, 4f, drop, lit, 056; 4: .word emit, ploop, 3b .word cr, lit, 8, pploop, 1b .word return /* operating system support words */ /* DIGIT ( char --- n true false ) */ .byte 5; .ascii "DIGIT" .word dump-8 digit: .word call .word lit, 060, minus .word dup, lit, 9, greater, over, lit, 17, less, and .word zbranch, 1f .word drop, false, branch, 4f 1: .word dup, lit, 9, ugreater, zbranch, 2f .word lit, 7, minus 2: .word dup, base, at, oneminus, ugreater, zbranch, 3f .word drop, false, branch, 4f 3: .word true 4: .word return /* CONVERT ( dl dh addr1 --- dl' dh' addr2 ) */ .byte 7; .ascii "CONVE" .word digit-8 convert: .word call .word tor; 1: .word fromr, oneplus, dup, tor, cat, digit .word zbranch, 2f, tor, base, at, umstarm, fromr, zero, dplus .word branch, 1b 2: .word fromr, return /* NUMBER ( ADDR --- N TRUE FALSE ) */ .byte 6; .ascii "NUMBE" .word convert-8 number: .word call .word dup, oneplus, cat, lit, 055, equal, dup, tor, minus .word zero, zero, rot, convert .word cat, lit, 040, equal, zbranch, 1f .word drop, fromr, plusminus, true, branch, 2f 1: .word twodrop, fromr, drop, false 2: .word return /* ?STACK ( --- T/F ) ( returns true if stack underflow ) */ .byte 6; .ascii "?STAC" .word number-8 qstack: .word call .word atsp, sp0, greater, return /* CHUCKBUF ( chuck rest of input buffer ) */ .byte 8; .ascii "CHUCK" .word qstack-8 chuckbuf: .word call .word tib, in, at, plus 1: .word dup, cat, eol, nequal, zbranch, 2f, oneplus .word branch, 1b 2: .word tib, minus, in, store, return /* ENDINTERP ( --- ) ( flush reset of input buffer ) */ .byte 9; .ascii "ENDIN" .word chuckbuf-8 endinterp: .word call .word sp0, storesp /* reset stack pointer */ .word chuckbuf, return /* INTERPRET */ .byte 9; .ascii "INTER" .word endinterp-8 interpret: .word call 1: .word here, lit, 6, lit, 040, fill .word lit, 040, word, cat, zbranch, 9f .word here, find, qdup, zbranch, 4f .word state, at, plus .word zbranch, 2f, execute, branch, 3f; 2: .word comma; 3: .word branch, 7f 4: .word number, zbranch, 6f .word state, at, zbranch, 5f, compile, lit, comma; 5: .word branch, 7f 6: .word here, count, type, pdotquote; .byte 2; .ascii " ?" .word cr,endinterp 7: .word qstack, zbranch, 8f, pdotquote .byte 12; .ascii " Stack empty"; .word cr, endinterp; 8: .word branch, 1b 9: .word return /* FLOAD ( adr[string] --- ) */ .byte 5; .ascii "FLOAD" .word interpret-8 fload: .word call .word zero, open, dup, zeroless, zbranch, 0f .word drop, pdotquote; .byte 11; .ascii " can't open" .word cr, branch, 3f 0: .word tor 1: .word rat, fquery, zbranch, 2f, interpret, branch, 1b 2: .word fromr, close, chuckbuf 3: .word return /* QUIT */ .byte 4; .ascii "QUIT " .word fload-8 quit: .word call .word zero, state, store, sp0, storesp .word cr, pdotquote; .byte 21; .ascii "VAX FORTH version 1.0" 1: .word cr, stdin, fquery, zbranch, 3f .word interpret .word state, at, zeroeq, zbranch, 2f, pdotquote .byte 3; .ascii " OK" 2: .word branch, 1b 3: .word cr, terminate, return /* the rest of the dictionary */ dict: .space 20000 !E!O!F