1: \ WORDINFO.FS V1.0 17may93jaw
2:
3: \ May be cross-compiled
4: \ If you want check values then exclude comments,
5: \ but keep in mind that this can't be cross-compiled
6:
7: INCLUDE look.fs
8:
9: \ Wordinfo is a tool that checks a nfa
10: \ and finds out what wordtype we have
11: \ it is used in SEE.FS
12:
13: : alias? ( nfa -- flag )
14: dup name> look
15: 0= ABORT" WINFO: CFA not found"
16: cell+
17: 2dup <>
18: IF nip dup 1 cells - here !
19: count $1f and here cell+ place true
20: ELSE 2drop false THEN ;
21:
22: : var? ( nfa -- flag )
23: (name>)
24: >code-address ['] leavings >code-address = ;
25:
26: : con? ( nfa -- flag )
27: (name>)
28: >code-address ['] bl >code-address = ;
29:
30: : does? ( nfa -- flag )
31: dup (name>)
32: >code-address ['] source >code-address =
33: dup IF swap (name>) cell+ @ here ! ELSE nip THEN ;
34:
35: : defered? ( nfa -- flag )
36: dup does?
37: IF here @ ['] source cell+ @ =
38: dup IF swap (name>) >body @ here ! ELSE nip THEN
39: ELSE drop false THEN ;
40:
41: : colon? ( nfa -- flag )
42: (name>)
43: >code-address ['] does? >code-address = ;
44:
45: \ VALUE VCheck
46:
47: \ : value? ( nfa -- flag )
48: \ dup does?
49: \ IF here @ ['] VCheck cell+ @ =
50: \ dup IF swap (name>) >body @ here ! ELSE nip THEN
51: \ ELSE drop false THEN ;
52:
53: : prim? ( nfa -- flag )
54: name>
55: forthstart u< ;
56:
57: \ None nestable IDs:
58:
59: 1 CONSTANT Pri# \ Primitives
60: 2 CONSTANT Con# \ Constants
61: 3 CONSTANT Var# \ Variables
62: 4 CONSTANT Val# \ Values
63:
64: \ Nestabe IDs:
65:
66: 5 CONSTANT Doe# \ Does part
67: 6 CONSTANT Def# \ Defer
68: 7 CONSTANT Col# \ Colon def
69:
70: \ Nobody knows:
71:
72: 8 CONSTANT Ali# \ Alias
73:
74: 9 CONSTANT Str# \ Structure words
75:
76: 10 CONSTANT Com# \ Compiler directives : ; POSTPONE
77:
78: CREATE InfoTable
79: ' Alias? A, Ali# ,
80: ' Con? A, Con# ,
81: ' Var? A, Var# ,
82: \ ' Value? A, Val# ,
83: ' Defered? A, Def# ,
84: ' Does? A, Doe# ,
85: ' Colon? A, Col# ,
86: ' Prim? A, Pri# ,
87: 0 ,
88:
89: : WordInfo ( nfa --- code )
90: InfoTable
91: BEGIN dup @ dup
92: WHILE swap 2 cells + swap
93: 2 pick swap execute
94: UNTIL
95: 1 cells - @ nip
96: ELSE
97: 2drop drop 0
98: THEN ;
99:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>