( LAST REVISION: 1986.06.22. ) ( FORTH words collected from many different sources, but some ) ( are original too! ) ( Needs FTHUTILA assembled into the FORTHRAM dictionary prior to ) ( loading. FTHUTILA is HP commercial, you can get a copy of it by ) ( ordering HP's "Software development handbook" from the Users' Library. ) BASE @ HEX : MYFORTH ; 0 WARN ! : ; [COMPILE] ; CR LATEST DUP COUNT 1F AND 1- TYPE 1 TRAVERSE C@ 7F AND EMIT SPACE ; IMMEDIATE -1 WARN ! : \ PREV @ 7 + C@ 2* >IN ! ; IMMEDIATE 2F441 CONSTANT ATTN : ENABLE 0 SWAP N! ; : DISABLE F SWAP N! ; DECIMAL -1 CONSTANT TRUE 0 CONSTANT FALSE : ON ( addr -- ) TRUE SWAP ! ; : OFF ( addr -- ) FALSE SWAP ! ; : BINARY 2 BASE ! ; : BIN. BASE @ SWAP BINARY U. ." b. " BASE ! ; : DEC. BASE @ SWAP DECIMAL U. ." d. " BASE ! ; : HEX. H. ." h. " ; : BASE? BASE @ DEC. ; \ : ADR. DUP U. 2 SPACES ; : 5SP 5 SPACES ; : 0<> ( n -- f ) 0= NOT ; : CLRSTK ( ? ? ... ? -- ) SP! ; ( BEGIN DEPTH WHILE DROP REPEAT ; ) : ROT> ( n1 n2 n3 -- n3 n1 n2 ) ROT ROT ; : SHIFT> ( n1 n2 -- n3 ) ?DUP 0<> IF 0 DO 2/ LOOP THEN ; : SHIFT< ( n1 n2 -- n3 ) ?DUP 0<> IF 0 DO 2* LOOP THEN ; : <= ( n1 n2 -- f ) > NOT ; : WITHIN ( n lo hi -- f ) >R OVER <= SWAP R> <= AND ; : SET ( addr mask -- ) OVER @ OR SWAP ! ; : CLEAR ( addr mask -- ) OVER @ SWAP NOT AND SWAP ! ; : BOUNDS ( addr len -- limit initial) OVER + SWAP ; : ERASE ( addr n -- ) 0 FILL ; : BIPBIP " BEEP4000,.2@BEEP4500,.2" BASICX ; : ALARM ( -- ) ATTN DISABLE BEGIN BIPBIP ?TERMINAL UNTIL KEY DROP ATTN ENABLE ; VARIABLE PAUSELEN 0 PAUSELEN ! : PAUSE \ pause for PAUSELEN/1000 seconds. PAUSELEN @ 1+ 0 DO LOOP ; : SCROLL " SCROLL1" BASICX ; : KEYWAIT ( -- key ) BEGIN ?TERMINAL UNTIL KEY ; : TAB$ ( str pos -- str) BEGIN 2DUP < WHILE ROT> " " S<& ROT REPEAT DROP ; : N-B ( n -- b ) 7 OVER 9 > AND + 48 + ; : N$ ( n -- str ) N-B CHR$ ; : N. ( n -- ) \ convert a nibble to its hex ascii equivalent. N-B EMIT ; : DUMP ( addr n -- ) \ Print n nibbbles starting from addr. ?DUP 0<> IF BOUNDS DO I N@ N. LOOP ELSE DROP THEN ; : DUMP+ ( addr n -- addr+n ) \ Do DUMP; leave next addr on stack. 2DUP + ROT> DUMP ; : SHOW ( addr n -- ) \ display contents of n consecutive memory cells. ?DUP 0<> IF 1+ 1 DO DUP H. 5SP DUP @ H. PAUSE CR 5+ LOOP ELSE DROP THEN ; : DELAY00 " DELAY0,0" BASICX ; : D-P " DISPLAYISPRINTER" BASICX ; : D-* " DISPLAYIS*" BASICX ; : D-D " DISPLAYISDISPLAY" BASICX ; : D-R " DISPLAYISRS232"BASICX ; : ROOM ( -- n ) \ Number of nibbles available in dictionary. SP0 @ HERE - 458 - ; : ROOM? ROOM DEC. ; : S. ( -- ) \ Print stack contents bottom first. ." [ " DEPTH 0> IF DEPTH 1 SWAP DO I PICK U. -1 +LOOP THEN ." ] " ; HEX : ADDR- ( anf1 -> anf2 ) \ Get the anf of the previous word. 5- @ ; : >NAME ( acf -- anf ) 2- -1 TRAVERSE ; : NAME> ( anf -- acf ) 1 TRAVERSE 2+ ; : BODY> ( apf -- acf ) 5- ; : N>LINK ( anf -- alf ) 5- ; : L>NAME ( alf -- anf ) 5+ ; : >LINK ( acf -- alf ) >NAME N>LINK ; : LINK> ( alf -- acf ) L>NAME NAME> ; : MYSELF LATEST NAME> ; IMMEDIATE : NAME ( anf -- ) DUP COUNT 1F AND 1- TYPE 1 TRAVERSE C@ 7F AND EMIT ; : NAME$ ( anf -- str ) DUP 2+ SWAP C@ 1F AND ; \ SPECIAL: Array containing list of words with remote acf's. \ 1st value is # of entries. CREATE SPECIAL D , E701A , ( COLON ) E71E8 , ( SEMI ) E1C54 , ( number ) E22ED , ( F-number ) E1C67 , ( DO ) E3FF1 , ( LOOP ) E3F81 , ( +LOOP ) E5D86 , ( IF / UNTIL / WHILE ) E5D99 , ( ELSE / REPEAT ) E0640 , ( " ) E0EFA , ( ." ) E580E , ( ABORT") E0168 , ( J ) : SPEC? ( acf -> acf # ) \ SPEC?: Find acf in SPECIAL. Return # of entry, or 0 if not present. 0 SPECIAL @ 1+ 1 DO ( acf 0 ) OVER SPECIAL I 5 * + @ = ( acf 0 acf SPECi ) IF DROP I LEAVE THEN LOOP ; ( acf # ) : 'NAME \ Given acf, type name. DUP >NAME SWAP OVER - 2/ 1- OVER C@ 1F AND = IF NAME ELSE DROP ." Unknown" THEN ; : HEREN ( n -- addr) \ Find the start of the n+1th link field. DUP C = IF DROP E6FAB ELSE 1+ 5 * E0000 + @ ( NFA ) BEGIN 5- DUP @ DUP 0 <> WHILE SWAP DROP REPEAT DROP THEN ; VARIABLE ENDA VARIABLE HERE0 : 'END ( acf -- ) \ Given acf, find the addr of the start \ of the next word and store in ENDA. DUP E0000 U< IF LATEST HERE ELSE DUP >NAME C@ 1F AND ( acf n ) DUP 5 * E0000 + @ SWAP HEREN THEN DUP HERE0 ! ENDA ! BEGIN 2DUP < WHILE DUP ENDA ! ADDR- REPEAT 2DROP ENDA @ HERE0 @ <> IF -5 ENDA +! THEN ; : +ADDR ( I -- I+5 ) \ Type addr following control word; incr addr. 5+ DUP DUP @ + ." to " H. ; : "STR ( I 4-or-2 ) \ Type the compiled string following a " word. SWAP 5+ DUP C@ 2DUP SWAP 5 ROLL + SWAP 22 EMIT SPACE TYPE 22 EMIT 2* + 1- ; FVARIABLE FTEMP \ FVariable to hold X during decompilation of a FP word. : WORDNAME ( I WA -- [ I' = next I -5] ) \ Given I and its WA, type the word identified; advance I. DUP ABS 10000 > \ Is this a legitimate word addr? IF SPEC? CASE 0 OF 'NAME ENDOF SWAP DROP 1 OF ." :" ENDOF 2 OF ." ;" ENDOF 3 OF 5+ DUP @ . ENDOF 4 OF 5+ DUP FTEMP STO RDN RCL F. RDN FTEMP RCL B + ENDOF 5 OF ." DO" ENDOF 6 OF ." LOOP" +ADDR ENDOF 7 OF ." +LOOP" +ADDR ENDOF 8 OF DUP 5+ @ 0> IF OVER 5+ DUP @ + 5- DUP @ 0< SWAP 5- @ E5D99 = AND IF ." WHILE" ELSE ." IF" THEN ELSE ." UNTIL" THEN +ADDR ENDOF 9 OF DUP 5+ @ 0> IF ." ELSE" ELSE ." REPEAT" THEN +ADDR ENDOF A OF 4 "STR ENDOF B OF ." ." 2 "STR 2- ENDOF C OF ." ABORT" 2 "STR 2- ENDOF D OF ." J" ENDOF ENDCASE ( addr') ELSE DROP ( addr'=addr ) THEN ; : WORD@ ( addr -- addr' ) \ where addr' = addr of next I. \ Given an addr, type it, it's content, and the word identified. DUP H. 5SP DUP @ DUP H. ( addr cfa ) WORDNAME 5+ PAUSE CR ; : UN:C ( cfa -- ) \ Decompile a word, omitting header. ." ACF: " DUP 'END DUP DUP @ - -5 = IF H. 5SP ." Primitive" PAUSE CR ELSE WORD@ BEGIN 5SP WORD@ DUP ENDA @ = UNTIL DROP THEN ; : UN: \ Decompile the word named next, including the header. ' DUP ." Word: " DUP 'NAME PAUSE CR >NAME ( acf anf ) DUP 5- ." ALF: " DUP H. 5SP @ ." Link: " H. PAUSE CR ( acf anf ) DUP ." ANF: " H. 5SP NAME$ 1+ 2* SWAP 2- SWAP DUMP PAUSE CR ( acf) UN:C ; : RS. \ Decompile the return stack, omitting the bottom two levels. RP@ RP0 @ 5- DO I @ WORD@ DROP -5 +LOOP ; \ RTNSAVE: Variable to hold SST environment. \ Contents of addr: \ RTNSAVE = I \ +5 = Orig. I -- in word that calls DOSST \ +A = ACF of SST word \ +F = END of SST word \ +14 = >RTN \ +19 = >RBOT \ RTNSAVE+E6 points to end of RTNSAVE--temp RP0@ CREATE RTNSAVE E6 NALLOT ( " CREATE TEXT RTNSAVE:PORT[1],500" BASICX ) ( : RTNSAVE " ADDR$['RTNSAVE']" BASIC$ DROP 2- NUMBER DROP 25 + ; ) : NEWRTN \ Copy the RTN stack & >RTN to RTNSAVE. RP@ RP0 @ ( >RTN >RBOT) OVER - SWAP OVER RTNSAVE E6 + SWAP - DUP RTNSAVE 14 + ! ( Save >RTN* ) ROT ( [ >RTN >RTN* # ] ) NMOVE ( COPY RTN stack to RTNSAVE) RTNSAVE 2FB7F ! ; ( Put RTNSAVE addr in 2FB7F ) : SSTERROR \ Onerror routine for single step. 0 ONERR ! RTNSAVE 19 + @ RP0 ! ( Restore >RBOT ) 2F7E4 4N@ DUP 2DUP ( 4 copies of errn ) 2EFF > ( >2EFF ? ) SWAP 2F41 < ( <2F41 ? ) AND SWAP 0= OR ( =0? ) IF R> ( Go back to ABORT ) ELSE " BEEP" BASICX " 'ERR:'&MSG$(ERRN)"BASIC$ TYPE SP! RP! QUIT THEN ; VARIABLE SSTOUT \ Variable to hold CFA of word to be executed after DOSST. : SST \ Single step the word identified by the instruction pointer I* \ stored at RTNSAVE, unless it is a semi. Then display the stack. RTNSAVE @ DUP @ DUP E71E8 <> ( I WA flag ) IF WORDNAME DROP 5 SPACES [ ' SSTERROR ] ( Put SSTERROR acf on stack for onerror ) LITERAL ONERR ! DOSST 0 ONERR ! SSTOUT @ EXECUTE ELSE ." ;" 2DROP THEN ; ' S. SSTOUT ! \ Initialize SSTOUT to hold S.'s acf. : READYSTEP \ Set up environment for STEP or BREAK. \ Save I*, END, CFA in RTNSAVE, do NEWRTN. ' DUP RTNSAVE A + ! ( Store acf ) DUP 'END ENDA @ RTNSAVE F + ! ( Store word END ) 5+ RTNSAVE ! ( Save new I ) NEWRTN ; : STEP \ Single step next word. READYSTEP SST ; : BP ( Ib -- ) \ Set a breakpoint. 2FB84 ! ; : CONT \ Continue execution of a BREAKed or SSTed word to next breakpoint. [ ' SSTERROR ] LITERAL ONERR ! BRRUN 0 ONERR ! SSTOUT @ EXECUTE ; : FINISH \ Complete execution of an interrupted word. 0 BP CONT ; : BREAK ( I -- I ) \ Execute next word, stopping at Ib specified on stack or at the final ;. READYSTEP BP CONT ; FVARIABLE FSCRATCH \ Floating point scratch variable ) : FINDW ( -- acf ) \ Get a word from input stream and return its acf. BL WORD FIND 0= IF ABORT" Word not found" THEN ; : PRINT \ Direct the display output of the next word to the printer. 2F78D 2FC79 7 NMOVE \ Save old Display device D-P \ Make printer the display FINDW EXECUTE CR \ Do it and print output) 2FC79 2F78D 7 NMOVE \ Restore old display 7 2F7B1 N! \ Reset display type 2FC79 7 0 NFILL \ Zero the assembler variables ; : SKIP \ Set printer to skip over perf mode. " PRINT CHR$(27);'&l1L';"BASICX ; : TIMED \ Execute the next word and display its execution time. \ The time is left in X. T is lost on input, and Z & T are lost on output. FINDW FSCRATCH TIME STO FDROP EXECUTE TIME FSCRATCH DUP DUP RCL F- TIME STO FDROP TIME F- RCL F+ F. ; : WORDS \ List the words defined in the current RAM dictionary. LATEST BEGIN DUP NAME DUP C@ 40 AND IF ." Immediate" THEN PAUSE CR ADDR- DUP 0= UNTIL DROP ; : 2! ( d addr -- ) DUP 5+ >R ! R> ! ; : 2@ ( addr -- d) DUP 5+ @ SWAP @ ; : 2CONSTANT ( D -- ) CREATE SWAP , , DOES> DUP @ SWAP 5+ @ ; : 2VARIABLE ( -- ) CREATE 5 ALLOT ; : 2ROT ( D1 D2 D3 -- D2 D3 D1 ) 6 ROLL 6 ROLL ; : DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; : DMIN 2OVER 2OVER D< NOT IF 2SWAP THEN DROP ; : D0= ( d -- f ) OR 0= ; : D= ( d1 d2 -- f ) D- D0= ; : D> ( d1 d2 -- f ) 2SWAP D< ; : +- 0< IF NEGATE THEN ; : D+- 0< IF DNEGATE THEN ; 8 STRING EDSCR : EDSCREEN EDSCR S! ; : EDSCREEN? EDSCR TYPE BL EMIT ; : EDLIST EDSCR " LIST FORTH$" BASICX ; : EDLOAD ." Loading " EDSCREEN? BASE @ " TIME" BASICI EDSCR LOADF " TIME" BASICI SWAP - ALARM CR DEC. ." sec. " BASE ! ; : ED EDSCR " EDTEXT FORTH$" BASICX ; : EDIT ED EDLOAD ; : ADDR$ ( addr -- str ) BASE @ HEX SWAP 0 <# # # # # # #> ROT BASE ! ; : TASK ; BASE !