wls@astrovax.UUCP (William L. Sebok) (06/26/84)
part 6 of 8
--------Cut here and extract with sh not csh------------
mkdir ./vaxforth
/bin/echo 'Extracting ./vaxforth/forth1.S'
sed 's/^X//' <<'//go.sysin dd *' >./vaxforth/forth1.S
X/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* *
* FORTH Compiler, Native Mode Kernel for VAX UNIX *
* W.L.Sebok July 1982 *
* rev March 11,1984 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
#ifdef BSD4_2
#include <syscall.h>
#endif
X/* Definition of Parameters */
X/* Definition of User Area (Task Control Block) */
.set usiz,0
.set active,usiz /* non-zero if coprocess is sleeping */
.set usiz,usiz+4
.set rsav,usiz /* save area for return stack */
.set usiz,usiz+4
.set rbot,usiz /* bottom of return stack */
.set usiz,usiz+4
.set sbot,usiz /* bottom of parameter stack */
.set usiz,usiz+4
.set typer,usiz /* points to control block of terminal */
.set usiz,usiz+4
.set typer0,usiz /* points to default terminal */
.set usiz,usiz+4
.set reader,usiz /* input device */
.set usiz,usiz+4
.set reader0,usiz /* reset for reader device */
.set usiz,usiz+4
.set head,usiz /* latest vocabulary entry */
.set usiz,usiz+4
.set darea,usiz /* area which describes disk buffers */
.set usiz,usiz+4
.set lcknt,usiz /* # of protected disk buffer i/o operations */
.set usiz,usiz+4
.set floc,usiz /* pointer to next location if UNIX type file.*/
.set usiz,usiz+4
.set dpl,usiz /*describes characteristics of last number converted
* 1st byte is negative of decimal exponent
* 2nd byte contains flag bits
* bit 0 on if negative (-0 is distinguished by this bit)
* bit 1 on if floating point
* bit 7 on if single precision integer */
.set usiz,usiz+4
.set scr,usiz /* current block being edited. */
.set usiz,usiz+4
.set base,usiz /* base used in number conversions */
.set usiz,usiz+4
.set context,usiz /* vocabulary with which words are interpreted*/
.set usiz,usiz+4
.set current,usiz /* vocabulary in which new words are compiled*/
.set usiz,usiz+4
.set state,usiz /* 0 if execute, 100000 if compile */
.set usiz,usiz+4
.set in,usiz /* char pointer in block being interpreted */
.set usiz,usiz+4
.set blk,usiz /* block currently being loaded */
/* (or 0 if terminal). */
.set usiz,usiz+4
.set msgbuf,usiz /* message buffer for terminal input. */
.set usiz,usiz+4
.set msgbuf0,usiz /* restore cell for memory management. */
.set usiz,usiz+4
.set dbparen,usiz /* stores pointer in output number formation. */
.set usiz,usiz+4
.set ssbot,usiz /* bottom of string stack. */
.set usiz,usiz+4
.set fsbot,usiz /* bottom of floating point stack */
.set usiz,usiz+4
.set errno,usiz /* Saved unix error number */
.set usiz,usiz+4
.set quitadd,usiz /* routine to intercept a QUIT */
.set usiz,usiz+4
X/* Dedicated Register Definitions */
.set u,7 /* user area pointer. */
.set h,8 /* dictionary pointer */
.set c,9 /* string stack pointer */
.set f,10 /* floating point stack pointer */
.set s,11 /* parameter stack pointer */
.set r,14 /* return stack pointer */
X/* Terminal Status Options */
.set RAW,040
.set CRMOD,020
.set ECHO,010
X/* Terminal ioctl functions */
#ifdef BSD4_2
.set TIOCGETP,0x4006<16|'t<8|8 /* get terminal options */
.set TIOCSETP,0x8006<16|'t<8|9 /* set terminal options */
#else
.set TIOCGETP,'t<8|8 /* get terminal options */
.set TIOCSETP,'t<8|9 /* set terminal options */
#endif
X/* Dictionary Flags Values */
.set IM,01 /* immediate */
.set INL,02 /* compile code in-line */
.set NUL,04 /* to make entry unavailable */
X/* Various System Parameters */
.set NBUF,4 /* number of buffers */
.set BUFLEN,1024 /* length of buffers in bytes. */
.set FSTKSZ,256 /* space allocated for floating point stack */
.set STRSTKSZ,1024 /* space allocated for string stack (in bytes)*/
.set RSTKSZ,300 /* space allocated for return stack (in bytes)*/
.set DESLEN,24 /* size of buffer descriptor */
.set PADOFF,30 /* PAD is offset PADOFF bytes from HERE */
.set FREESIZE,256 /* Size of Free Area after HERE */
.set TBUFSIZ,80 /* Characters read from terminal per line. */
.set MAXSTR,5 /* Largest string compiled in-line. */
X/* Definition of Error Conditions */
.set E.UCOND,1 /* Uncompleted conditional. */
.set E.QUER,2 /* ? message */
.set E.SBOT,3 /* Stack Empty */
.set E.DFULL,4 /* Dictionary Full */
.set E.ROVER,5 /* Return Stack Overflow. */
.set E.LOCK,6 /* All Buffers Locked. */
.set E.BADBL,7 /* Undefined block number */
.set E.ADOVF,8 /* Attempted Dictionary Overflow. */
.set E.FENCE,9 /* Attempted FORGET below fence. */
.set E.SEMPT,10 /* String Stack Empty */
.set E.SBAD,11 /* Bad String on String stack */
.set E.SOVER,12 /* String Stack Overflow */
.set E.FEMPT,13 /* Floating point stack empty */
.set E.FOVER,14 /* Floating point stack overflow. */
.set E.EOL,15 /* Ran off of End-of Line */
.set U.ERR,16 /* Offset for Intercepted Unix Errors. */
.set E.FLT,49 /* Offset for Floating point messages. */
.set E.INSTR,54 /* Illegal Instruction */
.set E.BUS,55 /* Bus error */
.set E.ADDR,56 /* Illegal Address */
.set E.SARG,57 /* Bad System Call Arguments. */
X/* Random Stuff */
.set BLANK,040
.set TAB,011
.set NL,012
X/* ====================================================================== */
X/* Initialization of Dictionary Chains */
.set fdc0,0 ; .set adc0,0
.set fdc1,0 ; .set adc1,0
.set fdc2,0 ; .set adc2,0
.set fdc3,0 ; .set adc3,0
.set fdc4,0 ; .set adc4,0
.set fdc5,0 ; .set adc5,0
.set fdc6,0 ; .set adc6,0
.set fdc7,0 ; .set adc7,0
.set fdc8,0 ; .set adc8,0
.set fdc9,0 ; .set adc9,0
.set fdca,0 ; .set adca,0
.set fdcb,0 ; .set adcb,0
.set fdcc,0 ; .set adcc,0
.set fdcd,0 ; .set adcd,0
.set fdce,0 ; .set adce,0
.set fdcf,0 ; .set adcf,0
X/* ========================================================================== */
X/* Globals */
.globl _errno
X/* ========================================================================== */
X/* ========================================================================== */
X/* << Start of TEXT >> */
.text
.word 0
pushal strtup
rsb /* jmp to initialization code */
X/* ========================================================================== */
X/* <<< OUTER INTERPRETER >>> */
newlin: bsbw query /* read in new line from terminal */
goloop: bsbw find /* look up word */
gloop2: tstl (%s) /* found it? */
beql con /* in not, try to handle as number */
blbc state(%u),ex /* compile mode? execute if not */
subl3 $10,(%s),r0 /* flags are 10 before parameter field */
blbs (r0),ex /* Immediate mode? compile if not */
bsbb compil
brw check
ex: subl3 $6,(%s)+,r0
jsb (r0)
brw check
con: bsbw strcon /* is it a string constant? */
tstl (%s)+
beql num
brw check
num: clrq -(%s)
movl %h,-(%s)
bsbw convert /* convert string to number */
bsbw cnmbr /* compile or return number */
brw check
X/* ========================================================================== */
X/* Words Used in Definitions */
X/* Execute Word */
.byte 8f-execut
9: .word 9b-fdc5
9: .set fdc5,9b
.long INL+012414254070 /* EXECUTE */
execut: subl3 $6,(%s)+,r0
jsb (r0)
8: rsb
X/* Compile into dictionary */
compil: subl2 $6,(%s)
movl (%s),r0
bitl $INL,-(r0) /* In-line? */
jeql _jbsb /* No, then compile jsb, bsbb, or bsbw to it. */
tstw -(r0) /* short link? */
bneq 1f /* yes */
tstl -(r0) /* no, then skip over long link */
1: movzbl -(r0),r0 /* get length of in-line code. */
movc3 r0,*(%s)+,(%h) /* and move it */
movl r3,%h
rsb
X/* End A Forth Definition. */
9: .word 9b-fdcb
9: .set fdcb,9b
.long IM+020202020310 /* ; (semicolon) */
semcol: movl current(%u),context(%u)
clrl state(%u)
movl head(%u),r0
bicl2 $NUL,(r0) /* make entry available */
bitb $INL,(r0) /* in-line defitition? */
beql 2f /* no */
subl3 r0,%h,r1
subl2 $4,r1
tstw -(r0) /* short link? */
bneq 1f /* yes */
tstl -(r0) /* no, skip over long link. */
1: movb r1,-(r0) /* install length of in-line code */
2: movb $5,(%h)+ /* compile rsb instruction */
rsb
X/* End a CODE definition */
9: .word 9b-fdc5
9: .set fdc5,9b
.long 01664207000 /* END-CODE */
brb semcol /* same as semicolon in this implementation */
9: .word 9b-fdc9
9: .set fdc9,9b
.long 020070741440 /* ICON in-line constant */
bsbb icode /* create dictionary entry */
bsbw lit /* compile as literal */
brb semcol
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020024207440 /* CODE */
code: moval asmdic,context(%u)
code0: bsbw create
subl2 $6,%h /* backup to code region of defintion */
bisl2 $NUL,*head(%u) /* make entry unfindable */
rsb
9: .word 9b-fdc9
9: .set fdc9,9b
.long 02420741450 /* ICODE in-line CODE definition */
icode: clrb (%h)+ /* reserve length */
bsbb code
bisl2 $INL,*head(%u) /* set mode=IN-LINE */
rsb
9: .word 9b-fdca
9: .set fdca,9b
.long IM+020202020310 /* : (colon) */
colon: movl current(%u),context(%u)
incl state(%u) /* set state=COMPILE */
jbr code0
9: .word 9b-fdcb
9: .set fdcb,9b
.long IM+02420741750 /* ;CODE */
moval asmdic,context(%u)
clrl state(%u)
moval semcod,-(%s)
jbr _jbsb /* compile call to semcod */
does: movl (%r)+,r0
movl (%r)+,-(%s)
jmp (r0)
9: .word 9b-fdc4
9: .set fdc4,9b
.long IM+037114247450 /* DOES> */
moval semcod,-(%s)
bsbw _jbsb
moval does,-(%s)
bsbw _jbsb
rsb
semcod: movl head(%u),r0
movl (%r)+,6(r0)
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 012114707400 /* CONSTANT */
constn: bsbw create
movl (%s)+,(%h)+
bsbb semcod
const: movl *(%r)+,-(%s)
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020200707430 /* CON (abbrev. for CONSTANT) */
jbr constn
9: .word 9b-fdc6
9: .set fdc6,9b
.long 0445100500 /* VARIABLE */
bsbw create
clrl (%h)+
rsb
9: .word 9b-fdc6
9: .set fdc6,9b
.long 020201100530 /* VAR */
bsbw create
movl (%s)+,(%h)+
rsb
variable:
movl (%r)+,-(%s)
rsb
X/* Deposit item in Dictionary, advancing dictionary pointer */
.byte 8f-0f
9: .word 9b-fdcc
9: .set fdcc,9b
.long INL+020202020210 /* , (comma) */
0: movl (%s)+,(%h)+
8: rsb
.byte 8f-0f
9: .word 9b-fdc3
9: .set fdc3,9b
.long INL+020202026020 /* C, (comma) */
0: cvtlb (%s)+,(%h)+
8: rsb
.byte 8f-0f
9: .word 9b-fdc9
9: .set fdc9,9b
.long INL+02024646410 /* IMMEDIATE */
0: bisl2 $IM,*head(%u) /* set precedence=IMMEDIATE */
8: rsb
9: .word 9b-fdc4
9: .set fdc4,9b
.long 07044302430 /* DEFINITIONS */
movl context(%u),current(%u) /* current=context */
rsb
X/* Create a dictionary entry */
enter: movl (%s)+,r1 /* get thread number */
moval *current(%u)[r1],r1 /* get addr of this thread */
subl3 (r1),%h,r2 /* will short link reach? */
bitl $0xffff0000,r2
beql 1f /* yes */
movl (r1),(%h)+ /* no, compile long link */
clrl r2 /* and make null short link */
1: movw r2,(%h)+ /* compile short link */
movl %h,head(%u) /* we're at head, remember it */
movl %h,(r1) /* and make vocab. remember it too */
movl (%s)+,(%h)+ /* enter packed definition name */
movw $0x9f16,(%h)+ /* preformat JSB *$variable */
moval variable,(%h)+
rsb
X/* construct a dictionary entry */
9: .word 9b-fdc3
9: .set fdc3,9b
.long 012004251060 /* CREATE (make new entry in dictionary) */
create: movl $BLANK,-(%s)
bsbw word
bsbw packit
bsbw enter
rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long IM+INL+020202020110 /* [ (to execute mode) */
0: clrl state(%u)
8: rsb
.byte 8f-0f
9: .word 9b-fdcd
9: .set fdcd,9b
.long INL+020202020110 /* ] (to compile mode) */
0: incl state(%u)
8: rsb
9: .word 9b-fdc8
9: .set fdc8,9b
.long IM+020202020210 /* ( comment operator */
paren: movl $0x29,-(%s)
bsbw word
tstl (%s)+
rsb
X/* Compiler Words Not in Standard ---------------- */
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020202035320 /* <: (from CODE to COMPILE mode) */
movl current(%u),context(%u)
incl state(%u)
rsb
9: .word 9b-fdca
9: .set fdca,9b
.long IM+020202037320 /* :> (from COMPILE to CODE mode) */
moval asmdic,context(%u)
clrl state(%u)
rsb
X/* ======================================================================= */
X/* Dictionary search */
search: movl (%s)+,r1 /* thread number */
movl (%s),r0 /* get packed name */
movl context(%u),r2 /* start at context */
0: movl r2,r5 /* save it for reference */
1: movl (r2)[r1],r3 /* get pointer to this thread */
beql 6f /* quit if it points nowhere */
X/* Main Loop */
2: bicl3 $3,(r3),r6 /* get rid of in-line and immediate flag bits */
cmpl r6,r0 /* compare dictionary header */
bneq 3f /* no go */
addl3 $10,r3,(%s) /* Success! return parameter addr */
rsb
3: movzwl -(r3),r4 /* get link */
beql 4f /* if null then look for long link */
subl2 r4,r3 /* short link is a displacement */
jneq 2b /* try next entry */
jbr 6f /* link to location 0 marks end of chain */
4: movl -(r3),r3 /* long link is absolute */
5: bneq 2b /* null long link ends chain */
6: movl -(r2),r2 /* Is this vocab linked to another? */
bneq 1b /* if so then try it */
cmpl r5,current(%u) /* have we tried current yet? */
beql fail /* if so then we'll never find it */
movl current(%u),r2 /* try current */
brb 0b
fail: clrl (%s) /* return null for failure */
rsb
X/*
* Packing Format
* 5 5 5 5 5 5 4 4 4 4 4 4 3 3 3 3 3 3 2 2 2 2 2 2 1 1 L L L H N I
* 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
* H = makes entry unavailable
* N = compile code in-line (rather than JSB to it)
* I = execute immediately (compiler directive)
*/
X/* Pack Bits In Dictionary Header */
9: .word 9b-fdc0
9: .set fdc0,9b
.long 04454140560 /* PACKIT */
packit: movl (%s),r0 /* get address */
movzbl (r0)+,r1 /* get byte length of string */
extzv $0,$4,(r0),r5 /* extract thread */
movl r1,r4 /* save length */
movl $2,r2 /* initialize bit offset pointer */
1: decl r1
bgeq 2f
movl $BLANK,r3 /* if off length of string - substitute blank */
brb 3f
2: movzbl (r0)+,r3 /* get character */
cmpl r3,$96 /* is it a small letter? */
blss 3f
subl2 $32,r3 /* convert to uppercase */
3: insv r3,r2,$6,(%s) /* emplace 6 bit characters */
acbl $26,$6,r2,1b /* loop */
insv r4,$3,$3,(%s) /* emplace length */
bicl2 $7,(%s) /* make sure flag bits are clear */
movl r5,-(%s) /* return thread number */
rsb
prompter:
.ascii "OK\n"
X/* Add code here for end-of-line "Signal" Stack */
prompt: moval prompter,-(%s)
movl $3,-(%s)
bsbw type0
jbr quit
X/* detect and handle end-of-line condition
* called from "find" str --- str (if len(str) != 0)
* str --- (if len(str) == 0)
* str points to a string with length in the first byte
*
* if (length != 0) { continue whatever you where doing }
* if (find not called from goloop) abort with message. }
* if from keyboard { type OK and QUIT }
* else { execute ;S routine }
*/
endline:
tstb *0(%s) /* zero length string? */
beql 1f
rsb /* no, continue. */
1: cmpl (%s)+,(%r)+ /* yes, pop stacks. */
cmpl (%r),$gloop2 /* `find' called from go loop? */
beql 2f
movl $E.EOL,r0
jbr abort /* Abort with "Ran off End of Line" */
2: tstl blk(%u) /* interpreting a block? */
beql prompt /* No. */
moval goloop,(%r) /* back it up */
jbr semies /* Yes, do ;S */
9: .word 9b-fdc6
9: .set fdc6,9b
.long 020020704440 /* FIND */
find: movl $BLANK,-(%s)
bsbw word
bsbb endline
bsbw packit
bsbw search
rsb
9: .word 9b-fdc7
9: .set fdc7,9b
.long IM+020202020210 /* ' (tick) */
tick: bsbb find
tstl (%s)
beql ques
jlbs state(%u),lit
rsb
ques: movl $E.QUER,r0
jbr abort
9: .word 9b-fdcb
9: .set fdcb,9b
.long IM+010064741510 /* [COMPILE] (make next token in */
bsbb find /* input stream be compiled, even */
tstl (%s) /* if Immediate) */
beql ques
brw compil
comp: movl (%r),r0
movl (r0)+,-(%s)
movl r0,(%r)
brw compil
9: .word 9b-fdc3
9: .set fdc3,9b
.long IM+04500647470 /* COMPILE (make next token be */
moval comp,-(%s) /* compiled when the definition now */
bsbw _jbsb /* under construction is executed) */
bsbb find
tstl (%s)
beql ques
movl (%s)+,(%h)+
rsb
X/* ===================================================================== */
9: .word 9b-fdc2
9: .set fdc2,9b
.long 020200254430 /* BYE exit back to system */
bye:
#ifdef FPROMPT
bsbw treset
#endif
bsbw flush
clrl -(%s)
brw s_exit
X/* ===================================================================== */
X/* Unix Terminal Interface */
.set is.arg,-18
.set is.mode,-14
.set s.arg,-12
.set s.mode,-8
.set rchan,-6
.set mung,-5
unxout: movl (r0),-(%s) /* get file descriptor */
bsbw s_write
tstl (%s)+
#ifdef COPROCESS
jbr c_wait
#else
rsb
#endif
unxin: blbc mung(r0),1f /* does terminal need reset? */
pushl r0 /* put control block in safer place */
bsbw ekey /* yes, reset it */
movl (%r)+,r0 /* recall control block */
1: tstl (%s) /* check count */
bgtr 2f /* count <= 0? */
addl2 $8,%s /* yes, quit */
rsb
2: movl 4(%s),r4
clrb (r4) /* in case it returns prematurely */
movzbl rchan(r0),-(%s) /* get file descriptor */
bsbw s_read
movl (%s)+,r0 /* get number of bytes read, EOF? */
jeql bye /* yes, then quit */
blss 3f /* handle errors */
clrb -(r4)[r0] /* place null at end of buffer. */
#ifdef COPROCESS
jbr c_wait
#else
rsb
#endif
X/*
* Terminal error handling here badly needs to be cleaned up. In particular,
* if it is reading from file descriptor 0 and gets an error it could try to
* reopen descriptor 0 as /dev/tty. It is now possible to hang FORTH by closing
* file descriptor 0.
*/
3: clrl r0
jbr abort
9: .word 9b-fdc4
9: .set fdc4,9b
#ifdef FPROMPT
.long 02514251160 /* TRESET reset terminal modes */
treset: movl reader(%u),r2
bicw2 $FPROMPT,s.mode(r2)
incb mung(r2)
jbr setty
#else
.long IM+02514251160 /* TRESET is dummy without FPROMPT */
rsb
#endif
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020144245740 /* <KEY (put terminal in Raw MOde) */
skey: movl reader(%u),r0
incb mung(r0)
bisw2 $RAW,s.mode(r0) /* set RAW mode into terminal status */
bicw2 $(ECHO|CRMOD),s.mode(r0) /* turn off ECHOing */
jbr setty
9: .word 9b-fdcb
9: .set fdcb,9b
.long 020371442440
ekey: movl reader(%u),r2
clrb mung(r2)
movc3 $6,is.arg(r2),s.arg(r2) /* reset arguments */
setty: movl reader(%u),r2
moval s.arg(r2),-(%s)
movl $TIOCSETP,-(%s)
movzbl rchan(r2),-(%s)
bsbw s_ioctl
tstl (%s)+
rsb
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020144245740 /* 0KEY (read 1 char onto stack) */
key0: movl reader(%u),r2
clrq -(%s) /* reserve a word */
moval 4(%s),(%s) /* point to this word */
movl $1,-(%s) /* read 1 word */
movzbl rchan(r2),-(%s) /* get file descriptor */
bsbw s_read
tstl (%s)+
jlss unxerr
rsb
X/* ========================================================================
*
* UNIX disk handler interface
*
* format of buffer descriptor
*
* offset from function
* buffer start
*
* 02000 reserved for null character at end of block.
* 02001 update flag
* 02002 lock flag
* 02004 ownership mark
* 02010 block number of this block (-1 if empty)
* 02014 link
* 02020 link back (to previous buffer in chain)
* 02024 raw link (this link is not touched once created)
*/
.set updat,-11
.set lock,-10
.set own,-8
.set locat,-4
.set link1,02014
.set link2,4
.set link0,8
.set L.blktab,10 /* Size of Disk block table */
.set CHANBOT,0xffffff00 /* Dscrpt 0 maps into this Block numb */
X/* define disk buffer descriptor control block */
.set bufs,12
.set n.blktab,bufs+4
.set b.blktab,n.blktab+4
.set e.blktab,b.blktab+(4*L.blktab)
.set f.blktab,e.blktab+(4*L.blktab)
.set Blktab,f.blktab+L.blktab
9: .word 9b-fdc3
9: .set fdc3,9b
.long 01070044070 /* CHANBOT */
movl $CHANBOT,-(%s)
rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long 020114312440 /* BUFS */
addl3 darea(%u),$bufs,-(%s)
rsb
9: .word 9b-fdce
9: .set fdce,9b
.long 05460127000 /* N.BLKTAB */
addl3 darea(%u),$n.blktab,-(%s)
rsb
9: .word 9b-fdcc
9: .set fdcc,9b
.long 05460127000 /* L.BLKTAB */
movl $L.blktab,-(%s)
rsb
9: .word 9b-fdc6
9: .set fdc6,9b
.long 05460127000 /* F.BLKTAB */
addl3 darea(%u),$f.blktab,-(%s)
rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long 05460127000 /* B.BLKTAB */
addl3 darea(%u),$b.blktab,-(%s)
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 05460127000 /* E.BLKTAB */
addl3 darea(%u),$e.blktab,-(%s)
rsb
X/* UNIX disk interface */
X/* buff count block rwtflag endaction DRWT */
drwt: tstl (%s)+ /* ignore unused end-action Flag */
movl (%s)+,r3 /* get read/write flag */
movl (%s)+,r1 /* get block number */
mcoml r1,r0 /* null block? */
bneq 1f /* no */
addl2 $8,%s /* yes, then do nothing */
rsb
1: subl3 $CHANBOT,r1,r2 /* is block number a channel number? */
bgequ unxfil /* yes */
X/* regular block style format file */
movl darea(%u),r4 /* get pointer to disk area */
movl n.blktab(r4),r2 /* get number of intems in mapping table */
moval b.blktab(r4)[r2],r0 /* get address of table */
1: decl r2
blss 2f /* loop and exit */
cmpl r1,-(r0) /* after beginning of item? */
blssu 1b /* no */
cmpl r1,e.blktab(r4)[r2] /* before end of item? */
bgtru 1b /* no, try next entry */
brb 3f /* Yes, got it!!! */
2: movl $E.BADBL,r0 /* undefined block number */
jbr abort
3: cvtbl f.blktab(r4)[r2],r2 /* get channel number */
subl2 (r0),r1 /* get file offset */
ashl $10,r1,r1 /* convert block offset to byte offset */
brb rw
unxfil: movl floc(%u),r1 /* get file offset */
/* at this point the file offset is in r1 */
rw: movl r2,-(%s) /* push file descriptor for read/write call */
movl r1,-(%s) /* file location for seek */
clrl -(%s) /* offset from file beginning */
movl r2,-(%s) /* file descriptor for seek */
bsbw s_seek
movl (%s)+,r0
jlss unxerr
blbs r3,2f /* test read/write flag */
movl 4(%s),r4 /* save buffer address */
movl 8(%s),r2 /* save count */
bsbw s_read /* assumed that s_read doesn't touch r2,r4 */
movl (%s)+,r0
jlss unxerr
cmpl r0,r4 /* full extent read in? */
bgeq 1f
clrb (r2)[r0] /* no, place null byte at end of record */
rsb
1: movb $NL,(r2)[r0] /* Yes, place new-line at end */
rsb
2: bsbw s_write
tstl (%s)+
jlss unxerr
rsb
X/* ----------------------------------------------------------------- */
X/* Block Buffer Processing (Locking and Unlocking Version) */
X/* See if block is in core */
core: movl darea(%u),r2
movl (r2),r0 /* most recently referenced buffer */
movl bufs(r2),r1 /* get buffer count */
1: cmpl locat(r0),(%s) /* is this the one? */
beql 2f /* yes */
movl (r0),r0 /* no check all other buffers */
sobgtr r1,1b /* check all buffers */
#ifdef COPROCESS
brb 3f /* can't find it */
#else
rsb
#endif
2: remque (r0),r1 /* unlink buffer */
insque (r0),(r2) /* and move it to beginning of search queue */
subl3 $link1,r0,(%s) /* save buffer */
tstl (%r)+ /* and skip extraneous games */
#ifdef COPROCESS
X/*
* Strategy here is to decrement the lock count on all other buffers whenever
* the referenced block changes
*/
cmpb lock(r0),lckcnt(%u) /* lock count already highest? */
bgequ 5f /* yes */
movb lcknt(%u),lock(r0) /* claim it */
movl %u,own(r0)
movl bufs(r2),r1 /* get number of bufs */
brb 4f
3: cmpl %u,own(r0) /* ours? */
bneq 4f /* no */
tstb lock(r0) /* already zero? */
beql 4f /* no */
decb lock(r0) /* decrement lock count */
bneq 4f
clrl own(r0)
4: movl (r0),r0
sobgtr r1,3b
#endif
5: rsb
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020054147440 /* LOCK lock buffer in place */
movl *darea(%u),r0 /* get block addr */
movl %u,own(r0) /* claim it */
clrb lock(r0) /* disable auto-unlocking */
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 01474607160 /* UNLOCK */
unlock: addl3 $link1,(%s),r0 /* get buffer addr */
#ifdef COPROCESS
cmpl %u,own(r0) /* one of our's */
beql 1f
tstl own(r0)
bneq 2f
#endif
1: movl locat(r0),r1 /* get blk num */
mnegl $1,locat(r0) /* mark buffer free */
movl darea(%u),r2
remque (r0),r3
insque (r0),*4(r2) /* move to end of buffer queue */
clrl own(r0) /* unlock */
clrb lock(r0)
blbs updat(r0),wwrite /* update? */
2: tstl (%s)+ /* no */
rsb
wwrite: clrb updat(r0) /* clr updat flag (& busy) */
cvtwl $BUFLEN,-(%s) /* bytes to read */
movl r1,-(%s) /* block number */
movl $1,-(%s) /* flag write (synchronous) */
clrl -(%s) /* asynchronous flag (not used in UNIX) */
jbr drwt /* do it. */
X/* Prepare to Read */
rread: movl (%s),r0 /* get buffer */
movl r0,-(%s) /* copy of buffer for read */
cvtwl $BUFLEN,-(%s) /* bytes to read */
movl (locat+link1)(r0),-(%s) /* copy of block number for read */
clrl -(%s) /* flag a read */
clrl -(%s) /* asynchronous flag for non-UNIX systems */
jbr drwt /* do it */
X/* Get a New Buffer */
9: .word 9b-fdc2
9: .set fdc2,9b
.long 02430312460 /* BUFFER get (but don't read in) buffer */
buffer: movl darea(%u),r2 /* get disk area pointer */
movl bufs(r2),r1 /* get buffer count */
1: movl 4(r2),r0 /* get buffer from end of queue */
tstl own(r0) /* is it free? */
beql 2f /* yes, got it */
sobgtr r1,1b /* try again */
movl $E.LOCK,r0 /* error, no free buffers */
jbr abort
2:
#ifdef COPROCESS
movl %u,own(r0) /* claim it */
movb lcknt(%u),lock(r0)
#endif
remque (r0),r0
insque (r0),(r2) /* place at head of queue */
movl locat(r0),r1
movl (%s),locat(r0)
subl3 $link1,r0,(%s) /* return buffer addr */
blbs updat(r0),4f /* update? */
rsb
4: subl3 $link1,r0,-(%s)
jbr wwrite
9: .word 9b-fdc5
9: .set fdc5,9b
.long 012004210160 /* UPDATE mark a block for output */
update: movl *darea(%u),r0
bisb2 $1,updat(r0)
rsb
X/* General Block handler */
9: .word 9b-fdc2
9: .set fdc2,9b
.long 05414746050 /* BLOCK */
block: bsbw core
bsbb buffer
bsbw rread
rsb
X/* ------------------------------------------------------------------------ */
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020020047440 /* LOAD divert input to block from terminal */
load: pushl floc(%u) /* save file location pointer */
pushl blk(%u) /* save which block to interpret */
pushl in(%u) /* save byte pointer */
clrl floc(%u) /* save offset in file */
movl (%s)+,blk(%u) /* get new block to interpret */
clrl in(%u) /* reset block pointer for new block */
jbr goloop /* interpret it */
9: .word 9b-fdcb
9: .set fdcb,9b
.long 020202011720 /* ;S */
semies: tstl (%r)+ /* do not return to caller */
movl (%r)+,in(%u) /* restore in */
movl blk(%u),r0 /* save old blk for reference */
movl (%r)+,blk(%u) /* restore blk */
movl (%r)+,floc(%u) /* restore file offset */
subl2 $CHANBOT,r0 /* is old blk a non-Block type file? */
blssu 1f /* no */
movl r0,-(%s)
bsbw s_close
1: rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long IM+020203726630 /* --> (continue on next screen) */
cmpl blk(%u),$CHANBOT
blssu 1f
bisl2 $(BUFLEN-1),floc(%u) /* "File Descriptor" file */
incl floc(%u) /* move floc to even screen boundary */
movl *darea(%u),r0 /* mark buffer stale */
mnegl $1,locat(r0)
brb 2f
1: incl blk(%u) /* regular screen number */
2: clrl in(%u)
rsb
9: .word 9b-fdc1
9: .set fdc1,9b
.long 020054146240 /* !LCK (store buffer lock count) */
movl (%s)+,lcknt(%u)
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 014521006450 /* EMPTY-BUFFERS (or EMPTY) */
movl darea(%u),r0
brb 2f
1: mnegl $1,locat(r0) /* mark buffer as nothing */
clrl own(r0) /* clear lock and ownership */
clrb lock(r0)
2: movl link0(r0),r0 /* get hard link */
bneq 1b /* process it if anything there */
rsb
9: .word 9b-fdc6
9: .set fdc6,9b
.long 04115246050 /* FLUSH (write out buffers) */
brb flush
9: .word 9b-fdc3
9: .set fdc3,9b
.long 026425300540 /* SAVE-BUFFERS */
X/* NOTE: this routine also gathers stray blocks */
flush: movl darea(%u),r6
brb 2f
1: subl3 $link1,r6,-(%s)
bsbw unlock
2: movl link0(r6),r6 /* use raw link */
bneq 1b
rsb
X/* ======================================================================= */
X/* Basic Utility Words */
X/* Stack Manipulation ------------------------------------------------- */
.byte 8f-0f
9: .word 9b-fdc4
9: .set fdc4,9b
.long INL+020201012430 /* DUP */
0: movl (%s),-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc4
9: .set fdc4,9b
.long INL+020100751040 /* DROP */
0: tstl (%s)+ /* pop one item from stack */
8: rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020100053540 /* SWAP */
swap: movl (%s)+,r0
movl (%s),-(%s)
movl r0,4(%s)
rsb
.byte 8f-0f
9: .word 9b-fdcf
9: .set fdcf,9b
.long INL+020110253040 /* OVER */
0: movl 4(%s),-(%s)
8: rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long 020201207530 /* ROT */
rot: movl 8(%s),-4(%s)
movc3 $12,-4(%s),(%s)
rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020120751240 /* -ROT (not in Standard) */
mrot: movc3 $12,(%s),-4(%s)
movl -4(%s),8(%s)
rsb
.byte 8f-0f
9: .word 9b-fdc0
9: .set fdc0,9b
.long INL+020054144540 /* PICK */
0: movl (%s),r0
movl (%s)[r0],(%s)
8: rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long 020060607540 /* ROLL */
roll: movl (%s),r1
movl (%s)[r1],(%s)+
ashl $2,r1,r1
movc3 r1,-4(%s),(%s)
rsb
.byte 8f-0f
9: .word 9b-fdcf
9: .set fdcf,9b
.long 020101242340 /* ?DUP */
0: tstl (%s)
beql 8f
movl (%s),-(%s)
8: rsb
rto: movl (%r)+,r0
pushl (%s)+
jmp (r0)
7: movl (%s)+,-(%r)
8:
9: .word 9b-fdce
9: .set fdce,9b
.long IM+020202011320 /* >R */
tstl state(%u)
beql rto
movc3 $(8b-7b),7b,(%h)
movl r3,%h
rsb
rfrom: movl (%r)+,r0
movl (%r)+,-(%s)
jmp (r0)
7: movl (%r)+,-(%s)
8:
9: .word 9b-fdc2
9: .set fdc2,9b
.long IM+020202037120 /* R> */
tstl state(%u)
beql rfrom
movc3 $(8b-7b),7b,(%h)
movl r3,%h
rsb
r_at: movl 4(%r),-(%s)
rsb
7: movl (%r),-(%s)
8:
9: .word 9b-fdc2
9: .set fdc2,9b
.long IM+020202000120 /* R@ */
tstl state(%u)
beql r_at
movc3 $(8b-7b),7b,(%h)
movl r3,%h
rsb
9: .word 9b-fdc4
9: .set fdc4,9b
.long 04121002450 /* DEPTH */
subl3 %s,sbot(%u),r0
ashl $-2,r0,-(%s)
rsb
X/* Stack Manipulation operators not in standard */
.byte 8f-0f
9: .word 9b-fdcd
9: .set fdcd,9b
.long INL+010075102250 /* -DROP (drop item 1 deep) */
0: movl (%s)+,(%s)
8: rsb
X/* Comparison ================================================== */
X/* Standard comparison Operators */
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020202020310 /* < */
less: cmpl (%s)+,(%s)+
jgtr true
jbr false
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020202020310 /* = */
equals: cmpl (%s)+,(%s)+
jeql true
jbr false
9: .word 9b-fdce
9: .set fdce,9b
.long 020202020310 /* > */
greater:
cmpl (%s)+,(%s)+
jlss true
jbr false
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020202036320 /* 0< */
zless: tstl (%s)+
jlss true
jbr false
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020202036720 /* 0= */
_zeq: tstl (%s)+
jeql true
jbr false
9: .word 9b-fdce
9: .set fdce,9b
.long 020201207430 /* NOT */
brb _zeq
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020202037320 /* 0> */
tstl (%s)+
jgtr true
jbr false
9: .word 9b-fdc5
9: .set fdc5,9b
.long 020202036120 /* U< */
cmpl (%s)+,(%s)+
jgtru true
jbr false
9: .word 9b-fdc4
9: .set fdc4,9b
.long 020202036020 /* D< */
d.less: movl %s,r1
addl2 $8,%s
movl %s,r0
addl2 $8,%s
cmpl (r0)+,(r1)+ /* compare high words */
beql 1f /* if equal inspect low words */
blss true
jbr false
9: .word 9b-fdc4
9: .set fdc4,9b
.long 020203612430 /* DU< (unsigned double compare) */
movl %s,r1
addl2 $8,%s
movl %s,r0
addl2 $8,%s
cmpl (r0)+,(r1)+
bneq 2f
1: cmpl (r0),(r1)
2: blssu true
jbr false
9: .word 9b-fdc4
9: .set fdc4,9b
.long 020203670030 /* D0= */
dzeq: bisl2 (%s)+,(%s)+
beql true
jbr false
true: movl $1,-(%s)
rsb
false: clrl -(%s)
rsb
X/* Comparison Operators not in Standard */
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020203736330 /* 0<> */
tstl (%s)+
jneq true
jbr false
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020203676330 /* 0<= */
tstl (%s)+
jleq true
jbr false
9: .word 9b-fdc0
9: .set fdc0,9b
.long 020203677330 /* 0>= */
tstl (%s)+
jgeq true
jbr false
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020202037320 /* <> */
cmpl (%s)+,(%s)+
bneq true
jbr false
9: .word 9b-fdcc
9: .set fdcc,9b
.long 020202036720 /* <= */
cmpl (%s)+,(%s)+
bgeq true
jbr false
9: .word 9b-fdce
9: .set fdce,9b
.long 020202036720 /* >= */
cmpl (%s)+,(%s)+
bleq true
jbr false
9: .word 9b-fdc5
9: .set fdc5,9b
.long 020202037120 /* U> */
cmpl (%s)+,(%s)+
jlssu true
jbr false
X/* Arithmetic And Logical ---------------------------------------- */
X/* Operators in Standard */
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202025720 /* 1+ */
0: incl (%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202026720 /* 1- */
0: decl (%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdca
9: .set fdca,9b
.long INL+020202020210 /* * */
0: mull2 (%s)+,(%s)
8: rsb
9: .word 9b-fdcf
9: .set fdcf,9b
.long 020020746640 /* /MOD */
divmod: movl (%s)+,r2
clrl r1
movl (%s),r0
bgeq 1f
decl r1
1: ediv r2,r0,-(%s),4(%s)
rsb
9: .word 9b-fdca
9: .set fdca,9b
.long 02074667650 # */MOD
tmdvmod:
emul 4(%s),8(%s),$0,r0
ediv (%s)+,r0,(%s),4(%s)
rsb
.byte 8f-0f
9: .word 9b-fdcf
9: .set fdcf,9b
.long INL+020202020210 /* / (divide) */
0: divl2 (%s)+,(%s)
8: rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020200207430 /* MOD */
bsbb divmod
tstl (%s)+
rsb
9: .word 9b-fdca
9: .set fdca,9b
.long 020202027620 # */ (multiply, then divide)
bsbb tmdvmod
movl (%s)+,(%s)
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 020202025120 /* U* */
movl (%s)+,r2
emul r2,(%s),$0,r0
tstl (%s)
bgeq 1f
addl2 r2,r1
1: tstl r2
bgeq 2f
addl2 (%s),r1
2: movl r0,(%s)
movl r1,-(%s)
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 02074667550 /* U/MOD */
X/* This is devilishly hard to do properly. Because the basic precision of vax */
X/* integers is more than the `standard' unsigned 16 bit integer, I am not */
X/* bothering to do unsigned arithemetic. */
movl (%s)+,r2
movl (%s)+,r1
movl (%s),r0
ediv r2,r0,-(%s),4(%s)
rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020201400430 /* MAX */
max: cmpl (%s)+,(%s)
bleq 1f
movl -4(%s),(%s)
1: rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020200704430 /* MIN */
min: cmpl (%s)+,(%s)
bgeq 1f
movl -4(%s),(%s)
1: rsb
9: .word 9b-fdc1
9: .set fdc1,9b
.long 020201141030
abs: tstl (%s) /* ABS */
bgeq 1f
mnegl (%s),(%s)
1: rsb
.byte 8f-0f
9: .word 9b-fdce
9: .set fdce,9b
.long INL+012004342460 /* NEGATE */
0: mnegl (%s),(%s)
8: rsb
9: .word 9b-fdc4
9: .set fdc4,9b
.long 0434247070 /* DNEGATE */
dnegate:
mnegl (%s),(%s)+
mnegl (%s),(%s)
sbwc $0,-(%s)
rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020200207030 /* AND */
0: mcoml (%s)+,r0
bicl2 r0,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdcf
9: .set fdcf,9b
.long INL+020202011020 /* OR */
0: bisl2 (%s)+,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc8
9: .set fdc8,9b
.long INL+020201107530 /* XOR */
0: xorl2 (%s)+,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202020210 /* + */
0: addl2 (%s)+,(%s)
8: rsb
9: .word 9b-fdc4
9: .set fdc4,9b
.long 020202025420 /* D+ */
d.plus: movq (%s)+,r0
addl2 r1,4(%s)
adwc r0,(%s)
rsb
.byte 8f-0f
9: .word 9b-fdcd
9: .set fdcd,9b
.long INL+020202020210 /* - */
0: subl2 (%s)+,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202025720 /* 2+ */
0: addl2 $2,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202026720 /* 2- */
0: subl2 $2,(%s)
8: rsb
X/* Operators not in Standard ------------------------ */
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202025320 /* 2* */
0: addl2 (%s),(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202027720 /* 2/ */
0: divl2 $2,(%s)
8: rsb
X/* Machine independent (hopefully) address arithmetic */
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020025214440 /* BYTE == 4* */
0: ashl $2,(%s),(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc7
9: .set fdc7,9b
.long INL+020200211130 /* WRD == 4/ */
0: ashl $-2,(%s),(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202025620 /* ++ (increment addr 1 word) */
0: addl2 $4,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdcd
9: .set fdcd,9b
.long INL+020202026620 /* -- (decrement addr 1 word) */
0: subl2 $4,(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202025420 /* A+ (add const to addr) */
0: movl (%s)+,r0
moval *(%s)+[r0],-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202000620 /* +A (add addr to const) */
0: movl 4(%s),r0
moval *(%s)+[r0],(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202026420 /* A- (subtract constant form addr) */
0: mnegl (%s)+,r0
moval *(%s)+[r0],-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202065730 /* 1+! */
0: incl *(%s)+
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202066730 /* 1-! */
0: decl *(%s)+
8: rsb
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202065730 /* 2+! */
0: addl2 $2,*(%s)+
8: rsb
.byte 8f-0f
9: .word 9b-fdc2
9: .set fdc2,9b
.long INL+020202066730 /* 2-! */
0: subl2 $2,*(%s)+
8: rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202065630 /* ++! (increment addr to next word) */
0: addl2 $4,*(%s)+
8: rsb
.byte 8f-0f
9: .word 9b-fdcd
9: .set fdcd,9b
.long INL+020202066630 /* --! (decrement addr to prev word) */
0: subl2 $4,*(%s)+
8: rsb
X/* Memory Operators ---------------------------------------------- */
.byte 8f-0f
9: .word 9b-fdc0
9: .set fdc0,9b
.long INL+020202020010 /* @ (retrieve value from address) */
0: movl *(%s)+,-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc1
9: .set fdc1,9b
.long INL+020202020210 /* ! (store value at address) */
0: movl (%s)+,r0
movl (%s)+,(r0)
8: rsb
.byte 8f-0f
9: .word 9b-fdc3
9: .set fdc3,9b
.long INL+020202000020 /* C@ (retrieve byte) */
0: movzbl *(%s)+,-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc3
9: .set fdc3,9b
.long INL+020202020420 /* C! (store byte) */
0: movl (%s)+,r0
cvtlb (%s)+,(r0)
8: rsb
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202020620 /* +! (sum into address) */
0: addl3 *(%s)+,(%s)+,*(-8)(%s)
8: rsb
9: .word 9b-fdcd
9: .set fdcd,9b
.long 020025307440 /* MOVE (move a string of words) */
move: ashl $2,(%s)+,r0
movl (%s)+,r1
movc3 r0,*(%s)+,(r1)
rsb
.byte 8f-cmove
9: .word 9b-fdc3
9: .set fdc3,9b
.long INL+02530746450 /* CMOVE (move string of bytes) */
cmove: movl (%s)+,r0
movl (%s)+,r1
movc3 r0,*(%s)+,(r1)
8: rsb
.byte 8f-fill
9: .word 9b-fdc6
9: .set fdc6,9b
.long INL+020060604440 /* FILL (fill with bytes) */
fill: movl (%s)+,r1
movl (%s)+,r0
movc5 $0,(%h),r1,r0,*(%s)+
8: rsb
X/* Control Structures =========================================== */
X/* Basic Conditional Branch */
0: tstl (%s)+
bneq 1f
brw 1f
1:
9: .word 9b-fdc9
9: .set fdc9,9b
.long IM+020202003020 /* IF */
if: movc3 $7,0b,(%h) /* tstl (s)+ ; bneq .+4 ; brw xxx ; */
movl r3,%h
movl %h,-(%s)
rsb
9: .word 9b-fdc7
9: .set fdc7,9b
.long IM+02460444150 /* WHILE */
brb if /* while requires same action as if */
9: .word 9b-fdc4
9: .set fdc4,9b
.long IM+020070244140 /* THEN */
then: movl (%s)+,r0
subl3 r0,%h,r1
movw r1,-(r0)
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long IM+020025146040 /* ELSE */
movb $0x31,(%h)+ /* compile brw opcode */
clrw (%h)+ /* reserve space for offset */
bsbb then
movl %h,-(%s)
rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long IM+0425002560 /* REPEAT */
bsbw swap
bsbw _br
bsbw then
rsb
1: tstl (%s)+
9: .word 9b-fdc5
9: .set fdc5,9b
.long IM+06045207150 /* UNTIL */
movw 1b,(%h)+ /* compile tstl (%s)+ */
movl $0x12,-(%s) /* compile assembler 0<> opcode */
brw auntil /* go to assembler `UNTIL' */
.byte 8f-here
9: .word 9b-fdc8
9: .set fdc8,9b
.long INL+020025102440 /* HERE push h on stack */
here: movl %h,-(%s)
8: rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long IM+07044342450 /* BEGIN */
brb here
do: movl (%r)+,r1 /* get linkage out of way */
movl (%s)+,r0 /* get initial value of counter */
cmpl r0,(%s) /* less than limit (counting upward)? */
bgeq 1f /* no */
decl (%s) /* yes, adjust limit downwards */
1: pushl (%s)+ /* push limit */
pushl r0 /* push counter */
jmp (r1) /* return */
9: .word 9b-fdc4
9: .set fdc4,9b
.long IM+020202007420 /* DO */
moval do,-(%s)
bsbw _jbsb /* compile `do' */
movl %h,-(%s)
rsb
1: addl2 $8,%r /* pop loop arguments */
popal: movc3 $3,1b,(%h)
movl r3,%h
rsb
9: .word 9b-fdcc
9: .set fdcc,9b
.long IM+020100747440 /* LOOP */
subl3 (%s),%h,r0
addl2 $5,r0
cvtbl r0,r1
movzbl $(0x60+r),-(%s) /* r ) */
movl $4,-(%s)
movzbl $(0xa0+r),-(%s) /* 4 r )) */
cmpl r0,r1
bneq 1f
bsbw _aobleq /* compile aobleq 4(%r),(%r),xxx */
brb popal
1: movl $1,-(%s)
movzbl $0x8f,-(%s)
bsbw d.swap
bsbw _acbl /* compile acbl 4(%r),$1,(%r),xxx */
brb popal
9: .word 9b-fdcb
9: .set fdcb,9b
.long IM+010074746250 /* +LOOP */
movzbl $(0x60+r),-(%s) /* r ) */
movzbl $(0x80+s),-(%s) /* s )+ */
movl $4,-(%s)
movzbl $(0xa0+r),-(%s) /* 4 r )) */
bsbw _acbl /* compile acbl 4(%r),(%s)+,(%r),xxx */
brb popal
X/* In this implementation, the following words MUST be called from compile
* mode */
.byte 8f-0f
9: .word 9b-fdc9
9: .set fdc9,9b
.long INL+020202020010 /* I (get inner loop index) */
0: movl (%r),-(%s)
8:
.byte 8f-0f
9: .word 9b-fdca
9: .set fdca,9b
.long INL+020202020010 /* J (get loop index 1 level out) */
0: movl 8(%r),-(%s)
8:
.byte 8f-0f
9: .word 9b-fdcb
9: .set fdcb,9b
.long INL+020202020010 /* K (get loop index 2 levels out) */
0: movl 16(%r),-(%s) /* not in Standards */
8:
.byte 8f-0f
9: .word 9b-fdcc
9: .set fdcc,9b
.long INL+02530042450 /* LEAVE leave do loop */
0: movl (%r),4(%r)
8:
.byte 1
9: .word 9b-fdc5
9: .set fdc5,9b
.long INL+020120454040 /* EXIT */
rsb
X/* Control structure not in 79 standards --------------- */
1: cmpl (%s)+,(%s)+
beql 2f
tstl -(%s)
brw 2f
2:
9: .word 9b-fdc3
9: .set fdc3,9b
.long IM+020025140440 /* CASE */
movc3 $(2b-1b),1b,(%h)
movl r3,%h
movl %h,-(%s)
rsb
X/* ============================================================== */
X/* Terminal I/O */
.byte 8f-type0
9: .word 9b-fdc0
9: .set fdc0,9b
.long INL+02501452350 /* 0TYPE */
type0: movl typer0(%u),r0
jsb *(r0)+
8: rsb
.byte 8f-type
9: .word 9b-fdc4
9: .set fdc4,9b
.long INL+020025014540 /* TYPE */
type: movl typer(%u),r0
jsb *(r0)+
8: rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 01425014060 /* EXPECT */
expect: movl reader(%u),r0
movl -4(r0),r1
jmp (r1)
9: .word 9b-fdc1
9: .set fdc1,9b
.long 014510252550 /* QUERY (read 80 char) */
query: movl msgbuf(%u),-(%s)
movzbl $TBUFSIZ,-(%s)
brb expect
9: .word 9b-fdcb
9: .set fdcb,9b
.long 020201442430 /* KEY (read 1 char RAW NOECHO) */
bsbw skey
bsbw key0
bsbw ekey
rsb
9: .word 9b-fdc5
9: .set fdc5,9b
.long 020120446440 /* EMIT (type 1 char from stack) */
movb (%s),(%h)
movl %h,(%s)
movl $1,-(%s)
jbr type
X/* =========================================================================
*
* Character string handling.
*
* Character strings are stored in-line if 5 chars or less
* otherwise they reside in a temporary file (usually file descriptor 4)
*
* handle escaped sequences
* chars preceded by a backslash are interpreted as control characters
* \b = backspace
* \e = escape char (octal 033)
* \f = form feed
* \n = new line (line-feed)
* \r = carriage return
* \t = tab
* \? = rubout character (octal 0177)
* \\ = backslash character
* \nnn = nnn is up to 3 digit octal number.
* \X = X is a capital letter. Value of X with most significant
* 3 bits removed, (i.e. \C = "control C")
*
* all other characters following a backslash yield an undefined result.
*
* r0 string in r1 string out
* r2 end of string r3 working char
* r4 number accumulator r5 digit & table counter
*/
.set NESCTB,8
esctb1: .byte '?,0x5c,'b,'e,'f,'n,'r,'t
esctb2: .byte 0177,0x5c,010,033,014,012,015,011
X/*
* addr ---
* addr = address of string (length in 1st byte)
*/
escap: movl (%s)+,r0
movzbl (r0)+,r2
beql escqit
addl2 r0,r2
movl r0,r1
esclup: movzbl (r0)+,r3
cmpb r3,$0x5c /* escaped? */
bneq escelp
movzbl (r0)+,r3
cmpb r3,$'0
blssu escndg
cmpb r3,$'7
bgtru escndg
clrl r4
movl $3,r5
escdig: mulb2 $8,r4 /* Convert up to 3 digit octal sequence */
subb2 $'0,r3
addb2 r3,r4
movzbl (r0)+,r3
cmpb r3,$'0
blssu escedg
cmpb r3,$'7
bgtru escedg
sobgtr r5,escdig
escedg: decl r0
movl r4,r3
brb escelp
escndg: movl $(NESCTB-1),r5
escklp: cmpb r3,esctb1[r5]
beql esckch
sobgeq r5,escklp
bicb2 $0xe0,r3 /* remove top bits */
brb escelp
esckch: movb esctb2[r5],r3
escelp: movb r3,(r1)+
cmpl r0,r2
blssu esclup
subl2 -4(%s),r1 /* compute string length */
decl r1
movb r1,*-4(%s)
escqit: rsb
X/*
* This is the check for a string constant in the goloop
* string constants begin with an (otherwise ignored) backslash
* string to test initially at (%h)
*
* dummy --- flag
* flag = 0 if not string = addr of string if string
*/
strcon: clrl (%s)
tstb (%h) /* special test for null string */
beql 1f
cmpb 1(%h),$0x5c /* begins with backslash? */
bneq 1f
moval 1(%h),r0 /* skip over backslash */
subb3 $1,(%h),(r0) /* decrement and move length byte */
movl r0,(%s)
movl r0,-(%s)
movl r0,-(%s)
bsbw escap
bsbw spush
tstl state(%u)
beql 1f
bsbw sliter
1: rsb
X/* Fetch String */
str: bsbw count
tstb (%s) /* in-line string? */
blss 1f /* no, retrieve from disk? */
movq (%s),-(%s) /* 2dup */
bsbw s.at /* reserve space on string stack */
addl2 (%s)+,(%s) /* return addr of end of string */
rsb
1: bicb2 $0x80,(%s) /* clear flag bit */
movq (%s),-(%s) /* 2dup */
bsbw s.at /* reserve space on string stack */
pushl (%s)+ /* save count for read call */
movl (%s),r2 /* recall in-line address */
addl2 $4,(%s) /* return location after offset */
movl (r2)+,-(%s) /* location in file for seek call */
clrl -(%s)
movl msgfil,-(%s)
bsbw s_seek /* position file to beginning of message */
tstl (%s)+
jlss unxerr
moval 1(%c),-(%s) /* get address for read call */
movl (%r)+,-(%s) /* get saved count */
movl msgfil,-(%s) /* file descriptor */
bsbw s_read
tstl (%s)+
jlss unxerr
rsb
X/* Compile a Character string */
slit: movl %c,-(%s) /* save string stack top */
bsbw sdrop /* remove knowledge of string */
movl (%s)+,r2 /* recall string */
movzbl (r2),r3 /* get length */
cmpb r3,$MAXSTR /* less than max in-line characters? */
bgtru 1f /* no, store on `message' file */
incl r3 /* include len byte itself */
movc3 r3,(r2),(%h) /* copy string to dictionary */
movl r3,%h
rsb
1: bisb3 $0x80,(r2)+,(%h)+ /* len has flag that str is disk resid*/
clrl -(%s)
movl $2,-(%s)
movl msgfil,-(%s)
bsbw s_seek
movl (%s)+,(%h)+
jlss unxerr
movl r2,-(%s) /* set up addr for write call */
movl r3,-(%s) /* set up length of string for write call */
movl msgfil,-(%s)
bsbw s_write /* write out message */
tstl (%s)+
jlss unxerr
rsb
X/* A Reference to this code fragment is compiled into a sliteral */
stri: movl (%r)+,-(%s)
bsbw str
jmp *(%s)+
9: .word 9b-fdc3
9: .set fdc3,9b
.long IM+02520446100 /* SLITERAL */
sliter: moval stri,-(%s)
bsbw _jbsb
bsbw slit
rsb
X/*
* Compile a string-storing word
*
* Format of String Reference:
*
* <len><string> in-line reference (parity bit set in 1st char)
* or <len><offset> disk reference (offset is 4 bytes long)
*
* FORTH call to string defining word
*
* : def ... char CDOES> ...... ;
* when `def string' appears in a definition a reference to
* `string' is compiled such that when that word is executed the
* stuff after CDOES> is executed with `string' on the string
* stack. `def string' can also be executed directly, rather than
* appearing in a definition. The execution of the stuff after
* CDOES> with `string' on the string stack will then take place
* immediately.
*
* Code generated by string reference compiling word CDOES>
* jbsb csav
* brb 1f
* jbsb cget
* 1: words to be executed to process the string ...
*/
cget: movl 4(%r),-(%s) /* get string location */
bsbw str /* retrieve string location */
movl (%s)+,4(%r) /* grandfather def. returns past string end */
rsb
csav: bsbw word
bsbw escap /* check for escaped characters */
movl %h,-(%s)
bsbw spush /* push string on string stack */
blbc state(%u),1f /* if no compile mode, exit code that follows */
addl3 $2,(%r)+,-(%s) /* compile call to past brb instruction */
bsbw _jbsb
bsbw slit /* compile string */
1: rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long IM+011424742060 /* CDOES> (compile string reference word) */
cdoes: moval csav,-(%s)
bsbw _jbsb /* compile call to csav */
movw $0x11,(%h)+ /* compile brb instruction */
pushl %h
moval cget,-(%s) /* compile call to cget */
bsbw _jbsb
movl (%r)+,r0 /* recall saved position */
subb3 r0,%h,-(r0) /* calculate displacement */
rsb
9: .word 9b-fdc2
9: .set fdc2,9b
.long IM+020202020210 /* " (push literal string on string stack) */
dqot: movl $042,-(%s)
bsbw csav
brb 1f
bsbb cget
1: rsb
stovf: movl $E.SOVER,r0
jbr abort
9: .word 9b-fdc3
9: .set fdc3,9b
.long 04115250150 /* SPUSH push string onto string stack */
spush: movl (%s)+,r0
movzbl (r0),r1 /* get length */
subl3 r1,%c,r2 /* get beginning of string */
tstw -(r2)
cmpl r2,fsbot(%u) /* overflowed into flt stack area (or beyond)?*/
blequ stovf
movl r2,%c
incl r1 /* include length byte */
movc3 r1,(r0),(r2) /* move string on to stack */
clrb (r3) /* add final null byte */
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020202000120 /* S@ addr len S@ */
s.at: movl (%s)+,r1
bgeq 1f
tstl (%s)+
rsb
1: cmpl r1,$0xff
bleq 2f
movzbl $0xff,r1
2: subl3 r1,%c,r2 /* get beginning of string */
tstw -(r2)
cmpl r2,fsbot(%u) /* overflowed into flt stack area (or beyond)?*/
blequ stovf
movl r2,%c
movb r1,(r2)+ /* put length byte in place */
movc3 r1,*(%s)+,(r2) /* move string on to stack */
clrb (r3) /* add final null byte */
rsb
X/* Probe downward in string stack. */
9: .word 9b-fdc3
9: .set fdc3,9b
.long 07134742150 /* SDOWN probe downward in string stack */
sdown: movl (%s)+,r0 /* get arg */
movzbl (r0)+,r1 /* get len */
addl2 r1,r0
incl r0 /* skip over null byte */
cmpl r0,ssbot(%u) /* end of string below stack bottom? */
blequ 2f /* no */
movl $E.SBAD,r0
cmpl %c,ssbot(%u) /* string stack at bottom? */
bneq 0f
movl $E.SEMPT,r0 /* yes, stack string stack Empty. */
0: jbr abort
2: movl r0,-(%s)
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 010075102150 /* SDROP drop item from string stack */
sdrop: movl %c,-(%s)
bsbb sdown
movl (%s)+,%c
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020202020520 /* S! pop from c and store in array */
s.stor: pushl %c
bsbb sdrop
movl (%r)+,r0
movzbl (r0)+,r1
movl (%s)+,r2
movc5 r1,(r0),$BLANK,r2,*(%s)+
rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 012071247450 /* COUNT return len and addr */
count: movzbl *(%s)+,r0
incl -(%s)
movl r0,-(%s)
rsb
.byte 8f-0f
9: .word 9b-fdc7
9: .set fdc7,9b
.long INL+020201151630 /* 'SS addr of strin stack top */
0: movl %c,-(%s)
8: rsb
.byte 8f-0f
9: .word 9b-fdc7
9: .set fdc7,9b
.long INL+020205151640 /* 'SS! change string stack top */
0: movl (%s)+,%c
8: rsb
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020101242140 /* SDUP */
sdup: movl %c,-(%s)
jbr spush
9: .word 9b-fdc3
9: .set fdc3,9b
.long 020202027120 /* S. print top item on str stack */
sdot: movl %c,-(%s)
bsbw sdrop
bsbb count
jbr type
9: .word 9b-fdce
9: .set fdce,9b
.long IM+020202021220 /* ." print a message */
movl $042,-(%s)
bsbw csav
brb 1f
bsbw cget
1: bsbb sdot
rsb
//go.sysin dd *
made=TRUE
if [ $made = TRUE ]; then
/bin/chmod 644 ./vaxforth/forth1.S
/bin/echo -n ' '; /bin/ls -ld ./vaxforth/forth1.S
fi
exit
--
Bill Sebok Princeton University, Astrophysics
{allegra,akgua,burl,cbosgd,decvax,ihnp4,kpno,princeton,vax135}!astrovax!wls