git.gag.com Git - debian/pforth/blob - fth/history.fth

   1 \ Command Line History
   2 \
   3 \ Author: Phil Burk
   4 \ Copyright 1988 Phil Burk
   5 \ Revised 2001 for pForth
   6
   7 0 [IF]
   8
   9 Requires an ANSI compatible terminal.
  10
  11 To get Windows computers to use ANSI mode in their DOS windows,
  12 Add this line to "C:\CONFIG.SYS" then reboot.
  13
  14   device=c:\windows\command\ansi.sys
  15
  16 When command line history is on, you can use the UP and DOWN arrow to scroll
  17 through previous commands. Use the LEFT and RIGHT arrows to edit within a line.
  18    CONTROL-A moves to beginning of line.
  19    CONTROL-E moves to end of line.
  20    CONTROL-X erases entire line.
  21
  22
  23 HISTORY#       ( -- , dump history buffer with numbers)
  24 HISTORY        ( -- , dump history buffer )
  25 XX             ( line# -- , execute line x of history )
  26 HISTORY.RESET  ( -- , clear history tables )
  27 HISTORY.ON     ( -- , install history vectors )
  28 HISTORY.OFF    ( -- , uninstall history vectors )
  29
  30 [THEN]
  31
  32 include? ESC[ termio.fth
  33
  34 ANEW TASK-HISTORY.FTH
  35 decimal
  36
  37 private{
  38
  39 \ You can expand the history buffer by increasing this constant!!!!!!!!!!
  40 2048 constant KH_HISTORY_SIZE
  41
  42 create KH-HISTORY kh_history_size allot
  43 KH-HISTORY kh_history_size erase
  44
  45 \ An entry in the history buffer consists of
  46 \   byte  - Count byte = N,
  47 \   chars - N chars,
  48 \   short -  line number in Big Endian format,
  49 \   byte  - another Count byte = N, for reverse scan
  50 \
  51 \ The most recent entry is put at the beginning,
  52 \ older entries are shifted up.
  53
  54 4 constant KH_LINE_EXTRA_SIZE ( 2 count bytes plus 2 size bytes )
  55
  56 : KH-END ( -- addr , end of history buffer )
  57     kh-history kh_history_size +
  58 ;
  59
  60 : LINENUM@ ( addr -- w , stores in BigEndian format )
  61     dup c@ 8 shift
  62     swap 1+ c@ or
  63 ;
  64
  65 : LINENUM! ( w addr -- )
  66     over -8 shift over c!
  67     1+ c!
  68 ;
  69
  70 variable KH-LOOK      ( cursor offset into history, point to 1st count byte of line )
  71 variable KH-MAX
  72 variable KH-COUNTER       ( 16 bit counter for line # )
  73 variable KH-SPAN          ( total number of characters in line )
  74 variable KH-MATCH-SPAN    ( span for matching on shift-up )
  75 variable KH-CURSOR        ( points to next insertion point )
  76 variable KH-ADDRESS       ( address to store chars )
  77 variable KH-INSIDE        ( true if we are scrolling inside the history buffer )
  78
  79 : KH.MAKE.ROOM ( N -- , make room for N more bytes at beginning)
  80     >r  ( save N )
  81     kh-history dup r@ + ( source dest )
  82     kh_history_size r> - 0 max move
  83 ;
  84
  85 : KH.NEWEST.LINE  ( -- addr count , most recent line )
  86     kh-history count
  87 ;
  88
  89 : KH.REWIND ( -- , move cursor to most recent line )
  90     0 kh-look !
  91 ;
  92
  93 : KH.CURRENT.ADDR ( -- $addr , count byte of current line )
  94     kh-look @ kh-history +
  95 ;
  96
  97 : KH.CURRENT.LINE ( -- addr count )
  98     kh.current.addr count
  99 ;
 100
 101 : KH.COMPARE ( addr count -- flag , true if redundant )
 102     kh.newest.line compare 0=   \ note: ANSI COMPARE is different than JForth days
 103 ;
 104
 105 : KH.NUM.ADDR ( -- addr , address of current line's line count )
 106     kh.current.line +
 107 ;
 108
 109 : KH.CURRENT.NUM ( -- # , number of current line )
 110     kh.num.addr LINENUM@
 111 ;
 112
 113 : KH.ADDR++  ( $addr -- $addr' , convert one kh to previous )
 114     count + 3 +
 115 ;
 116 : KH.ADDR--  ( $addr -- $addr' , convert one kh to next )
 117     dup 1- c@   \ get next lines endcount
 118     4 +  \ account for lineNum and two count bytes
 119     -       \ calc previous address
 120 ;
 121
 122 : KH.ENDCOUNT.ADDR ( -- addr , address of current end count )
 123     kh.num.addr 2+
 124 ;
 125
 126 : KH.ADD.LINE ( addr count -- )
 127     dup 256 >
 128     IF ." KH.ADD.LINE - Too big for history!" 2drop
 129     ELSE   ( add to end )
 130 \ Compare with most recent line.
 131         2dup kh.compare
 132         IF 2drop
 133         ELSE
 134             >r ( save count )
 135 \ Set look pointer to point to first count byte of last string.
 136             0 kh-look !
 137 \ Make room for this line of text and line header.
 138 \ PLB20100823 Was cell+ which broke on 64-bit code.
 139             r@ KH_LINE_EXTRA_SIZE + kh.make.room
 140 \ Set count bytes at beginning and end.
 141             r@ kh-history c!  ( start count )
 142             r@ kh.endcount.addr c!
 143             kh-counter @ kh.num.addr LINENUM!  ( line )
 144 \ Number lines modulo 1024
 145             kh-counter @ 1+ $ 3FF and kh-counter !
 146             kh-history 1+   ( calc destination )
 147             r> cmove  ( copy chars into space )
 148         THEN
 149     THEN
 150 ;
 151
 152 : KH.BACKUP.LINE  { | cantmove addr' -- cantmove , advance KH-LOOK if in bounds }
 153     true -> cantmove ( default flag, at end of history )
 154 \ KH-LOOK points to count at start of current line
 155     kh.current.addr c@       \ do we have any lines?
 156     IF
 157         kh.current.addr kh.addr++ -> addr'
 158         addr' kh-end U<      \ within bounds?
 159         IF
 160             addr' c@     \ older line has chars?
 161             IF
 162                 addr' kh-history - kh-look !
 163                 false -> cantmove
 164             THEN
 165         THEN
 166     THEN
 167     cantmove
 168 ;
 169
 170 : KH.FORWARD.LINE ( -- cantmove? )
 171     kh-look @ 0= dup not
 172     IF  kh.current.addr kh.addr--
 173     kh-history - kh-look !
 174     THEN
 175 ;
 176
 177 : KH.OLDEST.LINE   ( -- addr count | 0, oldest in buffer )
 178     BEGIN kh.backup.line
 179     UNTIL
 180     kh.current.line dup 0=
 181     IF
 182         nip
 183     THEN
 184 ;
 185
 186 : KH.FIND.LINE ( line# -- $addr )
 187     kh.rewind
 188     BEGIN kh.current.num over -
 189     WHILE kh.backup.line
 190         IF ." Line not in History Buffer!" cr drop 0 exit
 191         THEN
 192     REPEAT
 193     drop kh.current.addr
 194 ;
 195
 196
 197 : KH-BUFFER ( -- buffer )
 198     kh-address @
 199 ;
 200
 201 : KH.RETURN ( -- , move to beginning of line )
 202     0 out !
 203     13 emit
 204 ;
 205
 206 : KH.REPLACE.LINE  ( addr count -- , make this the current line of input )
 207     kh.return
 208     tio.erase.eol
 209     dup kh-span !
 210     dup kh-cursor !
 211     2dup kh-buffer swap cmove
 212     type
 213 ;
 214
 215 : KH.GET.MATCH ( -- , search for line with same start )
 216     kh-match-span @ 0=  ( keep length for multiple matches )
 217     IF kh-span @ kh-match-span !
 218     THEN
 219     BEGIN
 220         kh.backup.line not
 221     WHILE
 222         kh.current.line drop
 223         kh-buffer kh-match-span @ text=
 224         IF kh.current.line kh.replace.line
 225            exit
 226         THEN
 227     REPEAT
 228 ;
 229
 230 : KH.FAR.RIGHT
 231     kh-span @ kh-cursor @ - dup 0>
 232     IF
 233         tio.forwards
 234         kh-span @ kh-cursor !
 235     ELSE drop
 236     THEN
 237 ;
 238
 239 : KH.FAR.LEFT ( -- )
 240     kh.return
 241     kh-cursor off
 242 ;
 243
 244 : KH.GET.OLDER ( -- , goto previous line )
 245     kh-inside @
 246     IF kh.backup.line drop
 247     THEN
 248     kh.current.line kh.replace.line
 249     kh-inside on
 250 ;
 251
 252 : KH.GET.NEWER ( -- , next line )
 253     kh.forward.line
 254     IF
 255         kh-inside off
 256         tib 0
 257     ELSE  kh.current.line
 258     THEN
 259     kh.replace.line
 260 ;
 261
 262 : KH.CLEAR.LINE ( -- , rewind history scrolling and clear line )
 263     kh.rewind
 264     tib 0 kh.replace.line
 265     kh-inside off
 266 ;
 267
 268 : KH.GO.RIGHT  ( -- )
 269     kh-cursor @ kh-span @ <
 270     IF 1 kh-cursor +!
 271        1 tio.forwards
 272     THEN
 273 ;
 274
 275 : KH.GO.LEFT ( -- )
 276     kh-cursor @ ?dup
 277     IF 1- kh-cursor !
 278        1 tio.backwards
 279     THEN
 280 ;
 281
 282 : KH.REFRESH  ( -- , redraw current line as is )
 283     kh.return
 284     kh-buffer kh-span @ type
 285     tio.erase.eol
 286
 287     kh.return
 288     kh-cursor @ ?dup
 289     IF tio.forwards
 290     THEN
 291
 292     kh-span @ out !
 293 ;
 294
 295 : KH.BACKSPACE ( -- , backspace character from buffer and screen )
 296     kh-cursor @ ?dup  ( past 0? )
 297     IF  kh-span @ <
 298         IF  ( inside line )
 299             kh-buffer kh-cursor @ +  ( -- source )
 300             dup 1- ( -- source dest )
 301             kh-span @ kh-cursor @ - cmove
 302 \            ." Deleted!" cr
 303         ELSE
 304             backspace
 305         THEN
 306         -1 kh-span +!
 307         -1 kh-cursor +!
 308     ELSE bell
 309     THEN
 310     kh.refresh
 311 ;
 312
 313 : KH.DELETE ( -- , forward delete )
 314     kh-cursor @ kh-span @ <  ( before end )
 315     IF  ( inside line )
 316         kh-buffer kh-cursor @ + 1+ ( -- source )
 317         dup 1- ( -- source dest )
 318         kh-span @ kh-cursor @ - 0 max cmove
 319         -1 kh-span +!
 320         kh.refresh
 321     THEN
 322 ;
 323
 324 : KH.HANDLE.WINDOWS.KEY ( char -- , handle fkeys or arrows used by Windows ANSI.SYS )
 325     CASE
 326         $ 8D OF kh.get.match    ENDOF
 327             0 kh-match-span ! ( reset if any other key )
 328         $ 48 OF kh.get.older    ENDOF
 329         $ 50 OF kh.get.newer  ENDOF
 330         $ 4D OF kh.go.right ENDOF
 331         $ 4B OF kh.go.left  ENDOF
 332         $ 91 OF kh.clear.line  ENDOF
 333         $ 74 OF kh.far.right ENDOF
 334         $ 73 OF kh.far.left  ENDOF
 335         $ 53 OF kh.delete  ENDOF
 336     ENDCASE
 337 ;
 338
 339 : KH.HANDLE.ANSI.KEY ( char -- , handle fkeys or arrows used by ANSI terminal )
 340     CASE
 341         $ 41 OF kh.get.older    ENDOF
 342         $ 42 OF kh.get.newer  ENDOF
 343         $ 43 OF kh.go.right ENDOF
 344         $ 44 OF kh.go.left  ENDOF
 345     ENDCASE
 346 ;
 347
 348
 349 : KH.SPECIAL.KEY ( char  -- true | false , handle fkeys or arrows, true if handled )
 350     true >r
 351     CASE
 352
 353     $ E0 OF key kh.handle.windows.key
 354     ENDOF
 355
 356     ASCII_ESCAPE OF
 357         key dup $ 4F = \ for TELNET
 358         $ 5B = OR \ for regular ANSI terminals
 359         IF
 360             key kh.handle.ansi.key
 361         ELSE
 362             rdrop false >r
 363         THEN
 364     ENDOF
 365
 366         ASCII_BACKSPACE OF kh.backspace ENDOF
 367         ASCII_DELETE    OF kh.backspace ENDOF
 368         ASCII_CTRL_X    OF kh.clear.line ENDOF
 369         ASCII_CTRL_A    OF kh.far.left ENDOF
 370         ASCII_CTRL_E    OF kh.far.right ENDOF
 371
 372     rdrop false >r
 373
 374     ENDCASE
 375     r>
 376 ;
 377
 378 : KH.SMART.KEY ( -- char )
 379     BEGIN
 380         key dup kh.special.key
 381     WHILE
 382         drop
 383     REPEAT
 384 ;
 385
 386 : KH.INSCHAR  { charc | repaint -- }
 387     false -> repaint
 388     kh-cursor @ kh-span @ <
 389     IF
 390 \ Move characters up
 391         kh-buffer kh-cursor @ +  ( -- source )
 392         dup 1+ ( -- source dest )
 393         kh-span @ kh-cursor @ - cmove>
 394         true -> repaint
 395     THEN
 396 \ write character to buffer
 397     charc kh-buffer kh-cursor @ + c!
 398     1 kh-cursor +!
 399     1 kh-span +!
 400     repaint
 401     IF kh.refresh
 402     ELSE charc emit
 403     THEN
 404 ;
 405
 406 : EOL? ( char -- flag , true if an end of line character )
 407     dup 13 =
 408     swap 10 = OR
 409 ;
 410
 411 : KH.GETLINE ( max -- )
 412     kh-max !
 413     kh-span off
 414     kh-cursor off
 415     kh-inside off
 416     kh.rewind
 417     0 kh-match-span !
 418     BEGIN
 419         kh-max @ kh-span @ >
 420         IF  kh.smart.key
 421             dup EOL? not  ( <cr?> )
 422         ELSE 0 false
 423         THEN  ( -- char flag )
 424     WHILE ( -- char )
 425         kh.inschar
 426     REPEAT drop
 427     kh-span @ kh-cursor @ - ?dup
 428     IF tio.forwards  ( move to end of line )
 429     THEN
 430     space
 431     flushemit
 432 ;
 433
 434 : KH.ACCEPT ( addr max -- numChars )
 435     swap kh-address !
 436     kh.getline
 437     kh-span @ 0>
 438     IF kh-buffer kh-span @ kh.add.line
 439     THEN
 440     kh-span @
 441 ;
 442
 443 : TEST.HISTORY
 444     4 0 DO
 445         pad 128 kh.accept
 446         cr pad swap type cr
 447     LOOP
 448 ;
 449
 450 }private
 451
 452
 453 : HISTORY# ( -- , dump history buffer with numbers)
 454     cr kh.oldest.line ?dup
 455     IF
 456         BEGIN kh.current.num 3 .r ." ) " type ?pause cr
 457             kh.forward.line 0=
 458         WHILE kh.current.line
 459         REPEAT
 460     THEN
 461 ;
 462
 463 : HISTORY ( -- , dump history buffer )
 464     cr kh.oldest.line ?dup
 465     IF
 466         BEGIN type ?pause cr
 467             kh.forward.line 0=
 468         WHILE kh.current.line
 469         REPEAT
 470     THEN
 471 ;
 472
 473 : XX  ( line# -- , execute line x of history )
 474     kh.find.line ?dup
 475     IF count evaluate
 476     THEN
 477 ;
 478
 479
 480 : HISTORY.RESET  ( -- , clear history tables )
 481     kh-history kh_history_size erase
 482     kh-counter off
 483 ;
 484
 485 : HISTORY.ON ( -- , install history vectors )
 486     history.reset
 487     what's accept ['] (accept) =
 488     IF ['] kh.accept is accept
 489     THEN
 490 ;
 491
 492 : HISTORY.OFF ( -- , uninstall history vectors )
 493     what's accept ['] kh.accept =
 494     IF ['] (accept) is accept
 495     THEN
 496 ;
 497
 498
 499 : AUTO.INIT
 500     auto.init
 501     history.on
 502 ;
 503 : AUTO.TERM
 504     history.off
 505     auto.term
 506 ;
 507
 508 if.forgotten history.off
 509
 510 0 [IF]
 511 history.reset
 512 history.on
 513 [THEN]