version 1.22, 2003/01/04 08:26:57
|
version 1.24, 2003/01/19 23:35:30
|
Line 1
|
Line 1
|
\ LOOK.FS xt -> lfa 22may93jaw |
\ LOOK.FS xt -> lfa 22may93jaw |
|
|
\ Copyright (C) 1995,1996,1997,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995-2003 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 41 decimal
|
Line 41 decimal
|
@ |
@ |
then ; |
then ; |
|
|
: (look) ( xt startlfa -- lfa flag ) |
: search-name ( xt startlfa -- nt|0 ) |
\ look up name of primitive with code at xt |
\ look up name of primitive with code at xt |
swap |
swap |
>r false swap |
>r false swap |
Line 53 decimal
|
Line 53 decimal
|
nip dup |
nip dup |
THEN |
THEN |
REPEAT |
REPEAT |
drop rdrop |
drop rdrop ; |
dup 0<> ; |
|
|
|
: threaded>xt ( ca -- xt|0 ) |
: threaded>xt ( ca -- xt|0 ) |
\G For the code address ca of a primitive, find the xt (or 0). |
\G For the code address ca of a primitive, find the xt (or 0). |
Line 77 has? ec [IF]
|
Line 76 has? ec [IF]
|
|
|
has? rom |
has? rom |
[IF] |
[IF] |
: prim>name ( xt -- nt flag ) |
: prim>name ( xt -- nt|0 ) |
forth-wordlist @ (look) ; |
forth-wordlist @ search-name ; |
|
|
: look |
: look ( xt -- lfa flag ) |
dup [ unlock rom-dictionary area lock ] |
dup [ unlock rom-dictionary area lock ] |
literal literal within |
literal literal within |
IF |
IF |
>head-noprim dup ?? <> |
>head-noprim dup ?? <> |
ELSE |
ELSE |
xt>threaded threaded>name |
prim>name dup 0<> |
THEN ; |
THEN ; |
[ELSE] |
[ELSE] |
: look ( cfa -- lfa flag ) |
: look ( cfa -- lfa flag ) |
Line 97 has? rom
|
Line 96 has? rom
|
|
|
: PrimStart ['] true >head-noprim ; |
: PrimStart ['] true >head-noprim ; |
|
|
: prim>name ( xt -- lfa flag ) |
: prim>name ( xt -- nt|0 ) |
PrimStart (look) ; |
PrimStart search-name ; |
|
|
: look ( cfa -- lfa flag ) |
: look ( xt -- lfa flag ) |
dup in-dictionary? |
dup in-dictionary? |
IF |
IF |
>head-noprim dup ??? <> |
>head-noprim dup ??? <> |
ELSE |
ELSE |
prim>name |
prim>name dup 0<> |
THEN ; |
THEN ; |
|
|
[THEN] |
[THEN] |
[THEN] |
[THEN] |
|
|
: threaded>name ( ca -- lfa flag ) |
: threaded>name ( ca -- nt|0 ) |
threaded>xt prim>name ; |
threaded>xt prim>name ; |
|
|
: >head ( cfa -- nt|0 ) \ gforth to-head |
: >head ( cfa -- nt|0 ) \ gforth to-head |