[net.sources] Princeton FORTH v2.0 for the VAX, part 5 of 8

wls@astrovax.UUCP (William L. Sebok) (06/26/84)

part 5 of 8
------Cut here and extract with sh not csh --------------
/bin/echo 'Making directory "./vaxforth"'
mkdir ./vaxforth
/bin/echo 'Extracting ./vaxforth/forth.blk.txt'
sed 's/^X//' <<'//go.sysin dd *' >./vaxforth/forth.blk.txt
( Important fixed block Numbers )
;S
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
FORTH DEFINITIONS  DECIMAL
 4 LOAD   5 LOAD   6 LOAD   7 LOAD   8 LOAD   9 LOAD  10 LOAD
11 LOAD  12 LOAD  13 LOAD  14 LOAD  15 LOAD  16 LOAD  17 LOAD
18 LOAD  19 LOAD  20 LOAD  21 LOAD
22 LOAD ( string stack operations )
32 LOAD ( UNIX system call interfaces )
43 LOAD  44 LOAD  45 LOAD  ( Misc )
: 79-STANDARD  ." You Bet." ;
: TASK ;
X." Native Mode VAX/Unix FORTH version 2.0" CR ;S
;S
 
 
 
 
 
( Utilities )
CODE ASSIGN  S )+ ) R )+ 6 # ADDL3  END-CODE
ICODE 0X!  S )+ ) CLRL  END-CODE
ICODE 0!  S )+ ) CLRL  END-CODE
CODE IUPPER  S -) 8 R )) MOVL  S ) 4 R )) CMPL  0<= IF  S ) INCL
 THEN  END-CODE
ICODE SHIFT  0 S )+ MOVL  S ) S ) 0 ASHL  END-CODE
CODE ISGN  S ) TSTL  0> IF S ) 1 # MOVL  RSB THEN  0= IF
 S ) CLRL  RSB THEN  S ) 1 # MNEGL  END-CODE
ICODE RDROP  0 S )+ MOVL   R R ) 0 ] MOVAL  END-CODE
ICODE #DROP  0 S )+ MOVL   S S ) 0 ] MOVAL  END-CODE
ICODE 'S  S -) S MOVL  END-CODE
ICODE 'R  S -) R MOVL  END-CODE
ICODE -!  0 S )+ MOVL  0 ) S )+ SUBL2  END-CODE
;S
 
( Utilities )
ICODE CLEAR  0 S )+ 4 # MULL3  S )+ ) 0 0 # H ) 0 # MOVC5
 END-CODE
CODE SWABYT  1 S )+ MOVL  0 S )+ MOVL   BEGIN  2 0 )+ MOVB
 0 -) 0 ) MOVB  0 INCL  0 )+ 2 MOVB  1 SOBGTR  END-CODE
ICODE  OR! 0 S )+ MOVL  0 ) S )+ BISL2  END-CODE
ICODE  ~&! 0 S )+ MOVL  0 ) S )+ BICL2  END-CODE
CODE @++  0 S )  MOVL  S -) 0 )+ MOVL  4 S )) 0 MOVL  END-CODE
CODE !++  S )+ ) S )+ MOVL  S -) 4 # ADDL2  END-CODE
ICODE B!+  S )+ ) S )+ CVTLB  S -) INCL  END-CODE
ICODE COM  S ) S ) MCOML  END-CODE
CODE !X!  0 S )+ MOVL  1 S ) MOVL  S ) 0 ) MOVL  0 ) 1 ) MOVL
 1 ) S )+ MOVL  END-CODE
: CORE  'S HERE - 80 - ;
: ARRAY HERE 1 AND ALLOT CREATE HERE SWAP BYTE DUP ALLOT
  0 FILL ;                                                   ;S
( Utilities )
ICODE DP+!  H S )+ ADDL2  END-CODE
CODE LN2  0 S ) MOVL  0<> IF  S ) 31 # MOVL  BEGIN  S ) DECL
 0 0 ADDL2  0> NOT UNTIL  RSB THEN  S ) CLRL  END-CODE
: ?CON  >IN @ FIND IF 2DROP ELSE  >IN !  CONSTANT THEN ;
: /CEIL  2DUP XOR 0> -ROT /MOD -ROT 0<> AND IF 1+ THEN ;
: ]2  [COMPILE] 2LITERAL  ] ;
: ]1  [COMPILE]  LITERAL  ] ;
: 'SELF  HEAD @ 10 + [COMPILE] LITERAL ;   IMMEDIATE
: MYSELF HEAD @  4 + ASSEMBLER JBSB ;      IMMEDIATE
: !SIGNAL  SIGNAL ! ;
: JCODE  CREATE  [COMPILE] ASSEMBLER ;
: SP  SPACES ;
HEX  MSG 0CR  1 C, 0D C,  DECIMAL
;S
 
( String constants )
: .[  93 CDOES>  S. ;  IMMEDIATE
: ((  41 CDOES>     ;  IMMEDIATE
: [[  93 CDOES>     ;  IMMEDIATE
: ![  93 CDOES>  S! ;  IMMEDIATE
 
: VECT  CREATE DUP , 0 , BYTE  HERE SWAP DUP ALLOT  32 FILL
 ;CODE  S -) R )+ MOVL  S ) 8 # ADDL2  END-CODE
 
  1 VECT DUM  ' DUM -- @  FORGET DUM  ( get VECT's code addr )
 
: ?VECT DUP 3 A- @ LITERAL <> IF ." Not a Vector!!!" ABORT THEN
 2DUP 2 A- @ > IF ." Attempt to Overflow Vector!!!"  ABORT THEN
 -- ! ;
;S
 
( Mixed Arithmetic )
CODE M*  S -) 0 # S )+ S )+ EMUL <: SWAP ;
 
CODE /MMOD  2 S )+ MOVL  1 S )+ MOVL  0 S ) MOVL
 4 S )) S -) 0 2 EDIV  END-CODE
 
CODE M*/  4 S )+ MOVQ  1 S )+ MOVL  0 S ) MOVL  2 0 0 5 EDIV
 2 0 # 2 4 EMUL  3 2 2 5 EDIV  0 2 0 4 EMUL   S ) 0 MOVL
 S -) 1 MOVL  END-CODE
 
: M+   DBLE D+ ;
: M+!  >R DBLE R> D+! ;
: M/  /MMOD -DROP ;
: /MCEIL  /MMOD SWAP 0> + ;
;S
 
( 32-bit Output )
: '.'  46 HOLD ;
: P.D  >R  SWAP OVER DABS  <# R> ?DUP IF  0 DO # LOOP THEN '.'
 #S ROT SIGN #> ;
: .FR >R P.D R> OVER - SPACES TYPE ;
: .D  P.D TYPE SPACE ;
 
: Y/N  KEY DUP 3 = IF ." ^C" THEN  DUP EMIT  31 AND 25 = ;
;S
 
 
 
 
 
 
 
( Floating Point Processor Operations         4/05/79 W.Sebok )
4 CONSTANT FA          4 CONSTANT /F
ICODE FNEGATE  F ) F ) MNEGF  END-CODE
ICODE F+  F ) F )+ ADDF2  END-CODE
ICODE F-  F ) F )+ SUBF2  END-CODE
ICODE F*  F ) F )+ MULF2  END-CODE
ICODE F/  F ) F )+ DIVF2  END-CODE
 
CODE FDEPTH  S -) ' FSBOT @ U )) F SUBL3  S ) 4 # DIVL2
 END-CODE
;S
 
 
 
 
 
( Floating Point Processor Operations         4/05/79 W.Sebok )
ICODE 1FIX  S -) F )+ CVTFL  END-CODE
: FIX  1FIX DBLE ;
ICODE F+!   S )+ ) F )+ ADDF2  END-CODE
 
CODE F0<  S -) CLRL  F )+ TSTF   0< IF S ) INCL THEN  END-CODE
CODE F0=  S -) CLRL  F )+ TSTF   0= IF S ) INCL THEN  END-CODE
CODE F0>  S -) CLRL  F )+ TSTF   0> IF S ) INCL THEN  END-CODE
CODE F< S -) CLRL F )+ F )+ CMPF 0> IF S ) INCL THEN  END-CODE
CODE F= S -) CLRL F )+ F )+ CMPF 0= IF S ) INCL THEN  END-CODE
CODE F> S -) CLRL F )+ F )+ CMPF 0< IF S ) INCL THEN  END-CODE
;S
 
 
 
 
( Floating Point Processor Operations         4/05/79 W.Sebok )
ICODE 1/X  F ) 1E0 # F ) DIVF3  END-CODE
ICODE 1RND  S -) F )+ CVTRFL  END-CODE
: RND 1RND DBLE ;
ICODE 1FLOAT  F -) S )+ CVTLF  END-CODE
CODE FLOAT  S ) PUSHL  0< IF <: DNEGATE :> THEN  0 S )+ CVTLF
 0<> IF 0 4096 # ADDW2 THEN  F -) S )+ CVTLF  0< IF HEX
 2 5080 DECIMAL # CVTWL F ) 2 ADDF2  THEN  F ) 0 ADDF2
 R )+ TSTL  0< IF  F ) F ) MNEGF THEN   END-CODE
ICODE FABS  F ) 32768 # BICW2  END-CODE  DECIMAL
ICODE 'FS  S -) F MOVL  END-CODE
ICODE @EXPON  S -) F ) 8 # 7 # EXTZV  S ) 128 # SUBL2  END-CODE
ICODE !EXPON  S ) 128 # ADDL2  F ) 8 # 7 # S )+ INSV  END-CODE
: FDEPTH  FSBOT @ 'FS - FA / ;
;S
 
( Floating Point Stack Operations )
ICODE F@   F -) S )+ ) MOVL  END-CODE
ICODE F!   S )+ ) F )+ MOVL  END-CODE
ICODE F0!  S )+ ) CLRL  END-CODE
ICODE FR>  F -) R )+ MOVL  END-CODE
ICODE F>R  F )+ PUSHL  END-CODE
ICODE FDROP  F )+ TSTF  END-CODE
ICODE FDUP   F -) F ) MOVL  END-CODE
ICODE FOVER  F -) FA F )) MOVL  END-CODE
CODE FSWAP  0 FA F )) MOVL  F ) F )+ MOVL  F -) 0 MOVL END-CODE
;S
 
 
 
 
 
( Floating Point Stack Operations )
ICODE FPICK  0 S )+ MOVL  F -) -4 F )) 0 ] MOVL  END-CODE
ICODE FROT -4 F )) 8 F )) MOVL  F ) -4 F )) 12 # MOVC3 END-CODE
ICODE F-ROT -4 F )) F ) 12 # MOVC3 8 F )) -4 F )) MOVL END-CODE
CODE FROLL  1 S )+ MOVL  F ) F -) 1 ] MOVL  1 1 2 # ASHL
 F ) F )+ 1 MOVC3  END-CODE
ICODE FA+  0  S )+  MOVL  S -) S )+ ) 0 ] MOVAL  END-CODE
ICODE F+A  0 4 S )) MOVL  S )  S )+ ) 0 ] MOVAL  END-CODE
ICODE F++  S ) FA # ADDL2  END-CODE
ICODE F--  S ) FA # SUBL2  END-CODE
ICODE FA1+ S ) FA # ADDL2  END-CODE
ICODE FA1- S ) FA # ADDL2  END-CODE
;S
 
 
 
( Floating Point Utilities )
ICODE F,  H )+ F )+ MOVL  END-CODE
: FCONSTANT  CREATE F, ;CODE  F -) R )+ ) MOVF  END-CODE
: FVARIABLE  CREATE  0E0 F, ;
ICODE EXPON  S -) ' DPL @ U )) CVTBL  END-CODE
: X**N ?DUP IF FDUP DUP ABS 1- ?DUP IF 0 DO FOVER F* LOOP
 FSWAP THEN  FDROP   0< IF 1/X THEN  ELSE FDROP 1E0 THEN ;
: PF.  >R BASE @ 1FLOAT R@ X**N F* RND  R> ;
: F.  PF. .D ;
: F.R  >R PF.  R>  .FR ;
: E 2 QUESTION ; IMMEDIATE      ( catch old floating numbers )
: TFLOAT  FLOAT   BASE @ 1FLOAT  EXPON  NEGATE X**N  F* ;
;S
 
 
 
( Floating Point Logical/Utility Operations )
1E1 FCONSTANT TEN
: FARRAY  CREATE FA * ALLOT  ;CODE
 0 S ) MOVL  S ) R )+ ) 0 ] MOVAL  END-CODE
: F2* 'FS @ 0<> IF @EXPON 1+ !EXPON THEN ;
: F2/ 'FS @ 0<> IF @EXPON 1- !EXPON THEN ;
: F2^N*  @EXPON + !EXPON ;
: F/MOD  FOVER FOVER F/ FIX 2DUP  FLOAT F* F- ;
: SGN  FDUP F0< IF -1E0 ELSE 1E0 THEN FSWAP FABS ;
: (E.) 0  FDUP F0= IF 0, ELSE  FDUP FABS FDUP TEN  F< NOT
 IF BEGIN .1E0 F*  1+  FDUP TEN F< UNTIL  ELSE FDUP 1E0 F< IF
 BEGIN TEN F* 1- FDUP 1E0 F< NOT UNTIL THEN THEN 1E6 F* RND ROT
 THEN DUP >R ABS 0 <# # # 2DROP R> 0< IF 45 ELSE 43 THEN HOLD
 69 HOLD # # # # # # '.' #  F0< IF 45 ELSE 32 THEN HOLD #> ;
: E.  (E.) TYPE SPACE ;
;S
( Context independent long and short Operators )
ICODE H@  S -) S )+ ) CVTWL  END-CODE
ICODE UH@ S -) S )+ ) MVZWL  END-CODE
ICODE H!  0 S )+ MOVL  0 ) S )+ CVTLW  END-CODE
ICODE H,  H )+ S )+ CVTLW  END-CODE
ICODE H@++  S -) 0 S )) ) CVTWL  4 S )) 2 # ADDL2  END-CODE
ICODE H!++  S )+ ) S )+ CVTLW  S -) 2 # ADDL2  END-CODE
: L@  @ ;
: L!  ! ;
: L,  , ;
ICODE L+  S ) S )+ ADDL2  END-CODE
ICODE L1+  S ) INCL  END-CODE
CODE >WRD<  0 S )+ MOVW  S -) S ) MOVW  2 S )) 0 MOVW  END-CODE
: ?>WRD<  >WRD< ;
: ALIGN  HERE 3 OR 1+ HERE - ALLOT ;
;S
( Compatability between different data types                  )
: L->N ; IMMEDIATE              : L->1 ; IMMEDIATE ( obsolete )
: N->L ; IMMEDIATE              : 1->L ; IMMEDIATE ( obsolete )
: L->2  DBLE ;
: 2->L  DROP ;
: LSWAP   SWAP ;
: LOVER   OVER ;
: LNSWAP  SWAP ;                : NLSWAP  SWAP ;
: L1SWAP  SWAP ;                : 1LSWAP  SWAP ;
: 2LSWAP  -ROT ;                : L2SWAP  ROT ;
: 2NSWAP  -ROT ;                : N2SWAP  ROT ;
: LNOVER OVER ;                 : NLOVER OVER ;
: 2NOVER  3 PICK 3 PICK ;       : N2OVER  3 PICK ;
: 2LOVER  3 PICK 3 PICK ;       : L2OVER  3 PICK ;
;S
 
( Type independent operators )
ICODE <C@  S -) S )+ ) CVTBL  END-CODE
ICODE W@  S -) S -) ) MVZWL  END-CODE
ICODE <W@  S -) S )+ ) CVTWL  END-CODE
ICODE W!  0 S )+ MOVL  0 ) S )+ CVTLW  END-CODE
ICODE W,  H )+ S )+ CVTLW  END-CODE
ICODE <C@  S -) S )+ ) CVTBL  END-CODE
ICODE A1+  S ) 4 # ADDL2  END-CODE
ICODE A1-  S ) 4 # SUBL2  END-CODE
: LA1+  A1+ ;               : LA1-  A1- ;
: CA1+  1+ ;                : CA1-  1- ;
: WA1+  2+ ;                : WA1-  2- ;
ICODE CA+  S ) S )+ ADDL2  END-CODE
ICODE WA+  0 S )+ S ) ADDL3  S ) 0 ADDL2  END-CODE
ICODE LA+  0 S )+ S ) ADDL3  0 0 ADDL2  S ) 0 ADDL2  END-CODE
;S
( Type independent operators )
1 ICON /C    2 ICON /W    4 ICON /L   4 ICON /N
 
ICODE L>R  R -) S )+ MOVL  END-CODE
ICODE LR>  S -) R )+ MOVL  END-CODE
ICODE 2>R  R -) S )+ MOVQ  END-CODE
ICODE 2R>  S -) R )+ MOVQ  END-CODE
 
ICODE W@++  S -) 0 S )) ) CVTWL  4 S )) 2 # ADDL2  END-CODE
ICODE W!++  S )+ ) S )+ CVTLW  S -) 2 # ADDL2  END-CODE
: L@++  @++ ;
: L!++  !++ ;
;S
 
 
 
( Diverting Printed Characters to a Buffer  8/18/82   W.Sebok )
ASSEMBLER HERE DUP 3 A+ , ( addr) HERE 0 , ( length) HERE 0 ,
 1 0 )+ MOVL  2 S )+ MOVL  0 ) TSTL  0> IF  0 ) 2 SUBL2
 0< IF  2 0 ) ADDL2 THEN  0 -) 2 ADDL2  1 ) S )+ ) 2 MOVC3 RSB
 THEN  S )+ TSTL  END-CODE
 
: ENCODE  LITERAL !  LITERAL !  LITERAL TYPER ! ;
 
( i j n 2DO .... 2LOOP   iterate n times, maintaining two     )
(         parallel incrementing counters accessed by I and J  )
CODE 2DO  0 S )+ MOVL  S )+ PUSHL  0 PUSHL  S )+ PUSHL
 12 R )) ) JMP  END-CODE
CODE 2LOOP  1 R )+ MOVL  0 R MOVL  0 )+ INCL  0 )+ DECL  0> IF
 0 )+ INCL  0 )+ ) JMP  THEN  R 4 BYTE # ADDL2 1 ) JMP END-CODE
 
;S
( String Stack Manipulation                  01/11/81 W.Sebok )
ICODE SLEN  S -) C ) MVZBL  END-CODE
ICODE SLOC  S -) 1 C )) MOVAB  END-CODE
: SOVER  'SS SDOWN SPUSH ;
: SSWAP  'SS DUP SDOWN DUP SPUSH SDOWN 'SS SWAP 'SS! SWAP SPUSH
 SPUSH ;
 
: S@V  DROP SPUSH ;
: S!V  'SS SDROP  SWAP OVER C@ MIN 2DUP SWAP C!  1+ ROT SWAP
 CMOVE ;
 
: S!R  SLEN -  DUP 0> IF 2DUP 32 FILL  + SLEN  ELSE  SLEN + THEN
 SLOC -ROT   SDROP  CMOVE ;
-->
 
 
( String Stack Manipulation                  01/11/81 W.Sebok )
: S-#DROP  >R 'SS R@ 1 DO DUP SDOWN LOOP  SDOWN 'SS!  R> 1
 DO SPUSH LOOP ;
: S-DROP  2 S-#DROP ;
: SPICK 1- ?DUP IF 'SS SWAP 0 DO SDOWN LOOP SPUSH EXIT THEN
 SDUP ;
: SROLL  DUP SPICK  1+ S-#DROP ;
: SROT  3 SROLL ;
: S2DROP  SDROP SDROP ;
: //PRFX 'SS SDOWN C@  SLEN DUP ROT +  'SS C! 'SS DUP 2+  ROT 1+
 CMOVE  'SS 2+ 'SS! ;
: //  SSWAP  //PRFX ;
: SUBSTR  1- 'SS SDROP + DUP -ROT C!  SPUSH ;
: SREPLACE  'SS SDOWN  >R R@ 1+ OVER 1- 0 MAX  S@  //PRFX  + DUP
 R@ + R> C@ ROT - 1+ 0 MAX  S@ //  2 S-#DROP ;
-->
( Parsing routines -- Compare and Find Strings )
CODE -S?  S 12 # ADDL2  -12 S )) ) -16 S )) 32 # S )+ ) -4 S ))
 CMPC5  0= IF S -) CLRL  RSB THEN  0> IF S -) 1 # MOVL RSB THEN
 S -) 1 # MNEGL  END-CODE
 
: S?  'SS SDOWN COUNT  'SS COUNT  S2DROP  -S? ;
 
CODE -MATCH  S 12 # ADDL2  S )+ ) -4 S )) -8 S )) ) -12 S ))
 MATCHC  S -) 3 MOVL  S -) 0 MOVL  END-CODE
 
: SINDEX  SLEN  'SS SDOWN COUNT  'SS COUNT SDROP  -MATCH  IF
 2DROP 0 ELSE  'SS - SWAP - THEN ;
-->
 
 
 
( Parsing operations -- Find or skip delimiters )
CODE -SANY  6 S )+ MOVL  5 S )+ MOVL  4 S )+ MOVL  3 S ) MOVL
 4 TSTL  0> IF  BEGIN  1 5 MOVL  2 6 MOVL  0 3 ) MOVB  BEGIN
 1 )+ 0 CMPB  0<> IF >R  2 SOBGTR  3 INCL  4 SOBGTR
 R> THEN THEN  3 S ) SUBL2  S ) 3 1 # ADDL3  END-CODE
 
: SANY  'SS SDOWN COUNT  'SS COUNT  SDROP  -SANY ;
 
CODE -SNONE  6 S )+ MOVL  5 S )+ MOVL  4 S )+ MOVL  3 S ) MOVL
 BEGIN  1 5 MOVL  2 6 MOVL  0 3 ) MOVB  BEGIN  1 )+ 0 CMPB  0<>
 IF SWAP  2 SOBGTR  ELSE >R  3 INCL  4 SOBGTR  R> THEN
 3 S ) SUBL2  S ) 3 1 # ADDL3  END-CODE
 
: SNONE  'SS SDOWN COUNT  'SS COUNT  SDROP  -SNONE ;
-->
 
( string comparisons,  strings variables and string arrays )
: S=   ( =  comparison of top 2 strings )  S? 0= ;
: S<   ( <  comparison of top 2 strings )  S? 0< ;
: S>   ( >  comparison of top 2 strings )  S? 0> ;
 
: SWORD  SANY  >R SLEN  " "  'SS 2+ 'SS R@ CMOVE  R@ 1- 'SS C!
 R> - 1+  'SS SDOWN  0 OVER 1- C!  C! ;
: SSKIP  SNONE SLEN OVER - 1+ SWAP SUBSTR ;
: SSPACES  'S SPUSH  SLOC SWAP 32 FILL ;
: STRING-SPACE 1+ -2 AND  HERE SWAP DUP ALLOT  32 FILL ;
: STRING-VAR  CREATE DUP , 1+ STRING-SPACE DOES> @++ ;
: ()STRING  CREATE  SWAP DUP ,  0 DO DUP , DUP 1+ STRING-SPACE
 LOOP DROP DOES>  2+ DUP @ -ROT 3 PICK  1 OR  3 +  ROT * 2+ +
 SWAP ;
-->
 
( Find execute and forget from string stack )
: S,  HERE SLEN  DUP 1+ ALLOT S!V ;
: SMSGB  >IN @ BLK @  >IN 0X!  BLK 0X!  SLOC SDROP MSGBUF ! ;
: SRSTR  BLK !  >IN !  MSGBUF0 @ MSGBUF ! ;
: SFIND  SMSGB FIND  -ROT SRSTR ;
: SEXEC  SFIND ?DUP IF EXECUTE ELSE 2 QUESTION THEN ;
: SFORGET  SMSGB FORGET  SRSTR ;
 
: UCASE  SLOC SLEN + SLOC DO  I C@ 96 > IF I C@ 123 < IF I C@
 32 - I C! THEN THEN LOOP ;
 
: DETAB  1 BEGIN DUP SLEN <= WHILE DUP 'SS + C@ 9 = IF DUP 1- 7
 OR 2+ OVER - SSPACES  DUP SLEN + 1 ROT SREPLACE ELSE 1+ THEN
 REPEAT  DROP ;
-->
 
( Conditional Compilation - IFTRUE & IFEND   8/3/79  W.Sebok )
CODE -COMP  0 R )+ MOVL  1 0 )+ MVZBL  R -) 0 1 ADDL3
 2 H ) MVZBL  S -) CLRL  0 ) 1 32 # 1 H )) 2 CMPC5  0= IF
 S ) INCL THEN  END-CODE
CODE LCAS  0 S )+ MOVL  1 0 )+ MVZBL  BEGIN  0 )+ 32 # BISB2
 1 SOBGTR  END-CODE
: #ELSE  0 BEGIN  32 WORD LCAS  -COMP [ " #if" S, ] IF 1+ 0 ELSE
 -COMP [ " #else" S, ] IF DUP 0=    ELSE
 -COMP [ " #then" S, ] IF 1- DUP 0< ELSE   0 THEN THEN THEN
 UNTIL  DROP ;             IMMEDIATE
: #IF  NOT IF [COMPILE] #ELSE THEN ;         IMMEDIATE
: #THEN ;                                    IMMEDIATE
: ?;S  FIND IF  R> DROP ;S THEN ;
: #IFDEF  SFIND ;
: #IFNDEF  SFIND NOT ;
-->
( Words with which to Inquire From the Keyboard  6/18/78 wls )
: SASK  82 SSPACES  SLOC 80 EXPECT  " \0" SWORD  S-DROP ;
: ASK>  >R R@ IF ." Bad Number" CR ." Try Again: " 2DROP THEN
 R> NOT ;
: <ASK  SASK " \t " SWORD  S-DROP ;
: ATOL  0, 'SS CONVERT  SLOC - SLEN <>  SDROP ;
: ATOF  ATOL >R TFLOAT R> ;
: ATOI  ATOL -DROP ;
: ASK  BEGIN <ASK ATOL ASK> UNTIL ;
: IASK  ASK DROP ;
: 2ASK  ASK ;
: FASK  ASK TFLOAT ;
-->
 
 
 
( Make a unix file input stream {for reading not Loading} WLS )
( offset_l descr <SCAN   make WORD reference file `descr' )
CODE <SCAN  0 R )+ MOVL  ' >LOC @ U )) PUSHL
 ' >IN @ U )) PUSHL  ' BLK @ U )) PUSHL ' >IN @ U )) CLRL
 ' BLK @ U )) CHANBOT # S )+ ADDL3  ' >LOC @ U )) S )+ MOVL
 0 ) JMP  END-CODE
CODE SCAN>  0 R )+ MOVL  ' BLK @ U )) R )+ MOVL
 ' >IN @ U )) R )+ MOVL  ' >LOC @ U )) R )+ MOVL  0 PUSHL
 <: FLUSH ;
( addr SN@ str_s   put null delimited string on string stack )
: SN@  DUP BEGIN DUP C@ WHILE 1+ REPEAT  OVER - S@ ;
( item_s GETENV  entry_s     Get String From Unix Environment )
: GETENV  ENVIR  BEGIN @++ ?DUP WHILE  SN@  " =" SWORD 3 SPICK
 S= IF DROP 2 S-#DROP " =" SSKIP 1 EXIT THEN  SDROP REPEAT
 SDROP DROP 0 ;
-->
( Various String Utilities )
( count # of strings on str. stack, leave) ( SJR 12 Oct 82 )
: SDEPTH 0 'SS DUP SSBOT @ = IF DROP ELSE BEGIN SWAP
  1+ SWAP SDOWN DUP SSBOT @ = UNTIL DROP THEN ;
 
( input_s DETAB  output_s  Expand 8 column stop tabs to spaces)
: DETAB  1 BEGIN DUP SLEN <= WHILE DUP 'SS + C@ 9 = IF DUP 1- 7
 OR 2+ OVER - SSPACES  DUP SLEN + 1 ROT SREPLACE ELSE 1+ THEN
 REPEAT  DROP ;
 
( Convert strings of spaces to tabs at each 8 columns )
: ENTAB  SLOC 0  SLEN 1+ 1 DO  I 'SS + C@ 32 = IF  1+ I 7 AND 0=
 IF DROP 9 B!+ 0 THEN  ELSE ?DUP IF  0 DO 32 B!+ LOOP THEN  'SS
 I + C@ B!+  0 THEN LOOP  ?DUP IF 0 DO 32 B!+ LOOP THEN  SLOC -
 'SS SWAP OVER SDROP C!  SPUSH ;
;S
( Unix System Call interfaces               9/20/81 W.Sebok )
OCTAL   666 ICON CSTAT   DECIMAL
: ?UERROR  ERRNO @ IF ERRNO @ UERR + QUESTION THEN ;
: ?UERMSG  ERRNO @ IF ERRNO @ UERR + CR MESSAGE THEN ;
: CD  32 CDOES> $CD ;
 
( Open for input/output if possible, input only if not )
: RWOPEN  DUP 2 = IF  SDUP $OPEN DUP 0>= IF SDROP EXIT THEN DROP
 0 THEN  $OPEN ;
 
( Search in likely places for block files )
( Add user's own seach path? )
: ?OPEN  SLOC C@ 60 = IF  SLEN 1- 2  SUBSTR 1 DUP ELSE  DUP SDUP
 RWOPEN DUP 0< THEN  IF DROP FDIR //PRFX RWOPEN ELSE SDROP -DROP
 THEN ;
-->
( Find First Free Block Extent )
: BLFREE  -1  N.BLKTAB @ 0 DO  DROP CHANBOT
 N.BLKTAB @ 0 DO   E.BLKTAB J A+ @   B.BLKTAB I A+ @  U< IF
 B.BLKTAB I A+ @ 2DUP  U< IF DROP ELSE -DROP THEN  ( UMIN )
 THEN LOOP  DUP CHANBOT = NOT IF  2DUP E.BLKTAB I A+ @ - <
 IF  2DROP E.BLKTAB I A+ @ 0 LEAVE  THEN THEN  LOOP
 IF  0 N.BLKTAB @ 0 DO  E.BLKTAB I A+ @ 2DUP  U< IF -DROP ELSE
 DROP THEN  ( UMAX ) LOOP  SWAP OVER + CHANBOT U< NOT IF
X." Not Enough Block Space!!!" ABORT THEN  THEN  1+ ;
-->
 
 
 
 
 
 
( Remove Block file from mapping table        8/18/82 W.Sebok )
: REMOVE FLUSH  0 0 N.BLKTAB @ 1- DO DROP DUP B.BLKTAB I A+ @ =
 IF DROP I 0 LEAVE  ELSE 1 THEN -1 +LOOP  IF
 ." Bad Block Number!!" DROP EXIT THEN  >R  F.BLKTAB R@ + C@
 N.BLKTAB @ R> 1+ 2DUP = IF 2DROP  ELSE DO F.BLKTAB I + DUP C@
 SWAP 1- C!  E.BLKTAB I A+  DUP @ SWAP -- !  B.BLKTAB I A+ DUP @
 SWAP -- ! LOOP  THEN  N.BLKTAB 1-!  $CLOSE ;
 
: BLKTAB  CR ." Chan   Start    End"  CR  N.BLKTAB @ ?DUP IF 0
 DO F.BLKTAB I + C@ 3 .R  B.BLKTAB I A+ @  8 .R E.BLKTAB I A+ @
 8 .R  CR LOOP THEN ;
-->
 
 
 
 
( Install file as Range of Forth Blocks )
: 1INSTALL  N.BLKTAB @ L.BLKTAB < IF ?OPEN ?UERROR DUP $LENGTH
 ?UERROR 1024 /MOD  SWAP 0<> + EXIT THEN
 ."  Insufficient Room in Block Table!!!" ABORT ;
 
: 2INSTALL  FLUSH   SWAP F.BLKTAB N.BLKTAB @ + C!  OVER + 1-
 E.BLKTAB N.BLKTAB @ A+ !  B.BLKTAB N.BLKTAB @ A+ !
 N.BLKTAB 1+! ;
 
: -INSTALL  1INSTALL  2INSTALL ;
: 0INSTALL  1INSTALL  DUP BLFREE  DUP 2SWAP  2INSTALL ;
: INSTALL  32 CDOES> 2 -INSTALL ; IMMEDIATE
: RINSTALL 32 CDOES> 0 -INSTALL ; IMMEDIATE
-->
 
 
( Load from block files                      10/20/81 W.Sebok )
( Allocate into mapping table and load )
: S+LOADF  0 0INSTALL  DUP >R + LOAD R> REMOVE ;
: SLOADF   0 S+LOADF ;
: LOADF  32 CDOES>  SLOADF ; IMMEDIATE
: ?LOADF FIND  32 WORD SPUSH IF SDROP EXIT THEN  0 S+LOADF ;
 
( Load as straight file ... screens or with newlines )
: SFLOAD  FLUSH 0 ?OPEN ?UERROR CHANBOT + ' LOAD EXECUTE ;
: FLOAD  32 CDOES>  SFLOAD ;  IMMEDIATE
: ?FLOAD  FIND 32 WORD SPUSH IF SDROP EXIT THEN  SFLOAD ;
-->
 
 
 
 
( Create a New Block File                    10/20/81 W.Sebok )
( n FCREATE filnam    create and initialize forth screens )
: SCREATE -1 BUFFER DUP 1024 32 FILL 0 OVER ! CSTAT $CREATE
 ?UERROR ROT 0 DO 2DUP 1024 SWAP $WRITE ?UERROR DROP LOOP $CLOSE
 DROP ;
: FCREATE  32 CDOES> SCREATE ; IMMEDIATE
 
: COPYS  >R 2DUP < IF 0 R> 1- -1 ELSE R> 0 1 THEN  >R DO  OVER I
 +  OVER I +  EDITOR COPY FLUSH  J +LOOP  2DROP  R> DROP ;
FORTH
-->
 
 
 
 
 
( Shell Escape                               10/30/81 W.Sebok )
 :  WAIT BEGIN $WAIT -DROP DUP 0< IF DROP DUP THEN  OVER = UNTIL
 DROP HUP ;
 
: PFORK  $PIPE $FORK DUP 0< IF ?UERROR THEN IF >R 0 $CLOSE DUP
 $DUP ?UERROR DROP $CLOSE $CLOSE R> 1 EXIT THEN SWAP $CLOSE 0 ;
 
: SH  CR NOHUP TRESET  $FORK IF HUP " /bin/sh" " sh" 0 $EXEC
 THEN  WAIT ;
: CSH  CR NOHUP TRESET  $FORK IF HUP " /bin/csh" " csh" 0 $EXEC
 THEN  WAIT ;
 
: SH[  93 CDOES>  CR NOHUP TRESET $FORK IF HUP " /bin/sh" " sh"
 " -c" 4 SROLL  2 $EXEC THEN  WAIT  SDROP ;  IMMEDIATE
-->
 
( Terminal I/O Handler --- Output       Rev. Jun 1984 W.Sebok )
: DEVICE  CREATE 1+ HERE +A ,  DOES> @ TYPER ! ;
 
TYPER @  : CONSOLE LITERAL TYPER ! ;  ( define native terminal)
TYPER @  @ CONSTANT LETTER            ( addr of output routine)
TYPER @ -- @ CONSTANT STROKE          ( addr of input  routine)
 
: TERM  2 DEVICE  -1 , STROKE , LETTER , -1 , ;
 
: TERMINAL  TYPER0 @ TYPER ! ;
 
: CONNECT  TYPER @ 2DUP ++ !  2 A- ! ;
 
: DISCONNECT  TYPER @ TERMINAL ++ DUP @ $CLOSE  -1 SWAP ! ;
-->
 
( Diversion of output to a FILE          June 20,1984 W.Sebok )
TERM INOUT
(  ---            restore output to terminal and close )
: >#  ' INOUT @ ++ @ 0> IF ' INOUT @ ++ DUP @ $CLOSE -1 SWAP !
 THEN TERMINAL ;
 
( des ---         divert output to file referenced by des )
: >DESC  >#  ' INOUT @ ++ !  INOUT ;
 
( file_s  ---     divert output to file )
: >FILE  CSTAT $CREATE ?UERROR  >DESC ;
 
( file_s  ---     divert output to end of file )
: >>FILE  SDUP  1 $OPEN  ERRNO @ IF  >FILE ELSE SDROP
 0, 2 4 PICK $LSEEK 2DROP >DESC THEN ;
-->
( Implement Offline Printing through lpr  rev 6/09/83 W.Sebok )
TERM PRINTER
 
CODE PWRITE  0 ) -1 # CMPL  0= IF  S -) 0 MOVL <: ( open file )
 PFORK IF  " -l" " /usr/ucb/lpr"  " lpr"  1 $EXEC  THEN  DROP
 :> S )+ ) S )+ MOVL  0 -4 S )) MOVL
 THEN  LETTER BR END-CODE   ' PWRITE  6 - ' PRINTER @ !
 
: PRINT  PRINTER DISCONNECT ;
;S
 
 
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
( Some Special & risky Editor Words )
: LNMV CR ." From Block # = " IASK ."  Line # = " IASK SWAP CR
 ."   to Block # = " IASK ."  Line # = " IASK SWAP CR
 ."  Copy # Lines = "  IASK 0 DO 2SWAP DUP SCR ! SWAP EDITOR T
 1+ SWAP 2SWAP DUP SCR !  SWAP DUP R 1+ SWAP LOOP  4 #DROP ;
 
: STACK  DEPTH IF  1 DEPTH 1- DO I PICK . -1 +LOOP THEN ;
 
: FSTACK  FDEPTH IF  1 FDEPTH DO I FPICK E. -1 +LOOP  THEN ;
 
: SSTACK SDEPTH ?DUP IF 1 SWAP DO I SPICK S. SPACE  -1 +LOOP
 THEN ;
;S
 
 
 
( Dictionary Trace        rev. for new format 1/13/79 W.Sebok )
16 ARRAY DCSAV
: CRACK  0 SWAP <# -2 -26 DO DUP I SHIFT 63 AND ROT OVER 32 = OR
 -ROT DUP 32 < IF 64 + THEN HOLD 6 +LOOP  DUP -2 SHIFT 48 AND 4
 ROLL + DUP 32 < IF 64 + THEN  HOLD  32 HOLD 0, #> TYPE  DUP -3
 SHIFT 7 AND ROT 0= IF DUP 5 < IF 8 + THEN THEN 12 - <# 7 0 DO
 DUP 0< IF 32 ELSE 120 THEN HOLD 1+ LOOP  0 #> TYPE DUP 1 AND IF
 ."  Im" THEN 2 AND IF ."  Inl" THEN CR ;
: DICTIONARY -1 0 16 0 DO DCSAV I A+ @ OVER > IF 2DROP I DCSAV
 I A+ @ THEN LOOP  DUP 0<> IF  DUP 10 + 12 U.R 2DUP @ CRACK  2-
 DUP UH@ ?DUP IF -  ELSE 2- @ THEN   DCSAV ROT A+ !  0 ELSE
 ." End of Dictionary" CR 2DROP  1 THEN ;
: 'DIC 16 0 DO CONTEXT @ I A+ @ DCSAV I A+ ! LOOP ;
: VLIST CR 'DIC BEGIN DICTIONARY UNTIL ;
;S
 
( Output Formats -----       Dumping Words )
?;S 10I6
: 5I12  CR 0 DO I 6 .R SPACE  IUPPER I - 5 MIN  0 DO  DUP L@
 12 D.R  4 + LOOP  CR  5 +LOOP  DROP ;
 
: 10I6  CR 0 DO I 6 .R SPACE  IUPPER I - 10 MIN 0 DO DUP H@ 7 .R
 2+ LOOP  CR 10 +LOOP  DROP ;
 
: 8I6 CR 0 DO I 6 .R SPACE  IUPPER I - 8 MIN 0 DO DUP H@ 7 .R 2+
 LOOP  CR 8 +LOOP  DROP ;
 
: 5F12.3 CR 0 DO I 6 .R IUPPER I - 5 MIN  0 DO DUP F@ 3 12 F.R
 F++ LOOP  CR 5 +LOOP  DROP ;
;S
 
 
//go.sysin dd *
made=TRUE
if [ $made = TRUE ]; then
	/bin/chmod 644 ./vaxforth/forth.blk.txt
	/bin/echo -n '	'; /bin/ls -ld ./vaxforth/forth.blk.txt
fi
exit
-- 
Bill Sebok			Princeton University, Astrophysics
{allegra,akgua,burl,cbosgd,decvax,ihnp4,kpno,princeton,vax135}!astrovax!wls