Princeton FORTH v2.0 for the VAX, part 5 of 8
William L. Sebok
wls at astrovax.UUCP
Tue Jun 26 11:54:12 AEST 1984
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 at ++ 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 at ++ S -) 0 S )) ) CVTWL 4 S )) 2 # ADDL2 END-CODE
ICODE W!++ S )+ ) S )+ CVTLW S -) 2 # ADDL2 END-CODE
: L at ++ @++ ;
: 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 at 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
More information about the Comp.sources.unix
mailing list