copyright 1989, 1990 Frank C. Sergeant - see the file PYGMY.TXT Source code for PYGMY.COM version 1.3 screen 1 is the load screen for creating a new kernel screens 3-13 are the meta-compiler screens 17-80 are PYGMY (the kernel part) edit in your changes & type 1 LOAD that will create the nucleus named F1.COM (or whatever you changed it to on screen 1) exit to DOS with BYE then bring up the nucleus (eg C:\>F1 ).The source code file, PYGMY.SCR, will be opened automatically. Extend the kernel & save the result by typing 83 LOAD That will load the editor and assembler and anything else you wish (just edit scr 83 to include the extensions you desire). Scr 84-96 are the editor, Scr 100-120 are the assembler, Scr 169-181 include Starting Forth tips, Scr 125-168 include misc stuff. All should be thoroughly tested by you before use. ( file PYGMY.SCR for meta-compiling PYGMY.COM) ( HASH-OFF ( comment this out if you don't use hashing ) 16 CONSTANT TMAX-FILES ( allow room in tgt for 15 files, but MUST be a power of 2) 2 1 - CONSTANT TNB ( set number of disk buffers ) VARIABLE RAM VARIABLE H' $8000 , ( relocation amount ) ( 1st cell is tgt's DP & 2nd cell is tgt's offset) $8000 $2000 0 FILL $8000 H' ! ( build target image starting at $8000 ) 3 13 THRU ( meta ) 17 80 THRU PRUNE { $8100 HERE SAVEM H1.COM } ( scr 83 is load screen for editor, assembler, & extensions) ( load this screen if you want more info while meta-compiling) : LOAD ( n -) DUP CR ." loading scr # " . LOAD .S ; : THRU ( n n -) OVER - 1+ SWAP PUSH FOR POP POP DUP 1+ PUSH SWAP PUSH LOAD ?SCROLL NEXT POP DROP ; ( 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) ( same as semiS) VARIABLE TFOR ( for) VARIABLE TNEXT ( next) VARIABLE TARR ( array) VARIABLE TABORT ( abort") VARIABLE TDOT ( dot") VARIABLE TNULL ( assembler macros NXT, SWITCH, ) : NXT, AX LODS, AX JMP, ; ( lay down in-line next) : SWITCH, SP BP XCHG, ; ( switch data & return stack ptrs) : LJMP, ( a -) $E9 C, HERE 2 + - , ; ( lay down 3byte jump) ( XREF ) EXIT : XREF ( -) >PRN CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + COUNT $1F AND TYPE dA @ - HEX U. CR REPEAT DROP CR >SCR ; ( { } switch between host & target spaces ) : { dA @ HERE H' 2@ H ! dA ! H' 2! ; : } { ; ( : RECOVER -2 ALLOT ; ) ( RECOVER can be used after words that end in an endless loop) ( as the EXIT laid down by ; will never be reached. I ) ( have commented out the RECOVERs in order to leave the EXIT ) ( as an end of word indicator for SEE. ) HEX ( TCREATE ) : TCREATE ( -) ( 2byte link, counted name, & 3 byte jump to targets var) ( Meta's TVAR holds var's addr as soon as we know it) HERE 0 , 20 WORD ( cur.lfa cur.nfa ) CONTEXT @ HASH ( lfa nfa vocab ) 2DUP ( cur.lfa cur.nfa vocab cur.nfa vocab ) @ ( cur.lfa cur.nfa vocab cur.nfa prev.lfa) SWAP ( cur.lfa cur.nfa vocab prev.lfa cur.nfa) 2 - ( back up) ( cur.lfa cur.nfa vocab prev.lfa cur.lfa) ! ( cur.lfa cur.nfa vocab) SWAP ( cur.lfa vocab cur.nfa) C@ ( cur.lfa vocab len) 1+ ALLOT ( comma in the entire name field) ! ( make vocab point to this new word's link field ) TVAR @ LJMP, ( lay down 3byte jump to dovar) ; ( forget meta CONSTANT VARIABLE ARRAY ) HEX : forget ( -) CONTEXT @ HASH @ 2 + DUP C@ 20 XOR SWAP C! ; : CONSTANT ( n -) TCREATE -3 ALLOT BX PUSH, #, BX MOV, NXT, ; ( use "in-line" constants ) : VARIABLE ( -) ( RAM @ CONSTANT 2 RAM +! for ROMing) TCREATE 0 , ; : ARRAY ( a -) ( n -) ( runtime: n is a word, not byte, index) TCREATE -3 ALLOT TARR @ LJMP, , ; : DEFER ( ) ( ...) TCREATE -3 ALLOT 0 #, AX MOV, AX JMP, ; : IS ( a -) dA @ - ' 1+ ! ; ( SCAN TRIM CLIP PRUNE ) : SCAN ( lfa - lfa) @ BEGIN DUP 1 $8000 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 ! @ , ; : PRUNE ( -) { 8 HASH CLIP 6 HASH CLIP TNULL @ OFF ( zero out its link field) { ; ( rename some host words & dA@- ) : FORTH' FORTH ; : COMPILER' COMPILER ; COMPILER : \' \ \ ; FORTH : dA@- dA @ - ; ( this is used often ) : :' : ; ( 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 : \ 8 -' ABORT" ?" ,A ; ( F83's [COMPILE] ) : 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 , ; ( performs u times instead of u+1 times ) : NEXT ( h -) DUP \' THEN 2 + TNEXT @ ,A ,A ; FORTH HEX ( meta : & ; ) COMPILER : ABORT" TABORT @ ,A 22 STRING ; : ." TDOT @ ,A 22 STRING ; : ['] TLIT @ ,A ; FORTH : FORTH 6 CONTEXT ! ; : COMPILER 8 CONTEXT ! ; : : TCREATE -3 ALLOT 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' ( start target code BOOT ) HEX 6 HASH OFF 8 HASH OFF { ( to target) 100 ALLOT ( first 256 bytes reserved for DOS) -7 ALLOT ( align pfa of BOOT to $0100 ) ( as this version does not allow separated heads ) FORTH ( sets context to 6 ) CODE boot ( for now leave stacks & everything in one 64K seg) FF00 #, BP MOV, ( initialize return stack) FE00 #, SP MOV, ( initalize parameter stk) 0 #, AX MOV, ( addr of reset - patch it later) AX JMP, ( jump to "reset") END-CODE HERE TNULL ! ( following is null word that will get renamed) CODE $ -2 ALLOT 0 C, SWITCH, SI POP, SWITCH, NXT, END-CODE HERE dA @ - RAM ! 2A 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 ) 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 ( LINK,NAME,JMP<var>,VALUE ( 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 ( 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 SPAN 2 + DUP CONSTANT >IN 2 + DUP CONSTANT BLK 2 + DUP CONSTANT dA 2 + DUP CONSTANT SCR 2 + DUP CONSTANT ATTR 2 + DUP CONSTANT CUR 2 + DUP CONSTANT 'SOURCE 2 + DUP CONSTANT CURSOR 2 + DUP CONSTANT BASE 2 + DUP CONSTANT H 10 + ( allow room for 4 vocabs ) DUP CONSTANT CONTEXT 2 + DUP CONSTANT VID 2 + DUP CONSTANT CRTC ( for 6845) ( 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 ) HEX CODE 1+ ( n - n+1) BX INC, NXT, END-CODE CODE 1- ( n - n-1) BX DEC, NXT, END-CODE CODE SP! ( -) FE00 #, SP MOV, NXT, END-CODE CODE RP! ( -) FF00 #, BP MOV, NXT, END-CODE ( get video addresses ) CODE 'VIDEO ( - addr_6845 video_buffer) BX PUSH, $40 #, AX MOV, AX ES MOV, $10 #, DI MOV, $30 #, DX MOV, $B800 #, BX MOV, ES: 0 [DI] AX MOV, ( ie equip_flag ) DX AX AND, DX AX CMP, 0=, IF, ( mono) $B000 #, BX MOV, THEN, $63 #, DI MOV, ES: 0 [DI] AX MOV, ( ie addr_6845) AX PUSH, NXT, END-CODE HEX ( CS@ V@ V! MOVEL ) CODE CS@ ( - seg) BX PUSH, CS PUSH, BX POP, NXT, END-CODE CODE V! ( c attr addr -) AX POP, CX POP, CX AX OR, ' VID 2 + @ ) DX MOV, DX DS MOV, AX 0 [BX] MOV, CS AX MOV, AX DS MOV, BX POP, NXT, END-CODE CODE V@ ( addr - c attr) ' VID 2 + @ ) DX MOV, DX DS MOV, 0 [BX] AX MOV, AX BX MOV, AH AH SUB, AX PUSH, BL BL SUB, CS AX MOV, AX DS MOV, NXT, END-CODE CODE MOVEL ( fr-seg fr-off to-seg to-off word-count -) ( moves 2 bytes at a time ) BX CX MOV, SI DX MOV, DI POP, ES POP, SI POP, DS POP, CLD, REP, AX MOVS, CS AX MOV, AX DS MOV, DX SI MOV, BX POP, NXT, END-CODE ( P! PC! P@ PC@ ) CODE P! ( n port -) BX DX MOV, AX POP, ( 0) AX OUT, BX POP, NXT, END-CODE CODE PC! ( c port -) BX DX MOV, AX POP, ( 0) 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, ( BYTE) 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< BX AX MOV, CWD, DX BX MOV, NXT, END-CODE ( R.B.) ( 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 - n) ( 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 ( 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 ( WITHIN ABS MIN MAX EXECUTE ) 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) CODE ABS ( n - u) 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 DEFER EMIT DEFER KEY DEFER KEY? DEFER CR HEX ( EMIT ) CODE (EMIT) ( c-) BX AX MOV, ' CUR 2 + @ ) DI MOV, ' ATTR 2 + @ ) BX MOV, ( keep attr in BH) SI PUSH, DS PUSH, ( save 'em) ' VID 2 + @ ) CX MOV, CX DS MOV, CX ES MOV, ( pt to video ram) 0D #, AL CMP, 0=, IF, 50 #, CL MOV, DI AX MOV, 1 #, AX SHR, CL IDIV, AH AL MOV, AH AH SUB, 050 #, CX MOV, AX CX SUB, ( # words to fill) 20 #, AL MOV, BH AH MOV, ( add attr) REP, AX STOS, 0A0 #, DI SUB, ELSE, 0A #, AL CMP, 0=, IF, 0A0 #, 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 ( EMIT continued ) ELSE, BH AH MOV, AX STOS, ( CS: #OUT INC ) THEN, THEN, THEN, THEN, 0FA0 ( 4000) #, DI CMP, <, NOT, IF, DI DI SUB, 0A0 #, SI MOV, 780 #, CX MOV, REP, AX MOVS, 50 #, CX MOV, 20 #, AL MOV, BH AH MOV, REP, AX STOS, 0A0 #, DI SUB, THEN, CX POP, CX DS MOV, DI ' CUR 2 + @ ) MOV, CS: ' CRTC 2 + @ ) DX MOV, ( 6845 index) 0E #, AL MOV, AL OUT, DX INC, DI AX MOV, 1 #, AX SHR, AH AL MOV, AL OUT, DX DEC, 0F #, AL MOV, AL OUT, DX INC, DI AX MOV, 1 #, AX SHR, AL OUT, SI POP, BX POP, NXT, END-CODE ' (EMIT) IS EMIT 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 ) HEX : ?SCROLL ( -) KEY? IF KEY 1B = IF SP! 0 ( QUIT) THEN BEGIN KEY? UNTIL KEY 1B = IF SP! 0 ( 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 ' (EMIT) IS EMIT ( C@+ COUNT TYPE TYPE$ -TRAILING SPACE SPACES HOLD ) HEX 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 R@ + C@ 20 = WHILE NEXT 0 EXIT THEN POP 1+ ; : SPACE 20 EMIT ; : SPACES ( n) 0 MAX FOR SPACE NEXT ; : HOLD ( ..# x n - ..# x) SWAP PUSH SWAP 1+ POP ; ( EXPECT ) : EXPECT ( a # -) OVER 'SOURCE ! 0 ROT ROT ( #so-far a #) FOR ( #so-far a) BEGIN KEY DUP 8 = WHILE ( #so-far a key) PUSH OVER IF POP EMIT 1- 32 OVER C! -1 +UNDER ELSE POP DROP THEN REPEAT ( #so-far a key) DUP $0D - WHILE DUP EMIT OVER C! 1+ 1 +UNDER NEXT ELSE 32 EMIT POP 2DROP THEN DROP SPAN ! 0 0 >IN 2! ; ( EXPECT sets up 'SOURCE and >IN and BLK no it can be followed) ( immediately by c WORD . After using EXPECT and any WORDs ) ( SPAN OFF should be done to force the refilling of TIB) ( Numbers ) : DIGIT ( n -n) DUP 9 > 7 AND + 48 + ; : <# ( n - ..# n) ( -1) 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 ; : . ( n) (.) #> SPACE ; : .R ( n n) PUSH (.) OVER POP SWAP - SPACES #> ; : U.R ( u n) PUSH <# #S OVER POP SWAP - SPACES #> ; : U. ( u) 0 U.R SPACE ; : DUMP ( a - a) 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 ; : DU ( a n - a) FOR DUMP ?SCROLL NEXT ; ( HERE abort" dot" ) HEX : HERE ( - a) H @ ; : PAD ( - a) HERE 256 + ; DEFER ABORT : abort" ( f -) IF ABORT THEN POP COUNT + PUSH ; ' abort" TABORT ! : dot" POP DUP TYPE$ COUNT + PUSH ; ' dot" TDOT ! : (") ( - a) POP DUP COUNT + 1+ ( skip over z) PUSH ; ( buffer manager ) : ADDRESS ( n - a) -1024 * $F800 + ; ( highest buffer always at 63488 or $F800 ) ( lowest buffer is at 61440+1024 = 62464 only 2 allowed) ( lowest buffer is at 59392+1024 = 60416 with 4 allowed) : 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! DUP ADDRESS SWAP BUFFERS DUP @ 8192 ROT ! DUP 0< NOT IF POP DROP DROP THEN ; : UPDATE PREV @ BUFFERS DUP @ 32768 OR SWAP ! ; : ESTABLISH ( n a - a) SWAP OLDEST @ PREV N! BUFFERS ! ; : IDENTIFY ( n a - a) SWAP PREV @ BUFFERS ! ; ( allow multiple block files open at same time ) TMAX-FILES ( 16) 1- CONSTANT MAX-FILES ( must be power of 2) VARIABLE FILES HERE ( a) TMAX-FILES 1+ 8 * 2 - ALLOT ( a) TMAX-FILES 1+ 8 * 0 FILL ( each entry is 8 bytes) ( handle ending-block starting-block address-of-name) ( when empty or closed, handle is -1) : HANDLE ( u - a) 8 * FILES + ; : END# ( u - a) HANDLE 2 + ; : START# ( u - a) HANDLE 4 + ; : FNAME ( u - a) HANDLE 6 + ; : RANGE ( f# - starting# ending#) END# 2@ ; : #BLOCKS ( unit# - #) RANGE SWAP - 1+ ; ( Disk read/write ) VARIABLE F# ( file #) : LBLK ( global-blk# - local-blk#) ( & set F#) MAX-FILES 1+ FOR DUP F# @ DUP PUSH RANGE 2DUP SWAP U< PUSH BETWEEN NOT POP OR POP HANDLE @ 0< ( gblk f# f) OR ( gblk f) WHILE ( gblk) F# @ 1+ MAX-FILES AND F# ! NEXT ( DROP ( ) ." block# " U. -1 ABORT" is bad 1" THEN POP DROP ( gblk) F# @ DUP HANDLE @ 0< IF ." block# " DUP U. -1 ABORT" is bad 2" THEN ( gblk f#) START# @ - ( lblk) ; ( 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 ( f#) CR DUP 4 .R DUP START# @ 8 .R DUP END# @ 8 .R DUP HANDLE @ 8 .R DUP 4 SPACES .FILE ( #) 1+ NEXT DROP ( ) SPACE ; ( file positioning words) : >EOF ( f# -) ( move current position to end of an open file) HANDLE @ ( handle) 0 0 ROT $4202 DOS ( ax flg) ABORT" >EOF error" DROP ; : POSITION@ ( f# - ud) ( return current file position) HANDLE @ ( handle) 0 0 ROT $4201 DOS2 ( h l flg) ABORT" pos error" SWAP ; : >POSITION ( ud f# -) ( move to absolute position) HANDLE @ $4200 DOS ( ax flg) ABORT" pos error" DROP ; : >BOF ( f# -) 0 0 ROT >POSITION ; ( "to beginning of file") : +POSITION ( n f# -) 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) ( ?CLOSE OPEN ) : ?CLOSE ( f# -) HANDLE PUSH 0 0 R@ @ ?DUP IF $3E00 DOS THEN 2DROP -1 POP ! ; ( try to close it but ignore errors ) : OPEN ( f# -) ( file must exist) DUP ?CLOSE DUP FNAME ( f# a) @ DUP 0= ABORT" no name" 1+ ( ie name) 0 0 $3D02 DOS ( f# handle f) IF DROP .FILE ." OPEN err " ( ) ELSE ( f# h) OVER HANDLE ! ( f#) DUP >EOF DUP POSITION@ ( f# ud) 1024 UM/MOD ( f# r q) SWAP IF 1+ THEN ( f# #blks) OVER START# @ + 1- SWAP END# ! THEN ; ( ?OPEN EXISTS? MAKE ?MAKE ) : ?OPEN ( f# -) DUP ?CLOSE DUP FNAME @ DUP 0= IF 2DROP EXIT THEN 1+ 0 0 $3D02 DOS ( f# handle f) IF 2DROP ( ) ELSE ( f# h) OVER HANDLE ! ( f#) OPEN THEN ; : EXISTS? ( f# - flag) DUP ?OPEN DUP HANDLE @ 0< NOT IF ( f#) POSITION@ OR NOT NOT ELSE DROP 0 THEN ; ( this leaves file open, by the way) : MAKE ( f# -) DUP ?CLOSE DUP FNAME @ 1+ 0 0 $3C00 DOS ABORT" MAKE error" ( f# h) OVER HANDLE ! ( f#) OPEN ; : ?MAKE ( f# -) DUP EXISTS? NOT IF MAKE ELSE DROP THEN ; ( file write) : FILE-WRITE ( buf cnt f# -) OVER PUSH HANDLE @ $4000 DOS SWAP POP - OR ABORT" write error" ; : SET-FILE-SIZE ( ud f# -) ( ** be careful ** ) DUP PUSH >POSITION 0 0 R@ FILE-WRITE POP OPEN ; : MORE ( #blks-to-add f# -) ( ** be careful ** ) PAD 1024 32 FILL SWAP OVER >EOF ( f# #blks) FOR ( f#) PAD OVER ( f# a f#) 1024 SWAP ( f# a 1024 f#) FILE-WRITE ( f#) NEXT OPEN ; ( file read) VARIABLE #BYTES-READ : EOF? ( - f) #BYTES-READ @ 0= ; : FILE-READ ( buf cnt f# -) HANDLE @ $3F00 DOS ABORT" read error" #BYTES-READ ! ; HEX ( Disk read/write RESET-FILES OPEN-FILES UNIT .FILES ) : CLOSE-FILES ( -) MAX-FILES 1+ FOR R@ ?CLOSE NEXT ; : RESET-FILES ( -) CLOSE-FILES FILES [ TMAX-FILES ( MAX-FILES) 1+ 8 * ] LITERAL 0 FILL CLOSE-FILES ( to set handles to -1 ) ; : OPEN-FILES ( -) 0 ( f#) MAX-FILES 1+ FOR ( f#) DUP ?OPEN 1+ NEXT DROP ; ( above changed to open 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 local-dirty-blk#) 1024 M* F# @ >POSITION ( new# a a) 1024 ( new# a a #) F# @ ( new# a a # f#) FILE-WRITE ( new# a) ; : BUFFER ( n - a) buffer ESTABLISH ; : block ( n a - n a) OVER LBLK 1024 M* F# @ >POSITION ( n a) DUP 1024 F# @ ( n a a # f#) FILE-READ ( n a) ; : BLOCK ( n - a) ABSENT buffer block ESTABLISH ; ( block words ) : FLUSH NB 1+ FOR $2000 BUFFER DROP NEXT ; : 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 ; ( WORD written in code ) CODE WORD ( delim. - a) SI DX MOV, ( save IP) ' H 2 + @ ) DI MOV, DI PUSH, DI INC, ' 'SOURCE 2 + @ ) SI MOV, ' SPAN 2 + @ ) CX MOV, DS AX MOV, AX ES MOV, ' >IN 2 + @ ) AX MOV, AX SI ADD, AX CX SUB, CXNZ, IF, BEGIN, AL LODS, AL BL CMP, LOOPZ, ( eat leading delimiters) 0=, NOT, IF, AL STOS, THEN, CXNZ, IF, ( might be more) BEGIN, AL LODS, AL STOS, AL BL CMP, LOOPNZ, ( store till delim) 0=, IF, ( last char was delim) DI DEC, ( unstore) THEN, THEN, THEN, $20 #, AX MOV, AL STOS, ( blank) ' 'SOURCE 2 + @ ) SI SUB, SI ' >IN 2 + @ ) MOV, BX POP, ( here) DI AX MOV, BX AX SUB, AX DEC, AX DEC, AL 0 [BX] MOV, DX SI MOV, ( restore IP) NXT, END-CODE ( HASH ) : 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, ( keep here in BX) 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 - later I must put in ) ( the code to allow for an indirect bit set ) AX POP, DI PUSH, ( the pfa) BX BX SUB, ( the flag) DX SI MOV, NXT, END-CODE DEFER -FIND ' (-FIND IS -FIND ( Number input ) HEX : -DIGIT ( n - n) 30 - DUP 9 > IF 7 - DUP A < OR THEN DUP BASE @ U< NOT ABORT" ?" ; ( RECOVER) : 10*+ ( u a n - u a) ( multiplies number by BASE & adds digit) -DIGIT ROT BASE @ * + SWAP ; DEFER NUMBER : SNUMBER ( a - n) BASE @ SWAP COUNT OVER C@ 2D = DUP PUSH IF 1- 1 +UNDER THEN OVER C@ 24 ( $) = IF ( HEX) 10 BASE ! 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 SWAP BASE ! ; ( above allows $FF and 'a type literals ) ' SNUMBER IS NUMBER ( Control ) : -' ( n - here t | pfa f) 32 WORD SWAP -FIND ; : ' ( - pfa) CONTEXT @ -' ABORT" ?" ; : SOURCE ( blk offset - blk offset) OVER ?DUP IF BLOCK ELSE TIB @ THEN 'SOURCE ! ; : INTERPRET ( blk# offset -) ( blk# offset) >IN 2! ( we do SOURCE in LOAD or INTERPRET instead of in WORD ) BEGIN 2 -' ( search FORTH) IF NUMBER ELSE EXECUTE THEN AGAIN ; : QUIT RP! ['] (EMIT) ['] EMIT 1+ ! BEGIN CR TIB @ 80 EXPECT 0 0 ( blk offset) INTERPRET ." ok" AGAIN ; ( RECOVER) ' QUIT dA@- DUP ' ?SCROLL 23 + ! ' ?SCROLL 45 + ! ( Initialize & setup default ABORT ) FORTH : (ABORT ( -) HERE TYPE$ SPACE POP POP TYPE$ SP! BLK @ ?DUP DROP QUIT ; ' (ABORT IS ABORT DEFER BOOT : reset ( -) 0 ( save room for RESET to be patched in) BOOT ; ' reset dA@- ' boot 7 + ! ( DECIMAL HEX LOAD THRU ) : DECIMAL 10 BASE ! ; : HEX 16 BASE ! ; : LOAD ( n -) SPAN @ >IN 2@ PUSH PUSH PUSH 0 1024 SPAN ! ( blk offset) OVER BLOCK 'SOURCE ! INTERPRET 10 BASE ! POP SPAN ! POP POP SOURCE >IN 2! ; : THRU ( 1st last - ) ( keep scr# on return stack) ( * this would get much simpler if FOR used an upcounting I) OVER - 1+ SWAP PUSH FOR POP POP DUP 1+ PUSH SWAP PUSH LOAD ?SCROLL NEXT POP DROP ; ( CLEAR LIST ) : LIST ( n -) SCR N! DUP CR ." scr " . DUP BLOCK ( n a) SPACE SWAP LBLK DROP F# @ .FILE 16 FOR CR 64 FOR C@+ EMIT NEXT NEXT DROP CR ; : CLEAR ( n -) BLOCK 1024 32 FILL UPDATE ; ( ALLOT , C, ,A COMPILE LITERAL [ ] ) : 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) HEX ( PREVIOUS USE DOES SMUDGE RECURSIVE ; ) : 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 HEX ( Defining words CREATE : CONSTANT VARIABLE ) FORTH : (CREATE H @ 0 , ( lf) 20 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 ! E9 C, ( JMP instr) lit var HERE 2 + - , ; DEFER CREATE ' (CREATE IS CREATE : : CREATE -2 ALLOT lit docol HERE 2 + - , SMUDGE ] ; : CONSTANT ( n) CREATE -3 ALLOT 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 " ; : DEFER ( -) CREATE -3 ALLOT B8 C, lit CRASH , E0FF , ; : IS ( a-) ' 1+ ! ; ( WORDS .S debugger ON OFF .ID STRING ) : WORDS CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + TYPE$ 2 SPACES ?SCROLL REPEAT DROP ; CODE DEPTH ( - words) BX PUSH, SP BX MOV, HEX FDFE #, 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 ; : ? @ . ; : ON -1 SWAP ! ; : OFF 0 SWAP ! ; : NFA ( pfa - nfa) BEGIN 1- DUP C@ 127 AND 32 < UNTIL ; : .ID ( pfa -) NFA TYPE$ ; : STRING ( delim -) WORD C@ 1+ ALLOT ; ( file names UNIT ) : FILE-NAME: ( ) ( -a) CREATE 32 STRING 0 C, ; : NAMEZ: ( -) ( -a) HERE 2 + CREATE -3 ALLOT $C000 , ( al al add, trick puts zero immediately after name ) $53 C, ( bx push,) $BB C, , ( a #, bx mov,) $AD C, $E0FF , ( nxt,) ; : UNIT ( starting# name f# -) ( setup name & screen number) DUP PUSH FNAME ! R@ START# ! -1 POP HANDLE ! ; EXIT ( examples) NAMEZ: PYGMY.SCR FILE-NAME: F2 SUPPL.SCR FILE-NAME: F3 ASM.SCR FILE-NAME: ABC C:\UTILITY\ABC.COM ( start name slot ) 0 PYGMY.SCR 0 UNIT 300 F2 1 UNIT 600 F3 2 UNIT 900 ABC 3 UNIT ( SAVEM & SAVE for .COM files or memory images) HEX : SAVEM ( fr to -) ( follow with file name) 10000 ( dummy-start#) 20 WORD DUP C@ OVER + 1+ 0 SWAP C! ( fr to start# name) MAX-FILES ( ie always use last unit) DUP PUSH UNIT ( fr to) R@ MAKE R@ >BOF R@ FNAME OFF ( keep trash out of FILES) OVER - 1+ ( fr length) R@ FILE-WRITE ( ) R@ FNAME OFF POP ?CLOSE ; : SAVE ( -) ( follow w/ file name) 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 ( a ) ' \ LITERAL COMPILE 1+ COMPILE ! ; ( is could be moved to an optional words screen ) : " ( -) COMPILE (") 22 STRING 0 C, ( asciiz for files) ; FORTH : ( \ ( ; : ." 22 WORD TYPE$ ; forget ( (BOOT normal opening screen ) : (BOOT CR ." PYGMY Forth v1.3" CR ." copyright 1989, 1990 Frank C. Sergeant" CR 27 SPACES ." 809 W. San Antonio St." CR 27 SPACES ." San Marcos, TX 78666" CR ." (see file PYGMY.TXT for help)" CR OPEN-FILES .FILES CR ." hi" QUIT ; ' (BOOT IS BOOT : RESET NB ADDRESS $100 - TIB ! 'VIDEO VID ! CRTC ! >IN OFF dA OFF 10 BASE ! $0F00 CUR ! VID @ $B800 = IF $7100 ELSE $0700 THEN ATTR ! EMPTY-BUFFERS 2 CONTEXT ! ; ( RECOVER) ( ** RESET must be the last word) ' RESET dA@- ' reset 3 + ! ( patch reset ) NAMEZ: PYGMY.SCR ' PYGMY.SCR DUP NFA dA@- DUP ROT 4 + ! ' FILES 9 + ! ( equiv to 0 PYGMY.SCR 0 UNIT) CONTEXT 6 - DUP @ dA@- ' CONTEXT 2 + @ dA@- 2 - ! 2 - @ dA@- ' CONTEXT 2 + @ dA@- 4 - ! HERE dA@- ' H 2 + @ dA@- ! } ( to host ) ( load screen for the editor, assembler, & extensions ) 84 96 THRU ( load the editor) SAVE H2.COM 100 120 THRU ( load the assembler) SAVE H3.COM 129 130 THRU ( SEE) 134 LOAD ( OF THENS) 135 136 THRU ( L@ L! etc) 150 155 THRU ( print screens SHOW SHOW2 ) ' EPSON-CONDENSED IS CONDENSED ( 161 169 THRU ( hashing) ( ' (HBOOT IS BOOT ) NAMEZ: YOURFILE.SCR 300 YOURFILE.SCR 1 UNIT 1 OPEN SAVE H4.COM HEX ( INS UPDT XIN CLS L ) VARIABLE INS ( insert or overwrite flag) VARIABLE XIN VARIABLE #CUTS : CLAMP ( n lo hi - n') PUSH MAX POP MIN ; : CLS ( -) 20 ATTR @ 0 V! VID @ 0 OVER 2 81F MOVEL CUR OFF ; DECIMAL : .H ( -) CUR @ CUR OFF ." scr # " SCR @ . F# @ .FILE ." find(3,1) rep(4,2) del(5) join(6) cut(7,8) " INS @ IF ." i c=" ELSE ." c=" THEN #CUTS ? CUR ! ; : L1 ( -) SCR @ F# @ RANGE CLAMP ( scr#) SCR N! BLOCK CURSOR ! .H ; : L2 ( -) CUR @ 160 CUR ! CURSOR @ 64 FOR 45 EMIT NEXT CR 16 FOR 64 FOR C@+ EMIT NEXT ." |" CR NEXT DROP ( ) 64 FOR 45 EMIT NEXT CUR ! ; : L ( -) L1 L2 ; HEX ( A>B SET-CUR S@ S! CK-CUR L>A A>L .EOL X #REM >BEG ) : A>B ( a - a) ( rel-addr to buffer addr) CURSOR @ + ; : CUR-ON ( -) CUR @ 2/ DUP 100 / CRTC @ 0E OVER PC! 1+ PC! CRTC @ 0F OVER PC! 1+ PC! ; : SET-CUR ( a -) 40 U/MOD 2 + 50 * + 2* CUR ! ; : S! ( c -) DUP XIN @ A>B C! EMIT 1 XIN +! UPDATE ; : CK-CUR ( -) XIN @ 0 MAX 3FF MIN XIN ! ; : L>A ( line# - a) 40 * ; : A>L ( a - line#) 40 / ; : (B>B) ( fr to # - fr' to' #) ROT CURSOR @ + ROT CURSOR @ + ROT 0 MAX UPDATE ; : B>B ( fr to # -) (B>B) CMOVE> ; : B<B ( "-") (B>B) CMOVE ; : X ( - pos) ( x= 0..63) XIN @ 3F AND ; : #REM ( - #) 40 X - ; : .EOL ( -) CUR @ XIN @ A>B #REM FOR C@+ EMIT NEXT DROP CUR ! ; : >BEG ( a -a) FFC0 AND ; : >END ( a -a) 3F OR ; ( INSERT DELETE SPLIT ) : BLANK ( a # -) SWAP A>B SWAP 32 FILL ; : INSERT ( c -) XIN @ DUP 1+ ( c from to ) #REM 1- ( ie cnt) B>B ( c) .EOL S! ; : DELETE ( -) XIN @ ( a) DUP SET-CUR DUP DUP 1+ SWAP #REM 1- B<B >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 + DUP SET-CUR XIN ! L THEN ; ( HOLES ) : HOLES ( n -) 3040 CUR N! 80 SPACES CUR ! ." how many holes? " ( n) TIB @ 4 EXPECT 0 WORD NUMBER 0 50 CLAMP ?DUP IF ( u) #CUTS OFF ( u) F# @ END# @ PUSH ( save for later) DUP F# @ MORE ( extend) ( u) SCR @ ( #-to-insert after-scr#) 2DUP POP OVER - ( ie #above-insert-pt) PUSH ( #ins aft#) 1+ ( ie 1st-scr-to-move) DUP ROT + POP COPIES SWAP FOR 1+ DUP CLEAR NEXT DROP FLUSH F# @ DUP ?CLOSE OPEN L THEN ; ( DEL-IN ) : 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 ; ( SLEN S$ SET$ SRCH ) 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 CURSOR @ - XIN ! ; : SRCH ( -) -SRCH DROP ; : SET$ ( -) 3040 CUR ! 80 SPACES 3040 CUR ! ." enter search string " S$ 64 EXPECT SPAN @ SLEN ! SPAN OFF ." ok " SRCH ; : SRCHX ( -) BEGIN ?SCROLL -SRCH SCR @ F# @ END# @ < AND WHILE 1 SCR +! XIN OFF L1 REPEAT L2 ; ( RLEN R$ SETR$ REPL ) VARIABLE RLEN ( holds len of following string) RLEN OFF VARIABLE R$ 64 ALLOT ( default is null) : REPL ( -) RLEN @ IF SLEN @ DUP NEGATE XIN +! CK-CUR XIN @ SET-CUR FOR DELETE NEXT UPDATE R$ RLEN @ FOR C@+ INSERT NEXT DROP L THEN ; : SETR$ ( -) 3202 CUR ! 80 SPACES 3202 CUR ! ." enter replace string " R$ 64 EXPECT SPAN @ RLEN ! SPAN OFF ." ok " REPL ; ( PgUp PgDn ) : PgUp ( -) -1 SCR +! INS OFF L XIN OFF ; : PgDn ( -) 1 SCR +! INS OFF L XIN OFF ; : -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 to just past last chr on line) XIN @ >END A>B BEGIN DUP C@ 32 = WHILE 1- REPEAT CURSOR @ - 1+ XIN ! ; ( SPCL converted to use (onekey codes ) : ', ( -) ' , ; VARIABLE SPCL' -2 ALLOT 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 : SPCL ( n -) SPCL' 20 FOR 2DUP C@ - WHILE 3 + NEXT 2DROP ELSE SWAP POP 2DROP ( a) 1+ @ EXECUTE THEN ; ( ED ) : BEEP 7 EMIT ; : ED ( -) SCR @ LBLK DROP DECIMAL XIN OFF INS OFF CLS L BEGIN CK-CUR XIN @ SET-CUR CUR-ON KEY DUP 27 - WHILE ( not ESC) DUP 08 = IF DROP XIN @ IF -1 XIN +! DELETE THEN ELSE DUP 13 = IF DROP SPLIT ELSE DUP 128 < IF DUP 32 127 WITHIN IF ( reg key) INS @ IF INSERT ELSE S! THEN ELSE DROP THEN ELSE SPCL THEN THEN THEN REPEAT DROP 3040 CUR ! ; : EDIT ( n -) SCR ! ED ; ( SETTLE let heavy screens 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 screens) FLUSH DUP DUP END# @ ( unit unit hi-blk#) BEGIN DUP HEAVY? NOT WHILE 1- REPEAT 1+ OVER START# @ - ( unit unit #blks-to-keep) 1024 M* ROT SET-FILE-SIZE ( unit) DUP ?CLOSE OPEN ; HEX ( 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 ) ; : NOT, ( opcode - opcode') 01 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 CREATE -3 ALLOT 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 want to 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 ; EC 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 ; ( I am not implementing the inter-seg direct or indirect versions ) : NXT, ( -) AX LODS, AX JMP, ; : SWITCH, SP BP XCHG, ; FORTH ( don't actually load this screen, just use it as an index ) 127-128 ( 2 FORGETs ) 129-130 ( SEE) 131-133 ( HIDE) 134 ( OF THENS from Wil Baden ) 135-136 ( L@ L! LC@ LC!) 137 ( various EMITs >STD >DOS ) 138 ( show IBM graphics characters ) 139 ( FLIP) 140 ( test loading a large number of numbers ) ( index continued ) 141 ( allows over 200 files open simultaneously ) 142 ( @EXECUTE MS BEEPS ) 143 ( the name is the string ) 144 ( 2/MOD ) 148 ( INDEX ) 149 ( LCMOVE & LCMOVE>) 150-155 ( print screens SHOW SHOW2 SHADOW ) 156 ( BELL ) 157 ( BLK>TXT append range of blocks to a text file ) 158 ( one possible CASE: ) 159-169 ( hashed approach to dictionary searching) 170-182 ( code, notes, & tips for Starting Forth) ( REMEMBER; FORGET EMPTY ) ( This is the cmFORTH style FORGET. It is not used from the ) ( keyboard & it is not followed by the name of a word. Use it) ( only inside a place marking word such as EMPTY. ) ( e.g. : EMPTY FORGET REMEMBER; ) COMPILER : END \ RECURSIVE COMPILE EXIT ; : REMEMBER; CONTEXT 4 - 2@ , , \ END ; FORTH : FORGET ( ) POP DUP 4 + H ! 2@ CONTEXT 4 - 2! 2 CONTEXT ! ; ( a more familiar FORGET ) : FORGET ( -) 2 CONTEXT ! ( we can't forget in COMPILER) ' NFA 2 - DUP @ 2 HASH ! DUP 4 HASH @ > IF H ! THEN ; ( * we can't let here be before last word in COMPILER vocab) ( e.g. FORGET TST ) ( this version of FORGET must be followed by the name of the ) ( word that you want to FORGET. It and everything defined ) ( after it will disappear, providing no COMPILER words have ) ( been defined since that word. ) ( support for SEE ) : COLON? ( pfa - f) ( true if this is a colon definition) DUP C@ $E9 = OVER 1+ @ ROT 3 + + ['] docol = AND ; : .addr ( ... - ...) ." (" 2 +UNDER OVER @ U. ." )" ; ( crude decompiler SEE ** use only on colon definitions! ** ) : SEE ( -) CR ' DUP COLON? NOT ABORT" not a colon definition " 3 + BEGIN DUP @ DUP ['] EXIT - WHILE ( while not the EXIT ) DUP ['] 0branch = IF CR ." IF " .addr ELSE DUP ['] branch = IF CR ." ELSE " .addr ELSE DUP ['] lit = IF SPACE 2 +UNDER OVER @ U. ELSE DUP ['] next = IF ." next " 2 +UNDER ELSE DUP ['] for = IF ." for " 2 +UNDER ELSE DUP ['] dot" = IF ." ." 34 EMIT SPACE SWAP 2 + DUP TYPE$ COUNT + 2 - SWAP 34 EMIT 2 SPACES ELSE DUP ['] abort" = IF ." abort" 34 EMIT SPACE SWAP 2 + DUP TYPE$ COUNT + 2 - SWAP 34 EMIT 2 SPACES ELSE DUP ['] (") = IF SPACE 34 EMIT SPACE SWAP 2 + DUP TYPE$ COUNT + ( 1+ 2 -) 1- SWAP 34 EMIT 2 SPACES ELSE DUP SPACE .ID THEN THEN THEN THEN THEN THEN THEN THEN DROP 2 + REPEAT 2DROP ." ; " CR ; ( HIDE ) : HIDE ( -) CONTEXT @ HASH ' ( old-LF pfa1) BEGIN OVER @ ( oldLF pfa1 newLF) 2DUP 2 + COUNT 31 AND + ( oldLF pfa1 newLF pfa1 pfa2) - WHILE ( oldLF pfa1 newLF) ROT DROP SWAP ( newLF pfa1) REPEAT ( oldLF pfa1 newLF) NIP ( oldLF newLF) @ SWAP ! ( unlink middle word) ; ( loading the following two screens will unlink auxiliary words that you might not need to look up in the dictionary ) ( HIDE some words we might not need headers for ) HIDE lit HIDE array HIDE var HIDE 0branch HIDE branch HIDE docol HIDE dodoes HIDE for HIDE next HIDE abort" HIDE dot" HIDE buffer HIDE block HIDE reset HIDE does HIDE SPREAD HIDE CLOSE-FILES HIDE RESET HIDE INS HIDE XIN HIDE H HIDE #CUTS HIDE A>B HIDE CUR-ON HIDE S! HIDE SET-CUR HIDE CK-CUR HIDE L>A HIDE A>L HIDE B>B HIDE (B>B) HIDE B<B HIDE X HIDE #REM HIDE .EOL HIDE >BEG HIDE >END HIDE BLANK HIDE INSERT HIDE SPLIT HIDE DELETE HIDE DEL-LN HIDE JOIN HIDE CUT HIDE UNCUT HIDE SLEN HIDE S$ HIDE -SRCH HIDE SRCH HIDE SET$ HIDE SRCHX HIDE RLEN HIDE R$ HIDE REPL HIDE SETR$ HIDE PgUp HIDE PgDn HIDE -INS HIDE Rt HIDE Lt HIDE Up HIDE Dn HIDE Home HIDE End HIDE SPCL HIDE DISP ( HIDE some words we might not need headers for ) HIDE IMM? HIDE ACC? HIDE ,IMM HIDE 2REGS? HIDE M1 HIDE M2 HIDE M3 HIDE M4 HIDE M5 HIDE M6 HIDE M7 HIDE M8 HIDE M9 HIDE SHORT? HIDE .F HIDE R>M HIDE 1REG? HIDE orW HIDE modDISP, HIDE orDW ( 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 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 ; ( test loading a large number of numbers ) 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP 75 DROP ( 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 ! ; ( various BEEPs & @EXECUTE ) CODE @EXECUTE ( a -) 0 [BX] AX MOV, BX POP, AX JMP, END-CODE ( : BEEP ( -) ( 7 EMIT ; ) : MS ( n -) FOR 75 FOR NEXT NEXT ; : BEEPS ( n -) FOR BEEP 50 MS NEXT 500 MS ; : DBG ( n -) BEEPS KEY DROP ; ( eg 1 DBG 12 DBG etc scattered throughout troubled ) ( word for debugging screen displays ) ( 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$ ; ( this is cute ) 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 ( old fashioned 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 ( list blocks to printer ) : (PEMIT ( c -) ( print chr to LPT1: ) 0 0 $0500 DOS 2DROP ; : >PRN ( -) ['] (PEMIT IS EMIT ; : >SCR ( -) ['] (EMIT) IS EMIT ; 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 5 SPACES SWAP .LINE CR ; ( list block file to printer with 3 screens per page ) DEFER .HD ( print a heading ) : (.HD ( -) ." file " F# @ .FILE CR CR ; ' (.HD IS .HD : SHOW ( 1st last - ) OVER LBLK DROP ( set F#) >PRN DUP 1+ SCR-LIMIT ! OVER - 3 / 1+ FOR .HD 3 FOR DUP SCR<LIMIT? IF DUP LIST THEN 1+ NEXT $0C EMIT NEXT DROP >SCR ; ( make printer print in small type ) DEFER CONDENSED : 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 ; ' OKI-CONDENSED IS CONDENSED ( print 2 screens side by side ) : 2SCRS ( n1 n2 -) OVER SCR<LIMIT? IF DUP SCR<LIMIT? IF OVER .SCR# 62 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 ; : SHOW2 ( 1st last -) OVER LBLK DROP ( set F#) >PRN CONDENSED DUP 1+ SCR-LIMIT ! OVER - 6 / 1+ FOR .HD 3 FOR DUP DUP 3 + 2SCRS 1+ NEXT $0C EMIT 3 + NEXT DROP >SCR ; ( shadow ) : 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 ; : (.SHD ( scr1 scr2 -) ." file " OVER LBLK DROP F# @ .FILE CR CR ; ' (.SHD IS .HD ( shadow ) VARIABLE PAGE-CTRL : SHADOW ( 1st last 1st-shadow -) OVER LBLK DROP ( set F#) >PRN CONDENSED PAGE-CTRL OFF PUSH OVER - 1+ POP SWAP FOR ( 1st 1st-shadow) PAGE-CTRL @ 3 UMOD 0= IF .HD THEN 2DUP 2SCRS 1+ SWAP 1+ SWAP 1 PAGE-CTRL +! PAGE-CTRL @ 3 UMOD 0= IF $0C EMIT THEN NEXT 2DROP PAGE-CTRL @ 3 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 ) 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 ( slowly append a range of blocks to a text file BLK>TXT) VARIABLE UNIT# : (SEQ-EMIT ( c -) PAD C! PAD 1 UNIT# @ FILE-WRITE ; : >SEQ ( -) ['] (SEQ-EMIT IS EMIT ; : BLK>TXT ( 1st-blk# last-blk# unit# - ) ( append blocks to specified file) DUP UNIT# ! DUP OPEN >EOF ( 1st last) OVER - 1+ >SEQ FOR ( blk#) DUP BLOCK ( blk a) CR ." scr # " OVER U. CR CR 16 FOR ( blk a) DUP 64 -TRAILING ( blk a a #) ?DUP IF TYPE CR ELSE DROP THEN 64 + NEXT DROP 1+ CR NEXT DROP >SCR UNIT# @ ?CLOSE ; ( 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 ; ( n for default must be 00 and the default pair must be last.) ( numbers can be in any order except 00 must be last ) ( CASE: COLOR 7 RED 12 BLUE 472 ORANGE 15 PINK 00 BLACK ; ) ( : 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) Following is an add-on hash table dictionary lookup mechanism. It can be used during development and dropped in the target system. It rashly expects an available 64K segment above the segment DOS loads Pygmy into. Surely, on ordinary PC/XT/AT computers this is no problem. If it is, don't use this! CREATE and -FIND are DEFER'd in the kernel to make it easy to switch back & forth between the hashing and the normal look- up mechanisms. Note that SAVE is redefined to turn hashing off before saving a program image. My quick tests suggest that hashing will cut about 1/3rd off of the time to load an application. The larger the appli- cation, the more time is saved. The one problem I've noticed with hashing is that you cannot redefine a word and use its original definition as part of the new definition. To do this you must turn hashing off at least temporarily. ( HASH-SEG & HASH ) HEX : HASH-SEG ( - seg) CS@ 1000 + ; ( put in next seg above Pygmy) : HASH2 ( a n - a index) 2 - 1000 * ( convert vocab to 3 msbits) OVER ( a n a ) 0 OVER C@ 3 MIN 1+ FOR ( a n a index) 2* 2* 2* OVER R@ + C@ 7 AND + NEXT 22 * 1FFE AND ( 8k mod) NIP ( a n 13-bit-index) ( combine w/ vocab bits) + ( a 15-bit-index) ; ( REHASH ) HEX VARIABLE HASHED ( true if we have already hashed dict.) ( VARIABLE #BUMPS ) ( : BUMP ( ." bump " ( 7 EMIT) ( 1 #BUMPS +! ; ) : REHASH ( index - index') DUP E000 AND ( isolate vocab. bits) SWAP 2E + 1FFE AND ( mod to 8k) OR ( put back vocab bits) ; ( heart of the new search ) : FINDX ( h n - h index) ( index points to either an empty slot or a perfect match) HASH2 ( h index) 1000 FOR ( CR ." findx " ) ( ?SCROLL) HASH-SEG OVER L@ ( h x x-a) DUP IF ( h x x-a) PUSH OVER POP ( h x h x-a) OVER C@ 1+ COMP ( h x flag) THEN ( h x compare-flag | h x null-x-a-flag) ( flg zero because slot empty or perfect match or non-zero ) ( because of a collision ) WHILE ( h x) REHASH ( BUMP ) NEXT ( h x) 2DROP ABORT" hash table overflow " THEN ( h x) POP DROP ( clean up for next ) ( it is either empty slot or perfect match) ; ( -FIND2 ) : MATCH? ( a x - f) HASH-SEG SWAP L@ ( a x-a) ?DUP IF OVER C@ 1+ COMP 0= ELSE DROP 0 THEN ; : -FIND2 ( h n - h true | pfa false) FINDX ( h x) 2DUP MATCH? IF NIP HASH-SEG SWAP L@ ( DUP C@ + 1+) COUNT + ( pfa) 0 ELSE DROP -1 THEN ; ( CREATE2) : CREATE2 ( -) H @ ( lfa) (CREATE ( ie regular links) ( lfa) 2 + ( nfa) CONTEXT @ ( nfa n) FINDX ( nfa x) ( nfa x) HASH-SEG SWAP L! ; ( BUILD-HASH-TABLE ) : BUILD-HASH-TABLE ( -) ( #BUMPS OFF ) 0 HASH-SEG 0 L! HASH-SEG 0 OVER 2 32767 MOVEL ( clear hash table to zeroes) 2 FOR R@ 1+ 2* DUP HASH ( old hash) ( n voc-head) BEGIN ( ?SCROLL) ( n lfa) @ DUP WHILE ( not end of thread) 2DUP ( n lfa n lfa) 2 + ( n lfa n nfa) SWAP ( n lfa nfa n) FINDX ( n lfa nfa x) HASH-SEG OVER L@ ?DUP IF TYPE$ ." not unique " 2DROP ( n lfa) ELSE ( n lfa nfa x) HASH-SEG SWAP L! ( n lfa) THEN ( n lfa) REPEAT ( n empty-lfa) 2DROP NEXT ; EXIT ( just for testing ) : X-' ( n - h t | a f) 32 WORD SWAP -FIND2 ; : X' ( - pfa) CONTEXT @ X-' IF DROP ." not found " THEN ; : TT NFA TYPE$ ; ( examine hash table >HASH >NOT-HASH HASH-ON -OFF ) ( : CK-TBL ( -) ( HASH-SEG 0 8192 FOR 2DUP LC@ . 1+ ?SCROLL NEXT 2DROP ; ) : >HASH ( -) ['] -FIND2 IS -FIND ['] CREATE2 IS CREATE ; : >NOT-HASH ['] (-FIND IS -FIND ['] (CREATE IS CREATE ; : HASH-ON ( -) BUILD-HASH-TABLE HASHED ON >HASH ; : HASH-OFF ( -) HASHED OFF >NOT-HASH ; ( HASH-PAUSE -CONTINUE SAVE FORGET (HBOOT ) : HASH-PAUSE ( -) ( HASHED @ IF ) >NOT-HASH ( THEN) ; : HASH-CONTINUE ( -) HASHED @ IF >HASH THEN ; : SAVE ( -) ( instream: <name> ) HASHED @ HASHED OFF HASH-PAUSE SAVE HASH-CONTINUE HASHED ! ; ( ** saved image must not come up with HASHED true ** ) : (HBOOT ( -) HASH-ON ." hashed " (BOOT ; EXIT use following only if you have defined a compatible FORGET : FORGET ( -) ( instream: <word> ) HASH-PAUSE FORGET HASH-CONTINUE ; The following screens 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 - 1- ; 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 another 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 screens .S shows different stack pictures you have an error in the screens, 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 screen, type n EDIT The ESC key will get you out of the editor. To get back in to the same block, just type ED without giving it a block number. Ignore all the crazy T P F I E TILL etc line editing commands. The editor in Pygmy is much easier to use. 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 screen to get a feel for it. Use the arrow keys to move around the screen 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 screens. Press CR to split a line at the cursor and to scroll all the lower lines down. The bottom line will be lost. p. 101 ABORT" Pygmy 1.3 now has the 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'm quite undecided as to whether I like this or not. p. 258 TYPE in Pygmy is no longer 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 two byte link field, a 1 to 32 byte name field, 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 -- 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,
