home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / PASM386C.ZIP / BEHEAD.SEQ next >
Encoding:
Text File  |  1989-11-24  |  12.5 KB  |  337 lines
  1. \ BEHEAD - Headerless words for F-PC         by George T. Hawkins
  2.  
  3. \ Updated 24nov89, Gene Czarcinski
  4. \       . Merge some of George Hawkins' enhancements to BEHEADing
  5. \         into a version for F-PC 3.50
  6. \       . Fix bug: when the PASM386 was being processed in
  7. \         beheading mode, the space for regular defs was
  8. \         insufficient and overlapped the headerless headers.
  9. \         Change YDP-SHIFT so there is more space.
  10.  
  11. comment:
  12.  
  13.     The words "headerless", "headers", and "behead" can be
  14.     used together to provide a headerless word capability in
  15.     F-PC.
  16.  
  17.     Although the use of headerless words can save you head
  18.     space, their main advantage is in the software
  19.     engineering they provide.  That is, the definitions/
  20.     names are *completely lost* not just stashed away in
  21.     some obscure vocabulary.
  22.  
  23.     In general, during testing, you should set up your
  24.     {headerless/headers}/ behead definitions as described
  25.     above, but proceed it with a single "hwords-".  The
  26.     hwords- word will cause headerless, headers, and behead
  27.     to be treated as noops.  Once you've finished debugging
  28.     and are ready to go production, then change the
  29.     "hwords-" to "hwords+" (or, better still, simply remove
  30.     the "hwords-" word).  This will give the headerless,
  31.     headers, and behead words their standard meaning.
  32.     (Note: If you ever need to debug the code again, and
  33.     want to see the names, then change hwords+ to hwords-
  34.     (or re-insert a preliminary hwords-).  Also note that
  35.     the hwords-/+ word is global during a compilation
  36.     session and extends across colon definitions and
  37.     FLOAD's.)
  38.  
  39. comment;
  40.  
  41. only forth also hidden also
  42.  
  43. forth definitions
  44.  
  45. FALSE value haudit
  46. \
  47. \   A boolean variable which, if TRUE, automatically audits
  48. \   for beheading violations.  That is, you will receive
  49. \   error notifiction if:
  50. \
  51. \   1)  The search order (after CONTEXT) is modified
  52. \       on any subsequent invocation of
  53. \       "headerless", any invocation of "headers",
  54. \       or the final invocation of "behead";
  55. \
  56. \   2)  You attempt to behead words across multiple
  57. \       FLOAD's.
  58. \
  59. \   If either type error above occurs, you are given the
  60. \   appropriate diagnostic information and allowed the
  61. \   choice of either continuing the compilation session or
  62. \   aborting it.
  63. \
  64. \   Although "haudit" initially defaults to FALSE, I
  65. \   recommend that you set it to TRUE via:
  66. \
  67. \       HAUDIT+
  68.  
  69. : haudit+       ( -- )
  70. \       Enables automatic audit for beheading violations.
  71.                 TRUE !> haudit ;
  72.  
  73. : haudit-       ( -- )
  74. \       Disables automatic audit for beheading violations.
  75.                 FALSE !> haudit ;
  76.  
  77. hidden definitions
  78.  
  79. create h-pvoc           \ the headerless pseudo vocabulary
  80.  
  81. #threads 2* allot       \ thread area
  82.  
  83. : hv-insert     ( -- )
  84. \       Initializes and inserts the headerless pseudo vocabulary
  85. \       into the search order.
  86.                 h-pvoc [ #threads 2* literal ] erase
  87.                 context @     \ save context on stack
  88.                 h-pvoc context !
  89.                 also          \ insert headerless pseudo voc
  90.                 context ! ;   \ restore current context
  91.  
  92. 0 value sv-context      \ saved context
  93. 0 value sv-current      \ saved current
  94.  
  95. : cc-save       ( -- )
  96. \       saves context & current
  97.                 context @ !> sv-context
  98.                 current @ !> sv-current ;
  99.  
  100. : cc-rest       ( -- )
  101. \       restores context & current
  102.                 sv-context context !
  103.                 sv-current current ! ;
  104.  
  105.  
  106. 0   value   ydp-reg     \ the "regular" ydp
  107.  
  108. 0   value   ydp-hw      \ the "headerless" ydp
  109.  
  110. 0   value   h-state     \ keeps track of the "state" of the headerless
  111.                         \ word definitions.  It has the following
  112.                         \ values and interpretations:
  113.                         \
  114.                         \ h-state     meaning:
  115.                         \
  116.                         \   0         in start or behead state
  117.                         \   1         in initial headerless state
  118.                         \   2         in headers state
  119.                         \   3         in subsequent headerless state
  120.  
  121. : ydp-shift     ( -- )
  122. \       sets offset for headerless words
  123.                 #headsegs 16 * yhere - u2/
  124.                 7000                       \ sufficient space for PASM386
  125.                 2dup u> IF swap THEN drop  \ pick smaller of the two
  126.                 yhere + !> ydp-hw ;
  127.  
  128. create init-fl  b/hcb allot     \ Stores the name of the currently loaded file
  129.  
  130. create init-order #vocs 1- 2* allot     \ stores vocab order
  131.  
  132. 0 value init-ll                 \ initial load line
  133.  
  134. : save-flo      ( -- )
  135. \       save file status: name of file, line and search order
  136.                 seqhandle count init-fl place
  137.                 loadline @ !> init-ll
  138.                 context 2+ init-order [ #vocs 1- 2* literal ] cmove ;
  139.  
  140. : sorder.       ( addr -- )
  141. \       Prints search order (not including context) from address:
  142.                 cr ." Search order (after context):" cr
  143.                 [ #vocs 1- literal ] 0 DO
  144.                 dup @ ?dup IF
  145.                      body> >name .id
  146.                 THEN
  147.                 2+
  148.                 LOOP
  149.                 drop ;
  150.  
  151. : any-key       ( -- )
  152. \       pause
  153.                 cr ." Press <ESC> to abort or any other key to continue"
  154.                 key $1B = IF abort THEN ;
  155.  
  156. 0 value order-off
  157.  
  158. \ Defines the initial context array offset to begin comparing
  159. \ the search order.  The initial context array is saved with
  160. \ the vocabulary after CONTEXT in the search order.  When in a
  161. \ "headers" state, the context array search should be started
  162. \ at offset 2.  When in a "headerless" state, the context
  163. \ array search should be started at offset 3.  After final
  164. \ beheading (and the initial order is restored), the context
  165. \ array search should be started at offset 1.
  166. \
  167. \ Note that this value is not absolutely necessary.  That is,
  168. \ by judicious placement of "same-order?" and "horder-err" a
  169. \ constant offset can be assumed.  This seems not to be worth
  170. \ the effort considering the loss of generality involved along
  171. \ with the insignificnat time/overhead considerations.
  172.  
  173. : same-order?   ( -- f )
  174. \       Compares the current search order with init-order.  The
  175. \       initial context array offset is specified by "order-off".
  176. \       Returns TRUE if they are different.
  177.                 haudit not IF
  178.                    FALSE exit
  179.                 THEN
  180.                 FALSE ( assume the same )
  181.                 #vocs order-off DO
  182.                    I 2* context                + @
  183.                    I order-off - 2* init-order + @
  184.                    2dup <> IF
  185.                         3drop TRUE leave
  186.                    THEN
  187.                    + 0= ?leave
  188.                 LOOP ;
  189.  
  190. : ifi.          ( -- )
  191. \       Prints initial file info.
  192.                 cr ." Initial load file: " init-fl count type
  193.                 cr ." Initial load line: " init-ll . ;
  194.  
  195. : cfi.          ( -- )
  196. \       Prints current file info.
  197.                 cr ." Current load file: " seqhandle count type
  198.                 cr ." Current load line: " loadline @ . ;
  199.  
  200. : horder-err    ( -- )
  201. \       Informs user that a search order modification has occurred
  202. \       between the initial invocation of "headerless" and the final
  203. \       "behead".  Prints out diagnostic information and
  204. \       conditionally aborts.
  205.                 cr ." Beheading error: search order modified"
  206.                 ifi.
  207.                 init-order sorder.
  208.                 cfi.
  209.                 context order-off 2* + sorder. any-key ;
  210.  
  211. : same-file?    ( -- f )
  212. \       Compares the current load file with the initial headerless
  213. \       call load file.  Returns TRUE if they are different.
  214.                 haudit not IF
  215.                      FALSE exit
  216.                 THEN
  217.                 init-fl c@ seqhandle c@ <> IF TRUE exit THEN
  218.                 init-fl 1+ seqhandle 1+ seqhandle c@ caps-comp ;
  219.  
  220. : hfile-err     ( -- )
  221. \       Informs user that a multiple file behead has occurred
  222. \       between the initial invocation of "headerless" and the final
  223. \       "behead".  Prints out diagnostic information and
  224. \       conditionally aborts.
  225.                 cr ." Multiple file beheading"
  226.                 ifi. cfi. any-key ;
  227.  
  228.  
  229. forth definitions
  230.  
  231. defer headerless        ( -- )
  232. \       initiates/continues headerless word definitions
  233.  
  234. defer headers           ( -- )
  235. \       continues headers from a prior headerless word state
  236. \       NOTE: HEADERLESS must be used first.
  237.  
  238. defer behead            ( -- )
  239. \       beheads all headerless words
  240. \       NOTE: must be in a "headers" state
  241.  
  242. hidden definitions
  243.  
  244. : _headerless   ( -- )
  245. \       initiates headerless words
  246.                 h-state 1 and IF
  247.                    cr ." *** Currently in headerless state ***"
  248.                 ELSE
  249.                    yhere !> ydp-reg    \ save regular ydp
  250.                    cc-save             \ save context & current
  251.                    h-state IF          \ return to headerless state
  252.                                        \ NOTE: current state is headers
  253.                      2 !> order-off    \ set context offset
  254.                      same-order? IF    \
  255.                        horder-err      \ inform user of order error
  256.                      THEN              \
  257.                      3 !> h-state      \ set state
  258.                    ELSE                \ initial headerless state
  259.                      save-flo          \ save relevant state data
  260.                      hv-insert         \ insert headerless pvoc
  261.                      ydp-shift         \ shift ydp
  262.                      1 !> h-state      \ set state
  263.                    THEN
  264.                    also                \ put context in search order
  265.                    h-pvoc current !    \ defs to pseudo voc
  266.                    h-pvoc context !    \ also as context
  267.                    ydp-hw ydp !        \ set/restore headerless ydp
  268.                 THEN ;
  269.  
  270. : _headers      ( -- )
  271. \       restores regular words
  272.                 h-state 1 and IF
  273.                                        \ NOTE: current state is headerless
  274.                    3 !> order-off      \ set context offset
  275.                    same-order? IF      \
  276.                        horder-err      \ inform user of order error
  277.                    THEN
  278.                    yhere !> ydp-hw     \ save headerless ydp
  279.                    ydp-reg ydp !       \ restore regular ydp
  280.                    2 !> h-state        \ set state
  281.                    previous            \ remove context from search order
  282.                    cc-rest             \ restore context & current
  283.                 ELSE
  284.                    cr ." *** Must use headerless first ***"
  285.                 THEN ;
  286.  
  287. : _behead       ( -- )
  288. \       beheads headerless words
  289.                 h-state 1 and IF
  290.                    cr ." *** Must use headers first ***"
  291.                 ELSE
  292.                    h-state IF
  293.                      0 !> h-state      \ set state
  294.                      cc-save           \ save context & current
  295.                      previous          \ remove headerless pvoc
  296.                      cc-rest           \ restore context & current
  297.                                        \ NOTE: search order restored
  298.                      same-file? IF     \
  299.                          hfile-err     \ inform user of file error
  300.                      THEN              \
  301.                      1 !> order-off    \ set context offset
  302.                      same-order? IF    \
  303.                          horder-err    \ inform user of order error
  304.                      THEN              \
  305.                    ELSE
  306.                      cr ." *** Nothing to behead ***"
  307.                    THEN
  308.                 THEN ;
  309.  
  310. forth definitions
  311.  
  312. 0 value beheadable      \ allow the meta compiler to know that we are either
  313.                         \ beheading or we are NOT beheading.
  314.                         \ Tom Zimmer  12/06/88 15:26:12.57
  315.  
  316. : hwords+       ( -- )
  317. \       enables headerless words capability
  318.                 ['] _headerless is headerless
  319.                 ['] _headers    is headers
  320.                 ['] _behead     is behead
  321.                 0 !> h-state
  322.                 on> beheadable ;
  323.  
  324. hwords+
  325.  
  326. : hwords-       ( -- )
  327. \       disables headerless words capability
  328.                 ['] noop is headerless
  329.                 ['] noop is headers
  330.                 ['] noop is behead
  331.                 off> beheadable ;
  332.  
  333.  
  334. only forth also definitions
  335.  
  336.  
  337.