wordinfo.fs 2.85 KB
Newer Older
anton's avatar
anton committed
1 2
\ WORDINFO.FS  V1.0                                    17may93jaw

Anton Ertl's avatar
Anton Ertl committed
3
\ Copyright (C) 1995,1996,1998,2000,2003,2007,2012,2013,2014,2018 Free Software Foundation, Inc.
anton's avatar
anton committed
4 5 6 7 8

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
9
\ as published by the Free Software Foundation, either version 3
anton's avatar
anton committed
10 11 12 13 14 15 16 17
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
18
\ along with this program. If not, see http://www.gnu.org/licenses/.
anton's avatar
anton committed
19

anton's avatar
anton committed
20 21 22 23
\ May be cross-compiled
\ If you want check values then exclude comments,
\ but keep in mind that this can't be cross-compiled

24
require look.fs
anton's avatar
anton committed
25 26 27 28 29 30

\ Wordinfo is a tool that checks a nfa
\ and finds out what wordtype we have
\ it is used in SEE.FS

: var?  ( nfa -- flag )
anton's avatar
anton committed
31
    ((name>)) >code-address dovar: = ;
anton's avatar
anton committed
32 33

: con?  ( nfa -- flag )
anton's avatar
anton committed
34
    ((name>)) >code-address docon: = ;
anton's avatar
anton committed
35

36
: user?  ( nfa -- flag )
anton's avatar
anton committed
37
    ((name>)) >code-address douser: = ;
38

anton's avatar
anton committed
39
: does? ( nfa -- flag )
anton's avatar
anton committed
40
    ((name>))
41
    >does-code 0<> ;
anton's avatar
anton committed
42 43

: defered? ( nfa -- flag )
anton's avatar
anton committed
44
    ((name>)) >code-address dodefer: = ;
anton's avatar
anton committed
45 46

: colon? ( nfa -- flag )
anton's avatar
anton committed
47
    ((name>)) >code-address docol: = ;
48 49 50

\ the above words could be factored with create-does>, but this would
\ probably make this file incompatible with cross.
anton's avatar
anton committed
51

jwilke's avatar
jwilke committed
52
[IFDEF] forthstart
Bernd Paysan's avatar
Bernd Paysan committed
53 54 55
    : xtprim? ( xt -- flag )
	>code-address ['] noop >code-address
	['] image-header >link @ >code-address 1+ within ;
jwilke's avatar
jwilke committed
56 57
[ELSE]
: xtprim? ( xt -- flag )
anton's avatar
anton committed
58 59
    dup >body swap >code-address = ; \ !! works only for indirect threaded code
				     \ !! does not work for primitives
jwilke's avatar
jwilke committed
60
[THEN]
anton's avatar
anton committed
61
: prim? ( nfa -- flag )
jwilke's avatar
jwilke committed
62
        name>int xtprim? ;
anton's avatar
anton committed
63 64 65 66 67 68 69 70 71 72 73 74 75

\ None nestable IDs:

1 CONSTANT Pri#         \ Primitives
2 CONSTANT Con#         \ Constants
3 CONSTANT Var#         \ Variables
4 CONSTANT Val#         \ Values

\ Nestabe IDs:

5 CONSTANT Doe#         \ Does part
6 CONSTANT Def#         \ Defer
7 CONSTANT Col#         \ Colon def
76
8 CONSTANT Use#         \ User variable
anton's avatar
anton committed
77 78 79

\ Nobody knows:

80
9 CONSTANT Ali#         \ Alias
anton's avatar
anton committed
81

82
10 CONSTANT Str#         \ Structure words
anton's avatar
anton committed
83

84
11 CONSTANT Com#        \ Compiler directives : ; POSTPONE
anton's avatar
anton committed
85 86

CREATE InfoTable
87 88 89 90 91
        ' Prim?    A, Pri# ,
        ' Alias?   A, Ali# ,
        ' Con?     A, Con# ,
        ' Var?     A, Var# ,
\        ' Value?  A, Val# ,
anton's avatar
anton committed
92
        ' Defered? A, Def# ,
93 94 95
        ' Does?    A, Doe# ,
        ' Colon?   A, Col# ,
	' User?    A, Use# ,
anton's avatar
anton committed
96 97 98 99 100 101 102 103
        0 ,

: WordInfo ( nfa --- code )
        InfoTable
        BEGIN  dup @ dup
        WHILE  swap 2 cells + swap
               2 pick swap execute
        UNTIL
104
        cell- @ nip
anton's avatar
anton committed
105 106 107 108
        ELSE
        2drop drop 0
        THEN ;