( Command History Editor for forth environment ) ( started from Frank Sargent's Pygmy Forth17 ) ( 20100511-1353 EXPECT EXPERIMENTS ) 2001 2050 THRU EXIT ( this is the original definition ) : D.EXPECT ( a # -) SWAP ( #rem a) OVER PUSH ( #rem a) ( R:#) BEGIN OVER ( # a - # a # ) ( while chars remaining ) WHILE ( # a) KEY DUP $0D - ( while not CR ) WHILE ( # a key) DUP 8 = ( its a backspace ) IF DROP ( # a) OVER R@ < IF ( # a) 1- 32 OVER C! ( # a) 1 +UNDER 8 EMIT SPACE 8 EMIT THEN ELSE ( # a key) DUP EMIT OVER C! ( # a) -1 +UNDER 1+ THEN REPEAT DROP SPACE THEN ( # a) DROP POP SWAP - SPAN ! ; EXIT ( use QUERY to get input ready for WORD to work on ) EXIT : test ." MUPLIPLE while then " ; ( FORGET test ) : TEST ." type a number " BEGIN 19 10 AT KEY DUP . DUP 27 - WHILE ( escape ) DUP 65 - WHILE ( space ) DUP 66 - WHILE ( A ) DUP 67 - WHILE ( B ) DUP 68 - WHILE ( C ) DUP 69 - WHILE ( D ) 21 22 AT ." CHARACTER WAS ... " EMIT REPEAT THEN THEN THEN THEN THEN ." LEAVING TEST .... " .S ; : .BASE BASE @ DUP 10 = IF ." decimal " ELSE DUP 16 = IF ." hex " ELSE DUP 2 = IF ." binary " ELSE DUP ." not B-D-H " 2 BASE ! . THEN THEN THEN DROP ; : ROT-TEST 1 PUSH 2 PUSH 3 PUSH 99 137 5 ( DEST SOURCE COUNT ) BEGIN DUP WHILE CR .S ROT 2 - DUP . ROT 2 + DUP . ROT 1- DUP . REPEAT DROP DROP DROP POP POP POP .S ; EXIT ( CX=0607H UNDERLINE CURSOR CX=0007H BLOCK CURSOR ) CODE UCURSOR ( -) $01 #, AH MOV, $0607 #, CX MOV, $10 #, INT, NXT, END-CODE CODE BCURSOR ( -) $01 #, AH MOV, $0007 #, CX MOV, $10 #, INT, NXT, END-CODE ( ORIGINAL DIAGNOSTIC FOR CMD LINE EDIT ) ( 32 ) 256 CONSTANT TEST-BUF-SIZE CREATE TEST-BUF TEST-BUF-SIZE ALLOT ( testing edit buffer ) : DU-TEST-BUF TEST-BUF 16 - TEST-BUF-SIZE 16 16 + + 16 / DU ; : INIT-TEST-BUF TEST-BUF-SIZE FOR 65 I + TEST-BUF I + C! NEXT ; : .PAD CR ." PAD=" PAD DUP HEX . DECIMAL . PAD TEST-BUF-SIZE 16 / DU ; : .T ( CR ) DU-TEST-BUF .PAD ; : T.T CLS .T INIT-TEST-BUF CR .T ; : .TAT 5 0 AT .T ; : TEXT? 32 127 WITHIN ; : LTEST 7 FOR ( BEGIN ) ?SCROLL ( DUP WHILE 1- ) CR ( DUP . ." IF 1- ELSE DROP @MaxChars 1- THEN ; ( LEN of text at pointer ) VARIABLE WLEN : @WLEN WLEN @ ; : !WLEN WLEN ! ; : +WLEN 1 WLEN +! ; : -WLEN -1 WLEN +! ; VARIABLE RLEN : @RLEN RLEN @ ; : !RLEN RLEN ! ; : +RLEN 1 RLEN +! ; : -RLEN -1 RLEN +! ; : INC-WPTR ( - ) @WPTR INC-PTR !WPTR ( +WLEN ) ; : INC-RPTR ( - ) @RPTR INC-PTR !RPTR ( -RLEN ) ; : DEC-WPTR ( - ) @WPTR DEC-PTR !WPTR ( -WLEN ) ; : DEC-RPTR ( - ) @RPTR DEC-PTR !RPTR ( +RLEN ) ; : .PTR ." RPTR>" @RPTR . ." RLEN=" @RLEN . ." WPTR>" @WPTR . ." WLEN=" @WLEN . ; ( : .PTR ; ( removes diagnostic ) : @WPTR$ ( - $W ) @$Ebuffer @WPTR + ; : !WPTR-CHAR ( char - ) @WPTR$ C! ; : @RPTR$ ( - $Ebuffer ) @$Ebuffer @RPTR + ; : @RPTR-CHAR ( -char) @RPTR$ C@ ; VARIABLE CharsToGo : @CharsToGo CharsToGo @ ; : !CharsToGo CharsToGo ! ; : -CharsToGo @CharsToGo 1- !CharsToGo ; : +CharsToGo @CharsToGo 1+ !CharsToGo ; : NotMax? ( # - # t|f ) @CharsToGo @MaxChars < ; : SET-PTRS @WPTR !RPTR 0 !WLEN 0 !RLEN ; ( LEFT ARROW ) : LeftArrow @WLEN 0 > IF DEC-WPTR -WLEN +CharsToGo ( CUR@ 1- AT ) 8 EMIT ELSE 7 EMIT THEN ; : Home BEGIN @WLEN WHILE DEC-WPTR -WLEN +CharsToGo ( CUR@ 1- AT ) 8 EMIT ?SCROLL REPEAT ; ( right arrow ) : RightArrow @WPTR$ C@ 32 127 WITHIN IF @WPTR$ C@ EMIT INC-WPTR +WLEN -CharsToGo ELSE 7 EMIT THEN ; : End BEGIN @WPTR$ C@ 32 127 WITHIN WHILE @CharsToGo WHILE @WPTR$ C@ EMIT INC-WPTR +WLEN -CharsToGo ?SCROLL REPEAT THEN ; ( SCREEN ) VARIABLE SCREEN-ROW : !SCREEN-ROW SCREEN-ROW ! ; : @SCREEN-ROW SCREEN-ROW @ ; VARIABLE SCREEN-COL : !SCREEN-COL SCREEN-COL ! ; : @SCREEN-COL SCREEN-COL @ ; : cursor-save CUR@ !SCREEN-COL !SCREEN-ROW ; : cursor-restore @SCREEN-ROW @SCREEN-COL AT ; : SC cursor-save ; : RC cursor-restore ; ( might be off by 1 if full buffer ) : backspaces FOR 8 EMIT NEXT ; : (BS) ( CUR@ 1- AT SC ) 8 EMIT @WPTR !RPTR @CharsToGo !RLEN DEC-WPTR -WLEN +CharsToGo 0 BEGIN @RLEN 0 > WHILE -RLEN ( 0 is seed for bs ) ( 1000 MS 7 EMIT CR .S ) @RPTR-CHAR DUP DEC-RPTR @RPTR$ C! INC-RPTR DUP 13 - IF DUP EMIT 1 +UNDER ( CR .S 1000 MS ) THEN 13 - WHILE @RLEN 0 > IF INC-RPTR ELSE 2 @RPTR$ C! THEN REPEAT THEN 1 EMIT 1+ backspaces ( RC ) ; : DoBackSpace @WLEN 0 > IF (BS) ELSE 7 EMIT THEN ; : (DEL) ( CUR@ 1- AT ) SC @WPTR !RPTR @CharsToGo !RLEN BEGIN @RLEN 0 > WHILE INC-RPTR -RLEN ( next char ) @RPTR-CHAR DUP DEC-RPTR @RPTR$ C! ( move it ) DUP 13 - IF EMIT ELSE DROP THEN ( don't display cr ) @RPTR$ C@ 32 127 WITHIN WHILE ( ptr at text ) @RLEN 0 > IF INC-RPTR ELSE 2 @RPTR$ C! THEN ?SCROLL REPEAT THEN 1 EMIT RC ; : DEL @WLEN 0 > IF (DEL) ELSE 7 EMIT THEN ; ( Ins / Ovr insert and overwrite ) ( VARIABLE INSERT ) : INSERT? XIN @ ; 0 XIN ! BCURSOR : INS XIN DUP @ 0= DUP IF UCURSOR ELSE BCURSOR THEN SWAP ! ; : COPY-PREV-CHAR @RPTR$ DEC-RPTR @RPTR-CHAR SWAP C! ; : FIND-END ( tail of oldest input ) @CharsToGo 1- !RLEN INC-RPTR BEGIN ?SCROLL @RLEN WHILE @RPTR-CHAR 32 127 WITHIN WHILE ( skip to delimiter ) -RLEN INC-RPTR REPEAT THEN ( DEC-RPTR ( back up one ) ; : SLIDE-RIGHT ( slide each char right once position ) BEGIN @RPTR @WPTR = NOT WHILE ?SCROLL COPY-PREV-CHAR REPEAT ; : (insert) FIND-END SLIDE-RIGHT ; : DoRegularKeys ( - ) .Ekey ( move the char at wptr out of the way ) INSERT? IF (insert) THEN ( otherwise just overwrite like it does now ) @Ekey !WPTR-CHAR INC-WPTR +WLEN ) -CharsToGo ; ( UP Arrow ) : .DDD CUR@ 0 11 AT .PTR .S AT ( KEY DROP ) ; ( use ins to step ) ( : .DDD ; ( removes diagnostic ) : FIND-CR-L ( find cr or wrap to starting loc ) @MaxChars ( this would stop at start, now goes 1 extra ) BEGIN DUP WHILE 1- @RPTR$ C@ 13 = NOT WHILE ( nothing yet ) .DDD DEC-RPTR REPEAT THEN DROP 7 EMIT ; ( UP ARROW ) : FIND-PREV FIND-CR-L INC-RPTR ; : PREV>BUFFER @RPTR PUSH @WPTR PUSH CUR@ PUSH PUSH @MaxChars ( 1- ) BEGIN DUP WHILE 1- @RPTR-CHAR 32 127 WITHIN WHILE @RPTR-CHAR EMIT @RPTR-CHAR !WPTR-CHAR INC-RPTR INC-WPTR REPEAT THEN DROP ( MaxChar ) POP POP AT POP !WPTR POP !RPTR ; ( IS STACK ERROR DROP AFTER REPEAT? ) ( UP ARROW ) : UpArrow ( - ) ( start anyplace in INput line ) FIND-CR-L DEC-RPTR ( CUR@ 2 2 AT .PTR 7 SPACES .TAT AT ) FIND-PREV ( CUR@ 3 2 AT .PTR 7 SPACES .TAT AT ) PREV>BUFFER ( CUR@ 4 2 AT .PTR 7 SPACES .TAT AT ) ; ( DOWN ARROW ) : FIND-CR-R ( find cr or wrap to starting loc ) @MaxChars 1- ( this would stop at start, now goes 1 extra ) BEGIN DUP WHILE 1- @RPTR$ C@ 13 = NOT WHILE ( nothing yet ) .DDD INC-RPTR REPEAT THEN DROP 7 EMIT ; : FIND-NEXT FIND-CR-R INC-RPTR ; : DownArrow ( - ) ( start anyplace in INput line ) FIND-CR-R INC-RPTR ( CUR@ 2 2 AT .PTR 7 SPACES .TAT AT ) PREV>BUFFER ( CUR@ 4 2 AT .PTR 7 SPACES .TAT AT ) ; ( here forward works already ) : CCC CUR@ 18 65 AT .S AT .S ; : DoHome ( ." home " ) Home ; : DoLeft ( ." left " ) LeftArrow ; : DoEnd ( ." end " ) End ; : DoIns ( ." ins " ) INS ; : DoUp ( ." up " ) UpArrow ( UU ) ; : DoK5 ( ." K5 " ) KEYPAD5 ; : DoDown ( ." down " ) DownArrow ; : DoDel ( ." del " ) DEL ; : DoPgUp ( ." PgUp " ) PGUP ; : DoRight ( ." right " ) RightArrow ; : DoPgDn ( ." PgDn " ) PGDN ; : RegularKey? @Ekey DUP 32 127 WITHIN SWAP 13 = OR ; : DoESC .S 1 ABORT" ESCAPING " ; ( DoEditKeys from SPCL editor block 113 ) : ', ( -) ' , ; CREATE DoEditKeys' 199 C, ', DoHome 200 C, ', DoUp 201 C, ', DoPgUp 203 C, ', DoLeft 204 C, ', DoK5 205 C, ', DoRight 207 C, ', DoEnd 208 C, ', DoDown 209 C, ', DoPgDn 210 C, ', DoIns 211 C, ', DoDel 8 C, ', DoBackSpace 27 C, ', DoESC : DoEditKeys ( [Ekey] - ) ( CUR@ 18 65 AT ) @Ekey DoEditKeys' ( 22 ) 13 FOR 2DUP C@ - WHILE 3 + NEXT 2DROP ELSE SWAP POP 2DROP ( a) 1+ @ EXECUTE THEN ( AT ) ; EXIT ( do more keys later? change 12 to 13 ) : DMOVE @WLEN FOR @RPTR-CHAR PAD @WLEN I 1+ - + C! INC-RPTR ( .PAD ) NEXT PAD TIB @ @WLEN CMOVE ; : D.EXPECT ( a #max - #remaining ) DUP !MaxChars !CharsToGo !$Ebuffer SET-PTRS BEGIN ( while char-buffer locs remain ) @CharsToGo WHILE GetEkey ( not-CR? WHILE ) RegularKey? IF DoRegularKeys ELSE DoEditKeys THEN not-CR? WHILE ( saves CR in the buffer, CR ends loop ) REPEAT SPACE THEN @CharsToGo @MaxChars SWAP - 1- SPAN ! .S DMOVE .S ; ( DIAGNOTICS ) : DU.TEST-BUF TEST-BUF TEST-BUF-SIZE 16 / DU CR .S ; : setup TEST-BUF-SIZE . ." CHARS MAX " TEST-BUF TEST-BUF-SIZE .S DUP !CharsToGo !MaxChars !$Ebuffer .S GetEkey ; : SETUP setup SET-PTRS ; : TEST4 TEST-BUF-SIZE . ." CHARS MAX " CUR@ 16 SPACES ." <====" AT TEST-BUF TEST-BUF-SIZE D.EXPECT ; : S.T ( 17 1 ) 24 0 AT ( L ) .T CR .PTR .S ; : TTT TEST4 S.T ; EXIT : FFF CR ." FOR NEXT " 7 FOR I . NEXT ; : BBB CR ." BEGIN WHILE REPEAT " 0 BEGIN DUP 7 < WHILE DUP . 1+ REPEAT DROP ; : DDD CR ." BEGIN WHILE REPEAT " 7 BEGIN DUP 0 > WHILE DUP . 1- REPEAT DROP ; EXIT 0 BEGIN DUP @Max < WHILE DUP . 1+ REPEAT !LEN ; ( D.Intrepreter ) : D.INTERPRET ( blk# offset -) >IN 2! BEGIN 2 -' ( search FORTH) IF NUMBER ELSE EXECUTE THEN AGAIN ; ( RECOVER ) : D.QUERY ( -) ( TIB @ 255 ) TEST-BUF TEST-BUF-SIZE D.EXPECT SPAN @ #TIB ! 0 0 >IN 2! ; : (D.QUIT R0 @ RP! RESET-TIB ( CR ) BEGIN CR D.QUERY 0 0 ( blk offset) D.INTERPRET ." d.ok" AGAIN ; ( RECOVER ) EXIT 20100617 ' (D.QUIT IS QUIT ( figure out what RECOVER does and why it is here )