fth/flkdict.fs

   1 \  FLK basic dictionary management
   2 \
   3 \  Copyright (C) 1998 Lars Krueger
   4 \
   5 \  This file is part of FLK.
   6 \
   7 \  FLK is free software; you can redistribute it and/or
   8 \  modify it under the terms of the GNU General Public License
   9 \  as published by the Free Software Foundation; either version 2
  10 \  of the License, or (at your option) any later version.
  11 \
  12 \  This program is distributed in the hope that it will be useful,
  13 \  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 \  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 \  GNU General Public License for more details.
  16 \
  17 \  You should have received a copy of the GNU General Public License
  18 \  along with this program; if not, write to the Free Software
  19 \  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21 \ $Id: flkdict.fs,v 1.18 1998/08/30 10:50:59 root Exp $
  22 \ $Log: flkdict.fs,v $
  23 \ Revision 1.18  1998/08/30 10:50:59  root
  24 \ new optimizing algorithm
  25 \
  26 \ Revision 1.17  1998/07/05 18:45:25  root
  27 \ bugs corrected, added X forms routines, .faulty-word added
  28 \
  29 \ Revision 1.16  1998/07/03 20:57:50  root
  30 \ level 2 optimimizer added
  31 \
  32 \ Revision 1.15  1998/07/03 09:09:28  root
  33 \ support for level 2 optimizer
  34 \
  35 \ Revision 1.14  1998/06/01 17:51:42  root
  36 \ SEE shows the sourcefile using VIEW
  37 \
  38 \ Revision 1.13  1998/05/27 18:52:12  root
  39 \ \: commants added for SEE and HELP
  40 \
  41 \ Revision 1.12  1998/05/21 19:24:49  root
  42 \ XForms support
  43 \
  44 \ Revision 1.11  1998/05/09 21:47:05  root
  45 \ relocation-drop fixed (corrects a bug in "r, does>" )
  46 \
  47 \ Revision 1.10  1998/05/03 12:06:37  root
  48 \ added macro support
  49 \
  50 \ Revision 1.9  1998/05/01 18:11:25  root
  51 \ GNU license text added
  52 \ comments checked
  53 \
  54 \ Revision 1.8  1998/04/30 09:42:25  root
  55 \ Comments added.
  56 \
  57 \ Revision 1.7  1998/04/29 18:20:30  root
  58 \ better hash function
  59 \
  60 \ Revision 1.6  1998/04/24 16:47:39  root
  61 \ float support corrected
  62 \
  63 \ Revision 1.5  1998/04/15 18:15:30  root
  64 \ align changed for float support
  65 \
  66 \ Revision 1.4  1998/04/11 11:55:44  root
  67 \ FORGET/MARKER support added
  68 \
  69 \ Revision 1.3  1998/04/10 14:42:50  root
  70 \ bugs corrected
  71 \
  72 \ Revision 1.2  1998/04/09 11:35:03  root
  73 \ fixed SEARCH-WORDLIST (visibility check added)
  74 \
  75 \ Revision 1.1  1998/04/07 20:10:33  root
  76 \ Initial revision
  77 \
  78
  79 #BUCKETS CONSTANT #BUCKETS
  80
  81 \ Calculate the dictionary hash function from the given string. The return
  82 \ hash is limited to 0..#BUCKETS-1.
  83 : (calc-hash)         ( ca u -- hash )
  84 ( OK )
  85   OVER C@ 2*        \ ca u hash
  86   OVER 1 > IF         \ ca u hash
  87     ROT CHAR+ C@ + DUP 2* +     \ u hash
  88   ELSE
  89     ROT DROP        \ u hash
  90   THEN
  91   +
  92   #BUCKETS MOD ;
  93
  94 [META] HF-IMMEDIATE [PREVIOUS] CONSTANT HF-IMMEDIATE
  95 [META] HF-OIMMEDIATE [PREVIOUS] CONSTANT HF-OIMMEDIATE
  96 [META] HF-VISIBLE [PREVIOUS] CONSTANT HF-VISIBLE
  97 [META] HF-CREATED [PREVIOUS] CONSTANT HF-CREATED
  98
  99 \ Are we case insensitive?
 100 VARIABLE CAPS
 101
 102 \ Case sensitive/insensitive compare depending on the value in CAPS.
 103 : (swl-COMPARE)
 104 ( OK )
 105   CAPS @ IF
 106     CAPS-COMPARE
 107   ELSE
 108     COMPARE
 109   THEN ;
 110
 111 \ Print the name of the wordlist wid.
 112 : .VOC          ( wid -- )
 113 ( OK )
 114   DUP #BUCKETS CELLS + CELL+ COUNT  \ wid addr len
 115   DUP 0= IF         \ wid add len
 116     2DROP ." unnamed(" .addr ." ) "
 117   ELSE
 118     TYPE SPACE DROP
 119   THEN ;
 120
 121 \ Which wordlists are known?
 122 : VOCS          ( -- )
 123   ." Known wordlists: "  CR
 124   voc-link BEGIN      \ wid
 125     DUP .VOC #BUCKETS CELLS + @
 126     DUP IMAGE-BASE =
 127   UNTIL DROP CR
 128 ;
 129
 130 \ See standard.
 131 : DEPTH SP-BASE SP@ - 2 RSHIFT 1- ;
 132 ( OK )
 133
 134 \ See standard.
 135 : .S          ( -- )
 136 ( OK )
 137   BASE @ >R
 138   DEPTH         \ depth
 139   DECIMAL
 140   DUP ." <" 1 .R ." > "     \ depth
 141   8 MIN DUP 0 ?DO       \ ind
 142     DUP PICK
 143     . 1-
 144   LOOP DROP CR
 145   R> BASE ! ;
 146
 147 \ See standard.
 148 : SEARCH-WORDLIST       ( c-addr u wid -- 0 | xt 1 | xt -1 )
 149 ( OK )
 150   -ROT          \ wid ca u
 151   2DUP (calc-hash)      \ wid ca u hash
 152   CELLS         \ wid ca u offs
 153   TURN +        \ ca u &head
 154   BEGIN         \ ca u &head
 155     @           \ ca u xt
 156     DUP         \ ca u xt xt
 157     IMAGE-BASE <>
 158   WHILE         \ ca u xt
 159     DUP >NAME COUNT       \ ca u xt na nl
 160     ROT >R        \ ca u na nl / r: xt
 161     2OVER         \ ca u na nl ca u / r: xt
 162     (swl-COMPARE) 0= IF     \ ca u / r: xt
 163       R>        \ ca u xt
 164       DUP >FLAGS C@       \ ca u xt flags
 165       DUP HF-VISIBLE AND IF     \ ca u xt flags
 166         2SWAP 2DROP       \ xt flags
 167   HF-IMMEDIATE AND
 168   IF 1 ELSE -1 THEN
 169   EXIT
 170       ELSE        \ ca u xt flags
 171         DROP >R
 172       THEN
 173     THEN        \ ca u
 174     R>          \ ca u xt
 175   REPEAT        \ ca u image-base
 176   DROP 2DROP 0 ;
 177
 178 \ Storage area for wid's.
 179 #IN-ORDER CONSTANT #IN-ORDER
 180 CREATE ((order-field)) #IN-ORDER CELLS ALLOT
 181 VARIABLE ((order-cnt))
 182
 183 CREATE ((unique-order)) #IN-ORDER CELLS ALLOT
 184 VARIABLE ((unique-cnt))
 185
 186 \ Put the given wordlist-id into ((unique-order)) if it is not in it yet.
 187 : (unique-set-order)      ( wid -- )
 188   ((unique-cnt)) @ 0 ?DO
 189     I CELLS ((unique-order)) + @  \ wid wid-u
 190     OVER = IF         \ wid
 191       DROP UNLOOP EXIT
 192     THEN
 193   LOOP
 194   ((unique-order)) ((unique-cnt)) @ CELLS + !
 195   1 ((unique-cnt)) +!
 196 ;
 197
 198 \ See standard.
 199 : SET-ORDER         ( widn ... wid1 n -- )
 200 ( OK )
 201   DUP #IN-ORDER       \ ... n n max
 202   < INVERT IF -49 THROW THEN    \ .. n
 203   DUP 0= IF -50 THROW THEN    \ .. n
 204   DUP ((order-cnt)) !
 205   0 ((unique-cnt)) !
 206   0 DO          \ ... wid
 207     DUP (unique-set-order)
 208     I CELLS
 209     ((order-field)) + !
 210   LOOP ;
 211
 212 \ See standard.
 213 : GET-ORDER         ( -- widn ... wid1 n )
 214 ( OK )
 215   ((order-cnt)) @       \ n
 216   0 ?DO
 217     ((order-cnt)) @ 1- I - CELLS
 218     ((order-field)) + @
 219   LOOP
 220   ((order-cnt)) @ ;
 221
 222 \ Which wordlist is searched first?
 223 : TOP-VOC         ( -- wid )
 224 ( OK )
 225   ((order-field)) @ ;
 226
 227 VARIABLE (current)
 228
 229 \ See standard.
 230 : SET-CURRENT         ( wid -- )
 231 ( OK )
 232   (current) ! ;
 233
 234 \ See standard.
 235 : GET-CURRENT         ( -- wid )
 236 ( OK )
 237   (current) @ ;
 238
 239 \ See standard.
 240 : ORDER         ( -- )
 241 ( OK )
 242   ." Search order: "
 243   GET-ORDER 0 DO .VOC LOOP CR
 244   ." current: "
 245   GET-CURRENT .VOC CR ;
 246
 247 \ Same function as FIND, just more useful interface ( and faster too ).
 248 : SEARCH-WORDLISTS        ( c-addr u -- 0 / xt 1 / xt -1 )
 249 ( OK )
 250   ((unique-cnt)) @ 0 DO     \ c u
 251     2DUP        \ c u c u
 252     I CELLS ((unique-order)) + @    \ c u c u wid
 253     SEARCH-WORDLIST       \ c u ( 0 / xt imm ? )
 254     ?DUP IF         \ c u xt imm?
 255       2SWAP 2DROP       \ xt imm?
 256       UNLOOP EXIT
 257     THEN        \ c u
 258   LOOP
 259   2DROP 0 ;
 260
 261 \ See standard.
 262 : FIND      ( c-addr -- c-addr 0  |  xt 1  |  xt -1 )
 263 ( OK )
 264   DUP           \ co
 265   COUNT         \ co c u
 266   SEARCH-WORDLISTS      \ co ( 0 / xt flag )
 267   DUP IF
 268     ROT DROP
 269   THEN ;
 270
 271 ' NOOP RVALUE ALLOT-HOOK
 272 ' NOOP RVALUE CALLOT-HOOK
 273
 274 \ See standard.
 275 : ALLOT         ( n -- )
 276 ( OK )
 277   DUP 0> IF
 278     DUP UNUSED < INVERT IF
 279       -8 THROW
 280     THEN
 281   THEN
 282   +TO HERE ALLOT-HOOK EXECUTE ;
 283
 284 \ Store one item into the relocation table.
 285 : relocation!         ( x -- )
 286 ( OK )
 287   RELOCATION-TABLE@ SWAP IMAGE-BASE - []+= RELOCATION-TABLE! ;
 288
 289 \ remove all entries higher than addr but only in code area
 290 : relocation-drop       ( addr -- )
 291   IMAGE-BASE -        \ rel-addr
 292   RELOCATION-TABLE@       \ ra rt
 293   DUP []#         \ ra rt #rt
 294   BEGIN
 295     1- 2DUP         \ ra rt ind rt ind
 296     []@         \ ra rt ind cont
 297     FLOCK OVER        \ ra rt ind cont ra cont
 298     <
 299   WHILE         \ ra rt ind cont
 300     HA-CODESIZE @ < IF      \ ra rt ind
 301       ( cont is in code area )
 302       2DUP []-delete
 303     THEN
 304   REPEAT        \ ra rt ind cont
 305   2DROP 2DROP ;
 306
 307 \ See standard.
 308 : ,           ( x -- )
 309 ( OK )
 310   HERE 1 CELLS ALLOT ! ;
 311
 312 \ See standard.
 313 : C,          ( char -- )
 314 ( OK )
 315   HERE 1 CHARS ALLOT C! ;
 316
 317 \ Same as , but relocate the value.
 318 : r,          ( x -- )
 319 ( OK )
 320   HERE relocation! , ;
 321
 322 \ Same as ALLOT but in code area.
 323 : CALLOT        ( n -- )
 324 ( OK )
 325   DUP 0> IF
 326     DUP CUNUSED < INVERT IF
 327       -8 THROW
 328     THEN
 329   THEN
 330   +TO CHERE CALLOT-HOOK EXECUTE ;
 331
 332 \ Same as , but in code area.
 333 : c-,           ( x -- )
 334 ( OK )
 335   CHERE 1 CELLS CALLOT ! ;
 336
 337 \ Same as C, but in code area.
 338 : c-C,          ( char -- )
 339 ( OK )
 340   CHERE 1 CHARS CALLOT C! ;
 341
 342 \ Same as r, but in code area.
 343 : c-r,          ( x -- )
 344 ( OK )
 345   CHERE relocation! c-, ;
 346
 347 \ The assembler uses different names.
 348 : asm-r,   c-r, ;
 349
 350 \ The assembler uses different names.
 351 : asm-,    c-,  ;
 352
 353 \ The assembler uses different names.
 354 : asm-c,   c-C, ;
 355
 356 \ The assembler uses different names.
 357 : asm-here CHERE ;
 358
 359 \ The assembler uses different names.
 360 : asm-c!   C! ;
 361
 362 \ The assembler uses different names.
 363 : asm-!    ! ;
 364
 365 \ Align primitive. Used as an short-cut for the various ALIGNs (FLOATING POINT
 366 \ wordset).
 367 : (align)         ( new-here -- )
 368   DUP HERE-LIMIT >= IF -8 THROW THEN
 369   TO HERE ;
 370
 371 \ See standard.
 372 : ALIGN         ( -- )
 373 ( OK )
 374   HERE ALIGNED (align) ;
 375
 376 \ See standard.
 377 : WORDLIST        ( -- wid )
 378 ( OK )
 379   HERE
 380   #BUCKETS 0 DO
 381      IMAGE-BASE r,
 382   LOOP
 383   voc-link r,
 384   DUP TO voc-link
 385   0 C, ( name ) ;
 386
 387 \ See standard.
 388 : ALSO          ( -- )
 389 ( OK )
 390   GET-ORDER OVER SWAP 1+ SET-ORDER ;
 391
 392 \ See standard.
 393 : PREVIOUS          ( -- )
 394 ( OK )
 395   GET-ORDER         \ wid... n
 396   DUP 1 > IF
 397     1- NIP
 398   THEN
 399   SET-ORDER ;
 400
 401 \ See standard.
 402 : ONLY        ( -- )
 403 ( OK )
 404   FORTH-WORDLIST 1 SET-ORDER ;
 405
 406 \ See standard.
 407 : FORTH         ( -- )
 408 ( OK )
 409   GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ;
 410
 411 \ See standard.
 412 : ASSEMBLER         ( -- )
 413 ( OK )
 414   GET-ORDER NIP ASSEMBLER-WORDLIST SWAP SET-ORDER ;
 415
 416 \ See standard.
 417 : EDITOR        ( -- )
 418 ( OK )
 419   GET-ORDER NIP EDITOR-WORDLIST SWAP SET-ORDER ;
 420
 421 \ Put the environment wordlist on top of the search order. This is not allowed
 422 \ in a standard program and is only nessesary whenever new environment query
 423 \ items arrive.
 424 : ENVIRONMENT         ( -- )
 425 ( OK )
 426   GET-ORDER NIP ENVIRONMENT-WORDLIST SWAP SET-ORDER ;
 427
 428 \ Drop n items and n too.
 429 : nDROP         ( n*x n -- )
 430 ( OK )
 431   0 ?DO
 432     DROP
 433   LOOP ;
 434
 435 \ See standard.
 436 : DEFINITIONS         ( -- )
 437 ( OK )
 438   TOP-VOC SET-CURRENT ;