version 1.10, 1997/09/13 12:04:56
|
version 1.31, 2011/12/31 15:29:25
|
Line 1
|
Line 1
|
\ LOOK.FS xt -> lfa 22may93jaw |
\ LOOK.FS xt -> lfa 22may93jaw |
|
|
\ Copyright (C) 1995 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,2000,2003,2007,2011 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 15
|
Line 15
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ 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, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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 25
|
\ 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!!! |
|
|
: (look) ( xt startlfa -- lfa flag ) |
: xt>threaded ( xt -- x ) |
false swap |
\G produces the threaded-code cell for the primitive xt |
BEGIN @ dup |
threading-method 0= if |
WHILE dup name>int |
@ |
3 pick = IF nip dup THEN |
then ; |
REPEAT |
|
drop nip |
: search-name ( xt startlfa -- nt|0 ) |
dup 0<> ; |
\ look up name of primitive with code at xt |
|
swap |
|
>r false swap |
|
BEGIN |
|
@ dup |
|
WHILE |
|
dup name>int |
|
r@ = IF |
|
nip dup |
|
THEN |
|
REPEAT |
|
drop rdrop ; |
|
|
|
: threaded>xt ( ca -- xt|0 ) |
|
\G For the code address ca of a primitive, find the xt (or 0). |
|
[IFDEF] decompile-prim |
|
decompile-prim |
|
[THEN] |
|
\ walk through the array of primitive CAs |
|
>r ['] noop begin |
|
dup @ while |
|
dup xt>threaded r@ = if |
|
rdrop exit |
|
endif |
|
cell+ |
|
repeat |
|
drop rdrop 0 ; |
|
|
\ !!! nicht optimal! |
\ !!! nicht optimal! |
[IFUNDEF] look |
[IFUNDEF] look |
Line 48 has? ec [IF]
|
Line 75 has? ec [IF]
|
|
|
has? rom |
has? rom |
[IF] |
[IF] |
: look |
: prim>name ( xt -- nt|0 ) |
|
forth-wordlist @ search-name ; |
|
|
|
: look ( xt -- lfa flag ) |
dup [ unlock rom-dictionary area lock ] |
dup [ unlock rom-dictionary area lock ] |
literal literal within |
literal literal within |
IF |
IF |
>name dup ?? <> |
>head-noprim dup ?? <> |
ELSE |
ELSE |
forth-wordlist @ (look) |
prim>name dup 0<> |
THEN ; |
THEN ; |
[ELSE] |
[ELSE] |
: look ( cfa -- lfa flag ) |
: look ( cfa -- lfa flag ) |
>name dup ??? <> ; |
>head-noprim dup ??? <> ; |
[THEN] |
[THEN] |
|
|
[ELSE] |
[ELSE] |
|
|
: PrimStart ['] true >name ; |
: PrimStart ['] true >head-noprim ; |
|
|
: look ( cfa -- lfa flag ) |
: prim>name ( xt -- nt|0 ) |
dup dictionary-end forthstart within |
PrimStart search-name ; |
|
|
|
: look ( xt -- lfa flag ) |
|
dup in-dictionary? |
IF |
IF |
PrimStart (look) |
>head-noprim dup ??? <> |
ELSE |
ELSE |
>name dup ??? <> |
prim>name dup 0<> |
THEN ; |
THEN ; |
|
|
[THEN] |
[THEN] |
[THEN] |
[THEN] |
|
|
|
: threaded>name ( ca -- nt|0 ) |
|
threaded>xt prim>name ; |
|
|
|
: >name ( xt -- nt|0 ) \ gforth to-name |
|
\G tries to find the name token @var{nt} of the word represented |
|
\G by @var{xt}; returns 0 if it fails. This word is not |
|
\G absolutely reliable, it may give false positives and produce |
|
\G wrong nts. |
|
look and ; |
|
|
|
' >name ALIAS >head \ gforth to-head |
|
\G another name of @code{>name} |
|
|
|
\ print recognizer stack |
|
|
|
[IFDEF] forth-recognizer |
|
: .recs ( -- ) |
|
forth-recognizer get-recognizers 0 ?DO |
|
>name .name |
|
LOOP ; |
|
[THEN] |
|
|