level1/62_create_vocbase.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 ;; patches word size to HERE
   8 ;; call this after creating various arrays
   9 ;; because compiler should know their size
  10 : create;  ( -- )
  11   latest-lfa dp-temp-addr? dp-temp @ ifnot not endif
  12   if here latest-nfa nfa->sfa ! endif  ;; patch size
  13 ;
  14
  15
  16 256 buffer: (create-header-buf)
  17 (hidden)
  18
  19
  20 ;; common part, used to build word names
  21 : (create-build-name)  ( addr count -- )
  22   here >r  ;; remember HERE (we will need to fix some name fields later)
  23   ;; compile counter (we'll add flags and other things later)
  24   ;; it is guaranteed that all fields except length are zero here
  25   ;; (due to word header layout, and length check in callers)
  26   dup ,
  27   ;; copy parsed word to HERE (and allocate name bytes for it)
  28   dup if
  29     dup n-allot swap move
  30     ;; change the case of a new name?
  31     create-case? @ ?dup if r@ count rot +if upcase-str else locase-str endif endif
  32     ;; replace starting zero with space
  33     r@ 4+ c@ ifnot bl r@ 4+ c! endif
  34   else
  35     2drop
  36   endif
  37   (wflag-smudge) (current-create-mode) or  ;; put flags (ffa is 16 bits at nfa+2)
  38   r@ nfa->ffa tfa!     ;; it is safe to poke here, ffa is empty
  39   $if URFORTH_ALIGN_CFA_PFA
  40     0 c, r> c@ begin here 3 and while 1+ 0 c, repeat
  41     dup 255 u> err-aligned-name-too-long ?error
  42     here 1- c!
  43   $else
  44     r> c@ c,  ;; put length again (trailing length byte)
  45   $endif
  46 ; (hidden)
  47
  48
  49 : (create-temp-name?)  ( addr count -- flag )
  50   +if c@ 0= else drop true endif
  51 ; (hidden)
  52
  53 : (create-check-dp-temp)  ( addr count -- addr count )
  54   dp-temp @ if 2dup (create-temp-name?) ifnot
  55     current @ dp-temp-addr? err-no-temp-here not-?error
  56   endif endif
  57 ;
  58
  59 ;; this is used to create a header for the temporary codeblock in dp-temp
  60 ;; we need this so standard diagnostic words won't be confused
  61 ;; it won't change "latest", though
  62 : (create-temp-header-nocheck)  ( addr count -- )
  63   0 max-word-name-length clamp 255 min  ;; sanitize length, just in case
  64   $if URFORTH_ALIGN_HEADERS
  65   align-here
  66   $endif
  67   0 ,  ;; allocate dfa
  68   0 ,  ;; allocate sfa
  69   0 ,  ;; allocate bfa
  70   0 ,  ;; allocate lfa
  71   0 ,  ;; namehash
  72   (create-build-name)
  73 ; (hidden)
  74
  75
  76 ;; this can be used to create nameless words (with 0 name length)
  77 ;; nameless words are linked with LFA, but never put into any hash bucket
  78 ;; they also have zero namehash
  79 : (create-header-nocheck)  ( addr count -- )
  80   (create-check-dp-temp)
  81   0 max-word-name-length clamp 255 min  ;; sanitize length, just in case
  82   dup >r (create-header-buf) swap move (create-header-buf) r>
  83   $if URFORTH_ALIGN_HEADERS
  84   align-here
  85   $endif
  86   0 ,  ;; allocate dfa
  87   0 ,  ;; allocate sfa
  88   0 ,  ;; allocate bfa (it will be patched later)
  89   here ;; remember HERE (it will become the new latest)
  90   latest-lfa , ;; put lfa
  91   current @ !  ;; update latest
  92   ;; zero-length name, or name starts with zero byte means "do not register in hash table"
  93   dup if over c@ else false endif
  94   if  ;; ok, put into hash table
  95     2dup str-name-hash dup , ;; put name hash
  96     ;; fix bfa
  97     $if WLIST_HASH_BITS
  98       ( addr count hash )
  99       ;; check if vocab has hashtable
 100       current @ vocid-hashed? if
 101         name-hash-fold-mask current @ vocid->htable cells^  ;; calc bucket address
 102         dup @  ;; load old bfa link  ( addr count bkptr oldbfa )
 103         here nfa->bfa rot !  ;; store current bfa address
 104         here nfa->bfa !      ;; update bfa
 105       else drop endif
 106     $else
 107       drop  ;; we don't really need any hash
 108     $endif
 109   else
 110     0 ,  ;; namehash
 111   endif
 112   (create-build-name)
 113   create;  ;; setup initial size, why not
 114 ; (hidden)
 115
 116
 117 ;; A defining word used in the form: CREATE cccc
 118 ;; by such words as CODE and CONSTANT to create a dictionary header for
 119 ;; a Forth definition. Puts no code field.
 120 ;; The new word is created in the current vocabulary.
 121 ;; Note that SMUDGE bit is set (i.e. the word is invisible).
 122 : (create-header)  ( addr count -- )
 123   (create-check-dp-temp)
 124   ;; check for duplicate word?
 125   warning-redefine @ if
 126     ;; look only in the current dictionary
 127     2dup current @ voc-find-str if
 128       ?endcr if space endif cfa->nfa ." \`" id. ." \` redefined"
 129       (tib-fname>error-fname) error-line. cr
 130     endif
 131   endif
 132   ( addr count )
 133   ;; check length
 134   dup 1 max-word-name-length bounds? ifnot
 135     ?endcr if space endif ." \`" type ." \` " err-invalid-word-name error
 136   endif
 137   (create-header-nocheck)
 138 ; (hidden)
 139
 140
 141 : create-header-named  ( addr count -- )
 142   (create-header)
 143 ;
 144
 145 : create-header  ( -- )  \ word
 146   parse-name create-header-named
 147 ;
 148
 149 ;; the same as "CREATE", but without parsing
 150 : create-named  ( addr count -- )
 151   create-header-named (URFORTH-DOVAR-ADDR) compiler:(cfa-call,) create; smudge
 152 ;
 153
 154 : create-named-in  ( addr count vocid -- )
 155   get-current >r set-current ['] create-named catch r> set-current throw
 156 ;
 157
 158 ;; creates new word definition.
 159 ;; the code field contains the routine that returns the address of the word's parameter field.
 160 ;; the new word is created in the current vocabulary.
 161 : create  ( -- )  \ word
 162   parse-name create-named
 163 ;
 164
 165 : create-in  ( vocid -- )  \ word
 166   parse-name rot create-named-in
 167 ;
 168
 169
 170 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 171 ;; sadly, has to be here, because it is used by word searching code
 172 enum{
 173   value WORD-TYPE-OTHER
 174   value WORD-TYPE-FORTH
 175   value WORD-TYPE-VAR
 176   value WORD-TYPE-CONST
 177   value WORD-TYPE-VALUE
 178   value WORD-TYPE-DEFER
 179   value WORD-TYPE-DOES
 180   value WORD-TYPE-VOC
 181   ;; this word is new override (overriden words are not marked as special, yet they become non-Forth, i.e. "other")
 182   value WORD-TYPE-OVERRIDE
 183   value WORD-TYPE-OVERRIDEN
 184 }
 185
 186 create (WORD-CFA-TABLE) (hidden)
 187   dd  ur_DOFORTH,pfa "WORD-TYPE-FORTH"
 188   dd  ur_DOCONST,pfa "WORD-TYPE-CONST"
 189   dd  ur_DOVAR,pfa "WORD-TYPE-VAR"
 190   dd  ur_DOVALUE,pfa "WORD-TYPE-VALUE"
 191   dd  ur_DODEFER,pfa "WORD-TYPE-DEFER"
 192   dd  ur_DODOES,pfa "WORD-TYPE-DOES"
 193   dd  ur_DOOVERRIDE,pfa "WORD-TYPE-OVERRIDE"
 194   dd  0
 195 create;
 196
 197 : WORD-TYPE?  ( cfa -- type )
 198   dup c@ 0xe8 = if
 199     ;; check "vocabulary" flag
 200     dup cfa-vocab? if drop word-type-voc exit endif
 201     ;; calculate call address
 202     1+ compiler:(disp32@)
 203     ;; check for overriden word
 204     dup (code-base-addr) u> over real-here u< and if
 205       ;; it should be safe to peek
 206       dup c@ 0xe8 = if
 207         dup 1+ compiler:(disp32@)
 208         (URFORTH-DOOVERRIDE-ADDR) = if drop word-type-overriden exit endif
 209       endif
 210     endif
 211     ;; check table
 212     >r (word-cfa-table)
 213     begin dup @ ?dup while  ( tbladdr codeaddr | cfadest )
 214       r@ = if rdrop cell+ @ @ exit endif
 215     2 +cells repeat
 216     ( tbladdr | cfadest )
 217     rdrop
 218   endif
 219   drop
 220   word-type-other
 221 ;