1: \ report words used from the various wordsets
2:
3: \ Copyright (C) 1996,1998,1999,2003,2005,2006 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 3
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, see http://www.gnu.org/licenses/.
19:
20:
21: \ Use this program like this:
22: \ include it, then the program you want to check; then say print-ans-report
23: \ e.g., start it with
24: \ gforth ans-report.fs myprog.fs -e "print-ans-report bye"
25:
26: \ Caveats:
27:
28: \ Note that this program just checks which words are used, not whether
29: \ they are used in an ANS Forth conforming way!
30:
31: \ Some words are defined in several wordsets in the standard. This
32: \ program reports them for only one of the wordsets, and not
33: \ necessarily the one you expect.
34:
35:
36: \ This program uses Gforth internals and won't be easy to port
37: \ to other systems.
38:
39: \ !! ignore struct-voc stuff (dummy, [then] etc.).
40:
41: vocabulary ans-report-words ans-report-words definitions
42:
43: : wordset ( "name" -- )
44: latestxt >body
45: create
46: 0 , \ link to next wordset
47: 0 0 2, \ array of nfas
48: ( lastlinkp ) latest swap ! \ set link ptr of last wordset
49: ;
50:
51: wordlist constant wordsets wordsets set-current
52: create CORE 0 , 0 0 2,
53: wordset CORE-EXT
54: wordset CORE-EXT-obsolescent
55: wordset BLOCK
56: wordset BLOCK-EXT
57: wordset DOUBLE
58: wordset DOUBLE-EXT
59: wordset EXCEPTION
60: wordset EXCEPTION-EXT
61: wordset FACILITY
62: wordset FACILITY-EXT
63: wordset FILE
64: wordset FILE-EXT
65: wordset FLOAT
66: wordset FLOAT-EXT
67: wordset LOCAL
68: wordset LOCAL-EXT
69: wordset MEMORY
70: wordset SEARCH
71: wordset SEARCH-EXT
72: wordset STRING
73: wordset TOOLS
74: wordset TOOLS-EXT
75: wordset TOOLS-EXT-obsolescent
76:
77: \ www.forth200x.org CfV extension names
78: wordset X:deferred
79: wordset X:extension-query
80: wordset X:parse-name
81: wordset X:defined
82: wordset X:required
83: wordset X:ekeys
84: wordset X:fp-stack
85:
86: wordset non-ANS
87:
88: ans-report-words definitions
89:
90: : standardword { D: wordname D: wordset -- }
91: wordname find-name
92: ?dup-if
93: sp@ cell nextname create drop
94: wordset wordsets search-wordlist 0= abort" wordset unknown" ,
95: endif ;
96:
97: : answord ( "name wordset pronounciation" -- )
98: \ check the documentation of an ans word
99: parse-name parse-name parse-name 2drop standardword ;
100:
101: : xword ( "name wordset" )
102: parse-name parse-name standardword ;
103:
104: table constant answords answords set-current
105: warnings @ warnings off
106: include ./answords.fs
107: include ./xwords.fs
108: warnings !
109: ans-report-words definitions
110:
111: : add-unless-present ( nt addr -- )
112: \ add nt to array described by addr 2@, unless it contains nt
113: >r ( nt )
114: r@ 2@ bounds
115: u+do ( nt )
116: dup i @ =
117: if
118: drop rdrop UNLOOP EXIT
119: endif
120: cell
121: +loop
122: r@ 2@ cell extend-mem r> 2!
123: ( nt addr ) ! ;
124:
125:
126: : note-name ( nt -- )
127: \ remember name in the appropriate wordset, unless already there
128: \ or the word is defined in the checked program
129: dup [ here ] literal > \ word defined by the application
130: over locals-buffer dup 1000 + within or \ or a local
131: if
132: drop EXIT
133: endif
134: sp@ cell answords search-wordlist ( nt xt true | nt false )
135: if \ ans word
136: >body @ >body
137: else \ non-ans word
138: [ get-order wordsets swap 1+ set-order ] non-ANS [ previous ]
139: endif
140: ( nt wordset ) cell+ add-unless-present ;
141:
142: : find¬e-name ( c-addr u -- nt/0 )
143: \ find-name replacement. Takes note of all the words used.
144: lookup @ (search-wordlist) dup
145: if
146: dup note-name
147: endif ;
148:
149: : replace-word ( xt cfa -- )
150: \ replace word at cfa with xt. !! This is quite general-purpose
151: \ and should migrate elsewhere.
152: \ the following no longer works with primitive-centric hybrid threading:
153: \ dodefer: over code-address!
154: \ >body ! ;
155: dup @ docol: <> -12 and throw \ for colon defs only
156: >body ['] branch xt>threaded over !
157: cell+ >r >body r> ! ;
158:
159: : print-names ( endaddr startaddr -- )
160: space 1 -rot
161: u+do ( pos )
162: i @ name>string nip 1+ { len }
163: len + ( newpos )
164: dup cols 4 - >= if
165: cr space drop len 1+
166: endif
167: i @ .name
168: cell +loop
169: drop ;
170:
171: forth definitions
172: ans-report-words
173:
174: : print-ans-report ( -- )
175: cr
176: ." The program uses the following words" cr
177: [ get-order wordsets swap 1+ set-order ] [(')] core [ previous ]
178: begin
179: dup 0<>
180: while
181: dup >r name>int >body dup @ swap cell+ 2@ dup
182: if
183: ." from " r@ .name ." :" cr
184: bounds print-names cr
185: else
186: 2drop
187: endif
188: rdrop
189: repeat
190: drop ;
191:
192: \ the following sequence "' replace-word forth execute" is necessary
193: \ to restore the default search order without effect on the "used
194: \ word" lists
195: ' find¬e-name ' find-name ' replace-word forth execute
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>