-
Notifications
You must be signed in to change notification settings - Fork 1
/
pygmy.scr
1 lines (1 loc) · 201 KB
/
pygmy.scr
1
Pygmy Forth version 1.7 copyright 1989-2007 Frank C. Sergeant - [email protected] This file, PYGMY.SCR, contains the source code for PYGMY.COM. See the file PYGMY.TXT for more details. BSD/MIT/X-style license, see file license20040130.txt. Here is how to generate a new version of Pygmy: Edit in any changes Type 1 LOAD to create a new kernel named A1.COM (or whatever name you put 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. All should be thoroughly tested by you before use. ( file PYGMY.SCR for meta-compiling PYGMY.COM) 2 LOAD ( set options for kernel) 3 LOAD ( metacompiler) 4 LOAD ( kernel) ( { XREF } ) PRUNE { dRELOC $100 + HERE SAVEM E1.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 ( 0) CONSTANT TFILES ( allow textfiles) 258 CONSTANT TMAX/LINE ( max line length for textfiles) 4 1- CONSTANT TNB ( number of disk buffers, power of 2) $10000 CONSTANT TOP ( ie 65536 or very top of segment) ( note, in order to leave room for buffers and TIB, stack offsets must not be higher than about TOP 1024 TNB 1+ * - 256 - TMAX/LINE - ) $ECFE CONSTANT RSTACK ( stacks grow down from ) $EBFE CONSTANT DSTACK ( these offset values ) $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 71 THRU TFILES .IF 72 74 THRU .ELSE 75 LOAD .THEN 76 81 THRU TFILES .IF 83 84 THRU .ELSE 82 LOAD .THEN 85 100 THRU ( wrap up ) ' RESET dA @ - ' boot 6 + ! ( patch) " pygmy.scr" dA @ - ' FILES 7 + ! ( ie " pygmy.scr" 0 UNIT) 6 HASH @ dA @ - ' CONTEXT CELL + @ dA @ - CELL - ! 8 HASH @ dA @ - ' CONTEXT CELL + @ dA @ - 2 CELLS - ! HERE dA @ - ' H CELL + @ dA @ - ! ( ie initialize target's dictionary pointer) } ( to host ) ( load block for the editor, assembler, & extensions ) $C000 SET-EDGE ( allow for headerless words) 101 102 THRU ( BEEP CLAMP NFA FORGET ) 103 114 THRU ( load the editor) ( SAVE E2.COM ) 115 LOAD ( SETTLE CHOP) 116 138 THRU ( load the assembler) SAVE E3.COM 140 142 THRU ( other extensions) ( ' EPSON-CONDENSED ) ' LJ-CONDENSED IS CONDENSED " pygmy.dow" 1 UNIT " yourfile.scr" 2 UNIT " yourfile.dow" 3 UNIT " serial.scr" 4 UNIT " serial.dow" 5 UNIT " ed.scr" 8 UNIT " ed.dow" 9 UNIT SAVE E4.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 CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP CELL + DUP dA @ - 5 U.R ( ie print nfa) 2 SPACES COUNT $1F AND TYPE ?SCROLL CR REPEAT DROP CR BASE ! ; ( cross reference list of nfa and name) ( 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 TR@ ( R@ and I) VARIABLE TARR ( array) VARIABLE TABORT ( abort") VARIABLE TDOT ( dot") VARIABLE TNULL VARIABLE 'NXT ( for central next) ( switch between host & target spaces ) : { dA @ HERE H' 2@ H ! dA ! H' 2! ; : } { ; : RECOVER ( -) ( -2) CELL NEGATE ALLOT ; ( RECOVERs final EXIT when it can never be reached) ( headers) H/LESS OFF : THEAD ( -) ( this is the basic HEAD without VF 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) $D6 CONSTANT NONESUCH : HEAD ( -) HEADERS @ H/LESS @ NOT AND IF BLK @ , THEAD ELSE { THEAD NONESUCH C, H' @ , } THEN H/LESS OFF ; ( meta compiling words ) HEX : NXT, 'NXT @ JMP, ; ( for central next) : forget ( -) CONTEXT @ HASH @ CELL + DUP C@ 20 XOR SWAP C! ; : CREATE ( -) ( - a) HEAD TVAR @ LJMP, ; : USER ( n) ( - a) HEAD BX PUSH, RAM @ ) BX MOV, ( u) CELLS #, BX ADD, NXT, ; : VARIABLE ( -) ( RAM @ CONSTANT CELL 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 CELL + 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 ; ( like F83's [COMPILE] ) FORTH ( more meta compiling words ) COMPILER : ABORT" TABORT @ ,A $22 STRING ; : ." TDOT @ ,A $22 STRING ; : ['] TLIT @ ,A ; : R@ ( - n) TR@ @ ,A ; : I ( - n) TR@ @ ,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 ) ( sp ss 1st ) | CODE boot HERE 8 + JMP, 0 , 0 , 0 , PUSHALL, CS PUSH, DS POP, SS AX MOV, AX $104 ) MOV, SP $102 ) MOV, PUSHF, BX POP, DS AX MOV, AX ES MOV, CLI, AX SS MOV, RSTACK #, BP MOV, ( initialize return stack) DSTACK #, SP MOV, ( initalize parameter stk) BX PUSH, POPF, $106 ) AX MOV, AX JMP, ( jump to RESET) END-CODE HERE 2 + TNULL ! ( null word named '$' will get renamed) CODE $ -2 ALLOT 0 C, SWITCH, SI POP, SWITCH, HERE DUP 'NXT ! AX LODS, AX JMP, ( NXT,) END-CODE dA @ - CONSTANT 'NEXT ( allocate system and user variables) ALIGN ( align following on word boundaries) HERE DUP dA @ - RAM ! ( UP = start of system variables) HERE 32 TNB 1+ + CELLS ( UP UP #bytes-needed) DUP ALLOT ( UP UP #bytes-needed) 0 FILL ( UP) HERE dA @ - ( UP 'LINK) DUP ( LINK) , SWAP ! ( ) ( initialize UP) 0 ( TOS) , DSTACK , RSTACK , 10 ( BASE) , 0 ( RCURSOR??) , ( init 6 user variables) 44 CELLS ALLOT ( allow room for 44 more user 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) ( could use a inc a inc a inc, instead) 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) ( or 3 times a inc) 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 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 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 on 8088) 0 [SI] SI MOV, ( 17 clocks & 2 bytes on 8088) 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 UP ( User Pointer - must be first) CELL + DUP CONSTANT PREV ( last referenced buffer) CELL + DUP CONSTANT OLDEST ( Oldest loaded buffer ) CELL + DUP ARRAY BUFFERS ( Block in each buffer ) TNB DUP CONSTANT NB ( Number of buffers) CELLS + CELL + DUP CONSTANT TIB CELL + DUP CONSTANT H/LESS CELL + DUP CONSTANT HEADERS CELL + DUP CONSTANT SPAN CELL + DUP CONSTANT >IN CELL + DUP CONSTANT BLK CELL + DUP CONSTANT dA ( System variables ) CELL + DUP CONSTANT SCR CELL + DUP CONSTANT ATTR CELL + DUP CONSTANT >FIN CELL + DUP CONSTANT FBLK CELL + DUP CONSTANT #TIB CELL + DUP CONSTANT #FIB CELL + DUP CONSTANT FIB CELL + DUP CONSTANT FIBH CELL + DUP CONSTANT EBUF CELL + DUP CONSTANT H CELL + 4 CELLS + ( 10 + ) ( allow room for 4 vocabs ) DUP CONSTANT CONTEXT ( ram+) DROP ( blank ) ( USER variables, small constants ) 0 USER LINK ( point to next task's user area) 1 USER TOS ( saved value of this task's data stack ptr) 2 USER S0 ( holds initial SP value) 3 USER R0 ( holds initial RP value) 4 USER BASE 5 USER RCURSOR ( each task remembers its video cursor) 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! ( a -) BX SP MOV, ( no refill of tos?) NXT, END-CODE CODE RP! ( a -) BX BP MOV, BX POP, ( refill tos) NXT, END-CODE ( Note: SP! & RP! require an address on the stack.) ( 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 ( w/out sub#: a a sub a inc a b sub b b sbb nxt ) : NOT 0= ; CODE 0< 1 #, BX SHL, BX BX SBB, NXT, END-CODE ( technique from Andrew McKewan ) ( bit operators) CODE OR ( u u - u) AX POP, AX BX OR, NXT, END-CODE CODE XOR ( u u - u) AX POP, AX BX XOR, NXT, END-CODE CODE AND ( u u - u) 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 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 : U> ( a b - f) SWAP U< ; ( 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 ( math ) CODE * ( n n - n) AX POP, BX IMUL, AX BX MOV, NXT, END-CODE 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 UM* ( u u - ud) AX POP, BX MUL, 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 *** be careful of I ***) 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 R@ ( - n) HERE TR@ ! BX PUSH, 0 [BP] BX MOV, NXT, END-CODE ( math ) : U*/ ( u1 u2 u3 - u1*u2/u3) PUSH UM* POP UM/MOD NIP ; ( BETWEEN WITHIN 3DUP WRAP ODD? EVEN? ) 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) 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) : ODD? ( n - f) 1 AND ; : EVEN? ( n - f) ODD? NOT ; ( 3DUP WRAP UBETWEEN 2SWAP 2OVER ) : 3DUP ( a b c - a b c a b c) PUSH 2DUP ( a b a b -- c) R@ ROT ROT POP ; : WRAP ( n low high - n') 3DUP BETWEEN IF 2DROP ( n) EXIT THEN ( n low high) PUSH 2DUP < IF 2DROP POP ( high) EXIT THEN ( n low -- high) POP ( n low high) DROP NIP ( low) ; : UBETWEEN ( u low high - f) ROT DUP PUSH ( low high u) U< IF POP 2DROP 0 EXIT THEN POP ( low u) U> NOT ; : 2SWAP ( a b c d - c d a b) ROT PUSH ROT POP ; : 2OVER ( a b c d - a b c d a b) PUSH PUSH 2DUP POP POP 2SWAP ; ( 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 & PAUSE) DEFER PAUSE 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 ; ' NOP IS PAUSE ' (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) $0F00 #, DX MOV, ( $1800 for line 25, $0F00 for 16) 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 KEY $1B - IF EXIT THEN THEN S0 @ SP! QUIT THEN ; : (CR ( -) $0D EMIT $0A EMIT ; : (KEY ( - c) BEGIN PAUSE (KEY? UNTIL ((KEY DUP 0= IF DROP ((KEY $80 OR THEN ; ( for the extended keys, set the most significant bit ) ' (KEY 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 ; ( DUMP DU ) : .H ( u -) BASE @ HEX SWAP <# # #S #> BASE ! SPACE ; : DUMP ( a - a') BASE @ PUSH HEX CR DUP 5 U.R 2 SPACES 2 FOR 8 FOR C@+ .H NEXT SPACE NEXT 16 - 2 FOR 8 FOR C@+ DUP 32 127 WITHIN NOT IF DROP 46 THEN EMIT NEXT SPACE NEXT POP BASE ! ; : DU ( a n -) FOR DUMP ?SCROLL NEXT DROP ; ( 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 ) : GOODBLK? ( global-blk# - f) ( true if block# is valid) DUP 0 MAX-FILES 1+ 1000 * WITHIN NOT IF DROP 0 EXIT THEN 1000 U/MOD ( rel# unit#) #BLOCKS @ ( rel# #blks) U< ; : 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) 0 0 ROT $4202 DOS ( ax flg) ABORT" >EOF error" DROP ; : POSITION@ ( handle - ud) ( return current file position) 0 0 ROT $4201 DOS2 ( h l flg) ABORT" pos error" SWAP ; : >POSITION ( ud handle -) ( move to absolute position) $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 ( d handle) $4201 DOS ( ax flg) ABORT" pos error" DROP ; ( go forward or backward relative to current position) ( file handling ) : FCLOSE ( handle -) 0 0 ROT ?DUP IF $3E00 DOS THEN 2DROP ; : ?CLOSE ( unit# -) HANDLE DUP PUSH @ FCLOSE ( ) POP ON ; ( try to close it but ignore errors ) VARIABLE ACCESS : READ-ONLY 0 ACCESS ! ; : READ-WRITE 2 ACCESS ! ; : FOPEN ( name - handle flag) 1+ 0 0 ( $3D02) $3D00 ACCESS @ OR 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 the file open) : MAKE ( unit# -) DUP ?CLOSE DUP FNAME @ 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 -) 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 ( -) CLOSE-FILES FILES MAX-FILES 1+ 6 * 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 ( blk - a) PAUSE buffer ( blk a) ESTABLISH ( a) ; | : 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) PAUSE 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 - ; ( textfile 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 ; ( textfile 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 #) ; ( textfile version ) : SOURCE ( - a #) BLK @ ?DUP IF ( blk) BLOCK 1024 ( a #) EXIT THEN FBLK @ ?DUP IF ( handle) ?REFILL ( a #) EXIT THEN TIB @ #TIB @ ( a #) ; ( block only version ) : SOURCE ( - a #) BLK @ ?DUP IF ( blk) BLOCK 1024 ( a #) EXIT THEN TIB @ #TIB @ ( a #) ; ( 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 ) $D6 CONSTANT NONESUCH ( there is no opcode $D6 on the 8086) 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, NONESUCH #, 0 [DI] CMP, ( indirect pfa?) 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 ( c - n) $30 - DUP 9 > IF 7 - DUP $A < OR THEN DUP BASE @ U< NOT ABORT" ?" ; | : 10*+ ( u a c - 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 c) 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 ( Intrepreter ) : -' ( 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! ; VARIABLE DEFAULT-TIB ( must be initialized by RESET ) VARIABLE DEFAULT-FIB : RESET-TIB ( -) DEFAULT-TIB @ TIB ! DEFAULT-FIB @ FIB ! ; : (QUIT R0 @ RP! RESET-TIB ( CR ) BEGIN CR QUERY 0 0 ( blk offset) INTERPRET ." ok" AGAIN ; RECOVER ' (QUIT IS QUIT ( default ABORT allows textfiles ) : (ABORT ( -) ['] DEFAULT-EMIT 1+ @ ['] EMIT 1+ ! FBLK OFF FIBH @ FCLOSE FIBH OFF RESET-TIB HERE TYPE$ SPACE POP POP TYPE$ S0 @ SP! BLK @ ?DUP DROP QUIT ; RECOVER ' (ABORT IS ABORT ( LOAD THRU blocks only ) : LOAD ( u -) >IN 2@ PUSH PUSH 0 INTERPRET DECIMAL POP POP >IN 2! ; : THRU ( u u -) OVER - 1+ FOR ( n) DUP PUSH LOAD POP 1+ NEXT DROP ; $80 CONSTANT COMMAND-LINE ( it acts like a counted string) : EVALUATE ( a # -) >IN 2@ PUSH PUSH TIB @ PUSH #TIB @ PUSH #TIB ! TIB ! 0 0 INTERPRET POP #TIB ! POP TIB ! POP POP >IN 2! ; ( LOAD THRU allows text files ) : LOAD ( n -) >IN 2@ PUSH PUSH >FIN 2@ PUSH PUSH 0 0 >FIN 2! 0 INTERPRET DECIMAL POP POP >FIN 2! POP POP >IN 2! ; : THRU ( n n -) OVER - 1+ FOR ( n) DUP PUSH LOAD POP 1+ NEXT DROP ; $80 CONSTANT COMMAND-LINE ( it acts like a counted string) : EVALUATE ( a # -) >IN 2@ PUSH PUSH TIB @ PUSH #TIB @ PUSH #TIB ! TIB ! 0 0 INTERPRET ( 10 BASE ! ) POP #TIB ! POP TIB ! POP POP >IN 2! ; ( source code loading from text files ) : FLOAD ( name -) ( eg " 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 ( ) DECIMAL 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 ) 2 CONSTANT CELL : CELLS ( # - #') 2* ; : ALIGN ( -) H @ DUP 1 AND + H ! ; : ALLOT ( n -) H +! ; : , ( n -) H @ ! CELL ALLOT ; : C, ( c -) H @ C! 1 ALLOT ; : ,A ( a -) dA @ - , ; : COMPILE POP DUP @ , CELL + 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 ( - nfa n) CONTEXT @ HASH @ 2 + DUP C@ ; : >PFA ( nfa len - pfa) + 1+ DUP C@ NONESUCH = IF 1+ @ THEN ; : SMUDGE PREVIOUS $20 XOR SWAP C! ; ( flip bit 5 of len byte) : FORTH 2 CONTEXT ! ; : COMPILER 4 CONTEXT ! ; | : does PREVIOUS ( + 1+) >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 , ( EDGE, ie the edge of the world the headers fall off of. H' must be set prior to using { or } or HEADERS OFF, e.g. $C000 SET-EDGE. 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 @ ( viewfield) , HERE 0 ( linkfield) , 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 NONESUCH C, H' @ , } THEN H/LESS OFF ; ( Defining words ) FORTH : STRING ( delim -) WORD C@ 1+ ALLOT ; : 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 SP@ DEPTH .S ? ) : WORDS ( -) CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + COUNT 31 AND TYPE 2 SPACES ?SCROLL REPEAT DROP ; CODE SP@ ( - a) BX PUSH, SP BX MOV, NXT, END-CODE : DEPTH ( - words) SP@ S0 @ SWAP - CELL / 1- ; : .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 ; : ? ( a -) @ . ; ( 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 to make .COM files from 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 ; : I ( - n) COMPILE R@ ; ( 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 ( -) ( $80) COMMAND-LINE COUNT ( a #) EVALUATE ( if it doesn't do BYE, we fall through to the following:) $3F ATTR ! CLS CR ." Pygmy Forth v1.7" CR ." Copyright 1989-2007 Frank C. Sergeant" CR ." [email protected] http://pygmy.utoh.org" CR OPEN-FILES .FILES CR ." hi" QUIT ; RECOVER ' (BOOT IS BOOT ( RESET ) : RESET NB ADDRESS 256 - DUP TIB ! DUP DEFAULT-TIB ! READ-WRITE 258 ( ie MAX/LINE) - DUP FIB ! DEFAULT-FIB ! ( for use by (ABORT ) HEADERS ON H/LESS OFF >IN OFF dA OFF DECIMAL ( 0 0 AT AT@ 256 U/ ATTR ! CLS ) EMPTY-BUFFERS FORTH BOOT ; RECOVER ( final block of kernel ) CODE #BYE ( returncode -) ( use this for returning to C) PUSHF, AX POP, CLI, $102 ) SP MOV, $104 ) SS MOV, AX PUSH, POPF, AX POP, BX PUSH, ( replace saved AX with return code) POPALL, LRET, END-CODE ( Start of Extensions BEEP CLAMP NFA) : BEEP 7 EMIT ; : CLAMP ( n lo hi - n') PUSH MAX POP MIN ; : NFA ( pfa - nfa | 0) 2 FOR I 1+ 2* HASH BEGIN @ ( pfa lfa) ?DUP WHILE 2DUP 2 + C@+ $1F AND + DUP C@ NONESUCH = IF 1+ @ THEN ( pfa lfa pfa candidate-pfa) = UNTIL 2 + NIP POP DROP EXIT THEN NEXT DROP 0 ; ( NFA even works with headerless words whose heads have not yet been PRUNE'd) ( 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 | : .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? " QUERY 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) ( 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 ! ." 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 ! ." 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 ((KEY style 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 ) : 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) ( REPEAT, and AGAIN, are defined later) 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, ) EB opc NEVER, ( the rest can be made by following above with NOT, ) : LOOP, ( a -) E2 UNTIL, ; : LOOPZ, ( a -) E1 UNTIL, ; : LOOPNZ, ( a -) E0 UNTIL, ; EXIT : FAR-JMP, ( seg offset -) $EA C, , , ASM-RESET ; ( above does an absolute far jump ) 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 ; | : .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) 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 Pygmy's COM, but it would conflict with Pygmy's use of NOT, for inverting a flag for a conditional test. COM, stands for "complement" ) ( M5 for LDS, LEA, & LES, ) HEX | : M5 ( n -) ( -) CREATE C, DOES> C@ C, 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, ) : INT3, ( -) $CC C, ; : 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 ) ( intersegment indirect call and jump ) : LCALL, ( mem | reg -) 1REG? IF R>M THEN $FF C, $18 OR modDISP, ASM-RESET ; ( eg 0 [BX] LCALL, or DX LCALL, ) : LONGJMP, ( mem | reg -) 1REG? IF R>M THEN $FF C, $28 OR modDISP, ASM-RESET ; ( eg 0 [BX] LONGJMP, or DX LONGJMP, ) ( 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) : NXT, ( 'NEXT JMP, ) AX LODS, AX JMP, ; : SWITCH, SP BP XCHG, ; : AGAIN, ( a -) JMP, ; : REPEAT, ( a a -) AGAIN, THEN, ; ( more assembly macros) : PUSHALL, ( -) DS PUSH, ES PUSH, SI PUSH, DI PUSH, BP PUSH, DX PUSH, CX PUSH, BX PUSH, AX PUSH, ; : POPALL, ( -) AX POP, BX POP, CX POP, DX POP, BP POP, DI POP, SI POP, ES POP, DS POP, ; ( Assembler) : << ( - a depth) HERE DEPTH ; ( for dumping code to screen) : >> ( a depth -) ( ditto) DEPTH 1- - ABORT" bad stack" CR BASE @ PUSH HEX DUP 4 U.R SPACE HERE OVER - FOR C@+ 3 U.R NEXT DROP POP BASE ! SPACE ; ( blank ) ( loading of options is controlled by parenthesis in column 1) 143 LOAD ( NEWFILE create new block file w/ 8 blocks) 144 LOAD ( MS clock speed independent timing) ( 145 LOAD ( VIEW for listing only) 146 LOAD ( VIEW for editing) 147 LOAD ( .ID SEE) ( 148 LOAD ( NAMEZ:) ( 149 LOAD ( OF THENS from Wil Baden ) 150 151 THRU ( L@ L! LC@ LC!) 152 LOAD ( various EMITs >STD >DOS allow redirection) ( 153 LOAD ( show IBM graphics characters ) 154 LOAD ( BYTES FLIP) ( 155 LOAD ( allow hundreds of files) ( loading of options is controlled by parenthesis in column 1) ( 156 LOAD ( the name is the string ) ( 157 LOAD ( 2/MOD ) ( 158 LOAD ( INDEX ) ( 159 LOAD ( LCMOVE & LCMOVE>) 160 166 THRU ( print blocks SHOW SHOW2 SHADOW ) ( 167 LOAD ( BELL ) ( 168 LOAD ( BLK>TXT append range of blocks to textfile) ( 169 LOAD ( TXT>BLK create new block file from textfile) ( 170 LOAD ( one possible CASE: ) ( 171 LOAD ( SCROLL-UP SCROLL-DOWN) ( 172 173 THRU ( COLORS RED ON-CYAN etc.) ( loading of options is controlled by parenthesis in column 1) ( 175 LOAD ( #INPUT input a number ) ( 177 181 THRU ( SHELL for executing DOS commands) ( 182 LOAD ( DATE & TIME from DOS) ( 183 LOAD ( textfile left paren for multi-line cmnts) ( 184 LOAD ( load blocks relative to current unit#) ( 185 LOAD ( compare blocks or ranges of blocks) 186 192 THRU ( multitasker) ( 193 194 THRU ( examples of using the multitasker) ( 195 196 THRU ( additional multitasker examples) ( 197 200 THRU ( direct EMIT for fast video on slow machines) ( 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 the down-counting hardware 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 loops in 1ms and in MS) : 1ms ( -) T0@ BEGIN ( first) PAUSE DUP T0@ - 2250 > UNTIL DROP ; : MS ( # -) FOR 1ms NEXT ; ( VFA VIEW list the block) : VFA ( pfa - vfa) NFA 4 - ; : VIEW ( -) ' VFA @ ?DUP IF LIST THEN ; : V VIEW ; ( shorthand ) ( VFA VIEW V pop up the editor) : VFA ( pfa - vfa) 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] 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 DUP IS EMIT IS DEFAULT-EMIT ; : >STD ( -) ['] STD-OUT DUP IS EMIT IS DEFAULT-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 ; ( BYTES FLIP ) : BYTES ( xxyy - yy xx) $100 U/MOD ; : FLIP ( hhll - llhh) BYTES SWAP $100 * 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 CELLS + CONSTANT ; ( this version does not put a zero at end of name) : NAMEZ: ( -) ( -a) HERE 2 CELLS + CODE ( AL AL ADD,) $C000 , ( trick to put a zero immediately after name ) BX PUSH, ( a) #, BX MOV, NXT, ; : .NAME: ( -) ( -) HERE 2 CELLS + CREATE , DOES> @ TYPE$ ; ( types its own name) EXIT usage NAME: AEROPLANE NAME: 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 ?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 ( blank ) ( input a number) : #INPUT ( - n) QUERY 0 WORD NUMBER ; ( blank ) EXIT ( SHELL notes ) Here is my version of SHELL and EXEC. Use them to "shell out to DOS" (returning by typing EXIT) or to execute DOS commands. Here are some examples to suggest ways to use them. Note that the full path is needed if the file to be executed is not in the current directory. Each usage wastes a little dictionary space, so I have no objection if you rewrite this to be prefix and use PAD. " DIR *.SCR" EXEC ( directory listing of .SCR files) " COPY XYZ.TXT ABC.TXT" EXEC ( copy a file) " DIR *.TXT >TEXTDIR" EXEC ( 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" EXEC ; : Q ( filename -) " Q" SWAP shell ; ( invoke textfile editor) ( SHELL ) 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 ; EXIT FREE is actually "FREE-ALL-EXCEPT" as you tell it how many 16-byte paragraphs to keep. ( SHELL ) VARIABLE 'SP VARIABLE 'SS CREATE PBLK 14 ALLOT 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 pointers) DS AX MOV, AX ES MOV, $4B00 #, AX MOV, $21 INT, CS PUSH, DS POP, ( ????) CLI, ( ints off) 'SS ) SS MOV, 'SP ) SP MOV, STI, BP POP, SI POP, BX BX SBB, ( f) AX PUSH, NXT, END-CODE EXIT perhaps PUSHF, etc should be used to save interrupt flag ( SHELL ) : shell ( pgm$ tail$ -) $1000 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: " C:\COMMAND.COM" " /C DIR *.*" shell ( dir and return) " C:\COMMAND.COM" " " shell ( shell out to DOS) " D:\UTIL\Q.EXE" " trash.txt" shell ( run an editor) ( SHELL ) " C:\COMMAND.COM" CONSTANT COMMAND.COM : SHELL ( -) COMMAND.COM " " shell ; : EXEC ( tail$ -) COMMAND.COM ( tail a) SWAP ( a tail) " /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) EXIT e.g. " dir *.scr /p" EXEC ( DATE and TIME by L. Greg Lisle ) HEX 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 UBLK THRU ; ( compare 2 blocks or a range of blocks ) : SCR-COMP ( scr1 scr2 - f) BLOCK SWAP BLOCK 1024 COMP ; : SCR-COMPS ( file1-1st-scr file2-1st-scr # -) FOR 2DUP SCR-COMP IF CR OVER U. DUP U. THEN 1+ 1 +UNDER NEXT 2DROP ; : FINE-COMP ( scr1 scr2 -) SWAP BLOCK SWAP BLOCK ( a a) 16 FOR 2DUP 64 COMP IF CR ." 1:" OVER 64 TYPE CR ." 2:" DUP 64 TYPE THEN 64 + 64 +UNDER NEXT 2DROP ; ( multi-tasking) UP @ CONSTANT TERMINAL ( so we can restore our terminal task) : MAIN? ( - f) UP @ TERMINAL = ; ( Am I the terminal task?) VARIABLE #USER VARIABLE #SP VARIABLE #RP 6 CELLS #USER ! 64 CELLS #SP ! 64 CELLS #RP ! : LOCAL ( task a - a') UP @ - + ; EXIT we could add additional user variables with : USER ( u -) ( - a) HEAD b push UP #) di X b mov ( u) b add# NXT, ; ( Multi-tasker (PAUSE switch tasks) CODE (PAUSE ( -) BX PUSH, ( save current task's TOS) SI PUSH, ( save current task's IP) BP PUSH, ( save current task's rstkPtr) UP ) BX MOV, ( get current value of UP into BX) SP CELL [BX] MOV, ( save current task's dstkPtr into 'SP) 0 [BX] BX MOV, ( BX gets addr of next task from LINK) BX UP ) MOV, ( put addr of next task into UP) CELL [BX] SP MOV, ( restore new task's dstkPtr from 'SP) BP POP, ( restore new task's rstkPtr) SI POP, ( restore new task's IP) BX POP, ( restore new task's TOS) NXT, ( normal next will begin execution of new task) END-CODE ( Multi-tasker TASK: SINGLE MULTI) : TASK: ( -) ALIGN HERE PUSH ( save address of new task's user variables) UP @ R@ #USER @ DUP ALLOT ( fr to #) CMOVE ( copy vars) #SP @ ALLOT HERE R@ S0 LOCAL ! ( bottom of data-stack) #RP @ ALLOT HERE R@ R0 LOCAL ! ( bottom of return-stack) POP CONSTANT ; : SINGLE ( -) ['] NOP IS PAUSE ; : MULTI ( -) ['] (PAUSE IS PAUSE ; ( Multi-tasker AWAKE?) VARIABLE #TASKS 1 #TASKS ! : AWAKE? ( task - a | 0) ( ie return addr-of-previous-LINK or zero if not awake) PUSH ( ) #TASKS @ LINK ( addr of active task's link) ( # prev) BEGIN OVER WHILE ( # prev) -1 +UNDER DUP @ ( # prev next) DUP R@ - WHILE ( # prev next) NIP ( # next) REPEAT ( # prev next) DROP SWAP THEN DROP ( prev | 0) POP DROP ; ( Multi-tasker SLEEP STOP KILL-PROCESSES) : SLEEP ( task -) DUP TERMINAL = IF DROP EXIT THEN DUP AWAKE? ?DUP IF ( task prev.task) OVER @ SWAP ! ( unlink task) -1 #TASKS +! THEN DROP ; : STOP ( -) ( put current task to sleep) UP @ SLEEP PAUSE ; : KILL-PROCESSES ( -) UP @ ( current-task) #TASKS @ FOR ( a) DUP @ SLEEP NEXT DROP SINGLE ; ( To aWAKEn a task, insert it into the list of tasks after the current task ) : WAKE ( newtask -) DUP AWAKE? NOT ( new flag) IF ( new) DUP DUP ( new new new) LINK ( new new new curr) DUP @ PUSH ( ie save next on return stack) ! ( make new task successor of current task) ( new new) POP SWAP ( new next new) ! ( make next task successor of new task) ( new) 1 #TASKS +! THEN ( new) DROP ; ( Multi-tasker point task at a word to execute ) : TASK! ( routine task -) DUP S0 LOCAL @ ( routine task stack) CELL - 0 OVER ! ( push a dummy zero, for testing) CELL - ROT OVER ! ( task stack) ( "push" routine) CELL - 0 IF [ HERE SWAP ] EXECUTE UP @ SLEEP ABORT" unexpected end of task" ( abort must pause) THEN LITERAL ( task stack si) OVER ! ( "push" si) CELL - OVER R0 LOCAL @ OVER ! ( push addr of return stack) SWAP TOS LOCAL ! ( ) ; : MULTI-ABORT ( -) ['] DEFAULT-EMIT 1+ @ ['] EMIT 1+ ! FBLK OFF FIBH @ FCLOSE FIBH OFF HERE TYPE$ SPACE POP POP TYPE$ S0 @ SP! BLK @ ?DUP DROP MAIN? IF QUIT ELSE STOP THEN ; ' MULTI-ABORT IS ABORT ( it must return to terminal task!?) ( Test the Multi-tasker ) VARIABLE C1 VARIABLE C2 ( define some counters) TASK: T1 TASK: T2 : TST1 BEGIN ( CR .S CR .S ) 200 MS 1 C1 +! ( -1 ABORT" TST1 aborted! " ) AGAIN ; : TST2 BEGIN 2000 MS 1 C2 +! AGAIN ; ' TST1 T1 TASK! ' TST2 T2 TASK! T1 WAKE T2 WAKE ( MULTI ) ( Test the Multi-tasker ) TASK: T3 TASK: T4 : TST3 BEGIN 100 MS 5 40 AT C1 @ 8 U.R AGAIN ; : TST4 BEGIN 100 MS 7 40 AT C2 @ 8 U.R AGAIN ; ' TST3 T3 TASK! ' TST4 T4 TASK! T3 WAKE T4 WAKE ( MULTI ) : TTT BEGIN PAUSE KEY? UNTIL KEY DROP ; ( Simple Multitasker Example from March '99 article ) VARIABLE SECONDS : COUNT-SECONDS ( -) BEGIN 1 SECONDS +! 1000 MS AGAIN ; TASK: T1 ' COUNT-SECONDS T1 TASK! ( Start it running by typing T1 WAKE MULTI then test it by typing SECONDS @ U. ) ( Multiple channel ADC multitasking example) $0800 CONSTANT AtoD : V@ ( channel - raw) 2* AtoD + DUP C@ $100 * SWAP C@ + ; : V@ ( channel - raw) DROP T0@ ; : .Volts ( u -) 500 65535 U*/ <# # # '. HOLD #S #> ; : .V ( -) 0 V@ .Volts ; : SAMPLE ( channel y x -) AT ( chan) V@ 5 U.R ; : 2PUSH ( a b -) POP SWAP PUSH SWAP PUSH PUSH ; : 2POP ( - a b) POP POP SWAP POP SWAP PUSH ; : 2R@ ( - a b) POP 2POP 2DUP 2PUSH ROT PUSH ; : SAMPLES ( chan y x -) 2PUSH BEGIN ( chan) DUP 2R@ ( chan chan y x) SAMPLE 200 MS AGAIN ; : SAMPLE0 ( -) 0 2 15 SAMPLES ; : SAMPLE1 ( -) 0 4 15 SAMPLES ; TASK: S0 TASK: S1 ' SAMPLE0 S0 TASK! ' SAMPLE1 S1 TASK! : TST 99 98 2PUSH 2R@ 1+ 1 +UNDER 2POP ; ( direct video EMIT on this & next 3 blocks ) VARIABLE VSEG VARIABLE 'CRTC VARIABLE CURSOR 80 CONSTANT C/LINE 25 CONSTANT L/SCR : INIT-VIDEO $B800 $40 $10 LC@ $30 AND $30 = $800 AND - VSEG ! $40 $63 L@ 'CRTC ! ; INIT-VIDEO ( VSEG is B800 for color and B000 for mono) ( 'CRTC is 03D4 for color and 03B4 for mono) HEX ( direct video EMIT ) CODE (DEMIT ( c) BX AX MOV, CURSOR ) DI MOV, ATTR ) BH MOV, ( keep attr in BH) SI PUSH, DS PUSH, ( save'em) VSEG ) CX MOV, CX DS MOV, CX ES MOV, ( pt to video ram) 0D #, AL CMP, 0=, IF, C/LINE #, CL MOV, DI AX MOV, 1 #, AX SHR, CL IDIV, AH AL MOV, AH AH SUB, C/LINE #, CX MOV, AX CX SUB, ( # words to fill) 20 #, AL MOV, BH AH MOV, ( add attr) REP, AX STOS, C/LINE 2* #, DI SUB, ELSE, 0A #, AL CMP, 0=, IF, C/LINE 2* #, DI ADD, ELSE, 07 #, AL CMP, 0=, IF, ( bell) 61 #, DX MOV, AL IN, 3 #, AL OR, AL OUT, -1 #, CX MOV, BEGIN, LOOP, FC #, AL AND, AL OUT, ELSE, 08 #, AL CMP, 0=, IF, ( bs) DI DEC, DI DEC, 20 #, AL MOV, BH AH MOV, AX 0 [DI] MOV, ( continued on next screen ) HEX ( direct video EMIT (DEMIT continued ) ELSE, 0 #, AL CMP, 0=, IF, ( do nothing except set cursor) ELSE, BH AH MOV, AX STOS, ( CS: #OUT INC ) THEN, THEN, THEN, THEN, THEN, C/LINE L/SCR * 2* #, DI CMP, <, NOT, IF, DI DI SUB, C/LINE 2* #, SI MOV, C/LINE L/SCR 1- * #, CX MOV, REP, AX MOVS, C/LINE #, CX MOV, 20 #, AL MOV, BH AH MOV, REP, AX STOS, C/LINE 2* #, DI SUB, THEN, CX POP, CX DS MOV, DI CURSOR ) MOV, 'CRTC ) DX MOV, ( 6845 index) 1 #, DI SHR, 0E #, AL MOV, AL OUT, DX INC, DI AX MOV, AH AL MOV, AL OUT, DX DEC, 0F #, AL MOV, AL OUT, DX INC, DI AX MOV, AL OUT, SI POP, BX POP, ( restore 'em) NXT, END-CODE ( direct video EMIT continued ) : (DAT ( row col) SWAP C/LINE * + 2* CURSOR ! 0 (DEMIT ; : (DCUR@ ( - row col) CURSOR @ 2/ C/LINE U/MOD SWAP ; : (DCLS ( -) 0 0 2DUP (DAT L/SCR FOR CR NEXT (DAT ; : >DIRECT CUR@ (DAT ['] (DEMIT DUP IS EMIT IS DEFAULT-EMIT ['] (DAT IS AT ['] (DCUR@ IS CUR@ ['] (DCLS IS CLS ; : >SCR CUR@ (AT ['] (EMIT DUP IS EMIT IS DEFAULT-EMIT ['] (AT IS AT ['] (CUR@ IS CUR@ ['] (CLS IS CLS ; : (BOOT2 ( -) INIT-VIDEO >DIRECT (BOOT ( $3F ATTR ! ) ; ' (BOOT2 IS BOOT SAVE DPYGMY.COM