copyright 1989-1992 Frank C. Sergeant - see the file PYGMY.TXT. This block file contains source code for PYGMY.COM version 1.4. Here is how to generate a new version of Pygmy: Edit in your changes Type 1 LOAD to create a new kernel named A1.COM (or whatever name you used on block 1). Exit to DOS with BYE Run the new kernel (e.g. C:\>A1 ). Extend the kernel by typing 5 LOAD Simple? You bet! Edit the load blocks to include just the mix of options and extensions you prefer. _Starting Forth_ compatibility tips begin on block 178. All should be thoroughly tested by you before use. ( file PYGMY.SCR for metacompiling PYGMY.COM) 2 LOAD ( set options for kernel) 3 LOAD ( metacompiler) 4 LOAD ( kernel) PRUNE { dRELOC $100 + HERE SAVEM A1.COM } ( scr 5 is load block for editor, assembler, & extensions) ( type 1 LOAD to re-metacompile the kernel, then bring up the kernel and type 5 LOAD to extend it with editor, assembler, etc.) ( set options for PYGMY.COM kernel) 16 CONSTANT TMAX-FILES ( power of 2) -1 CONSTANT TFILES ( allow textfiles) 134 CONSTANT TMAX/LINE ( max line length for textfiles) 4 1- CONSTANT TNB ( number of disk buffers, power of 2) 1 ( 0) CONSTANT STACKSEG ( 0 for same, 1 for higher) $10000 CONSTANT TOP ( ie 65536 or very top of segment) ( note, if STACKSEG is 0, stack offsets must not be higher than TOP 1024 TNB 1+ * - 256 - 256 -) $FFFE ( $ECFE) CONSTANT RSTACK ( stacks grow down from ) $7FFE ( $EBFE) CONSTANT DSTACK ( these offset values ) ( use values in parentheses to put stacks in same segment ) $8000 CONSTANT dRELOC ( address of target image) ( metacompiler load block) 6 LOAD ( conditional compilation) ( 7 LOAD ( variants of LOAD and THRU for more information) 8 18 THRU ( kernel load block) 19 67 THRU TFILES .IF 68 70 THRU .ELSE 71 LOAD .THEN 72 77 THRU TFILES .IF 79 80 THRU .ELSE 78 LOAD .THEN 81 96 THRU ( extensions load block) ( load block for the editor, assembler, & extensions ) $C000 SET-EDGE ( allow for headerless words) 97 98 THRU ( NFA FORGET ) 99 111 THRU ( load the editor) SAVE A2.COM 112 132 THRU ( load the assembler) SAVE A3.COM 133 135 THRU ( other extensions) ' EPSON-CONDENSED ( ' NOP) ( ' LJ-CONDENSED) IS CONDENSED " PYGMY.DOW" 1 UNIT ( on bonus disk) " YOURFILE.SCR" 2 UNIT SAVE A4.COM ( conditional compilation) : ?LOAD ( scr flg -) IF DUP LOAD THEN DROP ; ( conditional) : MATCH? ( a a - f) ( end of input stream counts as a match) OVER C@ IF DUP C@ 1+ COMP 0= ELSE DROP THEN ; : .IF ( f -) 0= IF BEGIN 32 WORD DUP " .ELSE" MATCH? SWAP " .THEN" MATCH? OR UNTIL THEN ; : .ELSE ( -) BEGIN 32 WORD " .THEN" MATCH? UNTIL ; : .THEN ; ( optional versions to give more info while metacompiling) : LOAD ( n -) DUP CR ." loading scr # " . LOAD HERE 6 U.R 5 SPACES .S ; : THRU ( n n -) OVER - 1+ FOR ( n) DUP PUSH LOAD POP 1+ ?SCROLL NEXT DROP ; EXIT : XREF ( -) BASE @ HEX >PRN CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + DUP dA @ - 5 U.R ( ie print nfa) 2 SPACES COUNT $1F AND TYPE ?SCROLL CR REPEAT DROP CR >SCR BASE ! ; ( cross reference list of nfa and name to printer ) ( initialize target space) VARIABLE RAM VARIABLE H' dRELOC , ( relocation amount ) ( 1st cell is tgt's DP & 2nd cell is tgt's offset) dRELOC $2000 0 FILL dRELOC H' ! ( ie we will start target image at dRELOC) ( meta variables pointing to target runtime code ) VARIABLE TVAR ( variable) VARIABLE TLIT ( literal) VARIABLE TCOL ( docol) VARIABLE TBRA ( branch) VARIABLE T0BR ( zero branch) VARIABLE TEXIT ( EXIT) VARIABLE TFOR ( for) VARIABLE TNEXT ( next) VARIABLE TARR ( array) VARIABLE TABORT ( abort") VARIABLE TDOT ( dot") VARIABLE TNULL ( switch between host & target spaces ) : { dA @ HERE H' 2@ H ! dA ! H' 2! ; : } { ; : RECOVER -2 ALLOT ; ( RECOVERs final EXIT when it can never be reached) ( headers) H/LESS OFF : THEAD ( -) ( this is the basic HEAD without VFA etc) HERE 0 , ( lf) 32 WORD CONTEXT @ 2DUP -FIND NIP NOT IF OVER TYPE$ ." not unique " THEN HASH 2DUP @ ( lfa nfa voc nfa prev.lfa) SWAP 2 - ( lfa nfa voc prev.lfa cur.lfa) ! SWAP ( lfa voc nfa) C@ ( lfa voc len) 1+ ALLOT ! ; : | ( -) H/LESS ON { ; ( make following word headless) ( headers) ( View fields are always created) : HEAD ( -) H/LESS @ IF THEAD $D6 C, ( magic) H' @ , H/LESS OFF { ELSE BLK @ , THEAD THEN ; ( meta compiling words ) HEX : forget ( -) CONTEXT @ HASH @ 2 + DUP C@ 20 XOR SWAP C! ; : CREATE ( -) ( - a) HEAD TVAR @ LJMP, ; : VARIABLE ( -) ( RAM @ CONSTANT 2 RAM +! for ROMing) CREATE 0 , ; : ARRAY ( a -) ( n -) ( n is a word, not byte, index) HEAD TARR @ LJMP, , ; : CODE HEAD ASM-RESET ; : DEFER ( ) ( ...) HEAD 0 #, AX MOV, AX JMP, ; : IS ( pfa -) dA @ - ' 1+ ! ; ( SCAN TRIM CLIP PRUNE to relink dictionary after metacompiling) : SCAN ( lfa - lfa) @ BEGIN DUP 1 dRELOC WITHIN WHILE @ REPEAT ; : TRIM ( lfa new-lfa - new-lfa) DUP PUSH dA @ - SWAP ! POP DUP 2 + DUP C@ $DF AND SWAP C! ( unsmudge) ; : CLIP ( voc-head -) DUP BEGIN DUP SCAN DUP WHILE TRIM REPEAT DROP TNULL @ dA @ - SWAP ! ( @ ,) DROP ; : PRUNE ( -) { 8 HASH CLIP 6 HASH CLIP TNULL @ OFF ( zero out its link field) { ; ( rename some host words ) : FORTH' FORTH ; : COMPILER' COMPILER ; : :' : ; ( LITERAL ] ) COMPILER : LITERAL ( n -) TLIT @ ,A , ; FORTH : ] BEGIN 4 -' ( restrict execution to host's COMPILER) IF 6 -FIND ( restrict finding to target's FORTH ) IF NUMBER \ LITERAL ELSE ,A THEN ELSE EXECUTE THEN AGAIN ; ( meta structures UNTIL AGAIN IF THEN etc ) COMPILER : BEGIN ( - a) HERE ; : UNTIL ( a -) T0BR @ ,A ,A ; : AGAIN ( a -) TBRA @ ,A ,A ; : THEN ( a -) HERE dA @ - SWAP ! ; : IF ( - a) T0BR @ ,A HERE 0 , ; : WHILE ( a - a a ) \ IF SWAP ; : REPEAT ( a a -) \ AGAIN \ THEN ; : ELSE ( a - a) TBRA @ ,A HERE 0 , SWAP \ THEN ; : FOR ( h -) TFOR @ ,A \ BEGIN 0 , ; ( FOR performs body of loop u times, not u+1 times ) : NEXT ( h -) DUP \ THEN 2 + TNEXT @ ,A ,A ; : \ 8 -' ABORT" ?" ,A ; ( F83's [COMPILE] ) FORTH ( more meta compiling words ) COMPILER : ABORT" TABORT @ ,A $22 STRING ; : ." TDOT @ ,A $22 STRING ; : ['] TLIT @ ,A ; FORTH : FORTH 6 CONTEXT ! ; : COMPILER 8 CONTEXT ! ; : : HEAD TCOL @ LJMP, ( lay down 3byte jump to docol) forget ] ; COMPILER' :' ; forget POP DROP TEXIT @ ,A ; ( must be the last colon) ( def in the metacompiler) FORTH' HEX ( start target code boot ) 6 HASH OFF 8 HASH OFF { ( to target) $100 ALLOT ( first 256 bytes reserved for DOS) FORTH ( sets context to 6 ) | CODE boot RSTACK #, BP MOV, ( initialize return stack) DSTACK #, SP MOV, ( initalize parameter stk) 0 #, AX MOV, CS PUSH, BX POP, STACKSEG $1000 * #, BX ADD, BX SS MOV, AX JMP, ( jump to RESET) END-CODE HERE 2 + TNULL ! ( null word $ will get renamed) CODE $ -2 ALLOT 0 C, SWITCH, SI POP, SWITCH, NXT, END-CODE HERE dA @ - RAM ! $32 TNB 1+ 2* + ALLOT ( room for system variables) ( lit array ) | CODE lit ( -n) HERE TLIT ! BX PUSH, ( push TOS to SOS) AX LODS, ( ax <-- [IP], IP++ ) ( get in-line value, not addr) AX BX MOV, ( to TOS) NXT, END-CODE | CODE array ( n -a) HERE TARR ! ( nth word index into array ) 3 #, AX ADD, ( jump over 3 byte JMP) AX BX XCHG, 0 [BX] BX MOV, 1 #, AX SHL, ( multiply by 2 to addr nth word) AX BX ADD, ( now TOS holds addr of nth word of array) NXT, END-CODE ( var 0branch branch ) | CODE var HERE TVAR ! BX PUSH, ( push TOS to SOS) 3 #, AX ADD, ( jump over 3 byte JMP) AX BX MOV, ( put that addr in TOS) NXT, END-CODE | CODE 0branch HERE T0BR ! AX LODS, BX BX TEST, 0=, IF, AX SI MOV, THEN, BX POP, NXT, END-CODE | CODE branch HERE TBRA ! 0 [SI] SI MOV, NXT, END-CODE ( VIEW,LINK,NAME,JMP<var>,VALUE ( 2 2 ? 3 2 (# of bytes in each field) ( docol dodoes ) | CODE docol HERE TCOL ! SWITCH, SI PUSH, SWITCH, 3 #, AX ADD, ( jump over 3 byte JMP to this code ) AX SI MOV, ( put addr of new word list in IP ) NXT, END-CODE | CODE dodoes SWITCH, SI PUSH, SWITCH, SI POP, BX PUSH, 3 #, AX ADD, AX BX MOV, ( addr of parm field) NXT, END-CODE ( runtime FOR - keeps only count on Rstk ) | CODE for HERE TFOR ! SWITCH, BX PUSH, ( save loop count on R stk) SWITCH, BX POP, ( refill TOS ) 0 [SI] SI MOV, ( branch to next to skip loop 1st time) NXT, END-CODE ( runtime NEXT - keeps only count on Rstk ) | CODE next HERE TNEXT ! 1 #, 0 [BP] W-PTR SUB, CS, NOT, IF, ( loop isn't finished ) ( AX LODS, AX SI MOV, ( 18 clocks & 3 bytes) 0 [SI] SI MOV, ( 17 clocks & 2 bytes) NXT, THEN, BP INC, BP INC, ( remove count) SI INC, SI INC, ( skip over back addr) NXT, END-CODE ( EXIT) CODE EXIT HERE TEXIT ! SWITCH, SI POP, ( recover previous IP ) SWITCH, NXT, END-CODE ( System variables RAM allocation - all RAM for now ) RAM @ DUP CONSTANT PREV ( last referenced buffer) 2 + DUP CONSTANT OLDEST ( Oldest loaded buffer ) 2 + DUP ARRAY BUFFERS ( Block in each buffer ) TNB DUP CONSTANT NB ( Number of buffers) 2* + 2 + DUP CONSTANT TIB 2 + DUP CONSTANT H/LESS 2 + DUP CONSTANT HEADERS 2 + DUP CONSTANT SPAN 2 + DUP CONSTANT >IN 2 + DUP CONSTANT BLK 2 + DUP CONSTANT dA 2 + DUP CONSTANT SCR 2 + DUP CONSTANT ATTR 2 + DUP CONSTANT >FIN 2 + DUP CONSTANT FBLK 2 + DUP CONSTANT #TIB 2 + DUP CONSTANT #FIB 2 + DUP CONSTANT FIB 2 + DUP CONSTANT FIBH 2 + DUP CONSTANT EBUF 2 + DUP CONSTANT BASE 2 + DUP CONSTANT H 10 + ( allow room for 4 vocabs ) DUP CONSTANT CONTEXT ( ram+) DROP ( instead of a central docon, CONSTANTS are defined in-line) 0 CONSTANT 0 1 CONSTANT 1 -1 CONSTANT -1 2 CONSTANT 2 ( primitives ) CODE 1+ ( n - n+1) BX INC, NXT, END-CODE CODE 1- ( n - n-1) BX DEC, NXT, END-CODE CODE SP! ( -) DSTACK #, SP MOV, NXT, END-CODE CODE RP! ( -) RSTACK #, BP MOV, NXT, END-CODE ( CS@ locate kernel's code segment ) CODE CS@ ( - seg) BX PUSH, CS PUSH, BX POP, NXT, END-CODE ( P! PC! P@ PC@ access I/O ports ) CODE P! ( n port -) BX DX MOV, AX POP, AX OUT, BX POP, NXT, END-CODE CODE PC! ( c port -) BX DX MOV, AX POP, AL OUT, BX POP, NXT, END-CODE CODE P@ ( port - n) BX DX MOV, AX IN, AX BX MOV, NXT, END-CODE CODE PC@ ( port - c) BX DX MOV, AL IN, AX BX MOV, BH BH SUB, NXT, END-CODE : NOP ( -) ; ( COMP compare two strings ) CODE COMP ( a1 a2 len - -1 | 0 | +1 ; a1<a2=-1;a1=a2=0) SI DX MOV, BX CX MOV, DI POP, SI POP, ( don't test for len 0) DS AX MOV, AX ES MOV, ( don't assume ES is set up) ( Robert Berkey suggests setting zero flag so zero length ok) AX AX SUB, ( set zero flag ) REPZ, AL CMPS, 0=, NOT, IF, U<, IF, -1 #, CX MOV, ELSE, 1 #, CX MOV, THEN, THEN, CX BX MOV, DX SI MOV, NXT, END-CODE ( shifts 2* 2/ ) CODE 2* 1 #, BX SHL, NXT, END-CODE CODE 2/ 1 #, BX SHR, NXT, END-CODE ( unsigned) ( 2/ does not preserve sign bit, it shifts in zeroes ) ( stack operators) CODE DROP ( n -) BX POP, NXT, END-CODE CODE NIP ( a b - b) AX POP, NXT, END-CODE CODE ROT ( n1 n2 n3 - n2 n3 n1 ) AX POP, DX POP, AX PUSH, BX PUSH, DX BX MOV, NXT, END-CODE CODE SWAP ( n1 n2 - n2 n1 ) AX POP, BX PUSH, AX BX MOV, NXT, END-CODE CODE OVER ( n1 n2 - n1 n2 n1) AX POP, AX PUSH, BX PUSH, AX BX MOV, NXT, END-CODE CODE DUP ( n - n n) BX PUSH, NXT, END-CODE CODE ?DUP ( n - n n) BX BX TEST, 0=, NOT, IF, BX PUSH, THEN, NXT, END-CODE CODE 2DUP ( d - d d) AX POP, AX PUSH, BX PUSH, AX PUSH, NXT, END-CODE CODE 2DROP ( d -) BX POP, BX POP, NXT, END-CODE ( math ) CODE + ( n n - n) AX POP, AX BX ADD, NXT, END-CODE CODE +UNDER ( a b c - a+c b) DX POP, AX POP, AX BX ADD, BX PUSH, DX BX MOV, NXT, END-CODE CODE - ( n n - n) BX AX MOV, BX POP, AX BX SUB, NXT, END-CODE CODE NEGATE ( n - -n) ( take two's complement of n) BX NEG, NXT, END-CODE CODE D2* ( l h - l h ) ( multiply double number by 2 ) AX POP, 1 #, AX SHL, AX PUSH, 1 #, BX RCL, NXT, END-CODE ( single operand flag words ) CODE 0= ( n - f) 1 #, BX SUB, BX BX SBB, NXT, END-CODE : NOT 0= ; CODE 0< 1 #, BX SHL, BX BX SBB, NXT, END-CODE ( technique from Andrew McKewan ) ( bit operators) CODE OR ( n n - n) AX POP, AX BX OR, NXT, END-CODE CODE XOR ( n n - n) AX POP, AX BX XOR, NXT, END-CODE CODE AND ( n n - n) AX POP, AX BX AND, NXT, END-CODE ( two operand flag words ) CODE < ( n n - f) AX POP, BX AX SUB, 0 #, BX MOV, <, IF, BX DEC, THEN, NXT, END-CODE ( 62 or 52 cycles - avg 57 cycles & 12 bytes ) CODE > ( n n - f) AX POP, AX BX SUB, 0 #, BX MOV, <, IF, BX DEC, THEN, NXT, END-CODE CODE = ( n n - f) AX POP, BX AX SUB, 1 #, AX SUB, BX BX SBB, NXT, END-CODE CODE U< ( u u - f) AX POP, BX AX SUB, BX BX SBB, NXT, END-CODE ( math ) CODE U/MOD ( u u - r q ) AX POP, DX DX SUB, BX DIV, ( unsigned div) DX PUSH, ( rem) AX BX MOV, ( quot) NXT, END-CODE : U/ ( u u - q) U/MOD NIP ; CODE UM/MOD ( l h u - r q ) DX POP, AX POP, BX DIV, ( unsigned div) DX PUSH, ( rem) AX BX MOV, ( quot) NXT, END-CODE CODE */ ( n1 n2 n3 - n1*n2/n3) AX POP, CX POP, CX IMUL, ( signed) BX IDIV, ( signed) AX BX MOV, NXT, END-CODE CODE * ( n n - n) AX POP, BX IMUL, AX BX MOV, NXT, END-CODE ( math ) CODE / ( n n - q) AX POP, CWD, BX IDIV, AX BX MOV, NXT, END-CODE CODE M* ( n n - d) AX POP, BX IMUL, AX PUSH, DX BX MOV, NXT, END-CODE CODE M/ ( l h n - q ) DX POP, AX POP, BX IDIV, AX BX MOV, NXT, END-CODE : UMOD ( u u - r ) U/MOD DROP ; ( fetch & store ) CODE ! ( n a -) AX POP, AX 0 [BX] MOV, BX POP, NXT, END-CODE CODE N! ( n a - n) AX POP, AX 0 [BX] MOV, AX BX MOV, NXT, END-CODE CODE @ ( a - n) 0 [BX] BX MOV, NXT, END-CODE CODE +! ( n a -) AX POP, AX 0 [BX] ADD, BX POP, NXT, END-CODE CODE C! ( b a -) AX POP, AL 0 [BX] MOV, BX POP, NXT, END-CODE CODE C@ ( a - b) 0 [BX] BL MOV, BH BH SUB, NXT, END-CODE CODE 2@ ( a - d) 2 [BX] PUSH, 0 [BX] BX MOV, NXT, END-CODE CODE 2! ( d a -) AX POP, AX 0 [BX] MOV, AX POP, AX 2 [BX] MOV, BX POP, NXT, END-CODE : ON -1 SWAP ! ; : OFF 0 SWAP ! ; ( CMOVE CMOVE> FILL ) CODE CMOVE ( fr to # - ) CLD, SI DX MOV, BX CX MOV, DI POP, SI POP, DS AX MOV, AX ES MOV, REP, ( BYTE) AL MOVS, BX POP, DX SI MOV, NXT, END-CODE CODE CMOVE> ( fr to # - ) STD, SI DX MOV, BX CX MOV, DI POP, SI POP, DS AX MOV, AX ES MOV, BX DEC, ( BX DEC,) BX SI ADD, BX DI ADD, REP, ( BYTE) AL MOVS, BX POP, DX SI MOV, CLD, NXT, END-CODE CODE FILL ( addr # value -) CLD, CX POP, ( #) DI POP, DS AX MOV, AX ES MOV, BX AX MOV, REP, AL STOS, BX POP, NXT, END-CODE ( return stack operators ) CODE PUSH ( n -) ( same as >R) SWITCH, BX PUSH, SWITCH, BX POP, NXT, END-CODE CODE POP ( - n) ( same as R>) BX PUSH, SWITCH, BX POP, SWITCH, NXT, END-CODE CODE I ( - n) ( same as R@) BX PUSH, 0 [BP] BX MOV, NXT, END-CODE CODE R@ ( - n) BX PUSH, 0 [BP] BX MOV, NXT, END-CODE ( BETWEEN WITHIN ) CODE BETWEEN ( n l h - f) ( true if n l - hi lo - U<= ) AX POP, AX BX SUB, ( h-l is in BX) DX POP, AX DX SUB, ( n-l is in DX) ( BX DX SUB,) DX BX SUB, CMC, BX BX SBB, NXT, END-CODE : WITHIN ( n l h - f) ( true if h-l is U< than n-l ) 1- BETWEEN ; ( n 0 0 works as n 0 65536 - see Robert Berkey) ( ABS MIN MAX EXECUTE ) CODE ABS ( n - u) ( 6 bytes + next ) BX BX TEST, 0<, IF, BX NEG, THEN, NXT, END-CODE CODE MIN ( n n - n) AX POP, AX BX CMP, >, IF, AX BX MOV, THEN, NXT, END-CODE CODE MAX ( n n - n) AX POP, AX BX CMP, <, IF, AX BX MOV, THEN, NXT, END-CODE CODE EXECUTE ( a -) BX AX MOV, BX POP, AX JMP, END-CODE EXIT ( below would be better if we did not keep TOS in a reg.) CODE ABS ( n - u) ( 7 bytes + next) BX AX MOV, CWD, DX BX XOR, DX BX SUB, NXT, END-CODE ( DEFER'd I/O words ) DEFER DEFAULT-EMIT DEFER EMIT DEFER KEY DEFER KEY? DEFER CR DEFER AT DEFER CUR@ DEFER CLS ( BIOS Int $10 video functions ) CODE (AT ( row col -) BL DL MOV, BX POP, BL DH MOV, BX BX SUB, $0200 #, AX MOV, $10 #, INT, BX POP, NXT, END-CODE CODE (CUR@ ( - row col) BX PUSH, BX BX SUB, $0300 #, AX MOV, $10 #, INT, BX BX SUB, DL BL MOV, DL DL SUB, DH DL XCHG, DX PUSH, NXT, END-CODE CODE (EMIT ( c -) BX AX MOV, $0E #, AH MOV, BH BL MOV, $10 #, INT, BX POP, NXT, END-CODE ( BIOS Int $10 video functions ) CODE AT@ ( - aacc) ( read attr & char at current cursor pos) BX PUSH, BX BX SUB, $0800 #, AX MOV, $10 #, INT, AX BX MOV, NXT, END-CODE CODE .ATTR ( # -) ( Write # blanks using ATTR Does not change cursor position) BX CX MOV, ' ATTR 2 + @ ) BX MOV, ( attr in BL) $0920 #, AX MOV, $10 #, INT, BX POP, NXT, END-CODE : (CLS ( -) 0 0 AT 2000 .ATTR ; ' (EMIT DUP IS EMIT IS DEFAULT-EMIT ' (AT IS AT ' (CUR@ IS CUR@ ' (CLS IS CLS HEX ( terminal I/O & DOS & DOS2 ) CODE (KEY ( - c) BX PUSH, 7 #, AH MOV, 21 #, INT, AH AH SUB, AX BX MOV, NXT, END-CODE CODE (KEY? ( - f) BX PUSH, 0B #, AH MOV, 21 #, INT, AL AH MOV, AX BX MOV, NXT, END-CODE CODE (BYE ( -) ( set cursor at bottom of screen & return) $1800 #, DX MOV, BX BX SUB, $0200 #, AX MOV, $10 #, INT, $4C00 #, AX MOV, 21 #, INT, ( exit to DOS) END-CODE CODE DOS ( DX CX BX AX - AX carry) BX AX MOV, BX POP, CX POP, DX POP, 21 #, INT, AX PUSH, BX BX SBB, NXT, END-CODE ( for DOS int 21 services) CODE DOS2 ( DX CX BX AX - DX AX carry) BX AX MOV, BX POP, CX POP, DX POP, 21 #, INT, DX PUSH, AX PUSH, BX BX SBB, NXT, END-CODE ( also for int 21 ) ( ?SCROLL (CR (KEY DECIMAL HEX ) DEFER QUIT : ?SCROLL ( -) KEY? IF KEY $1B = IF SP! QUIT THEN BEGIN KEY? UNTIL KEY $1B = IF SP! QUIT THEN THEN ; : (CR ( -) $0D EMIT $0A EMIT ; : (ONEKEY ( - c) (KEY DUP 0= IF DROP (KEY $80 OR THEN ; ( for the extended keys, set the most significant bit ) ' (ONEKEY IS KEY ' (KEY? IS KEY? ' (CR IS CR : DECIMAL 10 BASE ! ; : HEX 16 BASE ! ; ( C@+ COUNT TYPE TYPE$ -TRAILING SPACE SPACES) CODE C@+ ( a - a+1 c) 0 [BX] AL MOV, BX INC, BX PUSH, BX BX SUB, AL BL MOV, NXT, END-CODE : COUNT ( a - a+1 #) C@+ ; : TYPE ( a # -) FOR C@+ EMIT NEXT DROP ; : TYPE$ ( a -) COUNT TYPE ; : -TRAILING ( a # - a #') FOR DUP I + C@ 32 = WHILE NEXT 0 EXIT THEN POP 1+ ; : -TRAILING<> ( a # c - a #') ROT ROT FOR ( c a) 2DUP I + C@ ( c a c c') - WHILE ( c a) NEXT NIP 0 EXIT THEN ( c a) NIP POP 1+ ; : SPACE 32 EMIT ; : SPACES ( n) 0 MAX FOR SPACE NEXT ; : EXPECT ( a # -) SWAP ( #rem a) OVER PUSH ( #rem a) BEGIN OVER WHILE ( # a) KEY DUP $0D - WHILE ( # a key) DUP 8 = IF DROP ( # a) OVER R@ < IF ( # a) 1- 32 OVER C! ( # a) 1 +UNDER 8 EMIT SPACE 8 EMIT THEN ELSE ( # a key) DUP EMIT OVER C! ( # a) -1 +UNDER 1+ THEN REPEAT DROP SPACE THEN ( # a) DROP POP SWAP - SPAN ! ; EXIT ( you can use QUERY to get input ready for WORD to work on ) ( Numbers ) : HOLD ( ..# x n - ..# x) SWAP PUSH SWAP 1+ POP ; : DIGIT ( n - c) DUP 9 > 7 AND + 48 + ; : <# ( n - ..# n) 0 SWAP ; : #> ( ..# n -) DROP FOR EMIT NEXT ; : SIGN ( ..# n n - ..# n) 0< IF 45 HOLD THEN ; : # ( ..# n - ..# N) BASE @ U/MOD SWAP DIGIT HOLD ; : #S ( ..# n - ..# 0) BEGIN # DUP 0= UNTIL ; : (.) ( n - ..# n) DUP PUSH ABS <# #S POP SIGN ; : .R ( n n -) PUSH (.) OVER POP SWAP - SPACES #> ; : . ( n -) 0 .R SPACE ; : U.R ( u n -) PUSH <# #S OVER POP SWAP - SPACES #> ; : U. ( u -) 0 U.R SPACE ; ( this version takes 293 bytes) ( DUMP DU ) : DUMP ( a - a) BASE @ PUSH HEX CR DUP 5 U.R SPACE 2 FOR 8 FOR C@+ 3 U.R NEXT SPACE NEXT SPACE 16 - 2 FOR 8 FOR C@+ DUP 32 127 WITHIN NOT IF DROP 46 THEN EMIT NEXT SPACE NEXT POP BASE ! ; ( Note, DUMP now saves and restores BASE and automatically displays in hexadecimal.) : DU ( a n -) FOR DUMP ?SCROLL NEXT DROP ; ( Note, DU no longer leaves the next address on the stack) ( HERE abort" dot" ) : HERE ( - a) H @ ; : PAD ( - a) HERE 256 + ; DEFER ABORT | : abort" ( f -) IF ABORT THEN POP COUNT + PUSH ; ' abort" TABORT ! | : dot" ( POP TYPE$ PUSH can't do this w/ current def of TYPE$) POP DUP TYPE$ COUNT + PUSH ; ' dot" TDOT ! | : (") ( - a) POP DUP COUNT + 1+ ( skip over z) PUSH ; ( buffer manager ) | : ADDRESS ( n - a) -1024 * [ TOP 1024 - ] LITERAL + ; ( highest buffer always starts 1024 bytes below TOP) | : ABSENT ( n - n) NB 1+ FOR DUP R@ BUFFERS @ XOR 2* WHILE NEXT EXIT THEN POP PREV N! POP DROP NIP ADDRESS ; | : UPDATED ( - a n) OLDEST @ BEGIN 1+ NB AND ( cheap MOD) DUP PREV @ XOR UNTIL OLDEST N! PREV N! ( buf#) DUP ADDRESS SWAP BUFFERS DUP @ ( a buf# old-blk#) $7FFF ROT ! ( a old-blk#) DUP 0< NOT IF ( a old-blk#) POP DROP DROP THEN ; : UPDATE PREV @ BUFFERS DUP @ $8000 OR SWAP ! ; | : ESTABLISH ( n a - a) SWAP OLDEST @ PREV N! BUFFERS ! ; ( allow multiple block files open at same time ) TMAX-FILES ( 16) 1- CONSTANT MAX-FILES ( must be power of 2) CREATE FILES HERE ( a) TMAX-FILES 1+ 6 * DUP ALLOT ( a #) 0 FILL ( each entry is 6 bytes) ( handle #blocks address-of-name) ( when empty or closed, handle is -1) : >UNIT# ( block# - unit#) 1000 U/ ; : HANDLE ( unit# - a) 6 * FILES + ; : #BLOCKS ( unit# - a) HANDLE 2 + ; : FNAME ( unit# - a) HANDLE 4 + ; : RANGE ( unit# - starting# ending#) DUP 1000 * ( unit# starting#) SWAP #BLOCKS @ OVER + 1- ; ( Disk read/write ) : LBLK ( global-blk# - local-blk# handle) 1000 U/MOD ( rel# unit#) 2DUP #BLOCKS @ ( rel# unit# rel# #blks) U< NOT ( rel# unit# flg) ABORT" bad block# " ( rel# unit#) HANDLE @ ; ( list files & units and their statuses ) : .FILE ( n -) FNAME @ ?DUP IF TYPE$ THEN ; : .FILES ( -) CR ." UNIT 1ST LAST HANDLE FILE" 0 MAX-FILES 1+ FOR ( unit#) CR DUP FNAME @ PUSH DUP 4 .R DUP RANGE ( unit# start# end#) SWAP POP IF 8 .R ELSE DROP 8 SPACES THEN OVER HANDLE @ DUP 0< NOT IF SWAP 8 .R ELSE SWAP DROP 8 SPACES THEN ( unit# handle#) 8 .R DUP 4 SPACES .FILE ( unit#) 1+ NEXT DROP ( ) SPACE ; ( file positioning words) : >EOF ( handle -) ( move current position to end of file) ( HANDLE @ ( handle) 0 0 ROT $4202 DOS ( ax flg) ABORT" >EOF error" DROP ; : POSITION@ ( handle - ud) ( return current file position) ( HANDLE @ ( handle) 0 0 ROT $4201 DOS2 ( h l flg) ABORT" pos error" SWAP ; : >POSITION ( ud handle -) ( move to absolute position) ( HANDLE @) $4200 DOS ( ax flg) ABORT" pos error" DROP ; : >BOF ( handle -) 0 0 ROT >POSITION ; ( "to begin. of file") : +POSITION ( n handle -) PUSH DUP 0< ( sign extend to double) POP ( HANDLE @) $4201 DOS ( ax flg) ABORT" pos error" DROP ; ( go forward or backward relative to current position) ( file handling ) : FCLOSE ( handle -) ( was named HANDLE-CLOSE in ver 1.3) 0 0 ROT ?DUP IF $3E00 DOS THEN 2DROP ; : ?CLOSE ( unit# -) HANDLE DUP PUSH @ FCLOSE ( ) POP ON ; ( try to close it but ignore errors ) : FOPEN ( name - handle flag) 1+ 0 0 $3D02 DOS ( true=error) ; : FMAKE ( name - handle flag) 1+ 0 0 $3C00 DOS ( true=error) ; : ?OPEN ( unit# -) ( no errors reported) DUP ?CLOSE DUP FNAME ( unit# a) @ FOPEN ( unit# handle flag) IF 2DROP ( ) ELSE ( unit# handle) OVER HANDLE N! ( unit# handle) DUP >EOF POSITION@ ( unit# ud) 1024 UM/MOD ( unit# r q) SWAP IF 1+ THEN ( unit# #blks) SWAP #BLOCKS ! ( ) THEN ; ( OPEN? EXISTS? MAKE ?MAKE ) : OPEN? ( unit# - flag) ( true if file is open) DUP HANDLE @ ( 0=) 0< SWAP ( flag unit#) FNAME @ 0= ( flag flag) OR NOT ( flag) ; : EXISTS? ( unit# - flag) DUP ?OPEN DUP OPEN? ( unit# flag) IF ( unit#) HANDLE @ POSITION@ ( ud) OR NOT NOT ( flag) ELSE ( unit#) DROP 0 THEN ; ( this leaves file open, by the way) : MAKE ( unit# -) DUP ?CLOSE DUP FNAME @ ( 1+ 0 0 $3C00 DOS) FMAKE ( unit# handle flag) ABORT" MAKE error" ( unit# h) OVER HANDLE ! ( unit#) ?OPEN ; : ?MAKE ( unit# -) DUP EXISTS? NOT IF MAKE ELSE DROP THEN ; ( file write) : FILE-WRITE ( buf cnt handle# -) ( was named HANDLE-WRITE) OVER PUSH $4000 DOS SWAP POP - OR ABORT" write error" ; : FILE-SIZE ( handle - ud) DUP >EOF POSITION@ ; : SET-FILE-SIZE ( ud handle -) ( ** be careful ** ) DUP PUSH >POSITION 0 0 ( R@) POP FILE-WRITE ( POP ?OPEN ) ; ( above does not reset unit table info) : MORE ( #blks-to-add handle -) ( ** be careful ** ) PAD 1024 32 FILL SWAP OVER >EOF ( handle #blks) FOR ( handle) PAD OVER ( handle a handle) 1024 SWAP ( handle a 1024 handle) FILE-WRITE ( handle) NEXT ( handle) DROP ( ) ; ( file read) VARIABLE #BYTES-READ : EOF? ( - f) #BYTES-READ @ 0= ; : FILE-READ ( buf cnt handle -) $3F00 DOS ABORT" read error" #BYTES-READ ! ; ( Disk read/write ) : CLOSE-FILES ( -) MAX-FILES 1+ FOR I ?CLOSE NEXT ; : RESET-FILES ( -) FILES [ TMAX-FILES ( MAX-FILES 1+) 6 * ] LITERAL 0 FILL CLOSE-FILES ( to set handles to -1 ) ; : OPEN-FILES ( -) CLOSE-FILES 0 ( unit#) MAX-FILES 1+ FOR ( unit#) DUP ?OPEN 1+ NEXT DROP ; ( above opens in ascending order) ( open what's available; don't report errors ) ( block words ) | : buffer ( blk - blk a) UPDATED ( new-blk# a old-dirty-blk#) OVER SWAP $7FFF AND LBLK ( new-blk# a a rel-dirty# handle) PUSH 1024 M* R@ >POSITION ( new# a a) 1024 ( new# a a #) POP ( new# a a # handle) FILE-WRITE ( new# a) ; : BUFFER ( n - a) buffer ESTABLISH ; | : block ( n a - n a) OVER LBLK PUSH 1024 M* R@ >POSITION ( n a) DUP 1024 POP ( n a a # handle) FILE-READ ( n a) ; : BLOCK ( n - a) ABSENT buffer block ESTABLISH ; ( block words ) : FLUSH NB 1+ FOR $7FFF BUFFER DROP NEXT ; : BYE ( -) FLUSH (BYE ; : EMPTY-BUFFERS PREV [ ' NB 2 + @ 3 + 2* ] LITERAL 0 FILL FLUSH ; : COPY ( n1 n2 -) BUFFER UPDATE SWAP BLOCK SWAP 1024 CMOVE FLUSH ; : COPIES ( fr to # -) ( work from high end toward low end) FOR 2DUP R@ + R@ +UNDER COPY NEXT 2DROP ; ( string handling needed by WORD ) CODE -LEADING<> ( a # char - a #) ( eat e/g before 1st matching character) 1 #, AL OR, DS AX MOV, AX ES MOV, BX AX MOV, CX POP, DI POP, REPNZ, AL SCAS, 0=, IF, DI DEC, CX INC, THEN, DI PUSH, CX BX MOV, NXT, END-CODE CODE -LEADING= ( a # char - a #) ( eat leading delimiters) AX AX SUB, ( force zero flg true) DS AX MOV, AX ES MOV, BX AX MOV, CX POP, DI POP, REPZ, AL SCAS, 0=, NOT, IF, DI DEC, CX INC, THEN, DI PUSH, CX BX MOV, NXT, END-CODE ( : -LEADING ( a # - a #) ( eat leading spaces 32 -LEADING= ;) : /STRING ( a # n - a #) OVER MIN DUP PUSH +UNDER POP - ; ( used for textfile loading version ) TMAX/LINE CONSTANT MAX/LINE : READ-LINE ( - a #) ( always read into the FIB ) FIBH @ DUP 0= ABORT" fibh @ is zero" PUSH ( ie save handle) >FIN @ 0 R@ >POSITION ( easy to change this to doubles) FIB @ DUP MAX/LINE POP FILE-READ #BYTES-READ @ ( a #) MAX/LINE OVER > NOT PUSH ( a #) 2DUP 13 -LEADING<> ( ie find 1st cr) ( a # a' #') 0= POP AND ( ie both no cr and not last line) ABORT" line too long" ( a # a') 2 + ( include cr & lf) ROT - ( # len) MIN ( ie don't take more than were read in) DUP >FIN +! FIB @ SWAP ( a #) DUP #FIB ! ; : -CTRL ( a # -) FOR DUP C@ 32 MAX OVER C! 1+ NEXT DROP ; ( used for text-file loading version ) : ?REFILL ( handle - a #) PUSH #FIB @ >IN @ > NOT ( flg) ( ie no unprocessed characters) FIBH @ R@ - ( flg flg) ( ie has handle changed) ( flg flg) OR ( flg) FIB @ SWAP ( a flg) IF ( a) >IN OFF ( we must refill the buffer) BEGIN ( a) DROP ( ) R@ FIBH ! READ-LINE ( a #) ?DUP WHILE ( a #) ( buffer now ends in a cr) 2DUP -CTRL ( a #) -TRAILING ( and then with no blanks) ( a #) DUP #FIB ! ( a #) UNTIL ( a) THEN ( a) THEN ( a) POP DROP #FIB @ ( a #) ; ( used for textfile loading version ) : SOURCE ( - a #) BLK @ ?DUP IF ( blk) BLOCK 1024 ( a #) ELSE FBLK @ ?DUP IF ( handle) ?REFILL ( a #) ELSE TIB @ #TIB @ ( a #) THEN THEN ; ( used for block only loading version ) : SOURCE ( - a #) BLK @ ?DUP IF ( blk) BLOCK 1024 ( a #) ELSE TIB @ #TIB @ ( a #) THEN ; ( HASH WORD) : WORD ( c - a) PUSH SOURCE ( buf rem#) OVER SWAP ( buf buf #) >IN @ /STRING 0 MAX ( ie remaining string) R@ -LEADING= ( buf 1stChr rem#) OVER SWAP ( buf 1stChr 1stChr rem#) POP -LEADING<> ( buf 1stChr LastChr+1 rem#) DROP DUP PUSH ( buf 1stChr LastChr+1) OVER - ( buf 1stChr #) DUP HERE C! HERE 1+ SWAP CMOVE ( buf) POP SWAP - 1+ >IN ! ( ) HERE ( a) ; : HASH ( n - vocab-a) CONTEXT SWAP - ; HEX ( -FIND ) CODE -FIND ( h n - h true | pfa false) SI DX MOV, ( save IP) ' CONTEXT 2 + @ #, DI MOV, BX DI SUB, ( hash) DS AX MOV, AX ES MOV, BX POP, ( 'here') 0 [BX] AL MOV, AH AH SUB, ( cnt) AX INC, DI PUSH, BEGIN, DI POP, 0 [DI] DI MOV, ( get next link addr) DI DI TEST, 0=, IF, BX PUSH, BX BX SUB, BX DEC, DX SI MOV, NXT, THEN, DI PUSH, 2 #, DI ADD, ( move to name field) BX SI MOV, ( here) AX CX MOV, ( reload count) REPZ, AL CMPS, 0=, UNTIL, ( fall thru occurs when count is all used up and ) ( the last compare was still equal, now check if indirect ) AX POP, $D6 #, 0 [DI] CMP, ( is 1st byte of pfa magic #?) 0=, IF, ( get indirect addr) DI INC, 0 [DI] DI MOV, THEN, DI PUSH, ( the pfa) BX BX SUB, ( the flag) DX SI MOV, NXT, END-CODE ( Number input ) ( see Ting's version of -DIGIT that leaves a flag) : -DIGIT ( n - n) $30 - DUP 9 > IF 7 - DUP $A < OR THEN DUP BASE @ U< NOT ABORT" ?" ; | : 10*+ ( u a n - u a) ( multiplies number by BASE & adds digit) -DIGIT ROT BASE @ * + SWAP ; ( Number input ) DEFER NUMBER : (SNUMBER ( a # - n) BASE @ PUSH OVER C@ $2D = DUP PUSH IF 1- 1 +UNDER THEN OVER C@ $24 ( $) = IF HEX 1- 1 +UNDER THEN OVER C@ $27 ( ') = IF DROP 1+ C@ ( character value) ELSE 0 ( a # 0 ) ROT ROT ( 0 a #) FOR ( u a ) DUP C@ ( u a n) 10*+ ( u a) 1+ NEXT DROP THEN POP IF NEGATE THEN POP BASE ! ; ( above allows $FF and 'a type literals ) : SNUMBER ( a - n) COUNT ( a #) (SNUMBER ; ' SNUMBER IS NUMBER ( Control ) : -' ( u - here t | pfa f) 32 WORD SWAP -FIND ; : ' ( - pfa) CONTEXT @ -' ABORT" ?" ; : INTERPRET ( blk# offset -) >IN 2! BEGIN 2 -' ( search FORTH) IF NUMBER ELSE EXECUTE THEN AGAIN ; RECOVER : QUERY ( -) TIB @ 255 EXPECT SPAN @ #TIB ! 0 0 >IN 2! ; : (QUIT RP! BEGIN CR QUERY 0 0 ( blk offset) INTERPRET ." ok" AGAIN ; RECOVER ' (QUIT IS QUIT ( default ABORT allows textfiles ) FORTH : (ABORT ( -) ['] DEFAULT-EMIT 1+ @ ['] EMIT 1+ ! FBLK OFF FIBH @ FCLOSE FIBH OFF HERE TYPE$ SPACE POP POP TYPE$ SP! BLK @ ?DUP DROP QUIT ; RECOVER ' (ABORT IS ABORT ( LOAD THRU blocks only ) : LOAD ( u -) >IN 2@ PUSH PUSH ( >FIN 2@ PUSH PUSH 0 0 >FIN 2! ) 0 INTERPRET 10 BASE ! ( POP POP >FIN 2! ) POP POP >IN 2! ; : THRU ( u u -) OVER - 1+ FOR ( n) DUP PUSH LOAD POP 1+ NEXT DROP ; ( LOAD THRU allows text files ) : LOAD ( n -) >IN 2@ PUSH PUSH >FIN 2@ PUSH PUSH 0 0 >FIN 2! 0 INTERPRET 10 BASE ! POP POP >FIN 2! POP POP >IN 2! ; : THRU ( n n -) OVER - 1+ FOR ( n) DUP PUSH LOAD POP 1+ NEXT DROP ; ( source code loading from text files ) : FLOAD ( name -) ( ie " UTILITY.TXT" FLOAD ) >IN 2@ PUSH PUSH >FIN 2@ PUSH PUSH 0 0 >FIN 2! ( name) FOPEN ( handle flag) ABORT" file?" ( handle) FBLK ! ( ) 0 0 INTERPRET ( ) 10 BASE ! FBLK @ FCLOSE FIBH OFF POP POP >FIN 2! POP POP >IN 2! ; : INCLUDE ( -) ( eg INCLUDE options.txt ) 32 WORD 0 OVER COUNT + C! ( a) FLOAD ; ( CLEAR LIST ) : (LIST ( n -) BLOCK ( n a) 16 FOR CR DUP 64 TYPE 64 + NEXT DROP CR ; : LIST ( n -) SCR N! DUP CR ." scr " U. SPACE DUP >UNIT# .FILE (LIST ; : CLEAR ( n -) BLOCK 1024 32 FILL UPDATE ; ( compiling ) : ALLOT ( n -) H +! ; : , ( n -) H @ ! 2 ALLOT ; : C, ( c -) H @ C! 1 ALLOT ; : ,A ( a -) dA @ - , ; : COMPILE POP DUP @ , 2 + PUSH ; COMPILER DEFER LITERAL : SLITERAL ( n - ) COMPILE lit , ; ' SLITERAL IS LITERAL : [ POP DROP ; FORTH : ] BEGIN 4 -' IF 2 -FIND IF NUMBER \ LITERAL ELSE ,A THEN ELSE EXECUTE THEN AGAIN ; RECOVER ( compiling ) : PREVIOUS ( - a n) CONTEXT @ HASH @ 2 + DUP C@ ; : SMUDGE PREVIOUS $20 XOR SWAP C! ; ( flip bit 5 of len byte) : COMPILER 4 CONTEXT ! ; : FORTH 2 CONTEXT ! ; | : does PREVIOUS + 1+ ( to pfa) $E9 OVER C! 1+ DUP POP SWAP 2 + - SWAP ! ( jump to parent's call to dodoes) ; COMPILER : ['] COMPILE lit ; : DOES> COMPILE does $E8 C, ( call) ['] dodoes HERE 2 + - , ; : RECURSIVE PREVIOUS $0DF AND SWAP C! ; : ; \ RECURSIVE POP DROP COMPILE EXIT ; FORTH ( allows headerless words even when not metacompiling ) VARIABLE EDGE VARIABLE H' 0 , ( always zero when not metacompiling ) ( EDGE, ie the edge of the world the headers fall off of, and H' must be set prior to using { or } or HEADERS OFF, e.g. $C000 SET-EDGE. The relocation factor should always be zero. Headers remain visible until PRUNE'd.) : SET-EDGE ( a -) DUP EDGE ! H' ! ; ( e.g. $C000 SET-EDGE ) : { dA @ HERE H' 2@ H ! dA ! H' 2! ; : } { ; : | ( -) H/LESS ON ; ( This block allows relocating the dictionary when not metacompiling. The headers are visible until PRUNE unlinks them.) ( e.g. { NEW-ASSEMBLER LOAD } <use assembler> PRUNE ) | : SCAN ( lfa - lfa) @ BEGIN DUP EDGE @ -1 WITHIN WHILE @ REPEAT ; | : TRIM ( lfa new-lfa - new-lfa) DUP ROT ! ; | : CLIP ( voc-head -) BEGIN DUP SCAN DUP WHILE TRIM REPEAT 2DROP ; : PRUNE ( -) EDGE @ H' @ - IF 4 HASH CLIP 2 HASH CLIP EDGE @ H' ! THEN ; ( (HEAD ) : (HEAD ( -) BLK @ , ( vf) HERE 0 , ( lf) 32 WORD CONTEXT @ 2DUP -FIND NIP NOT IF OVER TYPE$ ." not unique " THEN HASH 2DUP @ ( lfa nfa voc nfa prev.lfa) SWAP 2 - ( lfa nfa voc prev.lfa cur.lfa) ! SWAP ( lfa voc nfa) C@ ( lfa voc len) 1+ ALLOT ! ; ( HEAD allows making individual words headerless with | and allows making whole sections headerless with HEADERS OFF ....... HEADERS ON ) : HEAD ( -) HEADERS @ H/LESS @ NOT AND IF (HEAD ELSE { (HEAD $D6 C, ( magic) H' @ , } THEN H/LESS OFF ; ( Defining words ) FORTH : CREATE HEAD $E9 C, ( JMP instr) lit var HERE 2 + - , ; : : HEAD $E9 C, lit docol HERE 2 + - , SMUDGE ] ; : CONSTANT ( n) HEAD $53 C, $BB C, , $AD C, $E0FF , ; ( 7 byte 46 cyc "in-line" vs 5 byte 86 cyc "central" docon ) : VARIABLE ( -) CREATE 0 , ; : CRASH ( -) -1 ABORT" no vector " ; RECOVER : DEFER ( -) HEAD $B8 C, COMPILE CRASH $E0FF , ; : IS ( a-) ' 1+ ! ; ( WORDS .S debugger .ID STRING ) : WORDS CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + COUNT 31 AND TYPE 2 SPACES ?SCROLL REPEAT DROP ; CODE DEPTH ( - words) BX PUSH, SP BX MOV, HEX DSTACK 2 - #, BX SUB, BX NEG, 1 #, BX SAR, NXT, END-CODE DECIMAL : .S ( -) DEPTH DUP 0< ABORT" underflow " ?DUP IF DUP FOR POP ROT PUSH PUSH NEXT FOR POP POP DUP U. SWAP PUSH NEXT ." <top " ELSE ." stack empty " THEN ; : ? @ . ; : STRING ( delim -) WORD C@ 1+ ALLOT ; ( file names UNIT ) : FILE-NAME: ( ) ( -a) CREATE 32 STRING 0 C, ; : UNIT ( name unit# -) ( e.g. " SUPPL.SCR" 2 UNIT ) DUP ?CLOSE ( name unit#) FNAME ! ; : OPEN ( name unit# -) DUP PUSH UNIT ( ) R@ FNAME @ 0= ABORT" no name " R@ ?OPEN POP HANDLE @ 0< ABORT" OPEN err " ; EXIT ( examples) NAMEZ: PYGMY.SCR FILE-NAME: F3 ASM.SCR ( name unit# ) PYGMY.SCR 0 OPEN F3 1 OPEN " SUPPL.SCR" 2 OPEN ( SAVEM & SAVE for .COM files or memory images) : SAVEM ( fr to -) ( follow with file name) OVER - 1+ ( buf cnt) $20 WORD DUP C@ OVER + 1+ 0 SWAP C! ( buf cnt name) FMAKE ( buf cnt handle flag) ABORT" file?" DUP PUSH FILE-WRITE ( ) POP FCLOSE ; : SAVE ( -) ( follow w/ file name) PRUNE $100 HERE 1- SAVEM ; ( Structures ) COMPILER : \ 4 -' ABORT" ?" ,A ; : BEGIN ( - a) H @ ; : UNTIL ( a -) COMPILE 0branch ,A ; : AGAIN ( a -) COMPILE branch ,A ; : THEN ( a -) H @ dA @ - SWAP ! ; : IF ( - a) COMPILE 0branch H @ 0 , ; : WHILE ( a - a a ) \ IF SWAP ; : REPEAT ( a a -) \ AGAIN \ THEN ; : ELSE ( a - a) COMPILE branch H @ 0 , SWAP \ THEN ; : FOR ( - h) COMPILE for \ BEGIN 0 , ; : NEXT ( h -) DUP \ THEN 2 + COMPILE next ,A ; ( Strings ) HEX COMPILER : ABORT" COMPILE abort" 22 STRING ; : ." COMPILE dot" 22 STRING ; : ( 29 WORD DROP ; : IS ( pfa ) ' 1+ \ LITERAL COMPILE ! ; : " ( -) COMPILE (") 22 STRING 0 C, ( asciiz for files) ; FORTH : ( \ ( ; : ." 22 WORD TYPE$ ; forget : " ( - a) HERE '" STRING 0 C, ; ( embed the string in the dictionary ) ( (BOOT normal opening screen ) DEFER BOOT : (BOOT ( $1F ATTR ! CLS ( to force color to white on blue) CR ." PYGMY Forth v1.4 copyright 1989-1992 by Frank Sergeant" CR OPEN-FILES .FILES CR ." hi" QUIT ; RECOVER ' (BOOT IS BOOT ( RESET ) : RESET NB ADDRESS 256 - DUP TIB ! ( 256) 258 - FIB ! HEADERS ON H/LESS OFF >IN OFF dA OFF 10 BASE ! 0 0 AT AT@ 256 U/ ATTR ! CLS EMPTY-BUFFERS FORTH BOOT ; RECOVER ( final block of kernel ) ' RESET dA @ - ' boot 7 + ! ( patch) " PYGMY.SCR" dA @ - ' FILES 7 + ! ( ie " PYGMY.SCR" 0 UNIT) 6 HASH @ dA @ - ' CONTEXT 2 + @ dA @ - 2 - ! 8 HASH @ dA @ - ' CONTEXT 2 + @ dA @ - 4 - ! HERE dA @ - ' H 2 + @ dA @ - ! ( ie initialize target's dict. ptr) } ( to host ) ( Start of Extensions) ( NFA "works" with headerless words) : NFA ( pfa - nfa | 0) 2 FOR I 1+ 2* HASH BEGIN @ ( pfa lfa) ?DUP WHILE 2DUP 2 + C@+ $1F AND + DUP C@ $D6 = IF 1+ @ THEN ( pfa lfa pfa candidate-pfa) = UNTIL 2 + NIP POP DROP EXIT THEN NEXT DROP 0 ; ( FORGET ) : FORGET ( -) ' NFA 2 - ( lfa) DUP PUSH ( ie save the new HERE ) @ ( prev-lfa) ( ie will be the new top word in current vocab) 2 4 CONTEXT @ OVER = IF SWAP THEN ( current-lfa current-vocab other-vocab) DUP HASH @ ( ie top lfa of other vocab) BEGIN R@ OVER U< WHILE @ REPEAT ( ie walk back until lfa is before the new HERE ) SWAP HASH ! ( current-lfa current-vocab) HASH ! ( ) POP ( new-HERE) 2 - ( ie adjust for view field) H ! ; ( usage FORGET TST ) ( Editor ) | VARIABLE INS ( insert or overwrite flag) | VARIABLE XIN | VARIABLE #CUTS : CLAMP ( n lo hi - n') PUSH MAX POP MIN ; | : .H ( -) CUR@ 0 0 AT ." scr # " SCR @ DUP . >UNIT# .FILE ." find(3,1) rep(4,2) del(5) join(6) cut(7,8) " INS @ IF ." i c=" ELSE ." c=" THEN #CUTS ? AT ; | : L1 ( -) SCR @ BLOCK EBUF ! .H ; | : L2 ( -) CUR@ 1 0 AT EBUF @ 64 FOR 45 EMIT NEXT CR 16 FOR 64 FOR C@+ EMIT NEXT ." |" CR NEXT DROP ( ) 64 FOR 45 EMIT NEXT AT ; : L ( -) L1 L2 ; ( Editor ) | : A>B ( a - a) ( rel-addr to buffer addr) EBUF @ + ; | : CK-CUR ( -) XIN @ 0 MAX $3FF MIN XIN ! ; | : SET-CUR ( -) CK-CUR XIN @ 64 U/MOD 2 + SWAP AT ; | : S! ( c -) DUP XIN @ A>B C! EMIT 1 XIN +! UPDATE ; | : L>A ( line# - a) 64 * ; | : A>L ( a - line#) 64 / ; | : (B>B) ( fr to # - fr' to' #) ROT EBUF @ + ROT EBUF @ + ROT 0 MAX UPDATE ; | : B>B ( fr to # -) (B>B) CMOVE> ; | : B<B ( fr to # -) (B>B) CMOVE ; ( Editor ) | : X ( - pos) ( x= 0..63) XIN @ 63 AND ; | : #REM ( - #) 64 X - ; | : .EOL ( -) SET-CUR XIN @ ( a) A>B ( a') CUR@ ROT #REM FOR C@+ EMIT NEXT DROP AT ; | : >BEG ( a - a) $FFC0 AND ; | : >END ( a - a) 63 OR ; ( Editor ) | : BLANK ( a # -) SWAP A>B SWAP 32 FILL ; | : INSERT ( c -) SET-CUR XIN @ DUP 1+ ( c from to ) #REM 1- ( ie cnt) B>B ( c) S! X IF .EOL THEN ; | : DELETE ( -) SET-CUR XIN @ ( a) DUP DUP 1+ SWAP #REM 1- B<B ( a) >END 1 BLANK ( ) .EOL ; | : SPREAD ( l# -) L>A DUP 64 + 16 L>A OVER - B>B ; | : SPLIT ( -) XIN @ A>L 15 < IF XIN @ DUP DUP A>L 1+ DUP SPREAD ( a a l#) L>A DUP 64 BLANK ( a a a) #REM B>B ( a a) #REM BLANK ( ) XIN @ >BEG 64 + XIN ! SET-CUR L THEN ; ( Editor HOLES ) | : HOLES ( -) 19 0 2DUP AT ( y x) 80 SPACES AT ( ) ." how many holes? " ( 0 0 >IN 2!) QUERY ( TIB @ 4 EXPECT) 0 WORD NUMBER 0 50 CLAMP ?DUP ( 0 | u u) IF ( u) #CUTS OFF ( u) SCR @ >UNIT# ( u unit#) DUP RANGE PUSH ( save end# for later) DROP ( u unit#) 2DUP ( u unit# u unit#) HANDLE @ MORE ( u unit#) ?OPEN ( u) ( POP SWAP PUSH PUSH ) ( u) ( Rstk: end#) ( u) SCR @ ( #ins aft#) 2DUP ( #ins aft# #ins aft#) POP OVER - ( ie #above-insert-pt) PUSH ( #ins aft# #ins aft#) ( Rstk: unit# #above) 1+ ( ie 1st-scr-to-move) DUP ROT + POP COPIES ( #ins aft#) SWAP FOR ( aft#) 1+ DUP CLEAR NEXT DROP ( ) FLUSH L THEN ; ( Editor ) | : DEL-LN ( -) XIN @ >BEG DUP 64 + SWAP ( fr to) 15 L>A DUP PUSH OVER - ( fr to #) B<B POP 64 BLANK L ; | : JOIN ( -) XIN @ A>L 15 < IF XIN @ ( a) DUP 64 + >BEG DUP PUSH SWAP #REM B>B ( ) R@ DUP #REM + SWAP X B<B ( left justify) ( ) POP X + #REM BLANK L THEN ; | : CUT ( -) XIN @ >BEG A>B ( fr) #CUTS @ 64 * HERE + 256 + ( to) 64 CMOVE 1 #CUTS +! 64 XIN +! L ; | : UNCUT ( -) #CUTS @ ?DUP IF HERE 256 + DUP ( fr) XIN @ >BEG A>B ( to) 64 CMOVE ( # to) DUP 64 + ( fr) SWAP ROT 1- #CUTS N! 64 * ( #) CMOVE 64 XIN +! UPDATE L THEN ; ( Editor ) | VARIABLE SLEN ( holds len of following string) 1 SLEN ! | VARIABLE S$ 64 ALLOT 32 S$ ! ( default is a space) | : -SRCH ( - flg) XIN @ A>B ( a) 1024 XIN @ - FOR ( do it up to 1024 times) DUP S$ SLEN @ COMP WHILE 1+ NEXT -1 ( not found) ELSE POP DROP SLEN @ + 0 ( found) THEN SWAP EBUF @ - XIN ! ; | : SRCH ( -) -SRCH DROP ; | : SET$ ( -) 19 1 2DUP AT 80 SPACES ( y x) AT ." enter search string " S$ 64 EXPECT SPAN @ SLEN ! ( SPAN OFF) ." ok " SRCH ; | : SRCHX ( -) SCR @ >UNIT# RANGE PUSH DROP ( Rstk: end#) BEGIN ( ) ?SCROLL -SRCH ( flg) SCR @ R@ < ( flg flg) AND ( flg) WHILE ( ) 1 SCR +! XIN OFF L1 REPEAT POP DROP L2 ; ( Editor ) | VARIABLE RLEN ( holds len of following string) RLEN OFF | VARIABLE R$ 64 ALLOT ( default is null) | : REPL ( -) SET-CUR RLEN @ IF SLEN @ ( #) DUP NEGATE XIN +! FOR DELETE NEXT ( ) R$ RLEN @ FOR C@+ INSERT NEXT DROP THEN ; | : SETR$ ( -) 20 0 2DUP AT 80 SPACES ( y x) AT ( ) ." enter replace string " R$ 64 EXPECT SPAN @ RLEN ! ( SPAN OFF) ." ok " REPL ; ( Editor ) | : ?BUMP ( block-increment -) SCR @ DUP PUSH + ( scr') POP 2DUP >UNIT# RANGE ( scr' scr scr' 1st last) BETWEEN IF SWAP THEN SCR ! DROP L XIN OFF ; | : PgUp ( -) -1 ?BUMP ; | : PgDn ( -) 1 ?BUMP ; | : -INS INS @ NOT INS ! .H ; | : Rt 1 XIN +! ; | : Lt -1 XIN +! ; | : Up -64 XIN +! ; | : Dn 64 XIN +! ; | : Home ( -) ( move to beginning of line or to top of screen) X ?DUP IF NEGATE ELSE -1024 THEN XIN +! ; | : End ( -) ( move just past last chr on line) XIN @ >END A>B BEGIN DUP C@ 32 = WHILE 1- REPEAT EBUF @ - 1+ XIN @ >BEG MAX XIN ! ; ( Editor ) | CREATE MATES 0 , 0 , ( room for two block numbers) | : MARK ( -) SCR @ MATES DUP @ OVER 2 + ! ! ; | : ALTERNATE ( -) SCR @ PUSH MATES 2@ = IF 1000 R@ >UNIT# 1 AND ( odd?) IF NEGATE THEN ( rel) ELSE MATES 2@ - ABS NEGATE R@ DUP MATES 2@ PUSH U< SWAP POP U< OR IF ABS THEN ( rel) THEN ( rel) POP SWAP OVER + ( old new) DUP DUP >UNIT# RANGE BETWEEN IF SWAP THEN DROP SCR ! L XIN OFF ; ( Use Ctrl-A to alternate between shadow blocks, use Alt-A to mark the current block as one of the base blocks. ) ( Editor SPCL uses (ONEKEY codes ) : ', ( -) ' , ; | CREATE SPCL' 205 C, ', Rt 203 C, ', Lt 200 C, ', Up 208 C, ', Dn 199 C, ', Home 207 C, ', End 201 C, ', PgUp 209 C, ', PgDn 210 ( Ins) C, ', -INS 211 ( Del) C, ', DELETE 187 ( F1) C, ', SRCH 188 ( F2) C, ', REPL 189 ( F3) C, ', SET$ 190 ( F4) C, ', SETR$ 191 ( F5) C, ', DEL-LN 192 ( F6) C, ', JOIN 193 ( F7) C, ', CUT 194 ( F8) C, ', UNCUT 195 ( F9) C, ', HOLES 196 ( F10) C, ', SRCHX 1 ( Ctrl-A) C, ', ALTERNATE 158 ( Alt-A) C, ', MARK | : SPCL ( n -) SPCL' 22 FOR 2DUP C@ - WHILE 3 + NEXT 2DROP ELSE SWAP POP 2DROP ( a) 1+ @ EXECUTE THEN ; ( ED ) : BEEP 7 EMIT ; : ED ( -) DECIMAL XIN OFF CLS L BEGIN SET-CUR KEY DUP 27 - WHILE ( not ESC) DUP 08 = IF DROP XIN @ IF -1 XIN +! DELETE THEN ELSE DUP 13 = IF DROP SPLIT ELSE DUP 32 127 WITHIN IF ( regular-key) INS @ IF INSERT ELSE S! THEN ELSE SPCL THEN THEN THEN REPEAT DROP 19 0 AT ; : EDIT ( n -) INS OFF DUP BLOCK DROP SCR ! ED ; ( SETTLE let heavy blocks settle to the bottom of the range) : HEAVY? ( blk# - f) BLOCK 1024 -TRAILING NIP ; : SETTLE ( 1st last -) OVER - OVER SWAP ( 1st 1st #) 0 MAX FOR ( from to) 1 +UNDER OVER HEAVY? OVER HEAVY? NOT AND IF ( from to) 2DUP COPY OVER CLEAR 1+ ELSE DUP HEAVY? IF 1+ THEN THEN NEXT 2DROP ; : CHOP ( unit -) ( truncate ending blank blocks) FLUSH DUP DUP RANGE SWAP PUSH ( unit unit hi-blk#) ( Rstk: start#) BEGIN DUP HEAVY? NOT WHILE 1- REPEAT 1+ POP - ( unit unit #blks-to-keep) 1024 M* ROT HANDLE @ SET-FILE-SIZE ( unit) ?OPEN ; ( assembler control words ) VARIABLE DISP VARIABLE FLAGS ( xxxxxxccOMIAGSDW ) : ASM-RESET ( -) 2 FLAGS ! ( D on is default) DISP OFF ; : IF, ( opcode - a) C, HERE 0 C, ( save room for offset ) ; : WHILE, ( a1 opcode - a2 a1) IF, SWAP ; : NOT, ( opcode - opcode') 1 XOR ; : THEN, ( a -) HERE OVER 1+ - SWAP C! ; : ELSE, ( a - a') $EB ( ie intra-seg dir short jmp) C, HERE OVER - SWAP C! HERE 0 C, ; : BEGIN, ( - a) HERE ; : UNTIL, ( a opc -) C, HERE 1+ - C, ; : CODE HEAD ASM-RESET ; : END-CODE ; ( it doesn't need do anything in Pygmy) HEX ( relative jumps ) | : opc ( opcode -) ( - opcode) CREATE C, DOES> C@ ; 73 opc CS, 75 opc 0=, 79 opc 0<, 73 opc U<, E3 opc CXNZ, 7D opc <, 7E opc >, 76 opc U>, ( 71 opc OV, ) ( the rest can be made by following above with NOT, ) : LOOP, ( a -) E2 UNTIL, ; : LOOPZ, ( a -) E1 UNTIL, ; : LOOPNZ, ( a -) E0 UNTIL, ; HEX ( bit-flags and reg seg & r/m defining words ) ( VARIABLE DISP VARIABLE FLAGS ( xxxxxxccOMIAGSDW ) ( M=r/m; cc=reg count; I=immediate; A=accumulator; G=seg;) ( S=imm.size; D=direction; W=word or byte; O=disp only ) | : F-SET ( mask -) FLAGS @ OR FLAGS ! ; | : F-CLR ( mask -) -1 XOR FLAGS @ AND FLAGS ! ; | : F-GET ( mask -) FLAGS @ AND ; | : F-FLIP ( mask - ) FLAGS @ XOR FLAGS ! ; | : <reg> ( a - n) DUP 1+ C@ DUP 1 AND 1 XOR 2* 2* OR F-SET C@ ; | : reg ( 000a000w00rrr000 -) ( - 0000000000rrr000) CREATE , DOES> <reg> 100 FLAGS +! ( count regs) 2 F-FLIP ; | : seg ( n -) ( -n) CREATE , DOES> <reg> 2 F-SET ; | : r/m ( n -) ( disp - n) CREATE , DOES> <reg> 2 F-CLR ( D) SWAP DISP ! ; ( default D is on, r/m clears it, reg flips it, seg sets it) ( D=0 when r/m field is destination ) HEX ( R/M & REG are 16bit constants, but reg keeps count ) 4000 r/m [BX+SI] 4001 r/m [BX+DI] 4002 r/m [BP+SI] 4003 r/m [BP+DI] 4004 r/m [SI] 4005 r/m [DI] 4006 r/m [BP] 4007 r/m [BX] C006 r/m ) ( chg this?) ( bits 3-5=reg, bit 8=W, bit 9=D flg, bit 12=ACC flg ) 1100 reg AX 0108 reg CX 0110 reg DX 0118 reg BX 0120 reg SP 0128 reg BP 0130 reg SI 0138 reg DI 1000 reg AL 0008 reg CL 0010 reg DL 0018 reg BL 0020 reg AH 0028 reg CH 0030 reg DH 0038 reg BH 0900 seg ES 0908 seg CS 0910 seg SS 0918 seg DS | CREATE F$ 4457 , 4753 , 4941 , 4F4D , : 2^ ( n - 2^n) 1 SWAP FOR 2* NEXT ( 2/) ; | : .F ( -) FLAGS @ 8 FOR R@ 2^ F-GET IF F$ R@ + C@ ELSE 20 THEN EMIT NEXT 100 / 3 U.R ." regs " ; HEX ( REG>R/M #, orW 11mod 01mod 10mod ,DISP BYTE ) | : R>M ( reg -r/m) 2/ 2/ 2/ ; | : 1REG? 100 F-GET ; | : SHORT? ( n - f) -80 80 WITHIN ; : #, ( n1 - n1) 20 OVER SHORT? 04 AND OR F-SET ; | : orW ( --opc--- - --opc--w) 1 F-GET OR ; | : orDW ( --opc--- - --opc-dw) 3 F-GET OR ; | : modDISP, ( 2nd - ) 40 F-GET ( ie M) IF 80 F-GET ( ie Only) IF C, DISP @ , ELSE 8 F-GET ( ie G) DISP @ OR OVER 7 AND 6 = OR ( ie[BP]) IF DISP @ SWAP OVER SHORT? IF 40 OR C, C, ELSE 80 OR C, , THEN ELSE ( zero & not seg) C, THEN THEN ELSE C0 OR C, THEN ; | : IMM? ( -f) 20 F-GET ; : ACC? ( -f) 10 F-GET ; | : ,IMM ( n -) 5 F-GET 4 = IF ( S,-W) C, ELSE , THEN ; : W-PTR ( -) 1 F-SET ; ( the default is byte ) | : 2REGS? ( -f) 308 F-GET DUP 200 = SWAP 108 = OR ; ( one byte opcodes with no variables ) HEX | : M1 ( n -) ( -) CREATE , DOES> @ C, ASM-RESET ; 98 M1 CBW, F8 M1 CLC, FC M1 CLD, FA M1 CLI, F5 M1 CMC, 99 M1 CWD, CF M1 IRET, 90 M1 NOP, C3 M1 RET, CB M1 LRET, F9 M1 STC, FD M1 STD, FB M1 STI, D7 M1 XLAT, F3 M1 REP, F3 M1 REPZ, F2 M1 REPNZ, 9C M1 PUSHF, 9D M1 POPF, ( 2 operand instructions such as ADD, ) HEX | : M2 ( n -) ( various - ) CREATE , DOES> @ PUSH IMM? IF ACC? IF DROP POP orW 4 OR C, ELSE 1REG? IF R>M THEN 80 orW C, POP 38 AND OR modDISP, THEN ,IMM ELSE 2REGS? IF SWAP R>M THEN POP orDW C, OR modDISP, THEN ASM-RESET ; HEX ( use M2 to define ADD, like instructions ) 10 M2 ADC, 00 M2 ADD, 20 M2 AND, 38 M2 CMP, 08 M2 OR, 18 M2 SBB, 28 M2 SUB, 30 M2 XOR, HEX ( MOV, ) : MOV, IMM? IF 1REG? IF R>M B0 OR 1 F-GET 2* 2* 2* OR C, ELSE C6 orW C, modDISP, THEN ,IMM ELSE 90 F-GET 90 = IF 2DROP A0 2 F-FLIP orDW C, DISP @ , ELSE 2REGS? IF 2 F-GET ( ie D) IF SWAP THEN R>M THEN 8 F-GET ( ie G) IF 1 F-CLR 8C ELSE 88 THEN orDW C, OR modDISP, THEN THEN ASM-RESET ; ( one byte instr w/ W - the string instructions ) HEX | : M3 ( n -) ( reg -) CREATE , DOES> @ orW C, DROP ASM-RESET ; A6 M3 CMPS, AC M3 LODS, A4 M3 MOVS, AE M3 SCAS, AA M3 STOS, ( mul, div, etc. xxxxxxxW mdNNNr/m ) HEX | : M4 ( n -) ( -) CREATE , DOES> @ F6 orW C, SWAP 1REG? IF R>M THEN OR modDISP, ASM-RESET ; 30 M4 DIV, 38 M4 IDIV, 28 M4 IMUL, 20 M4 MUL, 18 M4 NEG, 10 M4 COM, ( NOT, is the the Intel name for my COM, but it would conflict w/ my flag inverter which I call NOT, ** be careful ** ) ( M5 for LDS, LEA, & LES, ) HEX | : M5 ( n -) ( -) CREATE , DOES> @ , OR modDISP, ASM-RESET ; C5 M5 LDS, 8D M5 LEA, C4 M5 LES, ( M6 for the rotate & shift instructions ) HEX | : M6 ( n -) ( n# r/m | r/m - ) CREATE , DOES> @ IMM? 10 U/ 2 XOR 1 F-GET ( ie W) OR D0 OR C, 1REG? IF SWAP R>M THEN OR modDISP, IMM? IF DROP THEN ASM-RESET ; 10 M6 RCL, 0 M6 ROL, 20 M6 SHL, 18 M6 RCR, 08 M6 ROR, 38 M6 SAR, 28 M6 SHR, ( examples to shift right 1 bit ) ( 1 #, SI SHR, 1 #, W-PTR 17 [BX] SHR, 1 #, AL SHR, ) ( examples to shift right the # of bits in CL ) ( SI SHR, AL SHR, 1300 rt-par SHR, 3752 W-PTR rt-par SHR, ) ( INC, & DEC, instructions ) HEX | : M7 ( n -) ( r1 | r/m -) CREATE , DOES> @ SWAP 1REG? IF ( opc r1) R>M THEN 1REG? 100 = 1 F-GET AND ( ie it's a 2-byte register) IF ( opc rX) OR 40 OR C, ELSE ( opc mem | opc rH | opc rL ) FE orW C, OR modDISP, THEN ASM-RESET ; 08 M7 DEC, 00 M7 INC, ( PUSH, & POP, instructions ) HEX | : M8 ( n -) ( reg | seg | r/m -) CREATE , DOES> @ 8 F-GET IF ( seg opc ) 2/ 2/ 2/ 2/ 1 AND 1 XOR 6 OR OR C, ELSE 1REG? IF ( reg opc ) 2/ 8 AND 8 XOR 50 OR SWAP R>M OR C, ELSE ( r/m opc) DUP 100 U/ FF AND C, OR modDISP, THEN THEN ASM-RESET ; FF30 M8 PUSH, 8F00 M8 POP, ( IN, OUT, instr ) HEX | : M9 ( n -) ( n# r1 | r1 -) CREATE , DOES> @ orW NIP IMM? IF ( n# opc) C, ( n#) ELSE ( opc) 8 OR THEN C, ASM-RESET ; E4 M9 IN, E6 M9 OUT, ( use port #, AL IN, or port #, AX IN, for 8 bit ports ) ( or AL IN, or AX IN, for port in the DX register ) ( do not use AL DX IN, - the DX is implied ) ( XCHG ) HEX : XCHG, ( reg mem | mem reg | reg1 reg2 -) 211 F-GET 211 = ( 2 regs & one is AX) IF ?DUP IF NIP THEN ( r1 ) R>M 90 OR C, ELSE 2REGS? IF R>M THEN OR 86 orW C, modDISP, THEN ASM-RESET ; ( TEST, instruction - almost like ADD, etc. ) HEX : TEST, ( various - ) IMM? IF ACC? IF DROP A8 orW ( 4 OR) C, ELSE 1REG? IF R>M THEN F6 orW C, ( OR) modDISP, THEN ,IMM ELSE 2REGS? IF SWAP R>M THEN 84 orW C, OR modDISP, THEN ASM-RESET ; ( INT, & segment override instructions ) HEX : INT, ( #n -) CD C, C, ASM-RESET ; ( eg 21 #, INT, ) : ES: ( -) 26 C, ; : CS: ( -) 2E C, ; : SS: ( -) 36 C, ; : DS: ( -) 3E C, ; ( CALL, instr ) HEX : CALL, ( various -) IMM? ( intra-seg direct ) IF ( n#) HERE 3 + - ( make it relative) E8 C, , ( eg 2389 #, CALL, calls addr $2389) ELSE ( mem | reg -) 1REG? IF R>M THEN FF C, 10 OR modDISP, ( eg 0 [BX] CALL, or DX CALL, ) THEN ASM-RESET ; ( this is intra-seg indirect ) ( I am not implementing the inter-seg direct or indirect versions ) ( JMP, instr & NXT, ) HEX : JMP, ( various -) 140 F-GET ( ie R or M intra-seg indirect ) IF ( mem | reg -) 1REG? IF R>M THEN FF C, 20 OR modDISP, ( eg 0 [BX] JMP, DX JMP, ) ( or 3759 rt-paren JMP, ) ELSE ( a) HERE 3 + - ( relative) DUP SHORT? IF 1+ EB C, C, ELSE E9 C, , THEN ( disp is added to IP, so this is a relative jump ) THEN ASM-RESET ; : LJMP, ( a -) $E9 C, HERE 2 + - , ; ( lay down 3byte jump) ( I am not implementing the inter-seg direct or indir. versions) : NXT, ( -) AX LODS, AX JMP, ; : SWITCH, SP BP XCHG, ; FORTH ( loading of options is controlled by parenthesis in column 1) ( 136 LOAD ( NEWFILE create new block file w/ 8 blocks) 137 LOAD ( MS clock speed independent timing) ( 138 LOAD ( VIEW for listing only) 139 LOAD ( VIEW for editing) 140 LOAD ( .ID SEE) ( 141 LOAD ( NAMEZ:) 142 LOAD ( OF THENS from Wil Baden ) 143 144 THRU ( L@ L! LC@ LC!) ( 145 LOAD ( various EMITs >STD >DOS allow redirection) ( 146 LOAD ( show IBM graphics characters ) ( 147 LOAD ( FLIP) ( 148 LOAD ( allow hundreds of files) ( loading of options is controlled by parenthesis in column 1) ( 149 LOAD ( the name is the string ) ( 150 LOAD ( 2/MOD ) ( 151 LOAD ( INDEX ) ( 152 LOAD ( LCMOVE & LCMOVE>) 153 159 THRU ( print blocks SHOW SHOW2 SHADOW ) ( 160 LOAD ( BELL ) ( 161 LOAD ( BLK>TXT append range of blocks to textfile) ( 162 LOAD ( TXT>BLK create new block file from textfile) ( 163 LOAD ( one possible CASE: ) ( 164 LOAD ( SCROLL-UP SCROLL-DOWN) ( 165 166 THRU ( COLORS RED ON-CYAN etc.) ( 167 LOAD ( INT3, for breakpoints) ( code, notes, & tips for Starting Forth begin on scr 178) ( loading of options is controlled by parenthesis in column 1) ( 168 LOAD ( #INPUT input a number ) ( 169 LOAD ( GETARG$ DOS Command Line Reader) ( 170 174 THRU ( SHELL for executing DOS commands) ( 175 LOAD ( DATE & TIME from DOS) ( 176 LOAD ( textfile left paren for multi-line cmnts) ( 177 LOAD ( load blocks relative to current unit# ) ( NEWFILE create new block file with 8 blocks) : NEWFILE ( name -) DUP FOPEN ( name handle flag) IF DROP ( name) FMAKE ABORT" file?" ( handle) 8 OVER MORE ( handle) ELSE DROP ." file already exists " THEN ( handle) FCLOSE ; EXIT examples " MYFILE.SCR" NEWFILE " TEST.SCR" NEWFILE then open as you would any file, e.g. " TEST.SCR" 4 OPEN ( machine speed independent MS for proper timing) CODE T0@ ( - u) ( read timer zero) BX PUSH, ( make room on the stack) AL AL SUB, $43 #, AL OUT, ( latch timer0) $40 #, AL IN, AL BL MOV, $40 #, AL IN, AL BH MOV, NXT, END-CODE ( timer 0 goes through 2 65,536 counts 18.2 times per second, so 65536 18.2 * 2* 1000 / should give time for 1 ms, or a count of 2385.5, but we'll reduce the count some to allow for the loop in MS) : 1ms ( -) T0@ BEGIN ( first) DUP T0@ - 2330 > UNTIL DROP ; : MS ( # -) FOR 1ms NEXT ; ( VFA VIEW list the block) : VFA ( pfa -) NFA 4 - ; : VIEW ( -) ' VFA @ ?DUP IF LIST THEN ; ( VFA VIEW V pop up the editor) : VFA ( pfa -) NFA 4 - ; : VIEW ( -) ( e.g. VIEW DUP) ' VFA @ ?DUP IF EDIT ( ELSE ." defined at keyboard" CR ) THEN ; : V VIEW ; ( shorthand ) ( streamlined version of SEE - used only for DEFER'd words) : .ID ( pfa -) NFA DUP 0= ABORT" ?" TYPE$ ; : SEE ( -) CR ' DUP C@ $B8 = IF DUP 1+ @ .ID CR THEN DROP ; ( NAMEZ: defines an asciiz string whose name is the string) : NAMEZ: ( -) ( - a) HEAD HERE NFA ( ** must not be headerless) $C000 , ( al al add, trick puts zero immediately after name ) $53 C, ( bx push,) $BB C, , ( a #, bx mov,) $AD C, $E0FF , ( nxt,) ; ( OF THENS ) COMPILER ( from Wil Baden) : OF COMPILE OVER COMPILE = \ IF COMPILE DROP ; : THENS ( n -) FOR \ THEN NEXT ; FORTH ( L@ & L! ) CODE L@ ( seg offset -- n) ( offset already in BX) ES POP, ( seg) ES: 0 [BX] BX MOV, ( retrieve n) NXT, END-CODE CODE L! ( n seg offset -- ) ( offset already in BX) ES POP, ( seg) AX POP, ( n) ES: AX 0 [BX] MOV, BX POP, ( refill TOS) NXT, END-CODE ( LC@ & LC! ) CODE LC@ ( seg offset -- c) ( offset already in BX) ES POP, ( seg) ES: 0 [BX] ( BX) BL MOV, ( retrieve c) BH BH SUB, NXT, END-CODE CODE LC! ( c seg offset -- ) ( offset already in BX) ES POP, ( seg) AX POP, ( c) ES: AL 0 [BX] MOV, BX POP, ( refill TOS) NXT, END-CODE ( DOS-EMIT for non-pc compatible MS-DOS computers ) VARIABLE TEMP : STD-OUT ( c -) ( uses handle 1) TEMP C! TEMP ( to DX) 1 ( to CX) 1 ( to BX) $4000 ( to AX) DOS 2DROP ; : DOS-OUT ( c -) ( uses Display Character function ) ( c to DX) 0 0 ( ie zeroes to CX & BX) $0200 ( func 2 to AX) DOS 2DROP ; : >DOS ( -) ['] DOS-OUT IS EMIT ; : >STD ( -) ['] STD-OUT IS EMIT ; ( show IBM graphics characters ) : TST-GPH ( -) CLS 128 ( chr) 128 FOR DUP . SPACE DUP EMIT SPACE 1+ NEXT DROP ; : TST-NON CLS 0 ( chr) 128 FOR DUP . SPACE DUP EMIT SPACE 1+ NEXT DROP ; ( FLIP ) : FLIP ( hhll - llhh) DUP $100 * SWAP $100 U/ OR ; ( relocate the handle alias table to allow more than 15 files) HEX CREATE HANDLE-ALIAS-TABLE MAX-FILES 5 + 20 MAX ALLOT 32 CONSTANT HAT-LENGTH 34 CONSTANT HAT-OFFSET VARIABLE HAT-LENGTH-SAVE VARIABLE HAT-OFFSET-SAVE : HAT-ON ( -) ['] HANDLE-ALIAS-TABLE MAX-FILES 5 + 20 MAX FF FILL HAT-OFFSET @ ['] HANDLE-ALIAS-TABLE MAX-FILES 5 + 20 MAX CMOVE HAT-OFFSET @ 5 + 0F FF FILL HAT-LENGTH @ HAT-LENGTH-SAVE ! HAT-OFFSET @ HAT-OFFSET-SAVE ! ['] HANDLE-ALIAS-TABLE HAT-OFFSET ! MAX-FILES 5 + 20 MAX HAT-LENGTH ! ; : HAT-OFF ( -) RESET-FILES HAT-OFFSET-SAVE @ HAT-OFFSET ! HAT-LENGTH-SAVE @ HAT-LENGTH ! ; ( words whose name is its string ) : NAME: ( -) ( -a) HERE 2 + CONSTANT ; ( this version does not put a zero at end of name) : NAMEZ: ( -) ( -a) HERE 2 + CODE ( AL AL ADD,) $C000 , ( trick to put a zero immediately after name ) BX PUSH, ( a) #, BX MOV, NXT, ; : .NAME: ( -) ( -) HERE 2 + CREATE , DOES> @ TYPE$ ; ( types its own name) EXIT usage NAME: AEROPLANE NAME: CABBAGE CABBAGE TYPE$ ( will type out "CABBAGE" ) ( 2/MOD ) CODE 2/MOD ( u - r q ) ( unsigned ) AX AX SUB, 1 #, BX SHR, 1 #, AX RCL, AX PUSH, NXT, END-CODE ( similar to regular INDEX but w/ only one argument) : INDEX ( n -) BEGIN DUP ?SCROLL CR DUP 4 .R SPACE DUP BLOCK 64 TYPE 1+ AGAIN ; ( It is designed to blow up at end of the file. Because paging up and down through a file is so fast, I don't usually use INDEX.) ( move anywhere in full PC address space ) CODE LCMOVE ( seg fr seg to # - :moving words & then ?odd byte) CLD, SI DX MOV, BX CX MOV, DI POP, ES POP, SI POP, DS POP, 1 #, CX SHR, REP, W-PTR AX MOVS, CX CX ADC, REP, ( BYTE) AL MOVS, CS AX MOV, AX DS MOV, BX POP, DX SI MOV, NXT, END-CODE CODE LCMOVE> ( seg fr seg to # - :moving words & then ?odd byte) STD, SI DX MOV, BX CX MOV, DI POP, ES POP, SI POP, DS POP, BX DEC, BX DEC, BX SI ADD, BX DI ADD, 1 #, CX SHR, REP, W-PTR AX MOVS, CX CX ADC, SI INC, DI INC, REP, ( BYTE) AL MOVS, CS AX MOV, AX DS MOV, BX POP, DX SI MOV, CLD, NXT, END-CODE ( (PEMIT to printer ) : (PEMIT ( c -) ( print chr to LPT1: ) 0 0 $0500 DOS 2DROP ; : >PRN ( -) ['] (PEMIT IS EMIT ; : >SCR ( -) ['] DEFAULT-EMIT 1+ @ IS EMIT ; ( SHOW ) VARIABLE SCR-LIMIT : SCR<LIMIT? ( n - f) SCR-LIMIT @ < ; : .SCR# ( n -) ." scr # " 5 .R ; : .LINE ( a - a') 64 FOR C@+ EMIT NEXT ; : 2LINES ( a1 a2 - a1' a2') SWAP .LINE 4 SPACES SWAP .LINE CR ; ( SHOW 3 blocks per page ) DEFER .HD ( print a heading ) : (.HD ( scr# -) ." file " >UNIT# .FILE ; ' (.HD IS .HD VARIABLE LM 7 LM ! ( left margin) : .LM ( -) LM @ SPACES ; : .UNDER ( -) 64 FOR ." _" NEXT ; : SHOW ( 1st last - ) >PRN OVER - 1+ ( 1st #) 0 SWAP ( 1st rel #) FOR ( 1st rel) DUP 3 UMOD 0= IF CR .LM OVER .HD THEN CR CR .LM ." scr # " OVER U. CR OVER BLOCK 16 FOR .LM ." |" .LINE ." |" CR NEXT DROP .LM ." |" .UNDER ." |" 1+ 1 +UNDER DUP 3 UMOD 0= IF $0C EMIT THEN NEXT 3 UMOD IF $0C EMIT THEN DROP >SCR ; ( make printer print in small type ) DEFER CONDENSED : ESC ( -) 27 EMIT ; : OKI-CONDENSED ( -) ( set OKI printer to small print) $1D EMIT ; : EPSON-CONDENSED ( -) ( this might set Epson printer to small print) ( if not, look it up in your printer manual ) 27 EMIT 33 EMIT 4 EMIT ; : LJ-CONDENSED ( -) ESC ." E" ESC ." &l0L" ESC ." &l5E" ( reset, left=0, top=5) ( ESC ." &l0o8D" ESC ." (10U" ESC ." (s0p17h8v0s-b0T" ) ESC ." &l0o6D" ESC ." (10U" ESC ." (s0p17h8v0s-b0T" ( 6 lpi) ( force internal-9 font) ; ( ' NOP) ' LJ-CONDENSED IS CONDENSED ( SHOW2 6 blocks per page ) : 2SCRS ( n1 n2 -) OVER SCR<LIMIT? IF DUP SCR<LIMIT? IF OVER .SCR# 57 SPACES DUP .SCR# CR SWAP BLOCK SWAP BLOCK 16 FOR 2LINES NEXT ELSE SWAP DUP .SCR# CR BLOCK 16 FOR .LINE CR NEXT THEN THEN 2DROP CR CR ; 3 CONSTANT SCRS/COLUMN : SHOW2 ( 1st last -) >PRN CONDENSED DUP 1+ SCR-LIMIT ! OVER - SCRS/COLUMN 2* U/MOD SWAP 1 MIN + FOR DUP .HD CR CR SCRS/COLUMN FOR DUP DUP SCRS/COLUMN + 2SCRS 1+ NEXT $0C EMIT SCRS/COLUMN + NEXT DROP >SCR ; ( SHADOW 6 blocks per page) : 2SCRS ( n1 n2 -) ( for use by SHADOW) OVER .SCR# 58 SPACES DUP .SCR# CR SWAP BLOCK SWAP BLOCK 16 FOR 2LINES NEXT 2DROP CR CR ; ( SHADOW 6 blocks per page) VARIABLE PAGE-CTRL : SHADOW ( 1st last 1st-shadow -) >PRN CONDENSED PAGE-CTRL OFF PUSH OVER - 1+ POP SWAP FOR ( 1st 1st-shadow) PAGE-CTRL @ SCRS/COLUMN UMOD 0= IF OVER .HD CR CR THEN 2DUP 2SCRS 1+ SWAP 1+ SWAP 1 PAGE-CTRL +! PAGE-CTRL @ SCRS/COLUMN UMOD 0= IF $0C EMIT THEN NEXT 2DROP PAGE-CTRL @ SCRS/COLUMN UMOD IF $0C EMIT THEN >SCR ; EXIT : IBM-PRO ( -) ( make NEC emulate IBM PRO-PRINTER) >PRN $1C EMIT ." Dc" >SCR ; : TST ( -) 3600 3602 3900 SHADOW ; ( BELL ) ( this works pc's speaker no matter where EMIT is vectored ) ( it may need longer delays for fast processors ) CODE BELL ( -) $61 #, DX MOV, AL IN, 3 #, AL OR, AL OUT, $1000 #, CX MOV, BEGIN, LOOP, $FC #, AL AND, AL OUT, NXT, END-CODE ( BLK>TXT append a range of blocks to a textfile ) : WRITE-EOL ( h -) PAD 2 ROT FILE-WRITE ; : BLK>TXT ( first last output-name -) 13 PAD C! 10 PAD 1+ C! ( setup crlf at PAD) FOPEN ABORT" output file?" ( first last handle) DUP >EOF ROT ROT OVER - 1+ ( handle first #) PUSH SWAP POP FOR ( blk# handle) DUP WRITE-EOL OVER BLOCK ( blk# h a) SWAP 16 FOR ( blk# a h) PUSH DUP 64 -TRAILING ( blk# a a #) R@ FILE-WRITE R@ WRITE-EOL 64 + POP NEXT SWAP DROP ( blk# handle) 1 +UNDER NEXT FCLOSE DROP ; ( if textfile does not exist you can create it with " textfile.ext" FMAKE DROP FCLOSE ) ( TXT>BLK convert a textfile to a block file ) VARIABLE #LINES : PUT-LINE ( a # h -) PUSH PAD 64 32 FILL PAD SWAP CMOVE ( ) PAD 64 POP FILE-WRITE 1 #LINES +! ; : GET-LINE ( - a #) READ-LINE ( a #) 2DUP -CTRL ( a #) ; : SETUP-FILES ( input-name output-name - handle) #LINES OFF SWAP FOPEN ABORT" input file?" ( out-name in-handle) FIBH ! 0 0 >FIN 2! ( out-name) FMAKE ABORT" output file?" ; : TXT>BLK ( input-name output-name -) SETUP-FILES ( out-handle) PUSH ( ) BEGIN GET-LINE ( a #) BEGIN ( a #) DUP 64 > WHILE ( a #) OVER 64 R@ PUT-LINE 64 - 64 +UNDER REPEAT ( a #) R@ PUT-LINE EOF? UNTIL ( ) PAD 64 32 FILL POP 16 #LINES @ 16 UMOD - ( handle #) FOR DUP PAD 64 ROT FILE-WRITE NEXT ( handle) FCLOSE FIBH @ FCLOSE FIBH OFF ; ( one possible CASE: ) : CASE: ( -) ( n -) CREATE ] DOES> ( n a) 2 + ( move past lit) BEGIN 2DUP @ DUP 0= PUSH ( n a n n') = POP OR NOT ( n a flg) WHILE ( no match) ( n a) 6 + REPEAT NIP 2 + @ EXECUTE ; EXIT N for default must be 00 and the default pair must be last. numbers can be in any order except 00 must be last, e.g. : RED ." RED" ; : BLUE ." BLUE" ; : ORANGE ." ORANGE" ; : PINK ." PINK" ; : BLACK ." BLACK" ; CASE: COLOR 7 RED 12 BLUE 472 ORANGE 15 PINK 00 BLACK ; an actual zero or a no match causes the default to be picked 7 COLOR REDok 472 COLOR ORANGEok 3000 COLOR BLACKok list must end with a semi-colon & numbers can't be constants ( additional BIOS Int $10 video words ) CODE SCROLL-UP ( r c r c #lines attr -) ( scroll w/in window) 6 #, AH MOV, HERE CX POP, CL AL MOV, DX POP, CX POP, CL DH MOV, CX POP, SWITCH, 0 [BP] CH MOV, SWITCH, BL BH MOV, $10 #, INT, BX POP, BX POP, NXT, END-CODE CODE SCROLL-DOWN ( r c r c #lines attr -) 7 #, AH MOV, JMP, END-CODE ( display and cycle through foreground & background colors) : COLORS ( -) BASE @ HEX BEGIN CLS CR CR ." This is attr $" ATTR @ DUP 2 U.R CR CR ." F1 changes foreground, F2 changes background, Esc exits" CR KEY DUP 27 - WHILE 188 ( F2) OF ( attr) $10 + $FF AND ( attr) ELSE 187 ( F1) OF ( attr) DUP 1+ $0F AND SWAP $F0 AND OR ( attr) ELSE DROP BEEP [ 2 ] THENS ATTR ! REPEAT 2DROP BASE ! ; ( Example of setting forground and background attributes.) ( Use previous block to find the attributes you like.) : FG: CREATE C, DOES> C@ ATTR @ $F0 AND OR ATTR ! ; : BG: CREATE C, DOES> C@ 16 * ATTR @ $F AND OR ATTR ! ; 0 FG: BLACK 1 FG: BLUE 2 FG: GREEN 3 FG: CYAN 4 FG: RED 5 FG: PURPLE 6 FG: BROWN 7 FG: GRAY 0 BG: ON-BLACK 1 BG: ON-BLUE 2 BG: ON-GREEN 3 BG: ON-CYAN 4 BG: ON-RED 5 BG: ON-PURPLE 6 BG: ON-BROWN 7 BG: ON-GRAY ( Don't take my color names seriously; I don't have any idea what cyan is, nor the difference between gray & light blue.) ( Addition to the assembler to allow 1-byte software interrupt) ( Suggested by Ian Watters ) : INT3, ( -) $CC C, ; ( input a number) : #INPUT ( - n) QUERY 0 WORD NUMBER ; ( DOS Command Line Reader by L. Greg Lisle) VARIABLE ARG$ 130 ALLOT : GETARG$ ( -- a ) ( Reads the command line args into ARG$ ) ( Returns ARG$ with length byte and ) ( null terminator. ) $80 DUP C@ 2 + 128 MIN ARG$ SWAP CMOVE ARG$ ; EXIT ( SHELL notes ) Greg Lisle and Brad Rodriguez offered versions of SHELL. Rather than choose between them I am just including my own version. Use it to execute DOS commands. Here are some examples to suggest ways to use it. Each usage wastes a little dictionary space, so I have no objection if you rewrite it to be prefix and use PAD. " DIR *.SCR" SHELL ( directory listing of .SCR files) " COPY XYZ.TXT ABC.TXT" SHELL ( copy a file) " DIR *.TXT >TEXTDIR" SHELL ( capture a directory listing) " TEXTDIR" " TEXTDIR.SCR" TXT>BLK ( so you can view it with) " TEXTDIR.SCR" 3 OPEN 3000 EDIT ( the editor) : DIR ( -) " DIR /P" SHELL ; : Q ( filename -) " Q" SWAP shell ; ( invoke textfile editor)( SHELL FCS ) CODE free ( #paragraphs - AX carry) DS AX MOV, AX ES MOV, $4A00 #, AX MOV, ( BX holds #paragraphs to retain) $21 INT, AX PUSH, BX BX SBB, NXT, END-CODE : FREE ( #paragraphs -) free IF ." err# " U. ABORT" FREE error" THEN DROP ; VARIABLE 'SP VARIABLE 'SS CREATE PBLK 14 ALLOT EXIT FREE is actually "FREE-ALL-EXCEPT" as you tell it how many 16-byte paragraphs to keep. ( SHELL FCS ) CODE EXEC ( pgm$ - AX f) BX DX MOV, ( set up file name) PBLK #, BX MOV, SI PUSH, BP PUSH, SS 'SS ) MOV, SP 'SP ) MOV, ( save stack pointer) DS AX MOV, AX ES MOV, $4B00 #, AX MOV, $21 INT, CLI, ( ints off) 'SS ) SS MOV, 'SP ) SP MOV, STI, BP POP, SI POP, BX BX SBB, ( f) AX PUSH, NXT, END-CODE ( SHELL FCS ) : shell ( pgm$ tail$ -) $3000 FREE ( you could lower this) PBLK 14 0 FILL 13 OVER DUP C@ 1+ + C! PBLK 2 + ! ( pgm$) CS@ PBLK 4 + ! ( pgm$) 1+ EXEC ( ax f) IF SPACE U. ABORT" Shell error" THEN DROP ; EXIT ordinarily you would use SHELL on the next block, but here are some usage examples of little shell: " DIR" " *.*" shell " COMMAND.COM" " DIR *.*" shell) ( SHELL FCS ) : SHELL ( tail$ -) " C:\COMMAND.COM" ( a) SWAP " /C " PAD 4 CMOVE ( a) COUNT DUP PUSH ( a+1 #) PAD 4 + SWAP CMOVE POP 3 + DUP PAD C! PAD + 1+ 13 SWAP C! ( pgm$ tail$) PAD shell ; ( This prepends " /C " to the command tail and moves it to PAD, and replaces ending zero byte with CR) ( DATE and TIME by L. Greg Lisle ) CODE DOS3 ( DX CX BX AX - DX CX AX carry) BX AX MOV, BX POP, CX POP, DX POP, 21 #, INT, DX PUSH, CX PUSH, AX PUSH, BX BX SBB, NXT, END-CODE ( also for int 21 ) ( : DOS2 ( dcba- DX AX c) ( DOS3 ROT DROP ; ) : DATE ( -y m d dow) 0 0 0 2A00 DOS3 DROP ROT DUP 100 / SWAP 0FF AND ROT 0FF AND ; : TIME ( -h m s ds) 0 0 0 2C00 DOS3 2DROP DUP 100 / SWAP 0FF AND ROT DUP 100 / SWAP 0FF AND ; ( left paren for multi-line comments in textfiles) COMPILER : ( BEGIN 32 WORD DUP C@ ?DUP WHILE + C@ ') = UNTIL ELSE DROP THEN ; FORTH : ( \ ( ; ( load blocks relative to current unit# ) : UBLK ( blk# - blk#) 1000 UMOD BLK @ >UNIT# 1000 * + ; : ULOAD ( blk# -) UBLK LOAD ; : UTHRU ( 1st last -) SWAP UBLK SWAP BLK THRU ; The following blocks contain some notes and code for using Pygmy with the 1st edition of the book _Starting Forth_ by Leo Brodie. ( DO LOOP R@ I compatible with _Starting Forth_) ( these words were written by Robert Berkey ) FORTH CODE 2R@ ( - x1 x2) BX PUSH, 2 [BP] PUSH, 0 [BP] BX MOV, NXT, END-CODE : (DO) ( limit index - for-index ;R ip - index-offset ip ) OVER 1- POP SWAP PUSH PUSH - ; COMPILER : DO ( runtime: limit index -) COMPILE (DO) \ FOR ; : LOOP ( runtime: - ;R x1 x2 - x1 x2 | x1 x2 - ) \ NEXT COMPILE POP COMPILE DROP ; : R@ ( rntime: - x ) ( r: x - x) COMPILE I ; : I ( -- index) ( ** do not use w/ FOR/NEXT, use R@ instead*) COMPILE 2R@ COMPILE - ; FORTH p. 12 & 13 STARS & CHAPTER 6 DO LOOP +LOOP instead of : STARS 0 DO STAR LOOP ; use : STARS FOR STAR NEXT ; the arguments for DO are limit & starting-index and the loop counts up from starting-index to just before limit e.g. : TST1 7 0 DO I . LOOP ; would print 0 1 2 3 4 5 6 ok FOR ... NEXT only takes one argument, the starting index. It counts down that many times, e.g. : TST1 7 FOR I . NEXT ; would print 6 5 4 3 2 1 0 ok p. 25 stack underflow and overflow Pygmy does not check for stack overflow. It checks for underflow whenever you do .S Anytime an error occurs - such as typing in a word that it doesn't know - it will reset the stack and the return stack to their correct initial values. The word .S will display the contents of the data stack. It shows the entire contents. This is handy for debugging. If before and after loading one or more blocks .S shows different stack pictures you have an error in the blocks, possibly an IF without a matching THEN. p. 50 & p. 83 non-destructive stack print The definition given in the book : .S CR 'S S0 @ 2- DO I @ . -2 +LOOP ; will not work in Pygmy as the following words are not even present in Pygmy 'S S0 2- DO +LOOP. Of course, 2- could be replaced by 2 - However, Pygmy has a built in .S that will work just fine. p. 52 & 53 2SWAP 2DUP 2OVER 2DROP double numbers Pygmy has 2DUP & 2DROP but does not have 2SWAP & 2OVER. Chapter 3 the editor To begin editing a specific block, type n EDIT The Esc key will get you out of the editor. To get back into the same block, just type ED without giving it a block number. There is a short reminder menu on the top line. F3 asks for the string to search for. F1 searches again using the same string. F4 asks for the string to replace it with. F2 does the replace again. F5 will delete the line the cursor is on. F6 will join the following line to the current one. -- continued -- Chapter 3 the editor -- continued -- F7 is the "cut" command and F8 is the "paste" command. Each time you press F7 it copies the current line to the "cut" buffer and moves the cursor down to the next line. Notice that the top status line shows you the count of the number of lines in the "cut" buffer. F8 removes the oldest line from the "cut" buffer and overlays the current line and moves the cursor down to the next line. Try it out on a dummy block to get a feel for it. Use the arrow keys to move around the block and just over- type to make your changes, or press the INS key to change to the insert mode. The backspace key deletes one char to left and Del key deletes the current char. Inserts & deletes only apply to the current line. -- continued -- Chapter 3 the editor The PgUp and PgDn keys allow for very fast movement between blocks. Press CR to split a line at the cursor and to scroll all the lower lines down. The bottom line will be lost. If you make changes you don't want to keep, you can get out ofthe editor with Esc and type EMPTY-BUFFERS to discard any changes that have not yet been written to disk. p. 101 ABORT" Pygmy has an IF built into ABORT" So, you can say DUP 0= ABORT" error " just as in the examples. p. 123 F83's >R is equivalent to Pygmy's PUSH p. 123 F83's R> is equivalent to Pygmy's POP p. 302 F83'S [COMPILE] is equiv to Pygmy's \ that's a backslash - it does not indicate the whole line is commented out as in F83. It forces compilation rather than execution of the following "immediate" word when you are making a colon definition. It only works on words that are in COMPILER. p. 177 <# and number conversion <# does not expect a double number, just a regular 16 bit number. However, in Pygmy you do not need to say TYPE after the ending #> as the the TYPE is done as part of #>. I was undecided as to whether I liked this or not, but it has grown on me. p. 258 TYPE in Pygmy is not like the TYPE in cmFORTH. In Pygmy, TYPE is the same as in _Starting Forth_ and F83, etc. Pygmy also has the word TYPE$ ( a -) which expects the address of a counted string. CHAPTER 9 internal structure In Pygmy, every definition consists of a 2-byte view field, a 2-byte link field, a 1 to 32-byte name field, and a variable length parameter field. The name field consists of a 1-byte count followed by zero to 31 characters. In a colon definition, the parameter field begins with a 3 byte jump to machine language code that nests down a level. Those 3 bytes are followed by the addresses of the words that make up the definition (2 bytes per address). In a CODE definition - machine language - the parameter field begins with the actual machine code. -- continued -- internal structure -- continued -- A word may be headerless, thus beginning with its parameter field. The following is information that you will not need unless you write CODE words: The top stack item is kept in register BX. The word must end with an "in-line" next. This is accomplished by the assembler macro NXT, Register SI is used for IP so if you want to use SI you need to save & restore it. PUSH, & POP, are used for both stacks, see source code examples of switching the value in registers BP & SP by using the assembler macro SWITCH, Miscellaneous _Starting Forth_'s is Pygmy's TIB TIB @
