Return to history.fs CVS log

Up to [gforth] / gforth

Removed BUGS, tried to clean up.

    1: \ History file support                                 16oct94py
    2: 
    3: 0 Value history
    4: 
    5: 2Variable forward^
    6: 2Variable backward^
    7: 2Variable end^
    8: 
    9: : force-open ( addr len -- handle )
   10:   2dup r/w open-file 0<
   11:   IF  drop r/w create-file throw  ELSE  nip nip  THEN ;
   12: 
   13: : get-history ( addr len -- wid )
   14:   force-open to history
   15:   history file-size throw
   16:   2dup forward^ 2! 2dup backward^ 2! end^ 2! ;
   17: 
   18: s" ~/.gforth-history" get-history
   19: 
   20: : history-cold
   21:     Defers 'cold
   22:     s" ~/.gforth-history" get-history ;
   23: 
   24: ' history-cold IS 'cold
   25: 
   26: \ moving in history file                               16oct94py
   27: 
   28: : clear-line ( max span addr pos1 -- max addr )
   29:   backspaces over spaces swap backspaces ;
   30: 
   31: : clear-tib ( max span addr pos -- max 0 addr 0 false )
   32:   clear-line 0 tuck dup ;
   33: 
   34: : hist-pos    ( -- ud )  history file-position throw ;
   35: : hist-setpos ( ud -- )  history reposition-file throw ;
   36: 
   37: : get-line ( addr len -- len' flag )
   38:   swap history read-line throw ;
   39: 
   40: : next-line  ( max span addr pos1 -- max span addr pos2 false )
   41:   clear-line
   42:   forward^ 2@ 2dup hist-setpos backward^ 2!
   43:   2dup get-line drop
   44:   hist-pos  forward^ 2!
   45:   tuck 2dup type 0 ;
   46: 
   47: : prev-line  ( max span addr pos1 -- max span addr pos2 false )
   48:   clear-line  backward^ 2@ forward^ 2!
   49:   over 2 + negate s>d backward^ 2@ d+ 0. dmax 2dup hist-setpos
   50:   BEGIN
   51:       backward^ 2!   2dup get-line  WHILE
   52:       hist-pos 2dup forward^ 2@ d<  WHILE
   53:       rot drop
   54:   REPEAT  2drop  THEN
   55:   tuck 2dup type 0 ;
   56: 
   57: : ctrl  ( "<char>" -- ctrl-code )
   58:   char [char] @ - postpone Literal ; immediate
   59: 
   60: Create lfpad #lf c,
   61: 
   62: : (enter)  ( max span addr pos1 -- max span addr pos2 true )
   63:   >r end^ 2@ hist-setpos
   64:   2dup swap history write-line throw
   65:   hist-pos 2dup backward^ 2! end^ 2!
   66:   r> (ret) ;
   67: 
   68: \ some other key commands                              16oct94py
   69: 
   70: : first-pos  ( max span addr pos1 -- max span addr 0 0 )
   71:   backspaces 0 0 ;
   72: : end-pos  ( max span addr pos1 -- max span addr span 0 )
   73:   type-rest 2drop over 0 ;
   74: 
   75: : extract-word ( addr len -- addr' len' )  dup >r
   76:   BEGIN  1- dup 0>=  WHILE  2dup + c@ bl =  UNTIL  THEN  1+
   77:   tuck + r> rot - ;
   78: 
   79: Create prefix-found  0 , 0 ,
   80: 
   81: : word-lex ( nfa1 nfa2 -- -1/0/1 )
   82:   dup 0=  IF  2drop 1  EXIT  THEN
   83:   cell+ >r cell+ count $1F and
   84:   dup r@ c@ $1F and =
   85:   IF  r> char+ capscomp 0<=  EXIT  THEN
   86:   nip r> c@ $1F and < ;
   87: 
   88: : search-voc ( addr len nfa1 nfa2 -- addr len nfa3 ) >r
   89:     BEGIN  dup  WHILE  >r dup r@ cell+ c@ $1F and <=
   90: 	IF  2dup r@ cell+ char+ capscomp  0=
   91: 	    IF  r> dup r@ word-lex
   92: 		IF  dup prefix-found @ word-lex
   93: 		    0>= IF  rdrop dup >r  THEN
   94: 		THEN >r
   95: 	    THEN
   96: 	THEN  r> @
   97:     REPEAT drop r> ;
   98: 
   99: : prefix-string ( addr len nfa -- addr' len' )
  100:     dup prefix-found !  ?dup
  101:     IF  cell+ count $1F and rot /string rot drop
  102: 	dup 1+ prefix-found cell+ !
  103:     ELSE
  104: 	2drop s" " prefix-found cell+ off
  105:     THEN ;
  106: 
  107: : search-prefix  ( addr1 len1 -- addr2 len2 )
  108:     0 vp dup @ 1- cells over +
  109:     DO  I 2@ <>
  110:         IF  I cell+ @ @ swap  search-voc  THEN
  111: 	[ -1 cells ] Literal +LOOP
  112:     prefix-string ;
  113: 
  114: : kill-expand ( max span addr pos1 -- max span addr pos2 )
  115:     prefix-found cell+ @  0 ?DO  (del)  LOOP ;
  116: 
  117: : tib-full? ( max span addr pos addr' len' -- max span addr pos addr1 u flag )
  118:     5 pick over 4 pick + prefix-found @ 0<> - < ;
  119: 
  120: : tab-expand ( max span addr pos1 -- max span addr pos2 0 )
  121:     kill-expand  2dup extract-word search-prefix
  122:     tib-full?
  123:     IF    7 emit  2drop  0 0 prefix-found 2!
  124:     ELSE  bounds ?DO  I c@ (ins)  LOOP  THEN
  125:     prefix-found @ IF  bl (ins)  THEN  0 ;
  126: 
  127: : kill-prefix  ( key -- key )
  128:   dup #tab <> IF  0 0 prefix-found 2!  THEN ;
  129: 
  130: ' kill-prefix IS everychar
  131: 
  132: ' next-line  ctrl N cells ctrlkeys + !
  133: ' prev-line  ctrl P cells ctrlkeys + !
  134: ' clear-tib  ctrl K cells ctrlkeys + !
  135: ' first-pos  ctrl A cells ctrlkeys + !
  136: ' end-pos    ctrl E cells ctrlkeys + !
  137: ' (enter)    #lf    cells ctrlkeys + !
  138: ' (enter)    #cr    cells ctrlkeys + !
  139: ' tab-expand #tab   cells ctrlkeys + !