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

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

\ 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
10
\ as published by the Free Software Foundation, either version 3
anton's avatar
anton committed
11 12 13 14 15 16 17 18
\ 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
19
\ along with this program. If not, see http://www.gnu.org/licenses/.
anton's avatar
anton committed
20

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

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

\ 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
32
    ((name>)) >code-address dovar: = ;
anton's avatar
anton committed
33 34

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

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

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

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

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

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

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

\ 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
77
8 CONSTANT Use#         \ User variable
anton's avatar
anton committed
78 79 80

\ Nobody knows:

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

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

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

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

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