Annotation of gforth/look.fs, revision 1.26

1.1       anton       1: \ LOOK.FS      xt -> lfa                               22may93jaw
                      2: 
1.26    ! anton       3: \ Copyright (C) 1995,1996,1997,2000,2003 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
                      9: \ as published by the Free Software Foundation; either version 2
                     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
                     18: \ along with this program; if not, write to the Free Software
1.15      anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.3       anton      20: 
1.1       anton      21: \ Look checks first if the word is a primitive. If yes then the
                     22: \ vocabulary in the primitive area is beeing searched, meaning
                     23: \ creating for each word a xt and comparing it...
                     24: 
                     25: \ If a word is no primitive look searches backwards to find the nfa.
                     26: \ Problems: A compiled xt via compile, might be created with noname:
                     27: \           a noname: leaves now a empty name field
                     28: 
1.16      jwilke     29: require stuff.fs
                     30: require environ.fs
                     31: 
1.1       anton      32: decimal
                     33: 
1.8       jwilke     34: \ look                                                  17may93jaw
1.1       anton      35: 
1.8       jwilke     36: \ rename to discover!!!
1.1       anton      37: 
1.18      anton      38: : xt>threaded ( xt -- x )
                     39: \G produces the threaded-code cell for the primitive xt
                     40:     threading-method 0= if
                     41:        @
                     42:     then ;
                     43: 
1.23      anton      44: : search-name  ( xt startlfa -- nt|0 )
1.22      anton      45:     \ look up name of primitive with code at xt
1.20      pazsan     46:     swap
1.21      pazsan     47:     >r false swap
1.17      anton      48:     BEGIN
                     49:        @ dup
                     50:     WHILE
1.22      anton      51:            dup name>int
1.21      pazsan     52:            r@ = IF
1.17      anton      53:                nip dup
                     54:            THEN
                     55:     REPEAT
1.23      anton      56:     drop rdrop ;
1.1       anton      57: 
1.22      anton      58: : threaded>xt ( ca -- xt|0 )
                     59: \G For the code address ca of a primitive, find the xt (or 0).
                     60:     [IFDEF] decompile-prim
                     61:        decompile-prim
                     62:     [THEN]
                     63:      \ walk through the array of primitive CAs
                     64:     >r ['] noop begin
                     65:        dup @ while
                     66:            dup xt>threaded r@ = if
                     67:                rdrop exit
                     68:            endif
                     69:            cell+
                     70:     repeat
                     71:     drop rdrop 0 ;
1.8       jwilke     72: 
                     73: \ !!! nicht optimal!
                     74: [IFUNDEF] look
1.9       jwilke     75: has? ec [IF]
                     76: 
1.10      jwilke     77: has? rom 
1.8       jwilke     78: [IF]
1.23      anton      79: : prim>name ( xt -- nt|0 )
                     80:     forth-wordlist @ search-name ;
1.22      anton      81: 
1.23      anton      82: : look ( xt -- lfa flag )
1.9       jwilke     83:     dup [ unlock rom-dictionary area lock ] 
                     84:     literal literal within
                     85:     IF
1.13      anton      86:        >head-noprim dup ?? <>
1.9       jwilke     87:     ELSE
1.23      anton      88:        prim>name dup 0<>
1.9       jwilke     89:     THEN ;
                     90: [ELSE]
1.8       jwilke     91: : look ( cfa -- lfa flag )
1.13      anton      92:     >head-noprim dup ??? <> ;
1.9       jwilke     93: [THEN]
1.8       jwilke     94: 
                     95: [ELSE]
                     96: 
1.13      anton      97: : PrimStart ['] true >head-noprim ;
1.8       jwilke     98: 
1.23      anton      99: : prim>name ( xt -- nt|0 )
                    100:     PrimStart search-name ;
1.22      anton     101: 
1.23      anton     102: : look ( xt -- lfa flag )
1.12      anton     103:     dup in-dictionary?
1.9       jwilke    104:     IF
1.13      anton     105:        >head-noprim dup ??? <>
1.12      anton     106:     ELSE
1.23      anton     107:        prim>name dup 0<>
1.9       jwilke    108:     THEN ;
1.1       anton     109: 
1.8       jwilke    110: [THEN]
                    111: [THEN]
1.22      anton     112: 
1.23      anton     113: : threaded>name ( ca -- nt|0 )
1.22      anton     114:     threaded>xt prim>name ;
1.13      anton     115: 
                    116: : >head ( cfa -- nt|0 ) \ gforth to-head
                    117:     \G tries to find the name token nt of the word represented by cfa;
                    118:     \G returns 0 if it fails.  This word is not absolutely reliable,
                    119:     \G it may give false positives and produce wrong nts.
                    120:     look and ;
                    121: 
                    122: ' >head ALIAS >name \ gforth to-name
                    123: \G old name of @code{>head}

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