home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / sedit2.seq < prev    next >
Text File  |  1991-03-15  |  10KB  |  232 lines
  1. \ SEDIT2.SEQ    The second part of the main body of the sequential editor
  2.  
  3. editor definitions
  4.  
  5. 0 value ?showcmd
  6.  
  7. : ecmdtgl       ( -- )
  8.         savescr savecursor cursor-off
  9.         ?showcmd 0= dup =: ?showcmd
  10.         if      2 8
  11. .box"  The names of edit functions will be shown in the upper left corner. "
  12.                 2 seconds
  13.         else    24 8 .box"  Turning off show names "
  14.                 1 seconds
  15.         then    restcursor restscr ;
  16.  
  17. : notavail      ( --- )
  18.              window.left statusline at cursor-off
  19.              ." \2 You MUST Load an expanded function set for that operation."
  20.              edeeol beep 2 seconds cursor-on ;
  21.  
  22. defer sedesc    ' sesc     is sedesc
  23. defer jstfy     ' notavail is jstfy
  24. defer shelp     ' notavail is shelp
  25. defer exportx   ' notavail is exportx
  26. defer excutx    ' notavail is excutx
  27. defer importx   ' notavail is importx
  28. defer pmenux    ' notavail is pmenux
  29. defer kerr      ' beep is kerr
  30. defer sedset    ' notavail is sedset
  31. defer sortlin   ' notavail is sortlin
  32. defer drawlin   ' notavail is drawlin
  33. defer lftjust   ' notavail is lftjust
  34. defer appendx   ' notavail is appendx
  35. defer alt-g     ' notavail is alt-g
  36. defer adjwind   ' notavail is adjwind
  37. defer alt-o     ' notavail is alt-o
  38. defer insany    ' ^cc      is insany
  39. defer zoomwind  ' notavail is zoomwind
  40. defer Ctrl-J    ' beep is Ctrl-J
  41.  
  42.                 \ control key functiontable
  43. : s^tbl         ( n1 --- )
  44.                 exec:
  45. \ @     A       B       C       D       E       F       G
  46. kerr    lwrd    jstfy   pdn     rchr    upln    rwrd    fdel
  47. \ H     I       J       K       L       M       N       O
  48. bdel    stab    Ctrl-J  kerr    lmset   nln     spltln  kerr
  49. \ P     Q       R       S       T       U       V       W
  50. kerr    kerr    pup     lchr    wdel    updt    itgl    sclup
  51. \ X     Y       Z       ESC
  52. dnln    ldel    scldn   sedesc  kerr    kerr    kerr    kerr  ;
  53.  
  54.  
  55.                 \ function key table
  56. : sfuntbl       ( n1 --- )
  57.                 exec:
  58. \ CBS Control Backspace
  59. fdel
  60. \ A-9   A-0     A -     A =     CPGUP   133     134     135
  61. kerr    kerr    kerr    kerr    kerr    kerr    kerr    kerr
  62. \ 136   137     138     139     140     141     142     BACKSPACE
  63. kerr    kerr    kerr    kerr    kerr    kerr    kerr    sbtab
  64. \ A-Q   A-W     A-E     A-R     A-T     A-Y     A-U     A-I
  65. kerr    wr->fl  kerr    NOOP    tabset  lundel  wudel   kerr
  66. \ A-O   A-P     154     155     156     157     A-A     A-S
  67. Alt-O   pmenux  kerr    kerr    kerr    kerr    appendx sedset
  68. \ A-D   A-F     A-G     A-H     A-J     A-K     A-L     167
  69. kerr    kerr    alt-g   kerr    joinln  kerr    lftjust kerr
  70. \ 168   169     170     171     A-Z     A-X     A-C     A-V
  71. kerr    kerr    kerr    kerr    send    excutx  exportx importx
  72. \ A-B   A-N     A-M     179     180     181     182     183
  73. kerr    kerr    NOOP    kerr    kerr    kerr    kerr    kerr
  74. \ 184   185     186     F1      F2      F3      F4      F5
  75. kerr    kerr    kerr    shelp   tscrn   smrk    bscrn   sgetl
  76. \ F6    F7      F8      F9      F10     197     198     199
  77. sloon   sortlin srepn   drawlin sesc    kerr    kerr    kerr
  78. \ 200   201     202     203     204     205     206     END
  79. kerr    kerr    kerr    kerr    kerr    kerr    kerr    sendl
  80. \ 208   209     210     Del     SF1     SF2     SF3     SF4
  81. kerr    kerr    kerr    fdel    kerr    kerr    kerr    kerr
  82. \ SF5   SF6     SF7     SF8     SF9     SF10    CF1     CF2
  83. kerr    sloob   sortlin repall  kerr    kerr    kerr    kerr
  84. \ CF3   CF4     CF5     CF6     CF7     CF8     CF9     CF10
  85. kerr    kerr    kerr    kerr    kerr    kerr    kerr    kerr
  86. \ AF1   AF2     AF3     AF4     AF5     AF6     AF7     AF8
  87. kerr    tmscrn  kerr    bmscrn  kerr    slooa   kerr    srepa
  88. \ AF9   AF10    242     CLEFT   CRIGHT  CEND    CPGDN   CHOME
  89. kerr    squt    kerr    lwrd    rwrd    send    kerr    shom
  90. \ A-1   A-2     A-3     A-4     A-5     A-6     A-7     A-8
  91. kerr    kerr    kerr    kerr    kerr    kerr    kerr    ecmdtgl ;
  92.  
  93. \ ***************************************************************************
  94. \ The following two words allow changing the functions installed in
  95. \ two previous tables
  96.  
  97. : ctlset        ( n1 | function --- )
  98.                 defined
  99.                 if      swap                    \ get address of functon
  100.                         0MAX 31 min 2*          \ clip n1 to valid CTRL char
  101.                         2+                      \ step past EXEC:
  102.                         ['] s^tbl >body @       \ relative segment of S^TBL
  103.                         +XSEG swap !L   \ convert to absolute segment & store
  104.                 else    nip cr count type
  105.                         ."  <- Not defined, and not installed "
  106.                 then    ;
  107.  
  108. : fnset         ( n1 | function --- )   \ same comments as ABOVE
  109.                 defined
  110.                 if      swap
  111.                         127 max 255 min 127 - 2*
  112.                         2+                      \ skip two bytes for EXEC:
  113.                         ['] sfuntbl >body @     \ relative segment of SFUNTBL
  114.                         +XSEG swap !L
  115.                 else    nip cr count type
  116.                         ."  <- Not defined, and not installed "
  117.                 then    ;
  118.  
  119. headerless
  120.  
  121. : ?.s^tbl       ( c1 -- c1 )    \ conditionally display each keys function
  122.                 ?showcmd
  123.                 if      savecursor
  124.                         savescr
  125.                         0 0 at
  126.                         dup 2*
  127.                         2+                      \ step past EXEC:
  128.                         ['] s^tbl >body @       \ relative segment of S^TBL
  129.                         +XSEG swap @L           \ fetch function from table
  130.                         >name .id               \ display the function name
  131.                         4 tenths
  132.                         restscr
  133.                         restcursor
  134.                 then    ;
  135.  
  136. : ?.sfuntbl     ( c1 -- c1 )
  137.                 ?showcmd
  138.                 if      savecursor
  139.                         savescr
  140.                         0 0 at
  141.                         dup 2*
  142.                         2+                      \ skip two bytes for EXEC:
  143.                         ['] sfuntbl >body @     \ relative segment of SFUNTBL
  144.                         +XSEG swap @L           \ fetch function from table
  145.                         >name .id               \ display the function name
  146.                         4 tenths
  147.                         restscr
  148.                         restcursor
  149.                 then    ;
  150.  
  151. : ?controls     ( c1 --- c1 )   \ handle control characters
  152.                 keychar 32 <
  153.                 if      keychar ?.s^tbl s^tbl
  154.                         off> keychar
  155.                 then    ;
  156.  
  157. : ?functions    ( c1 --- c2 )   \ handle function characters
  158.                 keychar 126 >       \ they have values >126
  159.                 if      keychar 127 - ?.sfuntbl sfuntbl
  160.                         off> keychar
  161.                 then    ;
  162.  
  163. : ?schr         ( c1 --- )      \ insert character if not a func
  164.                 keychar ?dup if schr then    ;
  165.  
  166. : doachar       ( c1 --- )
  167.                 =: keychar
  168.                 ?controls ?functions ?schr ;
  169.  
  170. : find.line     ( --- )         \ Assumes we are starting on first line.
  171.                 loadline @ 1- 0MAX maxlines min to.line ;
  172.  
  173. : ?exp_type_set ( -- )
  174.                 ?exp_tabs
  175.                 if      ['] exsltypel is sltypel
  176.                 else    ['] typel     is sltypel
  177.                 then    ;
  178.  
  179. : deferset      ( --- )         \ save current deferred words, and reset them
  180.                 @> keyfilter    is normfilter  ['] skeyfilter  is keyfilter
  181.                 @> key          is normkey     ['] statkey     is key
  182.                 @> bgstuff      is normbgstuff ['] ?showstatus is bgstuff
  183.                 @> dobutton     is normbutton   @> sbutton     is dobutton
  184.                 ?exp_type_set   ;
  185.  
  186. : deferreset    ( --- )         \ restore the deferred words old function.
  187.                 @> normbutton   is dobutton
  188.                 @> normbgstuff  is bgstuff
  189.                 @> normkey      is key
  190.                 @> normfilter   is keyfilter ;
  191.  
  192. ' deferreset is reset_defered   \ reset the defered words even if there
  193.                                 \ is a serious error condition
  194.  
  195. headers
  196.  
  197. : <reedit>      ( --- )         \ reenter edit of file
  198.                 get-cursor >r
  199.                 restore_vectors ?diskfull drop
  200.                 time-reset savestate
  201.                 decimal
  202.                 edscroll                \ enable sub screen scrolling
  203.                 off> updated
  204.                 etabsize tabsize !
  205. \                0 lmargin !
  206.                 rmset?
  207.                 if      rmmax 70 max
  208.                 else    ermargin
  209.                 then    rmargin !
  210.                 edready 0= abort" No file to re-edit."
  211.                 ?showfull drop
  212.                 find.line
  213.                 scrline curline first.textline + min
  214.                 last.textline min =: screenline
  215.                 showscreen
  216.                 on> ?border
  217.                 doborder
  218.                 off> ?eddone
  219.                 begin   on> vstaton
  220.                         showcur
  221.                         key doachar
  222.                         ?eddone
  223.                 until   restorestate
  224.                 set_vectors
  225.                 r> set-cursor ;
  226.  
  227. : reedit        ( --- )
  228.                 deferset <reedit> deferreset ;
  229.  
  230. forth definitions
  231.  
  232.