Return to look.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/look.fs, revision 1.16

1.1       anton       1: \ LOOK.FS      xt -> lfa                               22may93jaw
                      2: 
1.14      anton       3: \ Copyright (C) 1995,1996,1997,2000 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: 
                     38: : (look)  ( xt startlfa -- lfa flag )
                     39:         false swap
                     40:         BEGIN @ dup
1.5       anton      41:         WHILE dup name>int
1.1       anton      42:               3 pick = IF nip dup THEN
                     43:         REPEAT
                     44:         drop nip
                     45:         dup 0<> ;
                     46: 
1.8       jwilke     47: 
                     48: \ !!! nicht optimal!
                     49: [IFUNDEF] look
1.9       jwilke     50: has? ec [IF]
                     51: 
1.10      jwilke     52: has? rom 
1.8       jwilke     53: [IF]
1.9       jwilke     54: : look
                     55:     dup [ unlock rom-dictionary area lock ] 
                     56:     literal literal within
                     57:     IF
1.13      anton      58:        >head-noprim dup ?? <>
1.9       jwilke     59:     ELSE
                     60:        forth-wordlist @ (look)
                     61:     THEN ;
                     62: [ELSE]
1.8       jwilke     63: : look ( cfa -- lfa flag )
1.13      anton      64:     >head-noprim dup ??? <> ;
1.9       jwilke     65: [THEN]
1.8       jwilke     66: 
                     67: [ELSE]
                     68: 
1.13      anton      69: : PrimStart ['] true >head-noprim ;
1.8       jwilke     70: 
1.1       anton      71: : look ( cfa -- lfa flag )
1.12      anton      72:     dup in-dictionary?
1.9       jwilke     73:     IF
1.13      anton      74:        >head-noprim dup ??? <>
1.12      anton      75:     ELSE
1.9       jwilke     76:        PrimStart (look)
                     77:     THEN ;
1.1       anton      78: 
1.8       jwilke     79: [THEN]
                     80: [THEN]
1.13      anton      81: 
                     82: : >head ( cfa -- nt|0 ) \ gforth to-head
                     83:     \G tries to find the name token nt of the word represented by cfa;
                     84:     \G returns 0 if it fails.  This word is not absolutely reliable,
                     85:     \G it may give false positives and produce wrong nts.
                     86:     look and ;
                     87: 
                     88: ' >head ALIAS >name \ gforth to-name
                     89: \G old name of @code{>head}