urflibs/init/bootstrap/40-voc-creatori.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9 ;; vocabulary creation
  10 ;;
  11
  12 ;; worker for the following words
  13 : (DO-ALLOT)  ( n -- )  FORTH:(DP-TEMP) @ IF FORTH:(DP-TEMP) ELSE FORTH:(DP) ENDIF +! ; (HIDDEN)
  14
  15 ;; contrary to other systems, alloting negative number of bytes is prohibited.
  16 ;; use "UNALLOT" to "deallot" dictionary space.
  17 : N-ALLOT  ( n -- start-addr )  DUP 0< " negative allot" ?ERROR  HERE >R (DO-ALLOT) R> ;
  18
  19 ;; contrary to other systems, alloting negative number of bytes is prohibited.
  20 ;; use "UNALLOT" to "deallot" dictionary space.
  21 : ALLOT  ( n -- )  N-ALLOT DROP ;
  22
  23 ;; "deallot" given number of bytes.
  24 : UNALLOT  ( n -- )  DUP 0< " negative unallot" ?ERROR  NEGATE (DO-ALLOT) ;
  25
  26
  27 ALSO COMPILER
  28
  29 ;; create new headerless wordlist
  30 : (NEW-WORDLIST)  ( parentvocid need-hashtable? -- vocid )
  31   ;; typeid, used by Forth code (structs and such)
  32   0 ,                   ;; typeid
  33   HERE >R               ;; result -- vocid
  34   ;; create wordlist struct
  35   0 ,                   ;; latest
  36   HERE >R               ;; for voclink
  37   FORTH:(VOC-LINK) @ ,  ;; voclink
  38   SWAP ,                ;; parent
  39   0 ,                   ;; header NFA
  40   ;; create hashtable
  41   IF (VOC-HTABLE-SIZE) FOR 0 , ENDFOR
  42   ELSE (VOC-HTABLE-NOFLAG) ,
  43   ENDIF
  44   ;; link to voclink
  45   R@ (ADDR-TEMP-BIT) AND IF RDROP  \ ." NO-LINK!\n"
  46   ELSE R> FORTH:(VOC-LINK) !
  47   ENDIF
  48   ;; done
  49   R>
  50 ; (HIDDEN)
  51
  52 ;; create vocabulary word
  53 : (CREATE-NAMED-VOCAB)  ( vocid addr count -- )
  54   ;; name flags
  55   (GET-NEW-WORD-FLAGS)
  56   (WFLAG-SMUDGE) OR (WFLAG-VOCAB) OR
  57   (CREATE-WORD-HEADER)
  58   ;; fill CFA and PFA
  59   (CFAIDX-DO-VOC) ,  ;; cfa
  60   DUP , ;; wordlist address
  61   RESET-SMUDGE
  62   (VOCOFS-HEADER) + LATEST-NFA SWAP!
  63 ; (HIDDEN)
  64
  65 ;; create vocabulary word
  66 : (CREATE-VOCAB)  ( vocid -- )  \ vocname
  67   PARSE-NAME (CREATE-NAMED-VOCAB)
  68 ; (HIDDEN)
  69
  70 ;; check if the given CFA defined as a vocabulary header
  71 : (IS-VOC-WORD?)  ( cfa -- bool )
  72   DUP @ (CFAIDX-DO-VOC) =
  73   SWAP CFA->NFA @ (WFLAG-VOCAB) (WFLAG-SMUDGE) OR AND  LOGOR
  74 ;
  75
  76 ;; doesn't check arguments
  77 : (WORD->VOCID)  ( cfa -- vocid )
  78   CFA->PFA @
  79 ;
  80
  81 ;; doesn't check arguments
  82 : (VOCID-PARENT@)  ( vocid -- vocid )  (VOCOFS-PARENT) + @ ;
  83 : (VOCID-PARENT!)  ( parent-vocid vocid -- )  (VOCOFS-PARENT) + ! ;
  84
  85 : (VOCID-TYPEID@)  ( vocid -- typeid )  CELL- @ ;
  86 : (VOCID-TYPEID!)  ( typeid vocid -- )  CELL- ! ;
  87
  88 PREVIOUS
  89
  90 : VOCID-HEADNFA@  ( vocid -- head-nfa / FALSE )
  91   COMPILER:(VOCOFS-HEADER) + @
  92 ;
  93
  94 ;; useful low-level words to create vocabs with already parsed names
  95 : (VOCABULARY-EX)  ( addr count parent need-hashtbl? -- )
  96   (NEW-WORDLIST) NROT (CREATE-NAMED-VOCAB)
  97 ;
  98
  99 : (VOCABULARY)  ( addr count -- )  0 TRUE  (VOCABULARY-EX) ;
 100 : (SIMPLE-VOCABULARY)  ( addr count -- )  0 FALSE  (VOCABULARY-EX) ;
 101 : (NESTED-VOCABULARY)  ( addr count -- )  CURRENT @ TRUE  (VOCABULARY-EX) ;
 102 : (SIMPLE-NESTED-VOCABULARY)  ( addr count -- )  CURRENT @ FALSE  (VOCABULARY-EX) ;
 103
 104
 105 : VOCABULARY  ( -- )  \ vocname
 106   0 TRUE (NEW-WORDLIST)  (CREATE-VOCAB)
 107 ;
 108
 109 ;; vocabulary without a hash table
 110 : SIMPLE-VOCABULARY  ( -- )  \ vocname
 111   0 FALSE (NEW-WORDLIST)  (CREATE-VOCAB)
 112 ;
 113
 114 : NESTED-VOCABULARY  ( -- )  \ vocname
 115   CURRENT @ TRUE (NEW-WORDLIST)  (CREATE-VOCAB)
 116 ;
 117
 118 : SIMPLE-NESTED-VOCABULARY  ( -- )  \ vocname
 119   CURRENT @ TRUE (NEW-WORDLIST)  (CREATE-VOCAB)
 120 ;
 121
 122 : VOCID:  ( -- vocid )  \ vocname
 123   -FIND-REQUIRED DUP (IS-VOC-WORD?) " vocabulary name expected" ?NOT-ERROR
 124   ;; vocid is in PFA
 125   CFA->PFA @
 126   STATE @ IF
 127     ;; compile vocid literal
 128     COMPILE FORTH:(LITVOCID) ,
 129   ENDIF
 130 ; IMMEDIATE
 131
 132 : VOC-LATEST  ( vocid -- latest )
 133   COMPILER:(VOCOFS-LATEST) + @
 134 ;
 135
 136
 137 ;; ALSO-DEFS: vocname
 138 ;; does "ALSO vocname DEFINITIONS"
 139 : ALSO-DEFS:  ( -- )  \ vocname
 140   -FIND-REQUIRED DUP (IS-VOC-WORD?) " vocabulary name expected" ?NOT-ERROR
 141   ALSO (WORD->VOCID) CONTEXT ! DEFINITIONS
 142 ;
 143
 144 ;; does "PREVIOUS DEFINITIONS"
 145 : PREV-DEFS  ( -- )
 146   PREVIOUS DEFINITIONS
 147 ;
 148
 149
 150 ;; create vocabulary if we don't have such word yet
 151 : VOCAB-IF-NONE  ( -- )  \ name
 152   PARSE-NAME 2DUP FIND-WORD IF 2DROP DROP
 153   ELSE (VOCABULARY)
 154   ENDIF
 155 ;
 156
 157 ;; create vocabulary if we don't have such word yet
 158 : SIMPLE-VOCAB-IF-NONE  ( -- )  \ name
 159   PARSE-NAME 2DUP FIND-WORD IF 2DROP DROP
 160   ELSE (SIMPLE-VOCABULARY)
 161   ENDIF
 162 ;
 163
 164 ;; create nested vocabulary if we don't have such word yet
 165 : NESTED-VOCAB-IF-NONE  ( -- )  \ name
 166   PARSE-NAME 2DUP FIND-WORD IF 2DROP DROP
 167   ELSE (NESTED-VOCABULARY)
 168   ENDIF
 169 ;
 170
 171 ;; create nested vocabulary if we don't have such word yet
 172 : SIMPLE-NESTED-VOCAB-IF-NONE  ( -- )  \ name
 173   PARSE-NAME 2DUP FIND-WORD IF 2DROP DROP
 174   ELSE (SIMPLE-NESTED-VOCABULARY)
 175   ENDIF
 176 ;