version 1.13, 2000/05/27 09:41:28
|
version 1.19, 2002/12/13 21:20:39
|
Line 1
|
Line 1
|
\ LOOK.FS xt -> lfa 22may93jaw |
\ LOOK.FS xt -> lfa 22may93jaw |
|
|
\ Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 16
|
Line 16
|
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program; if not, write to the Free Software |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
\ Look checks first if the word is a primitive. If yes then the |
\ Look checks first if the word is a primitive. If yes then the |
\ vocabulary in the primitive area is beeing searched, meaning |
\ vocabulary in the primitive area is beeing searched, meaning |
Line 26
|
Line 26
|
\ Problems: A compiled xt via compile, might be created with noname: |
\ Problems: A compiled xt via compile, might be created with noname: |
\ a noname: leaves now a empty name field |
\ a noname: leaves now a empty name field |
|
|
|
require stuff.fs |
|
require environ.fs |
|
|
decimal |
decimal |
|
|
\ look 17may93jaw |
\ look 17may93jaw |
|
|
\ rename to discover!!! |
\ rename to discover!!! |
|
|
|
: xt>threaded ( xt -- x ) |
|
\G produces the threaded-code cell for the primitive xt |
|
threading-method 0= if |
|
@ |
|
then ; |
|
|
: (look) ( xt startlfa -- lfa flag ) |
: (look) ( xt startlfa -- lfa flag ) |
false swap |
swap decompile-prim false rot |
BEGIN @ dup |
BEGIN |
WHILE dup name>int |
@ dup |
3 pick = IF nip dup THEN |
WHILE |
REPEAT |
dup name>int xt>threaded |
drop nip |
3 pick = IF |
dup 0<> ; |
nip dup |
|
THEN |
|
REPEAT |
|
drop nip |
|
dup 0<> ; |
|
|
|
|
\ !!! nicht optimal! |
\ !!! nicht optimal! |