← Back to branch summary

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

« back to all changes in this revision

Viewing changes to roms/openbios/forth/lib/vocabulary.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/openbios/forth/lib/vocabulary.fs
 
1
\ tag: vocabulary implementation for openbios
 
2
\ 
 
3
\ Copyright (C) 2003 Stefan Reinauer
 
4
\ 
 
5
\ See the file "COPYING" for further information about
 
6
\ the copyright and warranty status of this work.
 
7
\ 
 
8
 
 
9
\ 
 
10
\ this is an implementation of DPANS94 wordlists (SEARCH EXT)
 
11
\ 
 
12
 
 
13
 
 
14
16 constant #vocs
 
15
create vocabularies #vocs cells allot \ word lists
 
16
['] vocabularies to context
 
17
 
 
18
: search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 )
 
19
  \ Find the definition identified by the string c-addr u in the word 
 
20
  \ list identified by wid. If the definition is not found, return zero. 
 
21
  \ If the definition is found, return its execution token xt and
 
22
  \ one (1) if the definition is immediate, minus-one (-1) otherwise.
 
23
  find-wordlist
 
24
  if
 
25
    true over immediate? if
 
26
      negate
 
27
    then
 
28
  else
 
29
    2drop false
 
30
  then
 
31
  ;
 
32
 
 
33
: wordlist ( -- wid )
 
34
  \ Creates a new empty word list, returning its word list identifier 
 
35
  \ wid. The new word list may be returned from a pool of preallocated 
 
36
  \ word lists or may be dynamically allocated in data space. A system 
 
37
  \ shall allow the creation of at least 8 new word lists in addition 
 
38
  \ to any provided as part of the system.
 
39
  here 0 ,
 
40
  ;
 
41
 
 
42
: get-order ( -- wid1 .. widn n )
 
43
  #order @ 0 ?do
 
44
    #order @ i - 1- cells context + @
 
45
  loop
 
46
  #order @
 
47
  ;
 
48
 
 
49
: set-order ( wid1 .. widn n -- )
 
50
  dup -1 = if
 
51
    drop forth-last 1 \ push system default word list and number of lists
 
52
  then
 
53
  dup #order !
 
54
  0 ?do 
 
55
    i cells context + ! 
 
56
  loop
 
57
  ;
 
58
 
 
59
: order ( -- )
 
60
  \ display word lists in the search order in their search order sequence
 
61
  \ from the first searched to last searched. Also display word list into
 
62
  \ which new definitions will be placed. 
 
63
  cr
 
64
  get-order 0 ?do
 
65
    ." wordlist " i (.) type 2e emit space u. cr
 
66
  loop
 
67
  cr ." definitions: " current @ u. cr
 
68
  ;
 
69
 
 
70
  
 
71
: previous ( -- )
 
72
  \ Transform the search order consisting of widn, ... wid2, wid1 (where 
 
73
  \ wid1 is searched first) into widn, ... wid2. An ambiguous condition 
 
74
  \ exists if the search order was empty before PREVIOUS was executed.
 
75
  get-order nip 1- set-order 
 
76
  ;
 
77
 
 
78
  
 
79
: do-vocabulary ( -- )  \ implementation factor
 
80
  does> 
 
81
    @ >r                (  ) ( R: widnew )
 
82
    get-order swap drop ( wid1 ... widn-1 n )
 
83
    r> swap set-order
 
84
  ;
 
85
 
 
86
: discard ( x1 .. xu u - ) \ implementation factor
 
87
  0 ?do 
 
88
    drop 
 
89
  loop
 
90
  ;
 
91
 
 
92
: vocabulary ( >name -- )
 
93
  wordlist create , do-vocabulary
 
94
  ;
 
95
 
 
96
: also  ( -- )
 
97
  get-order over swap 1+ set-order
 
98
  ;
 
99
 
 
100
: only  ( -- ) 
 
101
  -1 set-order also
 
102
  ;
 
103
 
 
104
only
 
105
 
 
106
\ create forth forth-wordlist , do-vocabulary
 
107
create forth get-order over , discard do-vocabulary
 
108
 
 
109
: findw  ( c-addr -- c-addr 0 | w 1 | w -1 )
 
110
  0                     ( c-addr 0 )
 
111
  #order @ 0 ?do
 
112
    over count          ( c-addr 0 c-addr' u       )
 
113
    i cells context + @ ( c-addr 0 c-addr' u wid   )
 
114
    search-wordlist     ( c-addr 0; 0 | w 1 | w -1 )
 
115
    ?dup if             ( c-addr 0; w 1 | w -1     )
 
116
      2swap 2drop leave ( w 1 | w -1 )
 
117
    then                ( c-addr 0   )
 
118
  loop                  ( c-addr 0 | w 1 | w -1    )
 
119
  ;
 
120
 
 
121
: get-current ( -- wid )
 
122
  current @
 
123
  ;
 
124
 
 
125
: set-current ( wid -- )
 
126
  current !
 
127
  ;
 
128
 
 
129
: definitions ( -- )
 
130
  \ Make the compilation word list the same as the first word list in 
 
131
  \ the search order. Specifies that the names of subsequent definitions 
 
132
  \ will be placed in the compilation word list.
 
133
  \ Subsequent changes in the search order will not affect the 
 
134
  \ compilation word list.
 
135
  context @ set-current
 
136
  ;
 
137
  
 
138
: forth-wordlist ( -- wid )
 
139
  forth-last
 
140
  ;
 
141
 
 
142
: #words ( -- )
 
143
  0 last
 
144
  begin 
 
145
    @ ?dup 
 
146
  while
 
147
    swap 1+ swap
 
148
  repeat
 
149
  
 
150
  cr
 
151
  ;
 
152
 
 
153
true to vocabularies?