Annotation of gforth/wordinfo.fs, revision 1.8
1.1 anton 1: \ WORDINFO.FS V1.0 17may93jaw
2:
1.8 ! anton 3: \ Copyright (C) 1995 Free Software Foundation, Inc.
! 4:
! 5: \ This file is part of Gforth.
! 6:
! 7: \ Gforth is free software; you can redistribute it and/or
! 8: \ modify it under the terms of the GNU General Public License
! 9: \ as published by the Free Software Foundation; either version 2
! 10: \ of the License, or (at your option) any later version.
! 11:
! 12: \ This program is distributed in the hope that it will be useful,
! 13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
! 14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! 15: \ GNU General Public License for more details.
! 16:
! 17: \ You should have received a copy of the GNU General Public License
! 18: \ along with this program; if not, write to the Free Software
! 19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
! 20:
1.1 anton 21: \ May be cross-compiled
22: \ If you want check values then exclude comments,
23: \ but keep in mind that this can't be cross-compiled
24:
25: INCLUDE look.fs
26:
27: \ Wordinfo is a tool that checks a nfa
28: \ and finds out what wordtype we have
29: \ it is used in SEE.FS
30:
31: : alias? ( nfa -- flag )
32: dup name> look
33: 0= ABORT" WINFO: CFA not found"
1.4 pazsan 34: \ cell+
1.1 anton 35: 2dup <>
36: IF nip dup 1 cells - here !
37: count $1f and here cell+ place true
38: ELSE 2drop false THEN ;
39:
40: : var? ( nfa -- flag )
1.7 anton 41: cell+ (name>) >code-address dovar: = ;
1.1 anton 42:
43: : con? ( nfa -- flag )
1.7 anton 44: cell+ (name>) >code-address docon: = ;
1.1 anton 45:
1.5 pazsan 46: : user? ( nfa -- flag )
1.7 anton 47: cell+ (name>) >code-address douser: = ;
1.5 pazsan 48:
1.1 anton 49: : does? ( nfa -- flag )
1.7 anton 50: \ !! does not work on all installations
51: cell+ (name>)
52: >code-address ['] bits >code-address = ;
1.1 anton 53:
54: : defered? ( nfa -- flag )
1.7 anton 55: cell+ (name>) >code-address dodefer: = ;
1.1 anton 56:
57: : colon? ( nfa -- flag )
1.7 anton 58: cell+ (name>) >code-address docol: = ;
59:
60: \ the above words could be factored with create-does>, but this would
61: \ probably make this file incompatible with cross.
1.1 anton 62:
63: \ VALUE VCheck
64:
65: \ : value? ( nfa -- flag )
66: \ dup does?
67: \ IF here @ ['] VCheck cell+ @ =
68: \ dup IF swap (name>) >body @ here ! ELSE nip THEN
69: \ ELSE drop false THEN ;
70:
71: : prim? ( nfa -- flag )
72: name>
73: forthstart u< ;
74:
75: \ None nestable IDs:
76:
77: 1 CONSTANT Pri# \ Primitives
78: 2 CONSTANT Con# \ Constants
79: 3 CONSTANT Var# \ Variables
80: 4 CONSTANT Val# \ Values
81:
82: \ Nestabe IDs:
83:
84: 5 CONSTANT Doe# \ Does part
85: 6 CONSTANT Def# \ Defer
86: 7 CONSTANT Col# \ Colon def
1.5 pazsan 87: 8 CONSTANT Use# \ User variable
1.1 anton 88:
89: \ Nobody knows:
90:
1.5 pazsan 91: 9 CONSTANT Ali# \ Alias
1.1 anton 92:
1.5 pazsan 93: 10 CONSTANT Str# \ Structure words
1.1 anton 94:
1.5 pazsan 95: 11 CONSTANT Com# \ Compiler directives : ; POSTPONE
1.1 anton 96:
97: CREATE InfoTable
1.5 pazsan 98: ' Prim? A, Pri# ,
99: ' Alias? A, Ali# ,
100: ' Con? A, Con# ,
101: ' Var? A, Var# ,
102: \ ' Value? A, Val# ,
1.1 anton 103: ' Defered? A, Def# ,
1.5 pazsan 104: ' Does? A, Doe# ,
105: ' Colon? A, Col# ,
106: ' User? A, Use# ,
1.1 anton 107: 0 ,
108:
109: : WordInfo ( nfa --- code )
110: InfoTable
111: BEGIN dup @ dup
112: WHILE swap 2 cells + swap
113: 2 pick swap execute
114: UNTIL
115: 1 cells - @ nip
116: ELSE
117: 2drop drop 0
118: THEN ;
119:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>