text: updated copyright years
  1: \ LOOK.FS xt -> lfa 22may93jaw 2: 3: \ Copyright (C) 1995,1996,1997,2000,2003: \ Look checks first if the word is a primitive. If yes then the 21: \ vocabulary in the primitive area is beeing searched, meaning 22: \ creating for each word a xt and comparing it... 23: 24: \ If a word is no primitive look searches backwards to find the nfa. 25: \ Problems: A compiled xt via compile, might be created with noname: 26: \ a noname: leaves now a empty name field 27: 28: require stuff.fs 29: require environ.fs 30: 31: decimal 32: 33: \ look 17may93jaw 34: 35: \ rename to discover!!! 36: 37: : xt>threaded ( xt -- x ) 38: \G produces the threaded-code cell for the primitive xt 39: threading-method 0= if 40: @ 41: then ; 42: 43: : search-name ( xt startlfa -- nt|0 ) 44: \ look up name of primitive with code at xt 45: swap 46: >r false swap 47: BEGIN 48: @ dup 49: WHILE 50: dup name>int 51: r@ = IF 52: nip dup 53: THEN 54: REPEAT 55: drop rdrop ; 56: 57: : threaded>xt ( ca -- xt|0 ) 58: \G For the code address ca of a primitive, find the xt (or 0). 59: [IFDEF] decompile-prim 60: decompile-prim 61: [THEN] 62: \ walk through the array of primitive CAs 63: >r ['] noop begin 64: dup @ while 65: dup xt>threaded r@ = if 66: rdrop exit 67: endif 68: cell+ 69: repeat 70: drop rdrop 0 ; 71: 72: \ !!! nicht optimal! 73: [IFUNDEF] look 74: has? ec [IF] 75: 76: has? rom 77: [IF] 78: : prim>name ( xt -- nt|0 ) 79: forth-wordlist @ search-name ; 80: 81: : look ( xt -- lfa flag ) 82: dup [ unlock rom-dictionary area lock ] 83: literal literal within 84: IF 85: >head-noprim dup ?? <> 86: ELSE 87: prim>name dup 0<> 88: THEN ; 89: [ELSE] 90: : look ( cfa -- lfa flag ) 91: >head-noprim dup ??? <> ; 92: [THEN] 93: 94: [ELSE] 95: 96: : PrimStart ['] true >head-noprim ; 97: 98: : prim>name ( xt -- nt|0 ) 99: PrimStart search-name ; 100: 101: : look ( xt -- lfa flag ) 102: dup in-dictionary? 103: IF 104: >head-noprim dup ??? <> 105: ELSE 106: prim>name dup 0<> 107: THEN ; 108: 109: [THEN] 110: [THEN] 111: 112: : threaded>name ( ca -- nt|0 ) 113: threaded>xt prim>name ; 114: 115: : >name ( xt -- nt|0 ) \ gforth to-name 116: \G tries to find the name token @var{nt} of the word represented 117: \G by @var{xt}; returns 0 if it fails. This word is not 118: \G absolutely reliable, it may give false positives and produce 119: \G wrong nts. 120: look and ; 121: 122: ' >name ALIAS >head \ gforth to-head 123: \G another name of @code{>name} 124: 125: \ print recognizer stack 126: 127: [IFDEF] forth-recognizer 128: : .recs ( -- ) 129: forth-recognizer get-recognizers 0 ?DO 130: >name .name 131: LOOP ; 132: [THEN]