📄 pygmy.scr
字号:
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 ⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -