home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / behead.seq < prev    next >
Text File  |  1989-09-21  |  4KB  |  148 lines
  1. \ Headerless words for F-PC         by George T. Hawkins
  2.  
  3. \ yhere xhere here        \ get initial dictionary locations
  4.  
  5. only
  6. forth also hidden also definitions
  7.  
  8. create h-pvoc           \ the headerless pseudo vocabulary
  9. #threads 2* allot       \ thread area
  10.  
  11. \ Initializes and inserts the headerless pseudo vocabulary
  12. \ into the search order.
  13. : hv-insert  ( -- )
  14.   h-pvoc [ #threads 2* literal ] erase
  15.   context @     \ save context on stack
  16.   h-pvoc context !
  17.   also          \ insert headerless pseudo voc
  18.   context ! ;   \ restore current context
  19.  
  20. 0 value sv-context      \ saved context
  21. 0 value sv-current      \ saved current
  22.  
  23. : cc-save  ( -- )   \ saves context & current
  24.   context @ !> sv-context
  25.   current @ !> sv-current ;
  26.  
  27. : cc-rest  ( -- )  \ restores context & current
  28.   sv-context context !
  29.   sv-current current ! ;
  30.  
  31.  
  32. 0   value   ydp-reg     \ the "regular" ydp
  33.  
  34. 0   value   ydp-hw      \ the "headerless" ydp
  35.  
  36. \ The following constant/variable keeps track of the "state"
  37. \ of the headerless word definitions.  It has the following
  38. \ values and interpretations:
  39. \
  40. \     h-state value:      meaning:
  41. \
  42. \         0               in start or behead state
  43. \         1               in initial headerless state
  44. \         2               in headers state
  45. \         3               in subsequent headerless state
  46. \
  47. 0   value   h-state
  48.  
  49. : ydp-shift ( -- )      \ sets offset for headerless words
  50.   #headsegs 16 * yhere - u2/
  51.   5000
  52.   2dup u> IF swap THEN drop  \ pick smaller of the two
  53.   yhere + !> ydp-hw ;
  54.  
  55. forth definitions
  56.  
  57. defer headerless
  58. defer headers
  59. defer behead
  60.  
  61. hidden definitions
  62.  
  63. : _headerless  ( -- )   \ initiates headerless words
  64.   h-state 1 and IF
  65.     cr ." *** Currently in headerless state ***"
  66.   ELSE
  67.     yhere !> ydp-reg    \ save regular ydp
  68.     cc-save             \ save context & current
  69.     h-state IF          \ return to headerless state
  70.       3 !> h-state      \ set state
  71.     ELSE                \ initial headerless state
  72.       hv-insert         \ insert headerless pvoc
  73.       ydp-shift         \ shift ydp
  74.       1 !> h-state      \ set state
  75.     THEN
  76.     also                \ put context in search order
  77.     h-pvoc current !    \ defs to pseudo voc
  78.     h-pvoc context !    \ also as context
  79.     ydp-hw ydp !        \ set/restore headerless ydp
  80.   THEN ;
  81.  
  82. : _headers  ( -- )      \ restores regular words
  83.   h-state 1 and IF
  84.     yhere !> ydp-hw     \ save headerless ydp
  85.     ydp-reg ydp !       \ restore regular ydp
  86.     2 !> h-state        \ set state
  87.     previous            \ remove context from search order
  88.     cc-rest             \ restore context & current
  89.   ELSE
  90.     cr ." *** Must use headerless first ***"
  91.   THEN ;
  92.  
  93. : _behead  ( -- )       \ beheads headerless words
  94.   h-state 1 and IF
  95.     cr ." *** Must use headers first ***"
  96.   ELSE
  97.     h-state IF
  98.       0 !> h-state      \ set state
  99.       cc-save           \ save context & current
  100.       previous          \ remove headerless pvoc
  101.       cc-rest           \ restore context & current
  102.     ELSE
  103.       cr ." *** Nothing to behead ***"
  104.     THEN
  105.   THEN ;
  106.  
  107. forth definitions
  108.  
  109. 0 value beheadable      \ allow the meta compiler to know that we are either
  110.                         \ beheading or we are NOT beheading.
  111.                         \ Tom Zimmer  12/06/88 15:26:12.57
  112.  
  113. : hwords+  ( -- )   \ enables headerless words capability
  114.   ['] _headerless is headerless
  115.   ['] _headers    is headers
  116.   ['] _behead     is behead
  117.   0 !> h-state
  118.   on> beheadable ;
  119.  
  120. hwords+
  121.  
  122. : hwords-  ( -- )   \ disables headerless words capability
  123.   ['] noop is headerless
  124.   ['] noop is headers
  125.   ['] noop is behead
  126.   off> beheadable ;
  127.  
  128.  
  129. only forth also definitions
  130.  
  131.  
  132. \ display dictionary space used:
  133.  
  134. \s
  135.  
  136. cr
  137. .( BEHEAD.SEQ uses:)
  138. cr
  139. here - negate cr .
  140. .(  bytes of code space)
  141. xhere rot - >r - negate 16 * r> + cr .
  142. .(  bytes of list space)
  143. yhere - negate cr .
  144. .(  bytes of head space)
  145. cr
  146.  
  147.  
  148.