forth/lib/vocabulary.fs

   1 \ tag: vocabulary implementation for openbios
   2 \
   3 \ Copyright (C) 2003 Stefan Reinauer
   4 \
   5 \ See the file "COPYING" for further information about
   6 \ the copyright and warranty status of this work.
   7 \
   8
   9 \
  10 \ this is an implementation of DPANS94 wordlists (SEARCH EXT)
  11 \
  12
  13
  14 16 constant #vocs
  15 create vocabularies #vocs cells allot \ word lists
  16 ['] vocabularies to context
  17
  18 : search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 )
  19   \ Find the definition identified by the string c-addr u in the word
  20   \ list identified by wid. If the definition is not found, return zero.
  21   \ If the definition is found, return its execution token xt and
  22   \ one (1) if the definition is immediate, minus-one (-1) otherwise.
  23   find-wordlist
  24   if
  25     true over immediate? if
  26       negate
  27     then
  28   else
  29     2drop false
  30   then
  31   ;
  32
  33 : wordlist ( -- wid )
  34   \ Creates a new empty word list, returning its word list identifier
  35   \ wid. The new word list may be returned from a pool of preallocated
  36   \ word lists or may be dynamically allocated in data space. A system
  37   \ shall allow the creation of at least 8 new word lists in addition
  38   \ to any provided as part of the system.
  39   here 0 ,
  40   ;
  41
  42 : get-order ( -- wid1 .. widn n )
  43   #order @ 0 ?do
  44     #order @ i - 1- cells context + @
  45   loop
  46   #order @
  47   ;
  48
  49 : set-order ( wid1 .. widn n -- )
  50   dup -1 = if
  51     drop forth-last 1 \ push system default word list and number of lists
  52   then
  53   dup #order !
  54   0 ?do
  55     i cells context + !
  56   loop
  57   ;
  58
  59 : order ( -- )
  60   \ display word lists in the search order in their search order sequence
  61   \ from the first searched to last searched. Also display word list into
  62   \ which new definitions will be placed.
  63   cr
  64   get-order 0 ?do
  65     ." wordlist " i (.) type 2e emit space u. cr
  66   loop
  67   cr ." definitions: " current @ u. cr
  68   ;
  69
  70
  71 : previous ( -- )
  72   \ Transform the search order consisting of widn, ... wid2, wid1 (where
  73   \ wid1 is searched first) into widn, ... wid2. An ambiguous condition
  74   \ exists if the search order was empty before PREVIOUS was executed.
  75   get-order nip 1- set-order
  76   ;
  77
  78
  79 : do-vocabulary ( -- )  \ implementation factor
  80   does>
  81     @ >r                (  ) ( R: widnew )
  82     get-order swap drop ( wid1 ... widn-1 n )
  83     r> swap set-order
  84   ;
  85
  86 : discard ( x1 .. xu u - ) \ implementation factor
  87   0 ?do
  88     drop
  89   loop
  90   ;
  91
  92 : vocabulary ( >name -- )
  93   wordlist create , do-vocabulary
  94   ;
  95
  96 : also  ( -- )
  97   get-order over swap 1+ set-order
  98   ;
  99
 100 : only  ( -- )
 101   -1 set-order also
 102   ;
 103
 104 only
 105
 106 \ create forth forth-wordlist , do-vocabulary
 107 create forth get-order over , discard do-vocabulary
 108
 109 : findw  ( c-addr -- c-addr 0 | w 1 | w -1 )
 110   0                     ( c-addr 0 )
 111   #order @ 0 ?do
 112     over count          ( c-addr 0 c-addr' u       )
 113     i cells context + @ ( c-addr 0 c-addr' u wid   )
 114     search-wordlist     ( c-addr 0; 0 | w 1 | w -1 )
 115     ?dup if             ( c-addr 0; w 1 | w -1     )
 116       2swap 2drop leave ( w 1 | w -1 )
 117     then                ( c-addr 0   )
 118   loop                  ( c-addr 0 | w 1 | w -1    )
 119   ;
 120
 121 : get-current ( -- wid )
 122   current @
 123   ;
 124
 125 : set-current ( wid -- )
 126   current !
 127   ;
 128
 129 : definitions ( -- )
 130   \ Make the compilation word list the same as the first word list in
 131   \ the search order. Specifies that the names of subsequent definitions
 132   \ will be placed in the compilation word list.
 133   \ Subsequent changes in the search order will not affect the
 134   \ compilation word list.
 135   context @ set-current
 136   ;
 137
 138 : forth-wordlist ( -- wid )
 139   forth-last
 140   ;
 141
 142 : #words ( -- )
 143   0 last
 144   begin
 145     @ ?dup
 146   while
 147     swap 1+ swap
 148   repeat
 149
 150   cr
 151   ;
 152
 153 true to vocabularies?