Return to vocabulary.fs CVS log

Up to [Qemu by Fabrice Bellard] / qemu / roms / openbios / forth / lib

Annotation of qemu/roms/openbios/forth/lib/vocabulary.fs, revision 1.1.1.1

1.1       root        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?

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.