home *** CD-ROM | disk | FTP | other *** search
- this is the source code for PYGMY.COM version 1.1 screen 1 is the load screen screens 3-16 are the meta-compiler screens 17-74 are PYGMY 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 make this file accessible by typing 0 OPEN PYGMY.SCR set up other default files by typing 77 LOAD load the editor & save by typing 80 LOAD then if you want the assembler loaded, type 1 UNIT 1 LOAD (assuming ASM.SCR is the second file) the version with the editor will be saved as F2.COM; the versionwith editor & assembler as F3.COM (unless you change the names on screens 80 & 301) HEX ( file PYGMY.SCR for meta-compiling PYGMY.COM) 0F CONSTANT TMAX-FILES ( allow room in tgt for 15 files) 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' ! DECIMAL 3 16 THRU ( meta ) 17 41 THRU ( target ) 42 LOAD ( 42 passes stack items to 43, therefore) 43 LOAD ( they cannot be loaded together w/ THRU ) 44 74 THRU HEX PRUNE { 8100 HERE SAVEM I1.COM } ( scr 80 is load screen for editor, scr 77 for opening files) ( load this screen if you want more info while meta-compiling) : LOAD ( n -) DUP CR ." loading scr # " . BLK @ >IN @ PUSH PUSH 0 INTERPRET 10 BASE ! POP POP >IN ! BLK ! .S ; : THRU ( n n -) OVER - FOR DUP LOAD 1+ NEXT DROP ; ( meta variables pointing to target runtime code ) VARIABLE TVAR ( variable) VARIABLE TLIT ( literal) VARIABLE TCON ( constant) VARIABLE TCOL ( docol) VARIABLE TBRA ( branch) VARIABLE T0BR ( zero branch) VARIABLE TDOES ( does>) 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, ; ( for in-line next) : SWITCH, SP BP XCHG, ; ( XREF ) EXIT HEX : XREF ( -) ' (PEMIT IS EMIT CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + DUP 1+ SWAP C@ 1F AND TYPE dA @ - HEX U. CR REPEAT DROP CR ['] (EMIT) IS EMIT ; ( { } ) : { dA @ HERE H' 2@ ( DP) 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 anyway. 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 to current lfa) ( lfa nfa vocab prev.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 ) E9 C, TVAR @ HERE 2 + - , ( 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 E9 C, ) ( **central**) ( TCON @ HERE 2 + - , , ; ) : CONSTANT ( n -) TCREATE -3 ALLOT BX PUSH, #, BX MOV, NXT, ; ( "in-line" ) : VARIABLE ( -) ( RAM @ CONSTANT 2 RAM +! for ROMing) TCREATE 0 , ; : ARRAY ( a -) ( n -) ( runtime: n is a word, not byte, index) TCREATE -3 ALLOT E9 C, TARR @ HERE 2 + - , , ; : DEFER TCREATE -3 ALLOT 0 #, AX MOV, AX JMP, ; : IS ( a -) dA @ - ' 1+ ! ; ( SCAN TRIM CLIP PRUNE ) HEX : 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) { ( EMPTY) ; ( 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 6 -' ( restrict execution to host's COMPILER) IF 4 -FIND ( restrict finding to target's FORTH ) IF NUMBER \ LITERAL ELSE EXECUTE THEN ELSE ,A THEN AGAIN ; ( meta structures UNTIL AGAIN IF THEN etc ) COMPILER : \ 8 -' IF DROP ABORT" ?" THEN ,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 ; : NEXT ( h -) 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 -2 ALLOT TCOL @ HERE 2 + - , ( lay down 3byte jump to docol) forget ] ; COMPILER' :' ; forget POP DROP TEXIT @ ,A ; ( must be last colon def) FORTH' ( start target code BOOT ) HEX 6 HASH OFF 8 HASH OFF ( 8000 2000 0 FILL 8000 H' ! ) { ( 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) DI DI SUB, ( DI is our quick "zero" ) AX JMP, NOP, ( jump to "reset") END-CODE HERE dA @ - RAM ! 30 ALLOT ( room for system variables) HERE TNULL ! : $ ; 3 ALLOT ( patch later) HEX ( 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) REPZ, ( BYTE) AL CMPS, 0=, NOT, IF, U<, IF, -1 #, CX MOV, ELSE, 1 #, CX MOV, THEN, THEN, CX BX MOV, DX SI MOV, DI DI SUB, NXT, END-CODE ( 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 ( 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, DI BX CMP, 0=, IF, AX SI MOV, THEN, BX POP, NXT, END-CODE CODE branch HERE TBRA ! AX LODS, AX SI MOV, NXT, END-CODE ( LINK,NAME,JMP<var>,VALUE ( 2 ? 3 2 (# of bytes in each field) EXIT ( docon 0 1 -1 ) ( instead of a central docon, CONSTANTS are defined "in-line") ( CODE docon HERE TCON ! ) ( BX PUSH, ( push TOS to SOS) ( 3 #, AX ADD, ( jump over 3 byte JMP to this code ) ( AX BX MOV, ( put addr of constant in BX ) ( 0 [BX] BX MOV, ( put constant's value in BX ) ( NXT, ) ( END-CODE ) 0 CONSTANT 0 1 CONSTANT 1 -1 CONSTANT -1 2 CONSTANT 2 ( 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 HERE TDOES ! SWITCH, SI PUSH, SWITCH, SI POP, 3 #, SI ADD, BX PUSH, 3 #, AX ADD, AX BX MOV, ( addr of parm field) NXT, END-CODE ( compiler's EXIT ) COMPILER CODE EXIT HERE TEXIT ! SWITCH, SI POP, ( recover previous IP ) SWITCH, NXT, END-CODE FORTH HEX ( CS@ V@ V! LMOVE ) CODE CS@ ( - seg) BX PUSH, CS PUSH, BX POP, NXT, END-CODE CODE V! ( c attr addr -) AX POP, CX POP, CX AX OR, RAM @ 28 + ) DX MOV, ( B000 #, 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) ( B000 #, DX MOV,) RAM @ 28 + ) 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 LMOVE ( 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, ( AX ES MOV,) DX SI MOV, BX POP, DI DI SUB, 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 ( 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 ) NXT, END-CODE ( runtime NEXT - keeps only count on Rstk ) CODE next HERE TNEXT ! SWITCH, CX POP, CXNZ, IF, ( loop isn't finished ) CX DEC, CX PUSH, ( 0 [SI] SI MOV, ( stuff back-addr into IP) AX LODS, AX SI MOV, ( 18 clocks vs 19 for above ) SWITCH, NXT, ( restore SP & ILNEXT) THEN, 2 #, SI ADD, ( skip over back addr) SWITCH, NXT, END-CODE ( some target primitives ) 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 ) CODE DROP ( n -) BX POP, NXT, END-CODE 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 CODE + ( n n - n) AX POP, AX BX ADD, NXT, END-CODE ( some target primitives continued ) CODE - ( n n - n) BX AX MOV, BX POP, AX BX SUB, NXT, END-CODE CODE 0< DI BX CMP, DI BX MOV, 0<, IF, BX DEC, THEN, 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 ( some target primitives continued ) 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 0= ( n - f) DI BX CMP, DI BX MOV, ( zero) 0=, IF, BX DEC, THEN, NXT, END-CODE : NOT 0= ; CODE OVER ( n1 n2 - n1 n2 n1) AX POP, AX PUSH, BX PUSH, AX BX MOV, NXT, END-CODE CODE ! ( n a -) AX POP, AX 0 [BX] MOV, BX POP, NXT, END-CODE CODE @ ( a - n) 0 [BX] BX MOV, NXT, END-CODE EXIT ( < > = U< ) CODE < ( n n - f) AX POP, BX AX SUB, DI BX MOV, 0<, IF, BX DEC, THEN, NXT, END-CODE CODE > ( n n - f) AX POP, AX BX SUB, DI BX MOV, 0<, IF, BX DEC, THEN, NXT, END-CODE CODE = ( n n - f) AX POP, BX AX SUB, DI BX MOV, 0=, IF, BX DEC, THEN, NXT, END-CODE CODE U< ( n n - f) AX POP, BX AX SUB, DI BX MOV, U<, IF, BX DEC, THEN, NXT, END-CODE ( /MOD M/MOD */ * ) CODE /MOD ( u u - r q ) AX POP, DX DX SUB, BX DIV, ( unsigned div) DX PUSH, ( rem) AX BX MOV, ( quot) NXT, END-CODE CODE M/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 u3 - n) ( n1*n2 /u3) 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 ( / M* M/ MOD ) CODE / ( n u - q) AX POP, DX DX SUB, 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 u - q ) DX POP, AX POP, BX IDIV, AX BX MOV, NXT, END-CODE : MOD ( u u - r ) /MOD DROP ; ( 2/MOD +! C! C@ 2@ 2! ) CODE 2/MOD ( n - r q ) BX AX MOV, DX DX SUB, ( or the reverse?) 2 #, BX MOV, BX IDIV, ( signed div) DX PUSH, ( rem) AX BX MOV, ( quot) 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, CXNZ, IF, REP, ( BYTE) AL MOVS, THEN, BX POP, DX SI MOV, DI DI SUB, NXT, END-CODE CODE CMOVE> ( fr to # - ) STD, SI DX MOV, BX CX MOV, DI POP, SI POP, DS AX MOV, AX ES MOV, CXNZ, IF, CX DI ADD, CX SI ADD, DI DEC, SI DEC, REP, ( BYTE) AL MOVS, THEN, BX POP, DX SI MOV, CLD, DI DI SUB, NXT, END-CODE ( be interesting to see what break even is w/ WORDS vs BYTES) CODE FILL ( addr # value -) CLD, CX POP, ( #) DI POP, DS AX MOV, AX ES MOV, BX AX MOV, CXNZ, IF, REP, AL STOS, THEN, BX POP, DI DI SUB, NXT, END-CODE ( PUSH POP DUP ?DUP 2DUP 2DROP 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 DUP ( n - n n) BX PUSH, NXT, END-CODE CODE ?DUP ( n - n n) DI BX CMP, 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 CODE I ( - n) ( same as R@) BX PUSH, 0 [BP] BX MOV, NXT, END-CODE ( WITHIN ABS MIN MAX EXECUTE ) CODE WITHIN ( n l h - f) ( true if l-h is U< than n-l ) AX POP, AX BX SUB, ( h-l is in BX) DX POP, AX DX SUB, ( n-l is in DX) BX DX CMP, DI BX MOV, U<, IF, BX DEC, THEN, NXT, END-CODE CODE ABS ( n - u) DI BX CMP, 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 ( RAM allocation - all RAM for now ) RAM @ CONSTANT PREV ( last referenced buffer) RAM @ 2 + CONSTANT OLDEST ( Oldest loaded buffer ) RAM @ 4 + ARRAY BUFFERS ( Block in each buffer ) 2 1 - CONSTANT NB ( Number of buffers ) RAM @ 8 + CONSTANT TIB RAM @ 0A + CONSTANT SPAN RAM @ 0C + CONSTANT >IN RAM @ 0E + CONSTANT BLK RAM @ 10 + CONSTANT dA RAM @ 12 + CONSTANT SCR RAM @ 14 + CONSTANT ATTR RAM @ 16 + CONSTANT CUR RAM @ 18 + CONSTANT CURSOR RAM @ 1A + CONSTANT BASE RAM @ 1C + CONSTANT H ( allow room for 4 vocabs ) RAM @ 26 + CONSTANT CONTEXT RAM @ 28 + CONSTANT VID RAM @ 2A + CONSTANT CRTC ( for 6845) HEX ( EMIT ) CODE (EMIT) ( c-) BX AX MOV, RAM @ 16 + ( CUR) ) DI MOV, SI PUSH, DS PUSH, ( save 'em) RAM @ 28 + ( VID) ) 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) 0720 #, AX MOV, 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, 0720 #, AX MOV, AX 0 [DI] MOV, ( continued on next screen ) HEX ( EMIT continued ) ELSE, AH AH SUB, CS: RAM @ 14 + ( ATTR) ) AX OR, 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, 0720 #, AX MOV, REP, AX STOS, 0A0 #, DI SUB, THEN, CX POP, CX DS MOV, DI RAM @ 16 + ( CUR) ) MOV, CS: RAM @ 2A + ( CRTC) ) DX MOV, ( 03B4 #, 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, DI DI SUB, 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 ( -) AX AX SUB, 21 #, INT, END-CODE CODE DOS ( DX CX BX AX - AX carry) BX AX MOV, BX POP, CX POP, DX POP, 21 #, INT, AX PUSH, DI BX MOV, U<, IF, BX DEC, THEN, 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, DI BX MOV, U<, IF, BX DEC, THEN, NXT, END-CODE ( also for int 21 ) ( ?SCROLL (CR (KEY ) HEX : ?SCROLL ( -) KEY? IF KEY 1B = IF 0 ( QUIT) THEN BEGIN KEY? UNTIL KEY 1B = IF 0 ( QUIT) THEN THEN ; : (CR) ( -) 0D EMIT 0A EMIT ; ' (KEY) IS KEY ' (KEY?) IS KEY? ' (CR) IS CR ( TYPE SPACE SPACES HOLD ) HEX : TYPE ( a -a) DUP C@ ?DUP IF 1- FOR 1+ DUP C@ EMIT NEXT THEN 1+ ; : SPACE 20 EMIT ; ( : SPACES ( n) ( 0 MAX FOR -ZERO SPACE THEN NEXT ; ) ( *?*) : SPACES ( n) 0 MAX ?DUP IF 1- FOR SPACE NEXT THEN ; ( old ) : HOLD ( ..# x n - ..# x) SWAP PUSH SWAP 1+ POP ; ( EXIT EXPECT ) HEX : EXIT POP DROP ; ( this for interp.; code ver for compiler) : EXPECT ( A # -) 0 SPAN ! 1- FOR KEY DUP 8 = IF ( bs) SPAN @ IF -1 SPAN +! SWAP 1- SWAP 2 ELSE 1 THEN POP + PUSH EMIT ( the bs) ELSE DUP D = IF ( cr) DROP DROP SPACE POP DROP ( drop FOR count) EXIT ELSE ( not bs or cr) DUP EMIT OVER C! 1+ ( put in buffer) ( a) 1 SPAN +! THEN THEN NEXT DROP ; ( Numbers ) : DIGIT ( n -n) DUP 9 > 7 AND + 48 + ; : <# ( n - ..# n) -1 SWAP ; : #> ( ..# n) DROP FOR EMIT NEXT ; : SIGN ( ..# n n - ..# n) 0< IF 45 HOLD THEN ; : # ( ..# n - ..# N) BASE @ /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 - 1- SPACES #> ; : U.R ( u n) PUSH <# #S OVER POP SWAP - 1- SPACES #> ; : U. ( u) 0 U.R SPACE ; : DUMP ( a - a) CR DUP 5 U.R SPACE 1 FOR 7 FOR DUP C@ 3 U.R 1+ NEXT SPACE NEXT SPACE 16 - 1 FOR 7 FOR DUP C@ DUP 32 127 WITHIN NOT IF DROP 46 THEN EMIT 1+ NEXT SPACE NEXT ; : DU ( a n - a) FOR DUMP ?SCROLL NEXT ; ( HERE abort" dot" ) HEX : HERE ( - a) H @ ; : abort" HERE TYPE SPACE POP ( 7FFF AND) TYPE 2DROP BLK @ ?DUP DROP 0 ( QUIT) ; ( *** must plug in QUIT ***) ' abort" TABORT ! : dot" POP TYPE PUSH ; ' dot" TDOT ! ( buffer manager ) : ADDRESS ( n - a) 61440 SWAP FOR 1024 + NEXT ; ( lowest buffer is at 61440+1024 = 62464 only 2 allowed) : ABSENT ( n - n) NB FOR DUP I BUFFERS @ XOR 2* WHILE NEXT EXIT THEN POP DUP PREV ! POP DROP SWAP DROP ADDRESS ; : UPDATED ( - a n) OLDEST @ BEGIN 1 + NB AND ( cheap MOD) DUP PREV @ XOR UNTIL DUP OLDEST ! DUP PREV ! 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 @ DUP PREV ! BUFFERS ! ; : IDENTIFY ( n a - a) SWAP PREV @ BUFFERS ! ; ( allow multiple block files open at same time ) TMAX-FILES CONSTANT MAX-FILES VARIABLE #FILES ( files actually in use) VARIABLE OFFSET VARIABLE FILES TMAX-FILES 6 * 2 - ALLOT ( each entry is 6 bytes - handle - 2bytes) ( starting block number - 2bytes) ( address of name - 2bytes) : >FCB ( n - a) 6 * FILES + ; HEX ( Disk read/write set up for terminal ) VARIABLE H# ( holds file handle) VARIABLE F# ( file #) VARIABLE #BLKS ( holds size of file in blocks, set by OPEN??) : HANDLE ( global-blk# - file-blk#) ( & set H# & F#) #FILES @ 1- FOR DUP I >FCB 2 + @ < WHILE NEXT ABORT" handle" THEN POP DUP F# ! >FCB DUP @ H# ! 2 + @ - ; : .FILE ( n -) >FCB 4 + @ TYPE DROP ; : >F ( dbl-offset -) ( set file ptr) H# @ 4200 DOS IF ABORT" >F error" THEN DROP ; : buffer ( n - a) UPDATED 7FFF AND HANDLE 400 M* >F DUP 400 H# @ 4000 DOS IF ABORT" buffer error" THEN DROP ; : BUFFER ( n - a) OFFSET @ + buffer ESTABLISH ; : block ( n a - n a) OVER HANDLE 400 M* >F DUP 400 H# @ 3F00 DOS IF ABORT" block error" THEN DROP ( actual # read) ; : BLOCK ( n - a) OFFSET @ + ABSENT buffer block ESTABLISH ; ( Disk read/write FLUSH EMPTY-BUFFERS COPY ) HEX : FLUSH NB FOR 2000 BUFFER DROP NEXT ; : EMPTY-BUFFERS PREV [ ' NB 2 + @ 3 + 2* ] LITERAL 0 FILL FLUSH ; : COPY ( n1 n2 -) BUFFER UPDATE SWAP BLOCK SWAP 400 CMOVE ; ( PARSE this is the heart of WORD written in code ) HEX CODE PARSE ( delim. source # destin. - source' actual# ) SI DX MOV, ( save IP) BX DI MOV, CX POP, SI POP, BX POP, DI PUSH, ( for later calculation of # chars moved to HERE) CXNZ, IF, DS AX MOV, AX ES MOV, 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, DI PUSH, 20 #, AX MOV, AL STOS, ( put in a blank) BX POP, AX POP, AX BX SUB, ( count of chars rec'd to TOS) SI PUSH, ( source') DX SI MOV, ( restore IP) DI DI SUB, NXT, END-CODE ( Interpreter SOURCE WORD ) : SOURCE ( - source remaining# ) >IN @ BLK @ IF BLK @ BLOCK + 1024 ELSE TIB @ + SPAN @ THEN >IN @ - ; : WORD ( delim - a) SOURCE ( delim source #) OVER PUSH ( save original source) HERE 1+ ( delim source # dest) PARSE ( source' word-len) HERE C! POP - >IN +! H @ ; ( HASH ) : HASH ( n - vocab-a) CONTEXT SWAP - ; HEX ( -FIND ) CODE -FIND ( h n - h true | pfa false) SI DX MOV, ( save IP) RAM @ 26 + #, DI MOV, ( CONTEXT ) 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, DI DI SUB, NXT, END-CODE ( Number input ) HEX : -DIGIT ( n - n) 30 - DUP 9 > IF 7 - DUP A < OR THEN DUP BASE @ U< IF EXIT THEN 2DROP ABORT" ?" ; ( RECOVER) : 10*+ ( u a n - u a) ( multiplies number by BASE & adds digit) -DIGIT ROT BASE @ * + SWAP ; : NUMBER ( a - n) DUP C@ ( a #) SWAP ( # a) 1+ DUP C@ 2D = DUP PUSH IF SWAP 1- SWAP 1+ THEN 0 ( # a 0 ) SWAP ROT ( 0 a #) 1- FOR ( u a ) DUP C@ ( u a n) 10*+ ( u a) 1+ NEXT DROP POP IF NEGATE THEN ; ( ** I have changed stack effects for 10*+ to allow addr to be) ( ** left on stack as this Forth does not have reg 6 ) ( ** to keep the incrementing addr in - so NUMBER is diff also) ( Control ) : -' ( n - h t | a f) 32 WORD SWAP -FIND ; : ' ( - a) CONTEXT @ -' IF DROP ABORT" ?" THEN ; ( forget) : INTERPRET ( n n ) ( blk# offset) >IN 2! ( >IN ! BLK !) BEGIN 2 -' ( search FORTH) IF NUMBER ELSE EXECUTE THEN AGAIN ; ( RECOVER) : QUIT SP! RP! ['] (EMIT) ['] EMIT 1+ ! BEGIN CR TIB @ 80 EXPECT 0 0 INTERPRET ." ok" AGAIN ; ( RECOVER) ' QUIT dA@- DUP DUP ' abort" 23 + ! ' ?SCROLL 21 + ! ' ?SCROLL 41 + ! ( Initialize ) FORTH : reset ( -) 0 ( save room for RESET to be patched in) CR ." PYGMY v1.1 " ." (type 601 EDIT for help)" CR ." hi" QUIT ; ' reset dA@- ' BOOT 7 + ! ( OCTAL DECIMAL HEX LOAD THRU ) : OCTAL 8 BASE ! ; : DECIMAL 10 BASE ! ; : HEX 16 BASE ! ; : LOAD ( n -) >IN 2@ PUSH PUSH 0 INTERPRET 10 BASE ! POP POP >IN 2! ; : THRU ( n1 n2 -) OVER - FOR DUP LOAD 1+ NEXT DROP ; ( CLEAR LIST ) : LIST ( n -) DUP SCR ! DUP CR ." scr " . BLOCK SPACE F# @ .FILE 15 FOR CR 63 FOR DUP C@ EMIT 1+ 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 ( 7FFF AND) DUP @ , 2 + PUSH ; COMPILER : LITERAL ( n - ) COMPILE lit , ; : [ 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 ! ( call to parent) ; COMPILER : ['] COMPILE lit ; : DOES> COMPILE does E8 C, 0 , ( call next instr sets stk) E9 C, ['] dodoes HERE 2 + - , ; : RECURSIVE PREVIOUS 0DF AND SWAP C! ; : ; \ RECURSIVE POP DROP COMPILE \ EXIT ; ( forget) FORTH HEX ( Defining words CREATE : CONSTANT VARIABLE ) FORTH : CREATE H @ 0 , ( lf) 20 WORD CONTEXT @ 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 + - , ; : : CREATE -2 ALLOT lit docol HERE 2 + - , SMUDGE ] ; ( : CONSTANT ( n) ( CREATE -2 ALLOT lit docon HERE 2 + - , , ;) : 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 ( -) ABORT" no vector " ; : DEFER ( -) CREATE -3 ALLOT B8 C, lit CRASH , E0FF , ; : IS ( a-) ' 1+ ! ; ( WORDS .S debugger ON OFF .ID STRING F" ) : WORDS CR CONTEXT @ HASH BEGIN @ DUP WHILE DUP 2 + TYPE DROP 2 SPACES ?SCROLL REPEAT DROP ; : .S ROT DUP U. ROT DUP U. ROT DUP U. ; ( 3 items, cheap) : ? @ . ; : ON -1 SWAP ! ; : OFF 0 SWAP ! ; : NFA ( pfa - nfa) BEGIN 1- DUP C@ 127 AND 32 < UNTIL ; : .ID ( pfa -) NFA TYPE DROP ; : STRING ( delim -) WORD C@ 1+ ALLOT ; : FORGET ( -) 2 CONTEXT ! ( we can't forget in COMPILER) ' NFA 2 - DUP @ 2 HASH ! DUP 4 HASH @ > IF H ! THEN ; EXIT COMPILER : END \ RECURSIVE COMPILE \ EXIT ; : REMEMBER; CONTEXT 4 - 2@ , , \ END ; FORTH : FORGET ( ) POP DUP 4 + H ! 2@ CONTEXT 4 - 2! 2 CONTEXT ! ; HEX ( Disk read/write F" <OPEN> OPEN <CLOSE> CLOSE ) : F" ( starting-blk# -) OFFSET @ + ( abs.starting.blk#) #FILES @ >FCB ( # a) 20 WORD ( # a h) DUP C@ 1+ ALLOT 0 C, OVER 4 + ! ( # a) 2 + ! 1 #FILES +! ; : <OPEN> ( n -) ( relative file number 0-9) >FCB ( a) DUP 4 + @ 1+ ( eg name) 0 0 3D02 DOS ( a handle err) IF ." OPEN err " 2DROP ELSE SWAP ! THEN ; : OPEN ( starting-blk# -) F" #FILES @ 1- <OPEN> ; : <CLOSE> ( -) H# @ ?DUP IF 0 0 ROT 3E00 DOS IF ." CLOSE err" THEN DROP THEN ; : CLOSE ( n -) >FCB @ H# ! <CLOSE> ; : CLOSE-FILES ( -) #FILES @ ?DUP IF 1- FOR I CLOSE NEXT THEN ; HEX ( Disk read/write RESET-FILES OPEN-FILES UNIT .FILES ) : .FILES ( -) #FILES @ ?DUP IF CR ." UNIT OFFSET FILE" 1- 0 >FCB OVER ( orig# fcb #) FOR CR OVER I - 4 .R DUP 2 + @ OFFSET @ - 8 .R 2 SPACES DUP 4 + @ TYPE DROP 6 + NEXT 2DROP SPACE THEN ; : RESET-FILES ( -) CLOSE-FILES FILES [ TMAX-FILES 6 * ] LITERAL 0 FILL #FILES OFF ; : OPEN-FILES ( -) #FILES @ ?DUP IF 1- FOR I <OPEN> NEXT THEN ; : UNIT ( n -) >FCB 2 + @ OFFSET ! ; ( SAVEM & SAVE for .COM files or memory images) HEX : MAKE ( name - handle) 1+ 0 0 3C00 DOS IF ABORT" MAKE error" THEN ; : SAVEM ( fr to -) ( follow with file name) H# @ ( ie curr-hdl) 20 WORD DUP C@ OVER + 1+ 0 SWAP C! MAKE ( fr to hdl1 hdl2) H# ! ROT ROT OVER - 1+ ( fr len ) H# @ ( hdl1 fr len hdl2) 4000 DOS IF ABORT" SAVE err" THEN DROP ( hdl1 ) <CLOSE> H# ! ( restore curr file) ; : SAVE ( -) ( follow w/ file name) 100 HERE 1- SAVEM ; ( Structures ) COMPILER : \ 4 -' IF ABORT" ?" THEN ,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 ; : NEXT ( h -) COMPILE next ,A ; ( Strings ) HEX FORTH 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 ) FORTH : ( \ ( ; ( forget ) HEX ( RESET and patch null ) : RESET F300 TIB ! >IN OFF dA OFF 0A BASE ! 0F00 CUR ! 0700 ATTR ! EMPTY-BUFFERS 2 CONTEXT ! OPEN-FILES OFFSET OFF ; ( FORGET ; RECOVER ( ** must be last word) ' RESET dA@- ' reset 3 + ! ( patch reset ) ( patch null 0000 00e9 docol POP DROP ; ) ' $ 2 - DUP 2 - OFF E900 OVER ! 2 + ' docol OVER 2 + - OVER ! ( rel br) 2 + ' POP dA@- OVER ! 2 + ' DROP dA@- OVER ! 2 + COMPILER ' EXIT dA@- SWAP ! FORTH CONTEXT 6 - DUP @ dA@- RAM @ 26 + ( CONTEXT) dA@- 2 - ! 2 - @ dA@- RAM @ 26 + ( CONTEXT) dA@- 4 - ! HERE dA@- RAM @ 1C + ( H) dA@- ! B000 RAM @ 28 + dA@- ! ( set up VID for a monochrome display) 03B4 RAM @ 2A + dA@- ! ( use B800 & 03D4 for a color display) } ( to host ) ( this screen sets up the default files ) ( RESET-FILES ) ( ** this block assumes the 1st two) ( 0 OPEN PYGMY.SCR ) ( lines have been done from keybd ) 300 OPEN ASM.SCR 600 OPEN HELP 900 OPEN GLOSSARY 1200 OPEN SUPPL.SCR 1500 OPEN ED.DOC 1800 OPEN STARTING.FTH 2100 OPEN ASM.DOC 2400 OPEN META.DOC 2700 OPEN TECH.DOC ( load screen for the editor ) ( 81 90 THRU ) 81 89 THRU 91 LOAD 90 LOAD ( shorter "case" ) SAVE I2.COM HEX ( INS UPDT XIN CLS L ) VARIABLE INS ( insert or overwrite flag) VARIABLE XIN VARIABLE #CUTS VARIABLE TILL ( search thru this scr) : CLS ( -) 20 0700 0 V! VID @ 0 OVER 2 81F LMOVE 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 ! ; : L ( -) 160 CUR ! SCR @ ( 0 MAX #BLKS @ MIN ( scr#) DUP SCR ! BLOCK DUP CURSOR ! .H 63 FOR 45 EMIT NEXT CR 15 FOR 63 FOR DUP C@ EMIT 1+ NEXT ." |" CR NEXT DROP ( ) 63 FOR 45 EMIT NEXT ; 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 /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 1- FOR DUP C@ EMIT 1+ 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 ; ( 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 ( ) I 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- DUP #CUTS ! 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) 1023 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 " SPAN @ S$ 64 EXPECT SPAN @ SLEN ! SPAN ! ." ok " SRCH ; : TILL# ( -) 3360 DUP CUR ! 80 SPACES CUR ! >IN OFF ." search thru screen # " TIB @ 6 EXPECT 32 WORD NUMBER TILL ! ; : SRCHX ( -) BEGIN -SRCH SCR @ TILL @ < AND WHILE 1 SCR +! XIN OFF L REPEAT ; ( 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 IF DUP NEGATE XIN +! CK-CUR XIN @ SET-CUR 1- FOR DELETE NEXT THEN UPDATE R$ RLEN @ 1- FOR DUP C@ INSERT 1+ NEXT DROP L THEN ; : SETR$ ( -) 3202 CUR ! 80 SPACES 3202 CUR ! ." enter replace string " SPAN @ R$ 64 EXPECT SPAN @ RLEN ! SPAN ! ." ok " REPL ; ( PgUp PgDn ) : PgUp ( -) ( UPDT @ IF UPDATE THEN) SCR @ 1- 0 MAX SCR ! INS OFF L XIN OFF ( UPDT OFF) ; : PgDn ( -) ( UPDT @ IF UPDATE THEN) 1 SCR +! INS OFF L XIN OFF ( UPDT 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 ! ; : NOP ; ( CASE for use with the editor ) : 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 SWAP DROP 2 + @ EXECUTE ; ( n for default must be 00 and the default pair must be last.) ( numbers can be in 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) ( SPCL ) CASE: SPCL ( -) 82 ( Ins) -INS 83 ( Del) DELETE 59 ( F1) SRCH 60 ( F2) REPL 61 ( F3) SET$ 62 ( F4) SETR$ 63 ( F5) DEL-LN 64 ( F6) JOIN 65 ( F7) CUT 66 ( F8) UNCUT 73 PgUp 81 PgDn 77 Rt 75 Lt 72 Up 80 Dn 71 Home 79 End 67 ( F9) TILL# 68 ( F10) SRCHX 00 NOP ; ( ED ) : ED ( -) DECIMAL XIN OFF INS OFF ( UPDT 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 IF DUP 32 127 WITHIN IF ( reg key) INS @ IF INSERT ELSE S! THEN ELSE DROP THEN ELSE KEY SPCL THEN THEN THEN REPEAT DROP 3040 CUR ! ; : EDIT ( n -) SCR ! ED ; ( SPCL ) : ', ( -) ' , ; VARIABLE SPCL' -2 ALLOT 77 C, ', Rt 75 C, ', Lt 72 C, ', Up 80 C, ', Dn 71 C, ', Home 79 C, ', End 73 C, ', PgUp 81 C, ', PgDn 82 ( Ins) C, ', -INS 83 ( Del) C, ', DELETE 59 ( F1) C, ', SRCH 60 ( F2) C, ', REPL 61 ( F3) C, ', SET$ 62 ( F4) C, ', SETR$ 63 ( F5) C, ', DEL-LN 64 ( F6) C, ', JOIN 65 ( F7) C, ', CUT 66 ( F8) C, ', UNCUT 67 ( F9) C, ', TILL# 68 ( F10) C, ', SRCHX : SPCL ( n -) SPCL' 19 FOR 2DUP C@ - WHILE 3 + NEXT 2DROP ELSE SWAP POP 2DROP ( a) 1+ @ EXECUTE THEN ;
