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     ! 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.