( PC/FORTH+ 2.0 Electives file 12/25/83 ) ;S Copyright (c) 1982, 1983 by Ray Duncan, Laboratory Microsystems Inc. this file created 29 Jan 1982 for PC/FORTH 1.0 modified 1/31/83 for use with PC/FORTH+ 1.x modified 12/25/83 for use with PC/FORTH+ 2.0 This file is provided for the convenience of PC/FORTH+ users who wish to rebuild the FORTH.COM file. Changes to this file are made at your own risk! To create new FORTH.COM, enter A>NUCLEUS ELECTIVE <return> (wait for system sign-on message, then enter:) 1 LOAD <return> New FORTH.COM will be written on the "current" disk drive. ( Build distributed FORTH file from base file 12/25/83 ) FORTH DEFINITIONS VOCABULARY HIDDEN IMMEDIATE ( predeclare all ) VOCABULARY ASSEMBLER IMMEDIATE ( vocabularies ) VOCABULARY EDITOR IMMEDIATE DECIMAL 16 LOAD CR .( Misc words) DECIMAL 26 LOAD CR .( New :) DECIMAL 12 LOAD CR .( .STACK ) DECIMAL 13 LOAD CR .( USING ) DECIMAL 15 LOAD CR .( LOAD-USING) DECIMAL 20 LOAD CR .( QX ) DECIMAL 21 LOAD CR .( DIR ) DECIMAL 8 LOAD CR .( FREEZE and SAVE ) DECIMAL 24 LOAD CR .( SHOWC ) DECIMAL 10 LOAD CR .( CASE ) --> ( Build distributed FORTH file from base file 01/04/83 ) DECIMAL 7 LOAD CR .( DUMP ) DECIMAL 11 LOAD CR .( #IN ) DECIMAL 17 LOAD CR .( MAP ) DECIMAL 19 LOAD CR .( Vocs ) DECIMAL 27 LOAD CR .( Index and List) DECIMAL 28 LOAD CR .( Show and Triad) DECIMAL 29 LOAD CR .( Words ) DECIMAL 30 LOAD CR .( Background multi-tasker) DECIMAL 33 LOAD CR .( Chdir ) DECIMAL 34 LOAD CR .( Chdisk) DECIMAL 35 LOAD CR .( Double precision extensions) FORTH DEFINITIONS DECIMAL .STACK CR .( Auxiliary functions loaded.) CR SAVE FORTH ;S ( System messages ) empty stack dictionary full has incorrect address mode is redefined is undefined disk address out of range stack overflow disk error BASE must be DECIMAL missing decimal point PC/FORTH+ 2.0 Laboratory Microsystems( System messages ) compilation only, use in definition execution only conditionals not paired definition not finished in protected dictionary use only when loading off current editing screen declare vocabulary illegal dimension in array definition negative array index array index too large ( 8086 Assembler messages ) 16 bit register not allowed 8 bit register not allowed address out of range immediate data value not allowed missing source register missing destination register illegal operation illegal operand instruction not implemented illegal destination register illegal source register illegal condition code register mismatch destination address missing ( Memory dump, byte format, intrasegment ) FORTH DEFINITIONS DECIMAL : DUMP ( addr n --- ) BASE @ >R HEX CR CR 6 SPACES 16 0 DO I 3 .R LOOP 2 SPACES 16 0 DO I 0 <# # #> TYPE LOOP CR OVER + SWAP DUP 15 AND XOR DO CR I 0 5 D.R SPACE I 16 + I 2DUP DO I C@ SPACE 0 <# # # #> TYPE LOOP 2 SPACES DO I C@ DUP 32 < OVER 126 > OR IF DROP 46 THEN EMIT LOOP 16 +LOOP CR R> BASE ! ; ;S ( Save FORTH memory image 12/28/83 ) FORTH DEFINITIONS VARIABLE MEMORY HEX ( --- ) : FREEZE [COMPILE] FORTH DEFINITIONS LATEST 010C ! ( INIT-FORTH ) HERE 0154 ! ( INIT-FENCE ) HERE 0158 ! ( INIT-DP ) VOC-LINK @ 015C ! ; ( INIT-VOC-LINK ) DECIMAL --> ( Save FORTH memory image 01/02/84 ) : SAVE ( --- ) FREEZE CLOSE-SCR SCREEN-FCB DUP 37 ERASE 1+ DUP 11 BLANK BL WORD 1+ SWAP HERE C@ 8 MIN CMOVE LIT" COM" COUNT SCREEN-FCB 9 + SWAP CMOVE 22 SCREEN-FCB ADDR>FDOS DROP 255 AND 255 = IF 7 EMIT ." Can't create COM file." 0 0 FDOS THEN 256 MEMORY ! BEGIN MEMORY @ set-dta 21 SCREEN-FCB ADDR>FDOS DROP 255 AND IF 7 EMIT CR ." Not enough disk space" CR 16 SCREEN-FCB ADDR>FDOS 2DROP 0 0 FDOS THEN MEMORY @ 128 + DUP MEMORY ! HERE SWAP U< UNTIL 16 SCREEN-FCB ADDR>FDOS 2DROP MEMORY @ 256 - CR U. ." bytes written into " SCREEN-FCB .FCB CR 0 0 FDOS ; ( CASE statement by Charles Eaker 02/07/83 ) ( from FORTH DIMENSIONS, II/3 page 37 modified for PC/FORTH+ ) FORTH DEFINITIONS DECIMAL : CASE ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE OVER COMPILE = COMPILE 0BRANCH HERE 0 W, COMPILE DROP 5 ; IMMEDIATE : ENDOF 5 ?PAIRS COMPILE BRANCH HERE 0 W, SWAP 2 [COMPILE] THEN 4 ; IMMEDIATE : ENDCASE 4 ?PAIRS COMPILE DROP BEGIN SP@ CSP @ = 0= WHILE 2 [COMPILE] THEN REPEAT CSP ! ; IMMEDIATE ( Input number from console and leave on stack 02/07/83 ) FORTH DEFINITIONS DECIMAL : #IN ( --- n ) 0 BEGIN KEY DUP 13 = IF DROP EXIT THEN DUP 8 = IF EMIT 32 EMIT 8 EMIT 10 / ELSE DUP 48 < OVER 57 > OR IF DROP 7 EMIT ELSE DUP EMIT 48 - SWAP 10 * + THEN THEN AGAIN ; ( Display stack modified for PC/FORTH+ 02/07/83 ) HEX ( --- ) : .STACK BASE @ >R SP@ S0 @ = IF CR ." <empty stack> " ELSE SP@ S0 @ SWAP DO CR I @ DUP DECIMAL 10 .R HEX ." (" 0 8 D.R ." h)" 4 +LOOP CR THEN R> BASE ! ; DECIMAL ( Source for USING 12/30/83 ) FORTH DEFINITIONS DECIMAL VARIABLE PREV-FILE 64 ALLOT ( --- ) : USING 3 SPACES SCREEN-HANDLE 2+ PREV-FILE 64 CMOVE SAVE-BUFFERS CLOSE-SCR BL WORD OPEN-SCR EMPTY-BUFFERS IF CR ." Can't find " .SCREEN-FILE 7 EMIT CR PREV-FILE OPEN-SCR DROP THEN ." Current screen file - " .SCREEN-FILE CR ; ( Source for LOAD-USING ) ( Load screens from another file, returning control to the ) ( current screen file when finished. Can be used while ) ( LOADing --- e.g. a master LOAD screen can compile from ) ( other screen files, however LOAD-USING's cannot be nested.) ( --- ) : LOAD-USING DEPTH 1 < 1 ?ERROR USING LOAD CLOSE-SCR EMPTY-BUFFERS PREV-FILE OPEN-SCR DROP ; ( misc exact time, ascii and string literals 12/25/83 ) FORTH DEFINITIONS DECIMAL : .T .TIME 58 EMIT @TIME 0 256 UM/MOD 0 <# # # #> TYPE 46 EMIT 0 <# # # #> TYPE DROP SPACE ; : ASCII BL WORD 1+ C@ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE : MYSELF ?COMP LATEST NAME> CFA, ; IMMEDIATE ( recursion) ( Compiling: stores the string preceded by 1-byte count. ) ( Executing: leaves addr of count byte on the stack ) : (LIT") R@ S&O>ADDR DUP C@ 1+ R> + >R ; : LIT" ?COMP COMPILE (LIT") 34 WORD C@ 1+ ALLOT ; IMMEDIATE ;S ( Memory allocation map modified for PC/FORTH+ 02/07/83 ) FORTH DEFINITIONS HEX : H. BASE @ >R HEX 0 4 D.R ." H" R> BASE ! ; : MAP CR CR ." Address of NEXT = " NEXT-LINK H. CR ." Top of dictionary = " DP @ H. CR ." Available room in dictionary = " SP@ DP @ - DECIMAL U. ." bytes" CR ." Base of data stack = " S0 @ H. CR ." Start of terminal input buffer = " TIB H. DECIMAL CR ." Size of terminal buffer = " C/L . ." bytes" CR ." Base of return stack = " R0 @ H. CR ." Size of return stack = " R0 @ S0 @ - . ." bytes" --> ( Memory allocation, continued 02/07/83 ) CR ." Disk buffers available = " #BUFF . CR ." Disk buffer size = " B/BUF . ." bytes" CR ." Disk buffers per screen = " B/SCR . CR CR ; DECIMAL ;S ( Debugging tool to list vocabulary linkages 12/25/83 ) : VOCS CURRENT @ 8 - >NAME CR CR ." Current voc = " .NAME CONTEXT @ 8 - >NAME CR ." Context voc = " .NAME CR ." Default voc = FORTH" BASE @ >R HEX VOC-LINK CR CR ." Defined vocabularies:" CR CR ." link nfa name" BEGIN @ DUP WHILE CR DUP 5 U.R 2 SPACES DUP 10 - >NAME DUP 5 U.R 4 SPACES .NAME REPEAT DROP R> BASE ! CR CR ; ( Quick screen index 08/07/83 ) FORTH DEFINITIONS DECIMAL : QX SAVE-BUFFERS BASE @ >R DECIMAL CR CR 0 BEGIN DUP BLOCK DISK-ERROR @ ?TERMINAL DUP IF KEY DROP THEN OR 0= WHILE OVER 3 .R SPACE 2+ 14 TYPE OUT @ 60 > IF CR ELSE OUT @ 20 MOD 20 SWAP - SPACES THEN 1+ REPEAT EMPTY-BUFFERS DROP DROP CR CR R> BASE ! ; ( Source for DIR 12/28/83 ) HIDDEN DEFINITIONS DECIMAL VARIABLE DIR-FCB 35 ALLOT VARIABLE DIR-FCB2 35 ALLOT 128 CONSTANT DIR-BUFF 20 CONSTANT DIR_WIDTH ( Initialize memory and file control block ) : DIR-INIT 26 DIR-BUFF ADDR>FDOS 2DROP DIR-FCB 37 ERASE BL WORD 1+ DIR-FCB 1 parse-filename DROP DIR-FCB 1+ C@ BL = IF DIR-FCB 1+ 8 ASCII ? FILL THEN DIR-FCB 9 + C@ BL = IF DIR-FCB 9 + 3 ASCII ? FILL THEN ; ( Search for first or next directory entry ) : DIR-SCH-FST 17 DIR-FCB ADDR>FDOS DROP 255 AND ; : DIR-SCH-NXT 18 DIR-FCB ADDR>FDOS DROP 255 AND ; --> ( Source for DIR, continued 12/28/83 ) HEX ( format fully qualified filename from directory entry ) : DIR-PFCB OUT @ 0<> IF 0B3 EMIT THEN 1+ 0B 0 DO I 8 = IF ASCII . EMIT THEN DUP I + C@ DUP 020 > IF DUP 40 > IF 20 OR THEN EMIT ELSE DROP THEN LOOP DROP ; : DIR-DISP DIR-BUFF DIR-PFCB DIR-FCB2 25 ERASE DIR-BUFF DIR-FCB2 0C CMOVE 0F DIR-FCB2 ADDR>FDOS 2DROP DIR-FCB2 10 + DUP W@ SWAP 2+ W@ 10000 * SWAP 0FFFF AND OR 0C OUT @ 14 MOD - SPACES 6 .R ; DECIMAL --> ( Source for DIR, continued 12/28/83 ) ( print file directory for selected or default disk ) FORTH DEFINITIONS DECIMAL : DIR HIDDEN BASE @ >R DECIMAL DIR-INIT DIR-SCH-FST 255 - IF CR CR ." Directory for drive " DIR-BUFF C@ ASCII @ + EMIT ASCII : EMIT CR DIR-DISP BEGIN DIR-SCH-NXT 255 - WHILE DIR-DISP OUT @ 65 > IF CR THEN REPEAT THEN CR CR R> BASE ! FORTH ; ( SHOWC compact screen printer RJW 03/23/84 ) FORTH DEFINITIONS HEX 0C CONSTANT FORMF : ESC-SEQ ( n -- ) 1B EMIT EMIT ; : COMP 0F EMIT ; : -COMP 12 EMIT ; : EMPH 45 ESC-SEQ ; : -EMPH 46 ESC-SEQ ; : ITAL 34 ESC-SEQ ; : -ITAL 35 ESC-SEQ ; : .BANNER -COMP ITAL EMPH CR CR CR ." Laboratory Microsystems PC/FORTH+ " .VERSION 07 SPACES .TIME 2 SPACES .DATE 2 SPACES .SCREEN-FILE -ITAL -EMPH COMP ; : ."SCR#" ." Screen # " ; : .BLK# ( n -- ) ( prints block#'s ) CR CR -COMP ITAL EMPH ."SCR#" DUP S>D <# #S #> DUP >R TYPE R> 1F SWAP - SPACES ."SCR#" 1+ S>D <# #S #> TYPE CR -ITAL -EMPH COMP ; --> ( SHOWC, continued 07/03/83 ) : SHOWC ( from to -- ) 2DUP > IF 2DROP EXIT THEN PRINTER FORMF EMIT 0 ROT ROT 1+ SWAP DO I .BLK# HERE 84 BLANK 400 0 DO J BLOCK I + HERE 40 CMOVE J 1+ BLOCK I + HERE 44 + 40 CMOVE HERE 84 -TRAILING TYPE CR 40 +LOOP 1+ DUP 3 = IF DROP 0 .BANNER FORMF EMIT THEN 2 +LOOP ?DUP IF 3 SWAP - 13 * 0 DO CR LOOP .BANNER THEN -COMP FORMF EMIT CONSOLE ; DECIMAL ;S ( Redefinition of COLON compiling word 07/03/83 ) HEX ( this version of : does not allow colon definitions to ) ( straddle the 64 kbyte boundary, which can cause the ) ( system to crash ) : : ?EXEC HERE 010001 < HERE 0FC00 > AND IF 10001 DP ! THEN [COMPILE] : ; IMMEDIATE ( index list 12/25/83 ) HEX : INDEX SAVE-BUFFERS DEPTH 2 < 1 ?ERROR ?DECIMAL ?DEVICE IF 0C EMIT THEN CR 1+ SWAP DO CR I 3 .R SPACE 0 I .LINE ?TERMINAL DUP IF KEY DROP THEN DISK-ERROR @ DUP IF EMPTY-BUFFERS THEN OR IF LEAVE THEN LOOP CR ; : LIST DEPTH 1 < 1 ?ERROR ?DECIMAL ?DEVICE IF CR ELSE CLEARSCREEN THEN DUP SCR ! ." Screen # " . 10 0 DO CR I 3 .R SPACE I SCR @ .LINE LOOP CR ; ;S ( triad show 03/23/84 ) HEX : TRIAD DEPTH 1 < 1 ?ERROR ?DECIMAL ?DEVICE IF 0C EMIT THEN 3 / 3 * 3 OVER + SWAP DO CR I LIST LOOP CR CR 0 OUT ! ." Laboratory Microsystems PC/FORTH+ " .VERSION 2E OUT @ - SPACES .TIME 2 SPACES .DATE 2 SPACES .SCREEN-FILE CR ; : SHOW DEPTH 2 < 1 ?ERROR ?DECIMAL PRINTER 1+ SWAP DO I TRIAD ?TERMINAL IF KEY DROP LEAVE THEN 3 +LOOP CONSOLE ; ;S ( Words 12/25/83 ) HEX : WORDS BASE @ >R HEX CR CR CONTEXT @ LINK@ ?DUP IF BEGIN DUP DUP 0 <# # # # # # #> TYPE DUP 1+ C@ IF SPACE .NAME ELSE ." null" DROP THEN OUT @ 3C > IF CR 0 OUT ! ELSE 14 OUT @ OVER MOD - SPACES THEN N>LINK LINK@ DUP 0= ?TERMINAL DUP IF KEY DROP THEN OR UNTIL DROP ELSE ." Empty vocabulary." THEN CR CR R> BASE ! ; ( multitasker 12/25/83 ) DECIMAL ( display names of active tasks ) : .TASKS CLEARSCREEN ." Active tasks:" #TASKS 0 DO I 4 * TASK_LIST + @ ?DUP IF 0 I 2+ GOTOXY I 1+ 2 .R 2 SPACES >NAME .NAME THEN LOOP CR CR ; --> ( multitasker 12/25/83 ) : KILL BL WORD FIND REVERSE HERE COUNT TYPE REVERSE-OFF IF FIND-TASK IF DUP 4 + SWAP TASK_LIST #TASKS 1+ 4 * + 2 PICK - CMOVE ." --- removed from task list" ELSE ." --- not in task list" THEN ELSE ." --- not in dictionary" THEN CR ; : KILL-TASKS TASK_LIST #TASKS 4 * ERASE ; --> ( multitasker 12/25/83 ) : START ( --- ) BL WORD FIND REVERSE HERE COUNT TYPE REVERSE-OFF IF 0 FIND-TASK IF ! ( *** store CFA into task table *** ) ." --- added to task list" ELSE ." --- too many tasks" DROP THEN ELSE ." --- not in dictionary" THEN CR ; ;S ( MSDOS Change subdirectory command 12/28/83 ) ( --- ; used in the form CHDIR name ) : CHDIR BL WORD 0 OVER DUP C@ + 1+ C! chdir CASE -1 OF CR ." Need PC-DOS 2.0 " ENDOF 0 OF CR ." Current directory is " HERE COUNT TYPE ENDOF ( default case ) CR ." Path not found" ENDCASE CR CR ; ( MSDOS Change disk command 12/28/83 ) DECIMAL ( used in the form: CHDISK unit ) : CHDISK BL WORD 1+ C@ ASCII A - 0 MAX 63 MIN DUP 14 SWAP FDOS DROP 255 AND >= IF CR ." Illegal drive." CR THEN ; ( Double precision extensions 01/04/83 ) : 2VARIABLE CREATE 0 , 0 , DOES> ; : 2CONSTANT CREATE HERE 2! 8 ALLOT DOES> 2@ ; : D* ( d u --- d ) DUP ROT * ROT ROT UM* ROT + ; : D/ ( d u --- d ) SWAP OVER /MOD >R SWAP UM/MOD SWAP DROP R> ; : D<= D> NOT ; : D>= D< NOT ; --> ( Double precision extensions 01/04/83 ) : 2OVER 3 PICK 3 PICK ; : 2ROT 5 ROLL 5 ROLL ; : D0= OR 0= ; : DU< ROT SWAP 2DUP U< IF 4DROP -1 ELSE <> IF 2DROP 0 ELSE U< THEN THEN ; : DMIN 2OVER 2OVER D> IF 2SWAP THEN 2DROP ; : DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; ;S
