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