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