--- gforth/look.fs 2002/12/13 21:20:39 1.19 +++ gforth/look.fs 2003/01/19 23:35:30 1.24 @@ -1,6 +1,6 @@ \ 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. @@ -41,19 +41,34 @@ decimal @ then ; -: (look) ( xt startlfa -- lfa flag ) - swap decompile-prim false rot +: search-name ( xt startlfa -- nt|0 ) + \ look up name of primitive with code at xt + swap + >r false swap BEGIN @ dup WHILE - dup name>int xt>threaded - 3 pick = IF + dup name>int + r@ = IF nip dup THEN REPEAT - drop nip - dup 0<> ; + 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! [IFUNDEF] look @@ -61,13 +76,16 @@ has? ec [IF] has? rom [IF] -: look +: prim>name ( xt -- nt|0 ) + forth-wordlist @ search-name ; + +: look ( xt -- lfa flag ) dup [ unlock rom-dictionary area lock ] literal literal within IF >head-noprim dup ?? <> ELSE - forth-wordlist @ (look) + prim>name dup 0<> THEN ; [ELSE] : look ( cfa -- lfa flag ) @@ -78,17 +96,23 @@ has? rom : PrimStart ['] true >head-noprim ; -: look ( cfa -- lfa flag ) +: prim>name ( xt -- nt|0 ) + PrimStart search-name ; + +: look ( xt -- lfa flag ) dup in-dictionary? IF >head-noprim dup ??? <> ELSE - PrimStart (look) + prim>name dup 0<> THEN ; [THEN] [THEN] +: threaded>name ( ca -- nt|0 ) + threaded>xt prim>name ; + : >head ( cfa -- nt|0 ) \ gforth to-head \G tries to find the name token nt of the word represented by cfa; \G returns 0 if it fails. This word is not absolutely reliable,