level1/61_wordfind_low.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
   7 ;; flags for "(VOC-FIND-FLAGS-MASK)"
   8 ;; word flags is 16 bit, use other bits for flags
   9 ;; it is still possible to use simple "and" to check the mask
  10 bitenum{
  11   24 set-bit
  12   value (VOC-FIND-CASE-SENSITIVE)
  13 }
  14
  15 ;; "(VOC-FIND-*)" will and flags-mask with word flags, and
  16 ;; will skip the word if the result is non-zero
  17 ;; default value is "ignore SMUDGE"
  18 $uservar "(VOC-FIND-FLAGS-MASK)" ua_ofs_vocfind_flags_mask FLAG_SMUDGE
  19
  20
  21 : (voc-find-case-sens?)  ( -- flags ) (voc-find-flags-mask) @ (voc-find-case-sensitive) and ; (hidden)
  22 ;; returns non-zero (not strictrly true)
  23 : (voc-find-test-mask)  ( wordflags -- skipit ) (voc-find-flags-mask) @ and ;
  24
  25 : voc-find-get-mask  ( mask -- )  (voc-find-flags-mask) w@ ;
  26 : voc-find-add-mask  ( mask -- )  0xffff and (voc-find-flags-mask) or! ;
  27 : voc-find-reset-mask  ( mask -- )  0xffff and (voc-find-flags-mask) ~and! ;
  28 : voc-find-replace-mask  ( mask -- )  (voc-find-flags-mask) w! ;
  29
  30 : voc-find-get-flags  ( flags -- )  (voc-find-flags-mask) @ 0xffff ~and ;
  31 : voc-find-add-flags  ( flags -- )  0xffff ~and (voc-find-flags-mask) or! ;
  32 : voc-find-reset-flags  ( flags -- )  0xffff ~and (voc-find-flags-mask) ~and! ;
  33 : voc-find-replace-flags  ( flags -- )  16 rshift (voc-find-flags-mask) 2+ w! ;
  34
  35
  36 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  37 : voc-find-str-linear  ( addr count vocid -- cfa -1 // cfa 1 // false )
  38   nrot 2dup str-name-hash >r rot
  39   ;; ( addr count lfa | hash )
  40   begin @ dup while
  41     ;; check hash
  42     dup lfa->hfa @ r@ = if
  43       >r 2dup r@ lfa->nfa id-count
  44       (voc-find-case-sens?) if s= else s=ci endif
  45       if ;; i found her!  ( addr count | lfa )
  46         r@ lfa->ffa ffa@ (voc-find-test-mask)
  47         ifnot 2drop r@ lfa->cfa r> lfa->ffa ffa@
  48               (wflag-immediate) and if 1 else -1 endif rdrop exit endif
  49       endif r>
  50     endif
  51   repeat rdrop nrot 2drop
  52 ;
  53
  54  $if WLIST_HASH_BITS
  55 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  56 : voc-find-str-hashed  ( addr count vocid -- cfa -1 // cfa 1 // false )
  57     \ (voc-find-str-linear) exit
  58   nrot 2dup str-name-hash dup >r
  59   name-hash-fold-mask (voc-header-size-cells) + cells >r rot r> +
  60   ;; ( addr count bfa | hash )
  61   begin @ dup while
  62     ;; check hash
  63     dup bfa->hfa @ r@ = if
  64       ;; check name
  65       >r 2dup r@ bfa->nfa id-count
  66       (voc-find-case-sens?) if s= else s=ci endif
  67       if ;; i found her!  ( addr count | hash bfa )
  68         r@ bfa->ffa ffa@ (voc-find-test-mask)
  69         ifnot 2drop r@ bfa->lfa lfa->cfa r> bfa->ffa ffa@
  70               (wflag-immediate) and if 1 else -1 endif rdrop exit endif
  71       endif r>
  72     endif
  73   repeat rdrop nrot 2drop
  74 ;
  75
  76 ;; returns `1` if cfa is immediate, or `-1` if it is a normal word
  77 : VOC-FIND-STR  ( addr count vocid -- cfa -1 // cfa 1 // false )
  78   dup vocid-hashed? if ['] voc-find-str-hashed else ['] voc-find-str-linear endif execute-tail
  79 ;
  80
  81 $else
  82 ;; no hashtables at all
  83 alias voc-find-str-hashed voc-find-str
  84 $endif