Annotation of gforth/look.fs, revision 1.30

1.1       anton       1: \ LOOK.FS      xt -> lfa                               22may93jaw
                      2: 
1.29      anton       3: \ Copyright (C) 1995,1996,1997,2000,2003,2007 Free Software Foundation, Inc.
1.3       anton       4: 
                      5: \ This file is part of Gforth.
                      6: 
                      7: \ Gforth is free software; you can redistribute it and/or
                      8: \ modify it under the terms of the GNU General Public License
1.28      anton       9: \ as published by the Free Software Foundation, either version 3
1.3       anton      10: \ of the License, or (at your option) any later version.
                     11: 
                     12: \ This program is distributed in the hope that it will be useful,
                     13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
                     14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     15: \ GNU General Public License for more details.
                     16: 
                     17: \ You should have received a copy of the GNU General Public License
1.28      anton      18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.3       anton      19: 
1.1       anton      20: \ Look checks first if the word is a primitive. If yes then the
                     21: \ vocabulary in the primitive area is beeing searched, meaning
                     22: \ creating for each word a xt and comparing it...
                     23: 
                     24: \ If a word is no primitive look searches backwards to find the nfa.
                     25: \ Problems: A compiled xt via compile, might be created with noname:
                     26: \           a noname: leaves now a empty name field
                     27: 
1.16      jwilke     28: require stuff.fs
                     29: require environ.fs
                     30: 
1.1       anton      31: decimal
                     32: 
1.8       jwilke     33: \ look                                                  17may93jaw
1.1       anton      34: 
1.8       jwilke     35: \ rename to discover!!!
1.1       anton      36: 
1.18      anton      37: : xt>threaded ( xt -- x )
                     38: \G produces the threaded-code cell for the primitive xt
                     39:     threading-method 0= if
                     40:        @
                     41:     then ;
                     42: 
1.23      anton      43: : search-name  ( xt startlfa -- nt|0 )
1.22      anton      44:     \ look up name of primitive with code at xt
1.20      pazsan     45:     swap
1.21      pazsan     46:     >r false swap
1.17      anton      47:     BEGIN
                     48:        @ dup
                     49:     WHILE
1.22      anton      50:            dup name>int
1.21      pazsan     51:            r@ = IF
1.17      anton      52:                nip dup
                     53:            THEN
                     54:     REPEAT
1.23      anton      55:     drop rdrop ;
1.1       anton      56: 
1.22      anton      57: : threaded>xt ( ca -- xt|0 )
                     58: \G For the code address ca of a primitive, find the xt (or 0).
                     59:     [IFDEF] decompile-prim
                     60:        decompile-prim
                     61:     [THEN]
                     62:      \ walk through the array of primitive CAs
                     63:     >r ['] noop begin
                     64:        dup @ while
                     65:            dup xt>threaded r@ = if
                     66:                rdrop exit
                     67:            endif
                     68:            cell+
                     69:     repeat
                     70:     drop rdrop 0 ;
1.8       jwilke     71: 
                     72: \ !!! nicht optimal!
                     73: [IFUNDEF] look
1.9       jwilke     74: has? ec [IF]
                     75: 
1.10      jwilke     76: has? rom 
1.8       jwilke     77: [IF]
1.23      anton      78: : prim>name ( xt -- nt|0 )
                     79:     forth-wordlist @ search-name ;
1.22      anton      80: 
1.23      anton      81: : look ( xt -- lfa flag )
1.9       jwilke     82:     dup [ unlock rom-dictionary area lock ] 
                     83:     literal literal within
                     84:     IF
1.13      anton      85:        >head-noprim dup ?? <>
1.9       jwilke     86:     ELSE
1.23      anton      87:        prim>name dup 0<>
1.9       jwilke     88:     THEN ;
                     89: [ELSE]
1.8       jwilke     90: : look ( cfa -- lfa flag )
1.13      anton      91:     >head-noprim dup ??? <> ;
1.9       jwilke     92: [THEN]
1.8       jwilke     93: 
                     94: [ELSE]
                     95: 
1.13      anton      96: : PrimStart ['] true >head-noprim ;
1.8       jwilke     97: 
1.23      anton      98: : prim>name ( xt -- nt|0 )
                     99:     PrimStart search-name ;
1.22      anton     100: 
1.23      anton     101: : look ( xt -- lfa flag )
1.12      anton     102:     dup in-dictionary?
1.9       jwilke    103:     IF
1.13      anton     104:        >head-noprim dup ??? <>
1.12      anton     105:     ELSE
1.23      anton     106:        prim>name dup 0<>
1.9       jwilke    107:     THEN ;
1.1       anton     108: 
1.8       jwilke    109: [THEN]
                    110: [THEN]
1.22      anton     111: 
1.23      anton     112: : threaded>name ( ca -- nt|0 )
1.22      anton     113:     threaded>xt prim>name ;
1.13      anton     114: 
1.27      anton     115: : >name ( xt -- nt|0 ) \ gforth to-name
                    116:     \G tries to find the name token @var{nt} of the word represented
                    117:     \G by @var{xt}; returns 0 if it fails.  This word is not
                    118:     \G absolutely reliable, it may give false positives and produce
                    119:     \G wrong nts.
1.13      anton     120:     look and ;
                    121: 
1.27      anton     122: ' >name ALIAS >head \ gforth to-head
                    123: \G another name of @code{>name}
1.30    ! pazsan    124: 
        !           125: \ print recognizer stack
        !           126: 
        !           127: [IFDEF] forth-recognizer
        !           128:     : .recs ( -- )
        !           129:        forth-recognizer get-recognizers 0 ?DO
        !           130:            >name .name
        !           131:        LOOP ;
        !           132: [THEN]

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>