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 line_number 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 : KH.SPECIAL.KEY ( char  -- true | false , handle fkeys or arrows, true if handled )
 349     true >r
 350     CASE
 351
 352     $ E0 OF key kh.handle.windows.key
 353     ENDOF
 354
 355     ASCII_ESCAPE OF
 356         key dup $ 4F = \ for TELNET
 357         $ 5B = OR \ for regular ANSI terminals
 358         IF
 359             key kh.handle.ansi.key
 360         ELSE
 361             rdrop false >r
 362         THEN
 363     ENDOF
 364
 365         ASCII_BACKSPACE OF kh.backspace ENDOF
 366         ASCII_DELETE    OF kh.backspace ENDOF
 367         ASCII_CTRL_X    OF kh.clear.line ENDOF
 368         ASCII_CTRL_A    OF kh.far.left ENDOF
 369         ASCII_CTRL_E    OF kh.far.right ENDOF
 370
 371     rdrop false >r
 372
 373     ENDCASE
 374     r>
 375 ;
 376
 377 : KH.SMART.KEY ( -- char )
 378     BEGIN
 379         key dup kh.special.key
 380     WHILE
 381         drop
 382     REPEAT
 383 ;
 384
 385 : KH.INSCHAR  { charc | repaint -- }
 386     false -> repaint
 387     kh-cursor @ kh-span @ <
 388     IF
 389 \ Move characters up
 390         kh-buffer kh-cursor @ +  ( -- source )
 391         dup 1+ ( -- source dest )
 392         kh-span @ kh-cursor @ - cmove>
 393         true -> repaint
 394     THEN
 395 \ write character to buffer
 396     charc kh-buffer kh-cursor @ + c!
 397     1 kh-cursor +!
 398     1 kh-span +!
 399     repaint
 400     IF kh.refresh
 401     ELSE charc emit
 402     THEN
 403 ;
 404
 405 : EOL? ( char -- flag , true if an end of line character )
 406     dup 13 =
 407     swap 10 = OR
 408 ;
 409
 410 : KH.GETLINE ( max -- )
 411     kh-max !
 412     kh-span off
 413     kh-cursor off
 414     kh-inside off
 415     kh.rewind
 416     0 kh-match-span !
 417     BEGIN
 418         kh-max @ kh-span @ >
 419         IF  kh.smart.key
 420             dup EOL? not  ( <cr?> )
 421         ELSE 0 false
 422         THEN  ( -- char flag )
 423     WHILE ( -- char )
 424         kh.inschar
 425     REPEAT drop
 426     kh-span @ kh-cursor @ - ?dup
 427     IF tio.forwards  ( move to end of line )
 428     THEN
 429     space
 430     flushemit
 431 ;
 432
 433 : KH.ACCEPT ( addr max -- numChars )
 434     swap kh-address !
 435     kh.getline
 436     kh-span @ 0>
 437     IF kh-buffer kh-span @ kh.add.line
 438     THEN
 439     kh-span @
 440 ;
 441
 442 : TEST.HISTORY
 443     4 0 DO
 444         pad 128 kh.accept
 445         cr pad swap type cr
 446     LOOP
 447 ;
 448
 449 }private
 450
 451
 452 : HISTORY# ( -- , dump history buffer with numbers)
 453     cr kh.oldest.line ?dup
 454     IF
 455         BEGIN kh.current.num 3 .r ." ) " type ?pause cr
 456             kh.forward.line 0=
 457         WHILE kh.current.line
 458         REPEAT
 459     THEN
 460 ;
 461
 462 : HISTORY ( -- , dump history buffer )
 463     cr kh.oldest.line ?dup
 464     IF
 465         BEGIN type ?pause cr
 466             kh.forward.line 0=
 467         WHILE kh.current.line
 468         REPEAT
 469     THEN
 470 ;
 471
 472 : XX  ( line# -- , execute line x of history )
 473     kh.find.line ?dup
 474     IF count evaluate
 475     THEN
 476 ;
 477
 478
 479 : HISTORY.RESET  ( -- , clear history tables )
 480     kh-history kh_history_size erase
 481     kh-counter off
 482 ;
 483
 484 : HISTORY.ON ( -- , install history vectors )
 485     history.reset
 486     what's accept ['] (accept) =
 487     IF ['] kh.accept is accept
 488     THEN
 489 ;
 490
 491 : HISTORY.OFF ( -- , uninstall history vectors )
 492     what's accept ['] kh.accept =
 493     IF ['] (accept) is accept
 494     THEN
 495 ;
 496
 497 privatize
 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]