qemu/roms/SLOF/slof/fs/search.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2008 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12 \
  13 \ Copyright 2002,2003,2004  Segher Boessenkool  <segher@kernel.crashing.org>
  14 \
  15
  16
  17 \ stuff we should already have:
  18
  19 : linked ( var -- )  here over @ , swap ! ;
  20
  21 HEX
  22
  23 \ \ \
  24 \ \ \   Wordlists
  25 \ \ \
  26
  27 VARIABLE wordlists  forth-wordlist wordlists !
  28
  29 \ create a new wordlist
  30 : wordlist ( -- wid )  here wordlists linked 0 , ;
  31
  32
  33 \ \ \
  34 \ \ \   Search order
  35 \ \ \
  36
  37 10 CONSTANT max-in-search-order \ should define elsewhere
  38 \ CREATE search-order max-in-search-order cells allot   \ stack of wids \ is in engine now
  39 \ search-order VALUE context    \ top of stack  \ is in engine now
  40
  41 : also ( -- )  clean-hash  context dup cell+ dup to context  >r @ r> ! ;
  42 : previous ( -- )  clean-hash  context cell- to context ;
  43 : only ( -- )  clean-hash  search-order to context  ( minimal-wordlist search-order ! ) ;
  44 : seal ( -- )  clean-hash  context @  search-order dup to context  ! ;
  45
  46 : get-order ( -- wid_n .. wid_1 n )
  47         context >r search-order BEGIN dup r@ u<= WHILE
  48         dup @ swap cell+ REPEAT r> drop
  49         search-order - cell / ;
  50 : set-order ( wid_n .. wid_1 n -- )     \ XXX: special cases for 0, -1
  51         clean-hash  1- cells search-order + dup to context
  52         BEGIN dup search-order u>= WHILE
  53         dup >r ! r> cell- REPEAT drop ;
  54
  55
  56 \ \ \
  57 \ \ \   Compilation wordlist
  58 \ \ \
  59
  60 : get-current ( -- wid )  current ;
  61 : set-current ( wid -- )  to current ;
  62
  63 : definitions ( -- )  context @ set-current ;
  64
  65
  66 \ \ \
  67 \ \ \   Vocabularies
  68 \ \ \
  69
  70 : VOCABULARY ( C: "name" -- ) ( -- )  CREATE wordlist drop  DOES> clean-hash  context ! ;
  71 \ : VOCABULARY ( C: "name" -- ) ( -- )  wordlist CREATE ,  DOES> @ context ! ;
  72 \ XXX we'd like to swap forth and forth-wordlist around (for .voc 's sake)
  73 : FORTH ( -- )  clean-hash  forth-wordlist context ! ;
  74
  75 : .voc ( wid -- ) \ display name for wid \ needs work ( body> or something like that )
  76         dup cell- @ ['] vocabulary ['] forth within IF
  77         2 cells - >name name>string type ELSE u. THEN  space ;
  78 : vocs ( -- ) \ display all wordlist names
  79         cr wordlists BEGIN @ dup WHILE dup .voc REPEAT drop ;
  80 : order ( -- )
  81         cr ." context:  " get-order 0 ?DO .voc LOOP
  82         cr ." current:  " get-current .voc ;
  83
  84
  85
  86
  87 \ some handy helper
  88 : voc-find ( wid -- 0 | link )
  89    clean-hash  cell+ @ (find)  clean-hash ;