This file contains a number of tools needed by me. It is catalogued in NEED.DIR These routines are for information only. Some are good and some aren't. My TOOLS.BLK changes all the time but I thought some examples were worthwhile. My F83 is a direct threaded version I wrote. This is pretty transparent to even CODE routines. BUT: I keep the top of the parameter stack in BX. If you try to use any CODE routine from here put a BX POP at the beginning and a BX PUSH just before NEXT. (This version is about twice as fast as the original.) Gary Bergstrom (216)-247-2492 9am -> 10pm ( CASE statement by Charles Eaker modified for F83 ) ( from FORTH DIMENSIONS, II/3 page 37 ) NEED ?COMP : CASE ?COMP CSP @ SP@ CSP ! 4 ; IMMEDIATE : OF 4 ?PAIRS COMPILE OVER COMPILE = COMPILE ?BRANCH HERE 0 , COMPILE DROP 5 ; IMMEDIATE : ENDOF 5 ?PAIRS COMPILE BRANCH HERE 0 , SWAP >RESOLVE 4 ; IMMEDIATE : ENDCASE 4 ?PAIRS COMPILE DROP BEGIN SP@ CSP @ = 0= WHILE >RESOLVE REPEAT CSP ! ; IMMEDIATE ( CASE 5/29/81 ) NEED ?COMP NEED ?PAIRS : COND ?COMP CSP @ !CSP 4 ; IMMEDIATE : (( 4 ?PAIRS COMPILE ?BRANCH HERE 0 , 5 ; IMMEDIATE : )) 5 ?PAIRS COMPILE BRANCH HERE 0 , SWAP >RESOLVE 4 ; IMMEDIATE : ENDCOND 4 ?PAIRS BEGIN SP@ CSP @ = 0= WHILE >RESOLVE REPEAT CSP ! ; IMMEDIATE EXIT Example: : TEST KEY COND DUP ASCII A ASCII Z WITHIN (( DO-LETTER )) DUP ASCII a ASCII z WITHIN (( DO-LOWER )) DUP 10 = (( DO-LF )) TRUE ( else ) (( DO-ERROR )) ENDCASE ; ( CTABLE ) DEFER ?, ( COMMA HOW MUCH? ) : PARSE-LIST ( N1 N2 N3 ... Nm ; ) BEGIN DEFINED DROP ['] ; = NOT WHILE 'WORD NUMBER ?, REPEAT ; : CHAR, DROP C, ; : CTABLE ( N1 N2 N3 ; ) CREATE ['] CHAR, IS ?, PARSE-LIST DOES> + C@ ; \ example: CTABLE REVERSE 9 8 7 6 5 4 3 2 1 0 ; : 16BIT, DROP , ; : TABLE CREATE ['] 16BIT, IS ?, PARSE-LIST DOES> SWAP 2* + @ ; : 32BIT, , , ; : DTABLE CREATE ['] 32BIT, IS ?, PARSE-LIST DOES> SWAP 2* 2* + 2@ ; ( 8 BIT QUEUE STRUCTURES GEB 4/7/85 ) \ NEED { ( lock out interrupts ) CODE NQ ( char addr -- ) DX POP BX DI MOV ( { ) 2 [DI] BX MOV DX 6 [BX+DI] MOV BX INC BX INC 0 [DI] BX AND BX 2 [DI] MOV ( } ) BX POP NEXT END-CODE CODE DQ? ( addr -- char true / false ) BX DI MOV ( { ) 4 [DI] BX MOV 2 [DI] BX CMP 0= IF ( }) BX BX XOR NEXT ELSE 6 [BX+DI] CX MOV BX INC BX INC 0 [DI] BX AND BX 4 [DI] MOV ( } ) CX PUSH 1 # BX MOV THEN NEXT END-CODE CODE Q? ( addr -- f f=0 means no chars ) BX DI MOV ( {) 4 [DI] BX MOV 2 [DI] BX SUB ( } ) NEXT END-CODE --> ( MORE QUEUE ) \ que 16 BIT POINTERS AND DATA \ structure: mask - into loc - from loc - data bytes \ mask is for wrap around of circular buffer : QUE: ( count=power of 2 eg 8,32,128 -- \ name ) CREATE DUP 1- 2* , 2* 4 + ALLOT ; : QFULL? ( addr -- f=1 means not full ) 2+ LENGTH SWAP @ = ; : QINIT ( addr -- ) 2+ >R 0. R> 2! ; : (QTYPE) ( addr -- ) PAD OFF >R BEGIN R@ DQ? WHILE PAD COUNT + C! PAD C@ 1+ PAD C! REPEAT R> DROP PAD COUNT ; : QTYPE ( addr -- ) (QTYPE) TYPE ; : >Q ( addr length addrq -- ) -ROT 0 ?DO DUP I + C@ 2 PICK NQ LOOP 2DROP ; ( SETS GEB 5/28/85 ) : SET: CREATE >IN @ BL WORD 1+ C@ SWAP >IN ! WORD C@ 1+ ALLOT DOES> ( char -- pos#/0 ) COUNT OVER >R BOUNDS ?DO I C@ OVER = IF DROP I R> R> 2DROP R> DROP R> - 1+ EXIT THEN LOOP R> 2DROP 0 ; SET: NUMERAL? /1234567890/ SET: NUMBER? /-1234567890/ SET: UPPER? /ABCDEFGHIJKLMNOPQRSTUVWXYZ/ SET: LOWER? /abcdefghijklmnopqrstuvwxyz/ SET: MATH? \+-*/\ SET: LETTER? /ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/ \ WARNING ONLY 1 SPACE IS ALLOWED BEFORE THE FIRST DELIMITER ( GREATEST COMMON DIVISOR ) : GCD BEGIN ?DUP WHILE TUCK MOD REPEAT ; ( NEW TEXT FORMATTER SEE DIMENSIONS IV #3 ) 7 CONSTANT LMARGIN 75 CONSTANT RMARGIN 4 CONSTANT TMARGIN 60 CONSTANT BMARGIN VARIABLE XTRA ( INDENT AMOUNT ON AUTO CR'S ) VARIABLE X-POS VARIABLE Y-POS ( TOP IS 0 ) VARIABLE SPACING ( 0=SINGLE 1=DOUBLE ) : skip ( N) DUP SPACES X-POS +! ; : line ( BEGIN NEW LINE AT APROPRIATE LEFT MARGIN ) 0 X-POS ! CR 1 Y-POS +! SPACING @ IF 1 Y-POS +! CR THEN LMARGIN XTRA @ + skip ; : start ( BEGIN PAGE AT TOP MARGIN; USE AT START ) 0 Y-POS ! TMARGIN 0 DO line LOOP ; --> ( MORE FORMATTER ) VARIABLE H-INDENT 5 H-INDENT ! : newpage ( BEGIN NEXT PAGE ) CR F/F start ; : cr ( BEGIN NEXT LINE; IF AT BOTTOM THEN F/F ) Y-POS @ BMARGIN > IF newpage ELSE line THEN ; : crs ( N ..) 0 DO cr LOOP ; : pp ( 2 cr'S) cr cr ; : tab ( N .. skip TO POSITION N RELATIVE TO LEFT MARGIN ) X-POS @ LMARGIN - - 1 MAX skip ; : indent ( N .. TAB AND RESET LMARGIN ) DUP tab XTRA ! ; : h-indent ( N .. INDENT, SUBSEQUENT LINES INDENT INDENT MORE) indent H-INDENT @ XTRA +! ; : single 0 SPACING ! ; : double 1 SPACING ! ; --> ( MORE FORMATTER ) : reset 0 XTRA ! ; ( RESET INDENT TO LMARGIN ) : type ( C .. PRINT TEXT TO DELIMITER C WITHIN MARGINS ) BEGIN BL WORD C@ 1 = IF HERE 1+ C@ OVER = IF 0 ELSE 1 THEN ELSE 1 THEN WHILE HERE C@ X-POS @ + RMARGIN > IF cr THEN HERE COUNT DUP 1+ X-POS +! TYPE SPACE PAUSE REPEAT DROP ; : [ ASCII ] type ; : < ASCII > type ; --> ( MORE FORMATTER ) : center[ ( CENTER BETWEEN MARGINS ) >IN @ RMARGIN LMARGIN - 5 + ASCII ] WORD C@ - 2/ tab >IN ! [ ; : r[ ( N .. RIGHT JUSTIFY IN A FIELD ) >IN @ SWAP ASCII ] WORD C@ - 0 MAX skip >IN ! [ ; : par[ SPACING @ IF cr ELSE pp THEN 5 tab [ ; DECIMAL : date[ double start cr 40 tab [ ; : greeting[ pp [ ; : closing pp single 40 tab ." Sincerely, " 4 crs 40 tab ." Gary Bergstrom " cr 40 tab ." 191 Miles Rd." cr 40 tab ." Chagrin Falls, OH 44022" ; \ ALIAS : IMMEDIATE? ( nfa -- f f<>0 if def. is immediate ) HEAD-SEG LC@ 64 AND ; : ALIAS CREATE IMMEDIATE DEFINED 0= ABORT" Not found" , DOES> @ STATE @ IF DUP >NAME IMMEDIATE? IF EXECUTE ELSE , THEN ELSE EXECUTE THEN ; \ TAB 18FEB86GEB: TAB ( n -- ) #OUT @ - 0 MAX SPACES ; ( TO VARIABLE ) VARIABLE %TO NEED CASE : (FROM) %TO OFF ; : LOC 1 %TO ! ; : -> 2 %TO ! ; : +TO 3 %TO ! ; : INTEGER CREATE 0 , DOES> %TO @ CASE 0 OF @ ENDOF \ 1 OF (FROM) ENDOF 2 OF ! (FROM) ENDOF 3 OF +! (FROM) ENDOF ENDCASE ; \ file compare NEED BLINK : =FILE ( lo hi -- ) 1+ SWAP DO I BLOCK I IN-BLOCK 1024 COMPARE IF I I BLINK THEN LOOP ; \ ARRAY AND CARRAY : ARRAY ( n <name> -- ) ( n -- addr ) \ starts with element 0 CREATE 1+ 2* ALLOT DOES> SWAP 2* + ; : CARRAY ( n <array> -- ) ( n -- addr ) CREATE 1+ ALLOT \ DOES> + ; ;CODE AX POP AX BX ADD NEXT END-CODE : DARRAY ( n <array> -- ) ( n -- addr ) CREATE 1+ 4 * ALLOT DOES> SWAP 2* 2* + ; \ +STRING : +STRING ( char addr.count -- ) DUP >R COUNT + C! R@ C@ 1+ R> C! ; \ ?COMP and ?PAIRS : ?COMP STATE @ NOT ABORT" Must be compiling" ; \ 2DCASE: 22FEB86GEB : 2DCASE: ( #rows #cols -- ) CREATE OVER C, DUP C, * 0 DO DEFINED 0= ABORT" NOT FOUND" , LOOP DOES> ( row# col# -- ) >R OVER R@ 1+ C@ * OVER + 2* -ROT SWAP R@ C@ U< NOT ABORT" ROW TOO BIG" R@ 1+ C@ U< NOT ABORT" COLUMN TOO BIG" R> 2+ + @ EXECUTE ; \ STRING WRITE : .STRING ( addr count -- ) \ string must terminate with a $ DROP 9 BDOS DROP ; : (.STRING) R> COUNT 2DUP + 1+ EVEN >R .STRING ; : DOS." ( --> string " ) \ state smart STATE @ IF COMPILE (.STRING) ," ASCII $ C, ALIGN ELSE ASCII " WORD COUNT PAD PLACE PAD COUNT 2DUP + ASCII $ SWAP C! .STRING THEN ; IMMEDIATE \ some utilities for display NEED LMOVE CREATE ENVIRONMENT $200 ALLOT CODE LFILL ( addr seg # char -- ) CLD ES AX MOV BX AX MOV CX POP ES POP DI POP REP AL STOS AX ES MOV BX POP NEXT END-CODE : LDUMP ( addr seg # -- ) DUP 1000 > ABORT" TOO BIG TO DUMP" >R PAD 100 + CSEG R@ LMOVE PAD 100 + R> DUMP ; \ ENVIRONMENT SUPPORT NEED +STRING VARIABLE 'ENVIR VARIABLE 'ONE.STR 60 ALLOT : @ONE.STRING 'ONE.STR 50 ERASE \ init pad to no string BEGIN 'ENVIR @ $2C @ LC@ 1 'ENVIR +! ?DUP WHILE 'ONE.STR +STRING REPEAT ; : .ENVIR \ print the current environment 'ENVIR OFF CR BEGIN @ONE.STRING 'ONE.STR COUNT ?DUP WHILE TYPE CR REPEAT DROP ; --> \ ENVIRONMENT SUPPORT VARIABLE S.BUFFER 40 ALLOT : ?ENVIR ( addr count -- addr.string length or 0 ) S.BUFFER PLACE 'ENVIR OFF BEGIN @ONE.STRING 'ONE.STR COUNT WHILE S.BUFFER COUNT CAPS-COMP 0= IF 'ONE.STR COUNT S.BUFFER C@ 1+ /STRING EXIT THEN REPEAT DROP 0 ; --> \ secondary command processor VARIABLE STACK.SEG VARIABLE STACK.POINTER CODE DOS.EXEC ( s.addr pb.addr -- f=error code ) DX POP DS PUSH ES PUSH PUSHF DI PUSH SI PUSH BP PUSH SS STACK.SEG #) MOV SP STACK.POINTER #) MOV $4B00 # AX MOV $21 INT CS: STACK.SEG #) SS MOV CS: STACK.POINTER #) SP MOV BP POP SI POP DI POP POPF ES POP DS POP C=1 IF AX BX MOV ELSE 0 # BX MOV THEN NEXT END-CODE --> \ more dos.exec 2 /20/88: MAKE-FCB ( -- fcb1 fcb2 ) \ MAKE DUMMY FCB'S 0 PAD C! PAD 1+ BL 11 FILL PAD 13 + 25 ERASE 0 PAD 50 + C! PAD 51 + BL 11 FILL PAD 63 + 25 ERASE PAD PAD 50 + ; CREATE BLCR 1 C, BL C, $0D C, CREATE DOS.BLOCK 0 , BLCR , 0 , MAKE-FCB , 0 , , 0 , : 'COMMAND.COM ( -- addr ) " COMSPEC" ?ENVIR DUP 0= ABORT" DOS ERROR" [ DOS ] >ASCIZ ; : COMMAND.COM HIDE.CURSOR FULL.SCREEN IBM DARK 0 0 AT $2C @ DOS.BLOCK ! CSEG DOS.BLOCK 4 + ! CSEG DOS.BLOCK 8 + 2DUP ! 4 + ! CR ." Type EXIT to return to FORTH " 'COMMAND.COM DOS.BLOCK DOS.EXEC ?DUP IF . TRUE ABORT" DOS ERROR" THEN [ WINDOW ] CLOSE.WINDOW M.SETUP TEXT/CURSOR CR MULTI THE DOS 'PATH ON ; \ >graphics 6 /13/88: MSG 6 6 40 3 $3A00 $900 OW CR ." Type DONE <cr> to return " 1500 MS CLOSE ; : >GRAPHICS HIDE.CURSOR FULL.SCREEN >VMODE DARK 0 0 AT TEXT/CURSOR ; : >HIRES msg 6 >GRAPHICS ; : >COLOR msg 4 >GRAPHICS ; : >EGA ( msg ) 16 >GRAPHICS ; CODE DOT ( X Y COLOR -- ) BL AL MOV 12 # AH MOV BX BX SUB DX POP CX POP 16 INT BX POP NEXT END-CODE CODE @DOT ( X Y -- COLOR ) 13 # AH MOV BX DX MOV CX POP 16 INT BH BH SUB AL BL MOV NEXT END-CODE \ vga support 1 /12/89variable palette 15 allot CODE @PALETTE ( -- ) $1009 # AX MOV PALETTE # DX MOV $10 INT NEXT END-CODE \ BLK TO ASCII CONVERTER NEED FILE[ : BLK>ASCII ( TO FROM -- ) ?DO I L/SCR 0 DO DUP IN-BLOCK I C/L * + C/L -TRAILING FILE[ >TYPE CR ]FILE LOOP DROP KEY? ?LEAVE LOOP ; \ LONG MOVE ROUTINE CODE LMOVE ( from: addr seg to: addr seg #bytes -- ) \ #bytes <= 64K BX CX MOV ( count ) CLD IP BX MOV ES POP DS DX MOV DI POP DS POP IP POP REP BYTE MOVS DX DS MOV BX IP MOV BX POP NEXT END-CODE \ PLAY WITH THE SCREEN COLORS VARIABLE SCRN $6 SCRN ! VARIABLE EDGE $17 EDGE ! : TOW 10 5 20 10 SCRN @ 256 * EDGE @ 256 * OW ; : TEST BEGIN TOW ." SCREEN= " SCRN @ 256 * U. CR ." EDGE = " EDGE @ 256 * U. CR KEY CASE 200 OF 1 SCRN +! ENDOF 208 OF -1 SCRN +! ENDOF 203 OF -1 EDGE +! ENDOF 205 OF 1 EDGE +! ENDOF $0D OF DONE EXIT ENDOF ENDCASE DONE AGAIN ; \ SIMPLE TERMINAL PROGRAM : TERM2 ( COM2 PORT ) BEGIN KEY? IF KEY $1B OVER = IF QUIT THEN >COM2 THEN $300 COM2 COMn $0100 AND IF COM2> EMIT THEN AGAIN ; \ dos int 21 call CODE DOS2 ( dx cx bx ax -- ax2 Negative return if err ) BX AX MOV BX POP CX POP DX POP $21 INT U< IF ( carry flag means error ) AX NEG THEN AX BX MOV NEXT END-CODE \ interrupt service handling DOS 2.x+ CODE @INT ( int# -- addr seg ) \ return int vector BX AX MOV $35 # AH MOV $21 INT BX PUSH ES BX MOV NEXT END-CODE CODE !INT ( addr seg int# -- ) DS CX MOV BL AL MOV $25 # AH MOV DS POP DX POP $21 INT CX DS MOV BX POP NEXT END-CODE \ ?KEY QUEUED KEYSTROKES NEED QUE: 128 QUE: KEYQUE KEYQUE QINIT : ?KEY (KEY?) IF (KEY) DUP $0CF = IF CR ." RESTART!" QUIT THEN KEYQUE NQ THEN ; : QKEY? ?KEY KEYQUE Q? ; : QKEY BEGIN ?KEY KEYQUE DQ? UNTIL ; : QEMIT ?KEY (EMIT) ; : KEYQ KEYQUE QINIT ['] QKEY? IS KEY? ['] QKEY IS KEY ['] QEMIT IS EMIT ; : NOQ ['] (KEY?) IS KEY? ['] (KEY) IS KEY ['] (EMIT) IS EMIT ; \ Display the WORDS in the Context Vocabulary 07Feb84map: WORDS (S -- ) CR LMARGIN @ SPACES CONTEXT @ HERE #THREADS 2* CMOVE BEGIN HERE #THREADS LARGEST DUP WHILE DUP L>NAME DUP C@ 31 AND ?LINE .ID SPACE SPACE @ SWAP ! REPEAT 2DROP ; \ control c handler NEED @INT HEX CSEG 103 23 !INT DECIMAL \ ALTERNATE COLORS NEED >HIRES CODE (COLORA) BX PUSH $B00 # AX MOV $100 # BX MOV 16 INT BX POP NEXT END-CODE : >COLORA >COLOR (COLORA) ; \ quad variables : QVARIABLE VARIABLE 6 ALLOT ; CODE Q@ ( a -- q ) 6 [BX] PUSH 4 [BX] PUSH 2 [BX] PUSH 0 [BX] BX MOV NEXT END-CODE CODE Q! ( q a -- ) 0 [BX] POP 2 [BX] POP 4 [BX] POP 6 [BX] POP BX POP NEXT END-CODE \ "array and "month , "day : "ARRAY ( compile: string-length -- ) ( run: -- a n ) CREATE C, ASCII " WORD COUNT >R HERE R@ MOVE R> ALLOT DOES> COUNT >R SWAP R@ * + R> ; \ WARNING!!! there must be only one space between the \ name and the quoted string \ eg 3 "ARRAY test " abc" \ not 3 "ARRAY test " abc" 3 "ARRAY "MONTH "JanFebMarAprMayJunJulAugSepOctNovDec" 3 "ARRAY "DAY "SunMonTueWedThuFriSat" \ TIME AND DATE NEED "DAY CODE @DATE ( -- year day month ) BX PUSH $2A00 # AX MOV $21 INT CX PUSH ( year ) DH BL MOV DH DH XOR DX PUSH ( day ) BH BH XOR NEXT END-CODE : .DATE @DATE 1- "MONTH TYPE SPACE 0 .R ." , " . ; CODE @TIME ( -- hund sec min hour ) BX PUSH $2C00 # AX MOV $21 INT DL BL MOV BH BH XOR BX PUSH ( hund ) DH DL MOV DH DH XOR DX PUSH ( sec ) CH BL MOV CH CH XOR CX PUSH ( min ) BH BH XOR NEXT END-CODE : ## ( n -- ) 0 <# # # #> TYPE ; : .TIME @TIME ## ." :" ## ." :" ## SPACE DROP ; \ NEW FOOTING FOR SHOW NEED .DATE : DATE.FOOT CR CR 15 SPACES ." DTC F83 Copyright 1988 by Gary Bergstrom" 20 SPACES .DATE 5 SPACES .TIME PAGE ; ALSO HIDDEN ' DATE.FOOT IS FOOTING PREVIOUS \ simple highlighting & print screen CODE INVERT (S addr -- ) DS DX MOV $B800 # AX MOV AX DS MOV 4 # CX MOV HERE 255 # 0 [BX] XOR 255 # $2000 [BX] XOR 80 # BX ADD LOOP DX DS MOV BX POP NEXT END-CODE : HILIGHT (S col row #chars -- ) >R DUP 0 24 WITHIN IF 320 * + R> BOUNDS ?DO I INVERT LOOP ELSE R> 2DROP DROP THEN ; CODE PRINT.SCREEN BP PUSH 5 INT BP POP NEXT END-CODE \ bound ( n1 lo hi -- lo<= n2 <= hi ) CODE BOUND ( n1 lo hi -- lo <= n2 <= hi ) CX POP AX POP AX BX CMP > IF AX BX MOV THEN BX CX CMP > IF CX BX MOV THEN NEXT END-CODE \ set raw output mode CODE RAW BX PUSH 1 # BX MOV $4400 # AX MOV $21 INT \ get STD OUT handle DH DH XOR $20 # DL OR \ set raw bit 1 # bx mov $4401 # AX MOV $21 INT BX POP NEXT END-CODE CODE COOKED BX PUSH 1 # BX MOV $4400 # AX MOV $21 INT \ get STD OUT handle DH DH XOR $0DF # DL AND \ clear raw bit 1 # BX mov $4401 # AX MOV $21 INT BX POP NEXT END-CODE CODE TEST BX PUSH 1 # BX MOV $4400 # AX MOV $21 INT \ get STD OUT handle DH DH XOR DX BX MOV NEXT END-CODE \ ANSI COLOR SET : >COLORS ( foreground background -- ) 27 EMIT ASCII [ EMIT 0 .R ASCII ; EMIT 0 .R ASCII m EMIT ; : >GREEN 40 32 >COLORS ; \ GREEN ON BLACK BACKGROUND : >AMBER 33 40 >COLORS ; \ AMBER ON BLACK BACKGROUND EXIT COLOR SET: FORGROUND COLOR BACKGROUND 30 black 40 31 red 41 32 green 42 33 yellow 43 34 blue 44 35 magenta 45 36 cyan 46 37 white 47 \ VECTOR + CODE V+ ( x y deltax deltay -- x' y' ) \ almost like D+ CX POP AX POP AX BX ADD AX POP AX CX ADD CX PUSH NEXT END-CODE \ Cursor Routines for IBM PC Bios 3 /17/88exit - not needed CODE (IBM-DARK) (S left right top bottom -- ) BL DH MOV BX POP BL CH MOV BX POP BL DL MOV BX POP BL CL MOV BP PUSH 0 # BH MOV $600 # AX MOV 16 INT BP POP BX POP NEXT END-CODE : IBM-DARK 0 79 0 24 (IBM-DARK) ; \ INTERVAL TIMER NEED .DATE 2VARIABLE 'TIMER : MU* ( ud un -- ud*un ) DUP >R UM* DROP 0 ROT R> UM* D+ ; : HMS>DS ( hun s m hour -- d.hundredths of sec ) 60 UM* ROT 0 D+ 60 MU* ROT 0 D+ 100 MU* ROT 0 D+ ; : TIME? ( -- d.hundredths of sec ) @TIME HMS>DS ; : START[ TIME? 'TIMER 2! ; : ]STOP ( -- d.hund) TIME? 'TIMER 2@ D- ; : TIMER ( -- ) START[ INTERPRET ]STOP D. ; \ BLINK CODE (>PAGE) ( n -- ) \ set text page number BL AL MOV 5 # AH MOV $10 INT BX POP NEXT END-CODE : >PAGE ( n -- ) DUP DSCR# C! (>PAGE) ; VARIABLE BLINK.SPEED 60 BLINK.SPEED ! : (BLINK) BEGIN 0 >PAGE BLINK.SPEED @ MS KEY? NOT WHILE 1 >PAGE BLINK.SPEED @ MS REPEAT KEY DROP ; : BLINK ( from.scr scr -- ) 2DUP - HOPPED ! HIDE.CURSOR [ QUICK ] FULL.SCREEN DARK 0 0 AT SINGLE FILE @ >R IN-FILE @ >R [ ALSO DOS ] R@ !FILES 0 >PAGE DARK 0 0 AT LIST R> R> SWAP >R !FILES 1 >PAGE DARK 0 0 AT LIST (BLINK) 0 20 AT R> IN-FILE ! DONE MULTI SHOW.CURSOR ; : BN ( blink next ) 1 SCR +! SCR @ DUP HOPPED @ + BLINK ; \ TESTING AREA FOR PLAYING WITH FAR DATA 29JAN86GEB: L2! ( d a seg -- ) 2DUP >R >R L! R> 2+ R> L! ; : L2@ ( a seg -- d ) 2DUP >R >R L@ R> 2+ R> L@ SWAP ; \ ANSI COLOR SET : >COLORS ( foreground background -- ) 27 EMIT ASCII [ EMIT 0 .R ASCII ; EMIT 0 .R ASCII m EMIT ; : >AMBER 33 40 >COLORS ; \ AMBER ON BLACK BACKGROUND >AMBER FORGET >COLORS EXIT COLOR SET: FORGROUND COLOR BACKGROUND 30 black 40 31 red 41 32 green 42 33 yellow 43 34 blue 44 35 magenta 45 36 cyan 46 37 white 47 \ MENU INPUT AND CALL ROUTINE - NUMBERS : ENTER ( -- d f ) QUERY BL WORD NUMBER? ; : ENTER.WINDOW ( -- ) 5 10 45 1 $600 $100 OW ; : GET ( addr len -- d ) ENTER.WINDOW BEGIN 2DUP DARK TYPE ENTER 0= WHILE 2DROP BEEP CR REPEAT 2SWAP 2DROP DONE ; : GET: ( -- ) \ GET: NEW-IT DO-IT " INPUT QUESTION " \ WHERE DO-IT TAKES A NUMBER CREATE ' , ASCII " PARSE 2DROP ," DOES> LENGTH SWAP COUNT GET DROP SWAP EXECUTE ; EXIT USAGE: GET: NAME ROUTINE-TO-DO " PROMPT STRING " NAME GET IS NON-DEFINING VERSION \ INTERRUPT LOCKING ALSO ASSEMBLER DEFINITIONS : { PUSHF CLI ; \ lock out ints : } POPF ; \ restore ints PREVIOUS DEFINITIONS ALSO CODE { BX PUSH { BX POP NEXT END-CODE CODE } BX PUSH } BX POP NEXT END-CODE PREVIOUS \ 4DROP CODE 4DROP BX POP BX POP BX POP BX POP NEXT END-CODE \ LONG ARRAYS TO SYTLE NEED INTEGER CAPS OFF : LARRAY 16 + 8 / allocate.memory ABORT" Memory error" CREATE , DOES> SWAP 2* SWAP @ %TO @ CASE 0 OF L@ ENDOF 1 OF (FROM) ENDOF 2 OF L! (FROM) ENDOF 3 OF 2DUP >R >R L@ + R> R> L! (FROM) ENDOF TRUE ABORT" TO VAR ERROR !" ENDCASE ; CAPS ON \ SPLIT WORD INTO BYTES CODE SPLIT ( n -- lsb msb ) AH AH SUB BL AL MOV AX PUSH BH BL MOV BH BH SUB NEXT END-CODE \ U*/ CODE U*/ (S n1 un2 un3 -- n1*n2/n3 ) AX POP CX POP CX PUSH ( save sign ) CX CX TEST 0< IF CX NEG THEN CX MUL BX DIV AX BX MOV AX POP AX AX TEST 0< IF BX NEG THEN NEXT END-CODE CODE UU*/ (S un1 un2 un3 -- n1*n2/n3 ) AX POP CX POP CX MUL BX DIV AX BX MOV NEXT END-CODE \ signed and unsigned scaling by unsigned factors \ NEWER .S : (.S) >R >R >R 11 4 40 DEPTH 1- 12 MIN $3900 $3900 OW ." TOP OF STACK" DEPTH 10 MIN 0 MAX ?DUP IF 0 DO 20 I AT I PICK 7 U.R LOOP 0 DEPTH 11 MIN AT ." Depth= " DEPTH . ELSE 20 0 AT ." empty" THEN WWAIT R> R> R> ; ' (.S) 188 2* 255 AND CC2 @ + ! ( PATCH TO F2 ) \ 2>R 2R> 2R@ 4R> 4>R CODE 2>R RP DEC RP DEC BX 0 [RP] MOV RP DEC RP DEC 0 [RP] POP BX POP NEXT END-CODE CODE 2R> BX PUSH 0 [RP] PUSH RP INC RP INC 0 [RP] BX MOV RP INC RP INC NEXT END-CODE CODE 2R@ BX PUSH 0 [RP] PUSH 2 [RP] BX MOV NEXT END-CODE CODE 4>R AX POP CX POP DX POP RP SP XCHG DX PUSH CX PUSH AX PUSH BX PUSH RP SP XCHG BX POP NEXT END-CODE CODE 4R> BX PUSH RP SP XCHG BX POP AX POP CX POP DX POP RP SP XCHG DX PUSH CX PUSH AX PUSH NEXT END-CODE CODE 4R@ BX PUSH 6 [RP] PUSH 4 [RP] PUSH 2 [RP] PUSH 0 [RP] BX MOV NEXT END-CODE \ IF& : THEN& ; : ELSE& ASCII & WORD DROP ; : IF& 0= IF ELSE& THEN ; exit interpreter IF,ELSE,THEN words IF& checks a flag and if false it skips to the next & Only limitation is that there can not be imbedded &'s example: DEFINED? 3DROP IF& DROP ELSE& DROP : 3DROP 2DROP DROP ; THEN& \ UWITHIN : UWITHIN (S n1 n2 n3 -- f ) \ true if n1<=n2<=n3 >R OVER U> IF R> 2DROP FALSE ELSE R> U> NOT THEN ; EXIT Note that this is not exactly an unsigned WITHIN \ FASTER CGA DOT ROUTINE $B800 CONSTANT CGA CODE !DOT ( x y color -- ) DX DX XOR BL DH MOV DX ROR DX ROR $00C0 # DX AND 5 # AL MOV BX POP ( y ) BX ROR C=1 IF BL MUL $200 # AX ADD ELSE BL MUL THEN CGA # AX ADD ( LINE ADDR IN AX ) BX POP DS PUSH AX DS MOV ( DS HAS SEG ) $00C0 # AX MOV BX CX MOV 3 # CX AND CX SHL DX CL SHR AX CL SHR 255 # AL XOR BX SHR BX SHR 0 [BX] AL AND DL AL OR AL 0 [BX] MOV DS POP BX POP NEXT END-CODE \ TYPE TO A FILE VARIABLE TEMP-TYPE : FILE[ ['] TYPE >IS @ TEMP-TYPE ! ['] FILE-TYPE IS TYPE ; : ]FILE TEMP-TYPE @ IS TYPE ; \ K CODE K (S -- n ) BX PUSH 12 [RP] BX MOV 14 [RP] BX ADD NEXT END-CODE DECIMAL \ BETTER SCROLL ROUTINE CODE +SCROLL ( tlx tly brx bry -- ) $601 # AX MOV ( one line function 6 ) BL DH MOV BX POP BL DL MOV BX POP BL CH MOV BX POP BL CL MOV BP PUSH 6 # BH MOV 16 INT BP POP BX POP NEXT END-CODE \ LCSET CODE LCSET ( b addr seg -- ) ES DX MOV BX ES MOV BX POP AX POP AL ES: 0 [BX] OR BX POP DX ES MOV NEXT END-CODE \ Managing Source Screens 07jan86map: IN-LIST ( n -- ) 1 ?ENOUGH CR DUP SCR ! .SCR L/SCR 0 DO CR I 3 .R SPACE DUP IN-BLOCK I C/L * + C/L -TRAILING >TYPE KEY? ?LEAVE LOOP DROP CR ; : LISTS ( hi lo -- ) SWAP 1+ SWAP ?DO I IN-LIST LOOP ; \ read ascii file : LF-IN BL LAST-KEY ! (CHAR) ; ' LF-IN $0A HOT.KEY ! ' LF-IN $1A HOT.KEY ! VARIABLE SAVE-KEY VARIABLE SAVE-CHAR VARIABLE SAVE-PROMPT VARIABLE SAVE-STATUS : >NORMAL SAVE-KEY @ IS KEY SAVE-CHAR @ IS CHAR SAVE-PROMPT @ IS PROMPT SAVE-STATUS @ IS STATUS ; : FILE-KEY [ DOS ] C/B CSEG 1 @IN-HANDLE $3F00 (LDOS) .ERROR 0= IF >NORMAL $0D ELSE C/B C@ THEN ; : FILE-CHAR LAST-KEY @ 3DUP DROP + C! 1+ ; : SAVE-IT ['] KEY >IS @ SAVE-KEY ! ['] CHAR >IS @ SAVE-CHAR ! ['] PROMPT >IS @ SAVE-PROMPT ! ['] STATUS >IS @ SAVE-STATUS ! ; : LOAD: FROM SAVE-IT ['] FILE-KEY IS KEY ['] FILE-CHAR IS CHAR ['] NOOP IS PROMPT ['] NOOP IS STATUS ; : NEW-ERROR DUP IF >NORMAL [ DOS ] FILE @ !FILES THEN (?ERROR) ; SAVE-IT ' NEW-ERROR IS ?ERROR \ FORCE ATTRIBUTE CODE >ATTRI ( attrib seg -- ) CX POP AL AL XOR CL AH MOV DS PUSH BX DS MOV 1 # BX MOV 2000 DO AH 0 [BX] MOV 2 # BX ADD LOOP DS POP BX POP NEXT END-CODE : >ATTRIB ( attrib -- ) $B800 >ATTRI ; \ 0 $B800 0 $B900 $1000 LMOVE $B900 >ATTRI \ 0 $B900 0 $B800 $1000 LMOVE ; \ .buffers 13may86map: .buffer ( n -- ) cr buffer# dup 2+ @ dup if .file SPACE length . 2+ length u. @ dup if -1 = if ." updated " else ." unread " then else drop ." in use " then else 2drop ." free " then ; : .buffers ( -- ) cr ." file, block, address, status" #buffers 0 ?do i 1+ .buffer loop ; \ CAPS? \ : CAPS? $417 0 LC@ $40 AND ; CODE CAPS? $0200 # AX MOV $16 INT BX PUSH AX BX MOV $40 # BX AND NEXT END-CODE \ NEWER ORDER : (ORDER) >R >R >R 11 4 60 4 $3900 $3900 OW 9 SPACES ." Vocabulary search order" ORDER WWAIT R> R> R> ; ' (ORDER) 189 2* 255 AND CC2 @ + ! ( PATCH TO F3 ) \ PRINT ALL FILES USED UP TO THIS POINT : .FILE-NAME DUP U. >NAME .ID ; : .FILES ( -- ) 1 BEGIN DUP 2* VIEW-FILES + @ .FILE-NAME CR START/STOP 1+ DUP NEXT-VIEW @ > UNTIL ; \ SPOOLER BACKGROUND: SPOOLER BEGIN 1 CAPACITY SHOW STOP AGAIN ; CR .( To use type SPOOLER WAKE ) CR \ DIVIDE BY ZERO HANDLER NEED >CODE : >ERR-BOX 11 6 40 2 $7400 $0400 OW SINGLE TYPE CR ." Do you wish to Continue or Abort (C/A)" BEGIN KEY UPC ASCII C OVER = OVER ASCII A = OR UNTIL CLOSE ASCII A = ABORT" " ; : 0/ " Division overflow occured" >ERR-BOX ; CODE (0/) >FORTH 0/ >CODE IRET END-CODE ' (0/) CSEG 0 !INT \ >FORTH AND >CODE WORDS FOR ASSEMBLY LANGUAGE : >CODE HERE 2 + , [ ASSEMBLER ] RP SP XCHG IP POP RP SP XCHG R> DROP ; IMMEDIATE : >FORTH ,JSR [ ' >CODE 1+ LENGTH + ] LITERAL ( addr of docol ) HERE 2+ - , COMPILER ; IMMEDIATE \ WORDS IN THREADS : #WORDS #THREADS 0 DO CR ." Thread# " I . ." # words in thread= " 0 CONTEXT @ I 2* + @ BEGIN DUP WHILE SWAP 1+ SWAP HEAD-SEG L@ REPEAT DROP . LOOP ; \ THE & OLD 6 /20/88: (THE) ( body.voc.word string.addr -- addr f ) ?UPPERCASE DUP ROT HASH @ (FIND) ; : THE \ usage THE FORTH DUP to find DUP in FORTH ' >BODY BL WORD (THE) 0= ?MISSING STATE @ IF , THEN ; IMMEDIATE : ` ( -- addr ) \ super find routine checks all vocs BL WORD >R VOC-LINK @ BEGIN DUP #THREADS 2* - R@ (THE) IF SWAP ." is in VOC " #THREADS 2* - BODY> >NAME .ID R> DROP EXIT THEN DROP @ DUP 0= UNTIL R> 2DROP TRUE ?MISSING ; EXIT : OLD \ double loops 4 /6 /88CODE (DLOOP) (S -- ) 1 # AX MOV AX 2 [RP] ADD C=1 IF 0 [RP] INC ELSE AX AX SUB THEN OV 1- ( NOT OV ) IF 0 [IP] IP MOV NEXT THEN 10 # RP ADD IP INC IP INC NEXT END-CODE CODE (+DLOOP) (S d -- ) AX POP AX 2 [RP] ADD 0 [RP] BX ADC BX 0 [RP] MOV BX POP OV 1- IF 0 [IP] IP MOV NEXT THEN 10 # RP ADD IP INC IP INC NEXT END-CODE CODE DI ( -- d ) BX PUSH 0 [RP] BX MOV 2 [RP] DX MOV 6 [RP] DX ADD 4 [RP] BX ADC DX PUSH NEXT END-CODE CODE (DLEAVE) 8 [RP] IP MOV 10 # RP ADD NEXT END-CODE CODE (?DLEAVE) BX BX OR BX POP ' (DLEAVE) JNE NEXT END-CODE --> \ double loops 4 /6 /88CODE (DDO) (S dl di -- ) AX POP CX POP DX POP RP SP XCHG 0 [IP] PUSH IP INC IP INC $8000 # CX ADD DX PUSH CX PUSH DX AX SUB CX BX SBB AX PUSH BX PUSH RP SP XCHG BX POP NEXT END-CODE CODE (?DDO) (S l i -- ) AX POP CX POP DX POP AX DX CMP 0= IF CX BX CMP 0= IF 0 [IP] IP MOV BX POP NEXT THEN THEN RP SP XCHG 0 [IP] PUSH IP INC IP INC $8000 # CX ADD DX PUSH CX PUSH DX AX SUB CX BX SBB AX PUSH BX PUSH RP SP XCHG BX POP NEXT END-CODE --> \ double loop 4 /6 /88: DDO COMPILE (DDO) >MARK 4000 ; IMMEDIATE : ?DDO COMPILE (?DDO) >MARK 4000 ; IMMEDIATE : DLOOP COMPILE (DLOOP) 4000 ?PAIRS DUP 2+ <RESOLVE >RESOLVE ; IMMEDIATE : +DLOOP COMPILE (+DLOOP) 4000 ?PAIRS DUP 2+ <RESOLVE >RESOLVE ; IMMEDIATE : DLEAVE COMPILE (DLEAVE) ; IMMEDIATE : ?DLEAVE COMPILE (?DLEAVE) ; IMMEDIATE \ EXTENDED ADDRESSING CODE >OFFSEG ( d.addr seg -- off seg ) AX POP DX POP DX CX MOV $0F # CX AND CX PUSH ( off ) AX SAR DX RCR AX SAR DX RCR AX SAR DX RCR AX SAR DX RCR ( /16 ) DX BX ADD NEXT END-CODE \ PRINTER RESET CODE PRINTER.RESET BX PUSH $0100 # AX MOV DX DX XOR 23 INT BX POP NEXT END-CODE CODE (>PRN) ( c -- status ) BL AL MOV 0 # AH MOV DX DX XOR ( PRINTER 0 ) 23 INT BH BH XOR AH BL MOV NEXT END-CODE : >PRN ( c -- ) (>PRN) 1 AND ABORT" PRINTER TIMED OUT!" ; \ TRIPLE ARRAYS FOR X,Y,Z DATA : 3ARRAY ( n -- ) CREATE 6 * ALLOT DOES> ( n -- addr ) SWAP 6 * + ; : 3@ ( addr -- n n n ) DUP >R 2@ R> 4 + @ ; : 3! ( n n n addr -- ) DUP >R 4 + ! R> 2! ; EXIT ;CODE PRIMER Given: : INC ( n -- ) CREATE , ;CODE ???? NEXT END-CODE 2 INC 2+ 3 INC 3+ etc How do we write ??? 2+ 's cfa points with a JSR to the ;code section of inc Since the top of stack now contains this address, and BX still contains the old top of stack we should be able to BX AX MOV BX POP 0 [BX] BX MOV AX BX ADD and we are done. \ INTEGER SQUART ROOT : (ISQRT) ( d guess #iters -- n' ) 0 DO 3DUP UM/MOD NIP + U2/ LOOP NIP NIP ; : ISQRT ( d -- SQRT-n ) 2DUP 1. D< IF 2DROP 0 ELSE 32767 16 (ISQRT) THEN ; \ bits and lbits \ note: this does Motorola style big-endian CODE BITS ( or.bits not.and.mask addr -- ) AX POP AX NOT 0 [BX] AH AND 1 [BX] AL AND CX POP CX AX OR AH AL XCHG AX 0 [BX] MOV BX POP NEXT END-CODE CODE LBITS ( or.bits not.and.mask offset seg -- ) ES DX MOV BX ES MOV BX POP AX POP AX NOT ES: 0 [BX] AH AND ES: 1 [BX] AL AND CX POP CX AX OR AH AL XCHG AX ES: 0 [BX] MOV BX POP DX ES MOV NEXT END-CODE
