/prods/Cognitive/p4th/history.fth

https://github.com/createuniverses/praxis · Forth · 513 lines · 434 code · 79 blank · 0 comment · 8 complexity · 84a73a2c33da2a77977d084b7b066946 MD5 · raw file

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