home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / ledit.seq < prev    next >
Text File  |  1989-07-11  |  17KB  |  421 lines
  1. \ LEDIT.SEQ     Line Editor Utility                     by Tom Zimmer
  2.  
  3. comment:
  4.  
  5.   Here is a relatively simple editor for editing one line strings.
  6.  
  7.   Support is provided for strings up to 126 characters in length, with
  8. full word and character operations using keypad or WordStar keys as follows:
  9.  
  10.         Ctrl-A                  Left word
  11.         Ctrl-S                  Left character
  12.         Ctrl-D                  Right character
  13.         Ctrl-F                  Right word
  14.         Ctrl-G                  Forward delete
  15.         Ctrl-T                  Word delete
  16.         Ctrl-Y                  Line delete or clear
  17.         Left arrow              Left character
  18.         Ctrl-Left arrow         Left word
  19.         Right arrow             Right character
  20.         Ctrl-Right arrow        Right word
  21.         Home                    Beginning of line
  22.         End                     End of line
  23.         ESC                     Discard changes and leave
  24.         Return/Enter            Save changes and leave
  25.  
  26.   The parameters needed by LINEEDIT are as follows:
  27.  
  28.         lineeditor    ( x y a1 n1 --- )
  29.  
  30.                 x = char pos on row,    zero = left edge
  31.                 y = row number,         zero = top line
  32.                 a1 = counted string
  33.                 n1 = edit limit length, maximum value = 80
  34.  
  35.   Here is an example of a command that would edit a line of text in
  36. SAMPLEBUFFER, with a maximum length of 12 characters, at location
  37. row 10 column 5 on the screen.
  38.  
  39.                 5 10 samplebuffer 12 lineedit
  40.  
  41.   Two auto resetting flags can be used to control the behavior of the
  42. line editor in special ways.
  43.  
  44.         The STRIPING_BL'S boolean "VALUE" determines whether the line
  45.         editor will strip trailing blanks from an edited string at
  46.         the completion of the edit. this VALUE defaults to TRUE, do
  47.         strip trailing blanks.
  48.  
  49.                 OFF> STRIPPING_BL'S     will prevent line edit from
  50.                                         stripping spaces.
  51.  
  52.         The AUTOCLEAR boolean "VALUE" determines whether the line
  53.         edit buffer will be automatically cleared if the first
  54.         character you enter on starting an edit is a normal text
  55.         char. This is used to ease the users life in the situation
  56.         where you want to give them the option of re-using a string
  57.         or easily entering a new one without having to delete the old
  58.         string first. This VALUE defaults to FALSE, no autoclear.
  59.  
  60.                 ON> AUTOCLEAR           will cause line edit to
  61.                                         automatically clear the edit
  62.                                         string if a letter if the
  63.                                         first thing entered.
  64.  
  65. comment;
  66.  
  67. only forth also hidden definitions also
  68.  
  69. headerless
  70.  
  71.       variable saveflg                  \ are we saving the results
  72.  
  73. headers
  74.  
  75.     0    value ?ldone                   \ is line edit done?
  76.     0    value lchar                    \ recent line edit character
  77.     0    value ex                       \ where we are editing X
  78.     0    value ey                       \ where we are editing Y
  79.     0    value ecursor                  \ edit cursor position
  80.     0    value lenlimit                 \ line edit length limit
  81.       variable insertmode               \ insert/overwrite mode flag
  82.  
  83. true     value stripping_bl's           \ are we stripping trailing blanks?
  84. false    value autoclear                \ automatically clear line if first
  85.                                         \ type entered is a letter;
  86.  
  87. defer ledbutton ' noop     is ledbutton
  88. defer >edattrib ' >attrib3 is >edattrib \ trailing edit attribute is 3
  89.  
  90. 132 constant maxedit
  91.     variable editbuf maxedit 2+ allot           \ our edit buffer,
  92.              editbuf off                        \ 132 characters max
  93.  
  94. : .ecursor      ( --- )                         \ show the cursor
  95.                 ex ecursor + COLS 1- min ey at ;
  96.  
  97. : .eline        ( --- )                         \ redisplay edit line
  98.                 ex ey at
  99.                 editbuf count type
  100.                 save> attrib >edattrib
  101.                 lenlimit editbuf c@ - 0MAX
  102.                 COLS 1- #out @ - 0MAX min spaces
  103.                 restore> attrib ;
  104.  
  105. headerless
  106.  
  107. : <doldel>      ( --- )                         \ Line delete
  108.                 0 editbuf c!
  109.                 off> ecursor ;
  110.  
  111. : <ichar>       ( c1 --- )
  112.                 autoclear               \ should we clear the line on the
  113.                 if      <doldel>        \ first character typed?
  114.                         off> autoclear
  115.                 then
  116.                 insertmode @
  117.                 if      editbuf 1+ ecursor + dup 1+
  118.                         maxedit ecursor - cmove>
  119.                         editbuf c@ 1+ lenlimit min editbuf c!
  120.                 then
  121.                 editbuf 1+ ecursor + c!
  122.                 ecursor 1+ lenlimit min COLS 1- min =: ecursor
  123.                 ecursor editbuf c@ max editbuf c! ;
  124.  
  125. : ?char         ( --- )                 \ handle normal keys, insert them
  126.                 lchar   bl '~' between
  127.                 if      lchar <ichar>
  128.                 then    ;
  129.  
  130. headers
  131.  
  132. : dohome        ( --- )                         \ beginning of line
  133.                 off> ecursor ;
  134.  
  135. : doend         ( --- )                         \ End of line
  136.                 editbuf c@ =: ecursor ;
  137.  
  138. headerless
  139.  
  140. : doright       ( --- )                         \ right a character
  141.                 ecursor 1+ editbuf c@ min COLS 1- min =: ecursor ;
  142.  
  143. : doleft        ( --- )                         \ left a character
  144.                 ecursor 1- 0MAX =: ecursor ;
  145.  
  146. headers
  147.  
  148. : <edone>       ( --- )      \ flag edit is finished, save changes
  149.                 on> ?ldone
  150.                 saveflg on ;
  151.  
  152. : <equit>       ( false --- true )      \ flag edit is finished, discard chngs
  153.                 on> ?ldone
  154.                 saveflg off ;
  155.  
  156. defer doret     ' <edone> is doret
  157. defer dotab     ' <edone> is dotab
  158. defer edone     ' <edone> is edone
  159. defer equit     ' <equit> is equit
  160. defer dolf      ' noop is dolf
  161. defer dopgup    ' noop is dopgup
  162. defer dopgdn    ' noop is dopgdn
  163. defer doup      ' noop is doup
  164. defer dodown    ' noop is dodown
  165. defer doldel    ' <doldel> is doldel
  166.  
  167. headerless
  168.  
  169. : dofdel        ( --- )                         \ Forward delete
  170.                 ecursor 1+ editbuf c@ max editbuf c!
  171.                 editbuf 1+ ecursor + dup 1+ swap maxedit ecursor - cmove
  172.                 -1 editbuf c+! ;
  173.  
  174. : >to=bl        ( --- )                         \ forward to a blank
  175.                 editbuf 1+ dup maxedit + swap ecursor +
  176.                 ?do     i c@ bl = ?leave
  177.                         1 +!> ecursor
  178.                 loop    editbuf c@ ecursor min =: ecursor ;
  179.  
  180. : >to<>bl       ( --- )                         \ forward to a non blank
  181.                 editbuf 1+ dup maxedit + swap ecursor +
  182.                 ?do     i c@ bl <> ?leave
  183.                         1 +!> ecursor
  184.                 loop    editbuf c@ ecursor min =: ecursor ;
  185.  
  186. : dorword       ( --- )                         \ Forward to next word
  187.                 >to=bl
  188.                 >to<>bl ;
  189.  
  190. : <to=bl+1      ( --- )                         \ back to char following BL
  191.                 ecursor 1- 0MAX =: ecursor
  192.                 editbuf 1+ dup ecursor + 1- editbuf 1+ max
  193.                 ?do     i c@ bl = ?leave
  194.                         -1 +!> ecursor
  195.             -1 +loop    ;
  196.  
  197. : <to<>bl       ( --- )                         \ Back to non blank
  198.                 ecursor 1- 0MAX =: ecursor
  199.                 editbuf 1+ dup ecursor + 1- editbuf 1+ max
  200.                 ?do     i c@ bl <> ?leave
  201.                         -1 +!> ecursor
  202.                 loop    ;
  203.  
  204. : dolword       ( --- )                         \ back a word
  205.                 <to<>bl
  206.                 <to=bl+1 ;
  207.  
  208. : dobdel        ( --- )                         \ back delete
  209.                 ecursor editbuf c@ max editbuf c!
  210.                 ecursor         ( --- f1 )
  211.                 doleft
  212.     ( --- f1 )  if      insertmode @            \ if we are in insertmode
  213.                         if      dofdel          \ then delete the character
  214.                         else    bl editbuf 1+ ecursor + c!
  215.                                                 \ else change char to blank
  216.                         then
  217.                 else    beep
  218.                 then    ;
  219.  
  220. : dowdel        ( --- )                         \ word delete
  221.                 begin   ecursor editbuf c@ <
  222.                         editbuf 1+ ecursor + c@ bl <> and
  223.                 while   dofdel
  224.                 repeat
  225.                 begin   ecursor editbuf c@ <
  226.                         editbuf 1+ ecursor + c@ bl = and
  227.                 while   dofdel
  228.                 repeat  ;
  229.  
  230. : strip_bl's    ( --- )                         \ strip blanks from editbuf
  231.                 ecursor >r
  232.                 doend
  233.                 begin   doleft
  234.                         editbuf 1+ ecursor + c@ bl =
  235.                         ecursor 0<> and
  236.                 while   dofdel
  237.                 repeat  editbuf c@ r> min 0MAX =: ecursor
  238.                 editbuf @               \ get count and first char
  239.                 $2001 =                 \ count=1 & char=blank
  240.                 if      0 editbuf c!    \ then reset buffer to empty
  241.                 then    ;
  242.  
  243. : doins         ( --- )                         \ toggle insert mode
  244.                 insertmode @ 0= dup insertmode !
  245.                 if      big-cursor
  246.                 else    norm-cursor
  247.                 then    ;
  248.  
  249. : doany         ( --- )                         \ handle any character entry
  250.                 graphchar       ( -- <c1> f1 )
  251.                 if      <ichar>
  252.                 then    ;
  253.  
  254. : ?control      ( --- )                         \ handle control characters
  255.                 lchar   bl <
  256.                 if      off> autoclear          \ no auto clear now
  257.                         lchar exec:
  258. \                       0 null  1 a     2 b     3 c     4 d     5 e     6 f
  259.                         noop    dolword noop    dopgdn  doright doup  dorword
  260. \                       7 g     8 h     9 i     LF      11 k    12 l    Enter
  261.                         dofdel  dobdel  dotab   dolf    noop    noop    doret
  262. \                       14 n    15 o    16 p    17 q    18 r    19 s    20 t
  263.                         noop    noop    noop    noop    dopgup  doleft  dowdel
  264. \                       21 u    22 v    23 w    24 x    25 y    26 z    Esc
  265.                         noop    doins   noop    dodown  doldel  noop    equit
  266. \                       28 \    29 ]    30 ^    31 _
  267.                         noop    noop    noop    noop
  268.                 then    ;
  269.  
  270. headers
  271.  
  272. : funcarray     ( n1 | <name> --- )     \ create an X array initialized to
  273.                                         \ NOOP functions
  274.                 >r create
  275.                 xhere paragraph + dup xdpseg ! xseg @ - , xdp off
  276.                 r> 0
  277.                 ?do     ['] noop x,
  278.                 loop    does> @ +XSEG swap 2* @L execute ;
  279.  
  280. 128 funcarray keyfuncs1
  281. 128 funcarray keyfuncs2
  282.  
  283. ' keyfuncs1 value keysfuncptr           \ default to table1
  284.  
  285. : >keys1        ( --- )
  286.                 ['] keyfuncs1 is keysfuncptr ;
  287.  
  288. : >keys2        ( --- )
  289.                 ['] keyfuncs2 is keysfuncptr ;
  290.  
  291.                                         \ for keys in the range 128 to 255
  292. : lkey!         ( a1 n1 --- )           \ store key function CFA a1 into
  293.                                         \ leuvalue n1 of the KEYFUNCS array
  294.                 128 - dup 0< over 127 > or
  295.                 abort" keys must be in the range 128 to 255"
  296.                 2* keysfuncptr >body @ +XSEG swap !L ;
  297.  
  298. : lkey@         ( n1 --- a1 )           \ fetch the function CFA a1 of
  299.                                         \ keyvalue n1 from the KEYFUNCS array
  300.                 128 - dup 0< over 127 > or
  301.                 abort" keys must be in the range 128 to 255"
  302.                 2* keysfuncptr >body @ +XSEG swap @L ;
  303.  
  304. headerless
  305.  
  306. : ?func         ( --- )                         \ handle function keys
  307.                 lchar   127 >
  308.                 if      off> autoclear          \ no auto clear now
  309.                         lchar 128 - 0MAX 127 min keysfuncptr execute
  310.                 then    ;
  311.  
  312.                                                 \ c1 = keyboard character
  313.                                                 \ f1 = true for done editing
  314. : dokey         ( c1 --- )                      \ process a key
  315.                 =: lchar
  316.                 ?char                           \ handle normal ascii
  317.                 ?func                           \ function characters
  318.                 ?control ;                      \ control chars
  319.  
  320. headers
  321.                                                 \ x = char pos on row
  322.                                                 \ y = line number
  323.                                                 \ a1 = counted string
  324.                                                 \ n1 = edit limit length
  325. : <ledit>       ( x y a1 n1 --- )       \ Edit line currently in EDITBUF.
  326.                 ['] ledbutton save!> dobutton
  327.                 save> lenlimit
  328.                 get-cursor >r
  329.                 over c@ ecursor min =: ecursor
  330.                 maxedit min =: lenlimit         \ save max edit length
  331.                 dup >r                          \ save source address
  332.                 editbuf over c@ lenlimit min 1+ cmove
  333.                 editbuf c@ lenlimit min editbuf c!
  334.                 =: ey =: ex                     \ save origin
  335.                 doins   doins
  336.                 off> ?ldone
  337.                 begin   .eline
  338.                         .ecursor key dokey
  339.                         ?ldone
  340.                 until   saveflg @ dup           \ proper save exit
  341.                 if      stripping_bl's          \ do we want to strip blanks?
  342.                         if      strip_bl's
  343.                         then    on> stripping_bl's      \ force it next time
  344.                         editbuf r@ over c@ lenlimit min 1+ cmove
  345.                 then    r>drop
  346.                 r> set-cursor           ( --- f1 )
  347.                 restore> lenlimit
  348.                 restore> dobutton
  349.                 off> autoclear ;                \ no automatic line clear
  350.  
  351. forth definitions
  352.                                         \ x = char pos on row
  353.                                         \ y = line number
  354.                                         \ a1 = counted string
  355.                                         \ n1 = edit limit length
  356.                                         \ f1 = true for saved changes
  357.                                         \ f1 = false for canceled with ESC
  358. : lineeditor    ( x y a1 n1 --- f1 )    \ Edit line in a1
  359.                 ['] <equit> save!> equit
  360.                 off> ecursor
  361.                 insertmode off
  362.                 ['] noop save!> doLF
  363.                 save> keysfuncptr
  364.                 >keys2
  365.                 <ledit>
  366.                 restore> keysfuncptr
  367.                 restore> doLF
  368.                 restore> equit ;
  369.  
  370. \ ***************************************************************************
  371. \ Initialize the key arrays for the proper function keys
  372.  
  373. >keys1
  374.  
  375. ' doany   158 lkey!     \ Alt-A
  376. ' dohome  199 lkey!     \ Home
  377. ' doup    200 lkey!     \ Up arrow
  378. ' doPgUp  201 lkey!     \ PgDn
  379. ' doleft  203 lkey!     \ Left arrow
  380. ' doright 205 lkey!     \ Right arrow
  381. ' doend   207 lkey!     \ End
  382. ' dodown  208 lkey!     \ Down arrow
  383. ' doPgDn  209 lkey!     \ PgDn
  384. ' doins   210 lkey!     \ Ins
  385. ' dofdel  211 lkey!     \ Del
  386. ' dolword 243 lkey!     \ Ctrl Left arrow
  387. ' dorword 244 lkey!     \ Ctrl Right arrow
  388.  
  389. >keys2
  390.  
  391. ' doany   158 lkey!     \ Alt-A
  392. ' dohome  199 lkey!     \ Home
  393. ' doup    200 lkey!     \ Up arrow
  394. ' doPgUp  201 lkey!     \ PgDn
  395. ' doleft  203 lkey!     \ Left arrow
  396. ' doright 205 lkey!     \ Right arrow
  397. ' doend   207 lkey!     \ End
  398. ' dodown  208 lkey!     \ Down arrow
  399. ' doPgDn  209 lkey!     \ PgDn
  400. ' doins   210 lkey!     \ Ins
  401. ' dofdel  211 lkey!     \ Del
  402. ' dolword 243 lkey!     \ Ctrl Left arrow
  403. ' dorword 244 lkey!     \ Ctrl Right arrow
  404.  
  405. behead
  406.  
  407. only forth also definitions
  408.  
  409. \s
  410.  
  411. only forth also definitions hidden also
  412.  
  413. variable samplebuffer 128 allot
  414.  
  415. : sample        ( --- )
  416.                 " Zimmer, Harold" ">$
  417.                 samplebuffer over c@ 1+ cmove
  418.                 on> autoclear
  419.                 27 04 samplebuffer 24 lineeditor drop ;
  420.  
  421.