dsforth/main_wfind.zas

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; word finder utilities
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5
   6 ;; VOCABULARY BODY:
   7 ;; "DOES>" ptr
   8 ;; name: " "
   9 ;; lfa
  10 ;; hash table (if there is any)
  11
  12 $IF !DSFORTH_TURNKEY || (defined(DSFORTH_KEEP_HEADERS) && DSFORTH_KEEP_HEADERS)
  13 ;; FORTH vocabulary
  14 $FORTH_DOES_CODE FORTH voc_does_code IMM
  15 $ENDIF ;; !DSFORTH_TURNKEY
  16 ;; k8, AberSoft
  17 ;; ( -- )
  18 IF VLIST_HASH_BITS
  19   ;; bfa
  20   defw 0
  21 ENDIF
  22   ;; name (space)
  23   defw #A081
  24   ;; CONTEXT and CURRENT points here
  25 forth_voc_latest:
  26   ;; voc latest
  27   defw 0 ;;latest_word
  28 ;;forth_voc_link:
  29 ;;  ;; prev voc-link
  30 ;;  defw 0
  31 forth_hash_tbl:
  32 forth_hash_table_offset equ forth_hash_tbl-forth_voc_latest
  33   ;;$printf "forth_hash_table_offset=%s", forth_hash_table_offset
  34   ;; hash table
  35 $IF !DSFORTH_TURNKEY || (defined(DSFORTH_KEEP_HEADERS) && DSFORTH_KEEP_HEADERS)
  36 $FORTH_EMIT_HTABLE
  37 $ENDIF ;; !DSFORTH_TURNKEY
  38
  39
  40 $IF !DSFORTH_TURNKEY
  41   $IF VLIST_HASH_BITS
  42     include "main_wfind_hashed.zas"
  43   $ELSE
  44     include "main_wfind_linear.zas"
  45   $ENDIF
  46 $ENDIF
  47
  48
  49 ; ENCLOSE ( addr1 c -- addr1 w_start_ofs w_end_ofs next_scan_ofs )
  50 ; The text scanning primitive used by WORD.
  51 ; From the text address addr1 and an ascii delimiting character c,
  52 ; is determined:
  53 ;   `w_start_ofs`: the byte offset to the first non-delimiter character
  54 ;   `w_end_ofs`: the offset to the first delimiter after the text
  55 ;   `next_scan_ofs`: the offset to the first character not included
  56 ; Note that `addr1` will be returned unmodified.
  57 ; This procedure will not process past an ascii "null", treating it
  58 ; as an unconditional delimiter.
  59 $FORTH_CODE_WORD ENCLOSE  NOTURNKEY
  60 ;; AberSoft
  61 ;; ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
  62   pop   de  ; E=delimeter
  63   pop   hl  ; HL=addr
  64   push  hl
  65
  66   ld    a,e
  67   ld    d,a
  68   ld    e,#FF
  69   dec   hl
  70
  71   ; here: E=word len; A=delim; HL=addr
  72 enclose0:
  73   ; skip delimiters
  74   inc   hl
  75   inc   e
  76   cp    (hl)
  77   jr    z,enclose0
  78
  79   ld    d,0
  80   push  de          ; store # of delimiters before the word
  81
  82   ld    d,a         ; D=delimiter
  83   ; check for "end of buffer" (#0)
  84   ld    a,(hl)
  85   and   a
  86   jr    nz,enclose1
  87
  88   ; oops... no more blondies
  89   ld    d,0
  90   inc   e
  91   push  de          ; store full length
  92
  93   dec   e
  94   push  de          ; store position of the next char to scan
  95   jp    i_next
  96
  97   ; here: E=word len; D=delim; HL=addr
  98 enclose1:
  99   ; now collect the word itself
 100   ld    a,d
 101   inc   hl
 102   inc   e
 103   cp    (hl)
 104   jr    z,enclose2  ; word ends?
 105   ; no, check "end of buffer"
 106   ld    a,(hl)
 107   and   a
 108   jr    nz,enclose1
 109
 110   ; oops... no more blondies on the island
 111   ld    d,0
 112   push  de          ; store full length
 113   push  de          ; store position of the next char to scan (???)
 114   jp    i_next
 115
 116 enclose2:
 117   ld    d,0
 118   push  de          ; store full length
 119   inc   e
 120   push  de          ; store position of the next char to scan
 121   jp    i_next
 122 $FORTH_END_CODE_WORD ENCLOSE
 123
 124
 125   $IF 0
 126 $FORTH_WORD (FIND-COMPLETION)  NOTURNKEY
 127 ;; ( addr count latest 0 -- addr count oknfa-or-0 )
 128 ;; ( addr count nfa-to-skip 1 -- addr count oknfa-or-0 )
 129     ;;DUMP-STACK KEY DROP
 130   0BRANCH .loop
 131   DUP 0BRANCH .nomore
 132   BRANCH .badlen
 133 .loop:
 134   ;; ( addr count lfa )
 135   @
 136 .loop1:
 137   ;; ( addr count nfa )
 138   DUP 0BRANCH .nomore
 139   ;; ( addr count nfa )
 140     ;;CR >R 2DUP XTYPE [CHAR] | XEMIT R@ ID. R>
 141   2DUP C@ LIT 31 AND > TBRANCH .badlen
 142   ;; ( addr count nfa )
 143     ;;SPACE DUP ID. KEY DROP CR
 144   >R 2DUP R@ 1+ NROT  ;; ( addr count nfa addr count | nfa )
 145   MEMCMP-ID
 146   ;; ( addr count cmpflag | nfa )
 147   R> SWAP
 148     ;;DUMP-STACK KEY DROP
 149   ;; ( addr count nfa cmpflag )
 150   0BRANCH .ifoundher
 151 .badlen:
 152   ;; ( addr count nfa )
 153     ;;DUMP-STACK KEY DROP
 154   NFA->CFA CFA->LFA
 155   BRANCH .loop
 156 .ifoundher:
 157 .nomore:
 158   ;S
 159 $FORTH_END_WORD (FIND-COMPLETION)
 160
 161   $ELSE
 162
 163 $FORTH_CODE_WORD (FIND-COMPLETION)  NOTURNKEY
 164 ;; ( addr count latest 0 -- addr count oknfa-or-0 )
 165 ;; ( addr count nfa-to-skip 1 -- addr count oknfa-or-0 )
 166 fword_find_completion:
 167   pop   hl
 168   exx
 169   ; HL' holds flag
 170   ; now prepare everything for the loop
 171   pop   hl
 172   ld    (fwcompl_curr_lfa),hl
 173   pop   hl
 174   pop   de
 175   ld    a,h
 176   or    a
 177   jr    z,fwcompl_lenok
 178   ; too long
 179 fwcompl_len_fucked:
 180   push  de
 181   push  hl
 182   exx       ; restore BC
 183   jp    i_push_zero
 184 fwcompl_lenok:
 185   ld    a,l
 186   or    a
 187   jr    z,fwcompl_len_fucked
 188   cp    32
 189   jr    nc,fwcompl_len_fucked
 190   ; source word length is ok, write vars
 191   ld    (fwcompl_straddr),de
 192   ld    (fwcompl_strlen_cmp),a
 193   ld    (fwcompl_strlen_cnt),a
 194   ; get back our flag (and BC)
 195   exx
 196   ld    a,h
 197   or    l
 198   jr    z,fwcompl_loop
 199   ld    hl,(fwcompl_curr_lfa)
 200   ; check for zero address
 201   ld    a,h
 202   or    l
 203   jr    z,fwcompl_end_of_list
 204   ; DE is NFA, move do next word
 205   jr    fwcompl_next_word_hl
 206
 207   ; main loop
 208 fwcompl_loop:
 209   ; move to the next lfa
 210   ld    hl,0  ; patched
 211 fwcompl_curr_lfa equ $-2
 212   ld    e,(hl)
 213   inc   hl
 214   ld    d,(hl)
 215   ex    de,hl
 216   ld    (fwcompl_curr_nfa),hl
 217   ld    a,h
 218   or    l
 219   jr    z,fwcompl_end_of_list
 220   ; HL is NFA here
 221   ; compare lengthes
 222   ld    a,(hl)
 223   and   #1F
 224   cp    0  ; patched in the setup code
 225 fwcompl_strlen_cmp equ $-1
 226   jr    c,fwcompl_next_word  ; too long
 227   ; length is ok, compare strings
 228   ld    de,0  ; patched in the setup code
 229 fwcompl_straddr equ $-2
 230   ld    a,0   ; patched in the setup code
 231 fwcompl_strlen_cnt equ $-1
 232   inc   hl
 233   ex    de,hl
 234 fwcompl_scmp_loop:
 235   ex    af,af'
 236   ld    a,(de)
 237   and   #7F
 238   cp    (hl)
 239   jr    nz,fwcompl_next_word
 240   inc   de
 241   inc   hl
 242   ex    af,af'
 243   dec   a
 244   jr    nz,fwcompl_scmp_loop
 245   ; equal, return this word
 246   ld    hl,(fwcompl_straddr)
 247   push  hl
 248   ld    hl,(fwcompl_strlen_cmp)
 249   ld    h,0
 250   push  hl
 251   ld    hl,(fwcompl_curr_nfa)
 252   jp    i_pushhl
 253 fwcompl_next_word:
 254   ld    hl,0  ; patched
 255 fwcompl_curr_nfa equ $-2
 256 fwcompl_next_word_hl:
 257   ld    a,(hl)
 258   and   #1F
 259   ld    e,a
 260   ld    d,0
 261   inc   hl
 262   add   hl,de
 263   ld    (fwcompl_curr_lfa),hl
 264   jr    fwcompl_loop
 265 fwcompl_end_of_list:
 266   ld    hl,(fwcompl_straddr)
 267   push  hl
 268   ld    hl,(fwcompl_strlen_cmp)
 269   ld    h,0
 270   push  hl
 271   ld    l,h
 272   jp    i_pushhl
 273
 274 $FORTH_END_CODE_WORD (FIND-COMPLETION)
 275
 276   $ENDIF
 277
 278   $IF 0
 279 $FORTH_WORD FF0
 280 ;; k8
 281   (") ~D-~  ;;"
 282   CONTEXT @ 0 (FIND-COMPLETION)
 283   CR
 284   DUMP-STACK
 285   ;S
 286 $FORTH_END_WORD FF0
 287
 288 $FORTH_WORD FF1
 289 ;; k8
 290   ;;CR DUP .
 291   DUP 0BRANCH .nomore
 292   DUP ID. CR
 293 .nomore:
 294   1 (FIND-COMPLETION)
 295   DUMP-STACK
 296   ;S
 297 $FORTH_END_WORD FF1
 298   $ENDIF
 299
 300
 301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 302 ;; create word header and vocabulary
 303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 304
 305 ; A defining word used in the form: CREATE cccc
 306 ; by such words as CODE and CONSTANT to create a dictionary header for
 307 ; a Forth definition. The code field contains the routine that returnrn
 308 ; the address of the word's parameter field. The new word is created in
 309 ; the current vocabulary.
 310 ; Note that SMUDGE bit is set (i.e. the word is invisible).
 311 $FORTH_WORD CREATE  NOTURNKEY
 312 ;; k8, AberSoft
 313 ;; ( -- )
 314   $IF VLIST_HASH_BITS
 315     ;; put 0 for hashtable link
 316     HERE >R  ;; save BFA to rstack
 317     0 ,
 318   $ENDIF
 319   ;; check for duplicate word
 320   ;; k8: look only in the current dictionary
 321   BL WORD  ;; ( here )
 322   ;; check for word redefinition?
 323   REDEFCHK @ 0BRANCH create1
 324   CURRENT @ (XFIND) 0BRANCH create0
 325   ;; found duplicate, tell the user about it
 326   ;; (XFIND) already returned name length for us, so use it
 327   LIT 31 AND - 3-  ;; 3- moves from CFA to the last name byte
 328   ENDCR ID. 4 MESSAGE ENDCR ;;SPACE
 329 create0:
 330   ;; counted word name is at HERE
 331   HERE
 332 create1:
 333   DUP C@  ;; ( orig-HERE count )
 334   LIT 31 MIN   ;; was `WIDTH @` instead of `LIT 31`  ( orig-HERE count )
 335   1+ ALLOT     ;; ( orig-HERE )
 336   DUP LIT #A0 TOGGLE  ;; set SMUDGE and BIT7  ( orig-HERE )
 337   ;; ( orig-HERE )
 338   HERE 1- LIT #80 TOGGLE  ;; toggle BIT7 in the last name byte
 339   ;; ( orig-HERE )
 340   ;; put LFA link
 341   LATEST ,
 342   ;; the stack is empty here
 343   ;; save orig-HERE to vocabulary LFAPTR
 344   CURRENT @ !
 345   ;; emit default CFA
 346   LIT 0xCD C,   ;; call
 347   LIT _dovar ,  ;; to _dovar
 348   ;; add to hashtable
 349   $IF VLIST_HASH_BITS
 350     R@ 2+ (XHASHNAME) 2U*  ;; ( hash*2 | bfa )
 351     CURRENT @ (VOC-WLINK->HTBL) +  ;; ( htaddr | bfa )
 352     ;; set [bfa] to [htaddr]
 353     DUP @ R@ !             ;; ( htaddr | bfa )
 354     ;; set [htaddr] to bfa
 355     R> SWAP !
 356   $ENDIF
 357   ;S
 358 $FORTH_END_WORD CREATE
 359
 360
 361 $FORTH_WORD VOCABULARY  NOTURNKEY
 362 ;; AberSoft, k8
 363 ;; ( -- )
 364 ;; $IF !DSFORTH_TURNKEY
 365   CREATE
 366   ;; bfa
 367   $IF VLIST_HASH_BITS
 368     0 ,
 369   $ENDIF
 370   ;; dummy name
 371   LIT #A081 ,
 372
 373   ;; LATEST
 374   ;;!CURRENT @ CFA ,
 375   0 ,  ;; new vocabulary doesn't inherit the old one
 376
 377   ;; link vocabularies
 378   ;;NOTUSED;; HERE VOC-LINK @ ,
 379   ;;NOTUSED;; VOC-LINK !
 380
 381   ;; names hash table
 382   $IF VLIST_HASH_BITS
 383     (CREATE-EMPTY-HASH)
 384   $ENDIF
 385   DOES>
 386 ;; $ENDIF ;; !DSFORTH_TURNKEY
 387 voc_does:
 388   ;; skip over dummy word name
 389   $IF VLIST_HASH_BITS
 390     4+
 391   $ELSE
 392     2+
 393   $ENDIF
 394   CONTEXT !
 395   ;S
 396 $FORTH_END_WORD VOCABULARY
 397
 398 voc_does_code:
 399   pop   hl
 400   inc   hl
 401   inc   hl
 402   $IF VLIST_HASH_BITS
 403   inc   hl
 404   inc   hl
 405   $ENDIF
 406   ld    (f_context),hl
 407   jp    i_next
 408
 409
 410 $FORTH_WORD FORGET  NOTURNKEY
 411 ;; AberSoft
 412 ;; ( -- )
 413   CURRENT @ CONTEXT @ - LIT 24 ?ERROR
 414   ' DUP FENCE @ U< LIT 21 ?ERROR
 415   DUP CFA->NFA DP ! CFA->LFA @ CURRENT @ !
 416   $IF VLIST_HASH_BITS
 417     ;;FIXME: trace and remove instead of rehashing?
 418     CONTEXT @ (VOC-REHASH)
 419   $ENDIF
 420   ;S
 421 $FORTH_END_WORD FORGET