level1/63_wordfind_high.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; high-level word lookup
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 ;; save current search flags to return stack
  10 : (WFIND-FLAGS>R)  ( -- )
  11   r> (voc-find-flags-mask) @ >r >r
  12 ; (hidden)
  13
  14 ;; restore current search flags from return stack
  15 : (WFIND-R>FLAGS)  ( -- )
  16   r> r> (voc-find-flags-mask) ! >r
  17 ; (hidden)
  18
  19
  20 ;; hidden words won't be found unless current vocabulary is the top context one
  21 ;; this doesn't do any colon (namespace) resolving
  22 ;; it is basically used for the first search, and iterates over vocabulary stack
  23 ;; it doesn't look in CURRENT
  24 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  25 : WFIND-BASIC  ( addr count -- cfa -1 // cfa 1 // false )
  26   (wfind-flags>r) (wflag-smudge) voc-find-add-mask  ;; skip smudge words
  27   2>r context ;; search context stack
  28   ( ctxptr | addr count )
  29   begin dup @ dup while  ( ctxptr voclptr | addr count )
  30     ;; if voc-to-search is the current one, allow hidden words
  31     (wflag-hidden) over current @ = if voc-find-reset-mask else voc-find-add-mask endif
  32     ( ctxptr voclptr | addr count )
  33     2r@ rot voc-find-str ?dup if  ( ctxptr cfa immflag )
  34       2rdrop rot drop (wfind-r>flags) exit
  35     endif
  36     ( ctxptr | addr count )
  37     ;; if voc-to-search is the current one, look into parents
  38     dup @ current @ = if
  39       ;; hidden words already allowed above
  40       dup @ begin vocid->parent @ ?dup while
  41         ( ctxptr voclptr | savedmask addr count )
  42         dup 2r@ rot voc-find-str ?dup if  ( ctxptr voclptr cfa immflag )
  43           2rdrop 2swap 2drop (wfind-r>flags) exit
  44         endif
  45       repeat
  46     endif
  47     cell-  ;; up context stack
  48   repeat
  49   2drop 2rdrop (wfind-r>flags) false
  50 ;
  51
  52
  53 ;; inner loop over (multiple) colons
  54 ;; splitted to separate word for clarity
  55 ;; input string is the full string, with vocabulary name unstripped
  56 ;; i.e. "forth:words"
  57 ;; vocid is vocabulary id for that string (i.e. "forth" vocid)
  58 ;; the code will immediately strip vocabulary name
  59 ;; note that the string MUST contain a colon, no checks are made
  60 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  61 : (WFIND-VOC-LOOP)  ( addr count vocid -- cfa -1 // cfa 1 // false )
  62   ;; make sure that we can find any hidden word this way
  63   (wfind-flags>r) (wflag-hidden) voc-find-reset-mask
  64   >r  ( addr count | vocid )
  65   begin
  66     ;; we'll come here with guaranteed colon
  67     [char] : str-skip-after-char
  68     2dup r@ voc-find-str ?dup if  ;; i found her!
  69       ( addr count cfa immflag | vocid )
  70       2swap 2drop rdrop (wfind-r>flags) exit
  71     endif
  72     ( addr count | vocid )
  73     2dup [char] : str-trim-at-char ?dup ifnot  ;; no more colons
  74       ( addr count addr | vocid )
  75       2drop drop rdrop false (wfind-r>flags) exit
  76     endif
  77     ;; vocabulary recursion?
  78     ( addr count vocname-addr vocname-count | vocid )
  79     r@ voc-find-str ifnot  ;; not found
  80       ( addr count | vocid )
  81       2drop rdrop false (wfind-r>flags) exit
  82     endif
  83     ( addr count cfa | vocid )
  84     ;; is it a vocabulary?
  85     dup word-type? word-type-voc = ifnot
  86       drop 2drop rdrop false (wfind-r>flags) exit
  87     endif
  88     rdrop voc-cfa->vocid >r
  89     ( addr count | newvocid )
  90     ;; vocabulary name will be stripped with the above code
  91   again
  92 ;
  93
  94
  95 ;; check for several know special vocabulary names
  96 : (WFIND-SPECIAL-NAME?)  ( addr count -- vocid true // false )
  97   ;; first, FORTH vocabulary should be accessible from anywhere (just in case)
  98   2dup " FORTH" s=ci if
  99     2drop  ;; drop vocname
 100     ['] FORTH voc-cfa->vocid
 101     true exit
 102   endif
 103   ;; second, CURRENT vocabulary should be accessible too (because it may not be in the search list)
 104   2dup " CURRENT" s=ci if
 105     2drop  ;; drop vocname
 106     current @
 107     true exit
 108   endif
 109   ;; no more (for now)
 110   2drop
 111   false
 112 ;
 113
 114
 115 ;; this is The Word that should be used for vocabulary searches
 116 ;; this does namespace resolution
 117 ;; if "a:b" is not a known word, try to search "b" in dictionary "a"
 118 ;; things like "a:b:c" are allowed too
 119 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
 120 : WFIND  ( addr count -- cfa -1 // cfa 1 // false )
 121   ;; try full word first
 122   2dup wfind-basic ?dup if 2swap 2drop exit endif
 123   ;; first colon
 124   2dup [char] : str-trim-at-char ?dup ifnot
 125     ;; no colon
 126     drop 2drop false exit
 127   endif
 128   ;; try to find a vocabulary
 129   ( addr count vocname-addr vocname-count )
 130   2dup wfind-basic ifnot
 131     ;; not found; check for some special names
 132     (wfind-special-name?) ifnot
 133       2drop false exit
 134     endif
 135   else
 136     ;; check if it is a vocabulary
 137     dup word-type? word-type-voc = ifnot
 138       ;; not a vocabulary, try some special names
 139       drop  ;; we don't need CFA anymore
 140       (wfind-special-name?) ifnot
 141         2drop false exit
 142       endif
 143     else
 144       voc-cfa->vocid
 145       nrot 2drop   ;; drop vocname
 146     endif
 147   endif
 148   ( addr count vocid )
 149   (wfind-voc-loop)
 150 ;
 151
 152
 153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 154 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
 155 : -find  ( -- cfa -1 // cfa 1 // false )  \ word
 156   parse-name wfind
 157 ;
 158
 159 : xfind  ( addr count -- cfa immflag true // addr count false )
 160   2dup wfind dup if 2swap 2drop true endif
 161 ;
 162
 163 : xfind-required-ex  ( addr count -- cfa immflag )
 164   xfind ifnot
 165     ?endcr if space endif ." \`" type ." \`? "
 166     err-word-expected error
 167   endif
 168 ;
 169
 170 : -find-required-ex  ( -- cfa immflag )  \ word
 171   parse-name [execute-tail] xfind-required-ex
 172 ;
 173
 174 : -find-required  ( -- cfa )  \ word
 175   -find-required-ex drop
 176 ;
 177
 178 : has-word?  ( addr count -- flag )
 179   wfind dup if nip endif
 180 ;
 181
 182
 183 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 184 : (voc-search-with-mask)  ( addr count vocid flags -- addr count false // cfa -1 // cfa 1 )
 185   (wfind-flags>r) voc-find-replace-mask
 186   >r 2dup r> voc-find-str dup if 2swap 2drop endif
 187   (wfind-r>flags)
 188 ;
 189
 190 ;; this searches a vocabulary for a word, ignoring hidden and smudged
 191 : voc-search  ( addr count vocid -- addr count false // cfa -1 // cfa 1 )
 192   [ (wflag-smudge) (wflag-hidden) or (wflag-vocab) or (wflag-codeblock) or ] literal
 193   (voc-search-with-mask)
 194 ;
 195
 196
 197 ;; this searches a vocabulary for a word, ignoring hidden, smudged and immediate
 198 : voc-search-noimm  ( addr count vocid -- addr count false // cfa -1 // cfa 1 )
 199   [ (wflag-smudge) (wflag-hidden) or (wflag-vocab) or (wflag-codeblock) or (wflag-immediate) or ] literal
 200   (voc-search-with-mask)
 201 ;