← Back to branch summary

~pmdj/ubuntu/trusty/qemu/2.9+applesmc+fadtv3

« back to all changes in this revision

Viewing changes to roms/SLOF/slof/fs/search.fs

  • Committer: Phil Dennis-Jordan
  • Date: 2017-07-21 08:03:43 UTC
  • mfrom: (1.1.1)
  • Revision ID: phil@philjordan.eu-20170721080343-2yr2vdj7713czahv
New upstream release 2.9.0.

Show diffs side-by-side

added added

removed removed

Lines of Context:
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 ;