Annotation of gforth/ans-report.fs, revision 1.20
1.1 anton 1: \ report words used from the various wordsets
2:
1.20 ! anton 3: \ Copyright (C) 1996,1998,1999,2003,2005,2006,2007,2009 Free Software Foundation, Inc.
1.1 anton 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
1.17 anton 9: \ as published by the Free Software Foundation, either version 3
1.1 anton 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
1.17 anton 18: \ along with this program. If not, see http://www.gnu.org/licenses/.
1.1 anton 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:
1.2 anton 39: \ !! ignore struct-voc stuff (dummy, [then] etc.).
40:
1.1 anton 41: vocabulary ans-report-words ans-report-words definitions
42:
43: : wordset ( "name" -- )
1.11 anton 44: latestxt >body
1.1 anton 45: create
46: 0 , \ link to next wordset
47: 0 0 2, \ array of nfas
1.11 anton 48: ( lastlinkp ) latest swap ! \ set link ptr of last wordset
1.1 anton 49: ;
50:
51: wordlist constant wordsets wordsets set-current
52: create CORE 0 , 0 0 2,
53: wordset CORE-EXT
1.14 anton 54: wordset CORE-EXT-obsolescent
1.1 anton 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
1.14 anton 75: wordset TOOLS-EXT-obsolescent
1.15 anton 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
1.19 anton 85: wordset X:number-prefixes
86: wordset X:structures
87: wordset X:ftrunc
1.15 anton 88:
1.1 anton 89: wordset non-ANS
1.15 anton 90:
1.1 anton 91: ans-report-words definitions
92:
1.15 anton 93: : standardword { D: wordname D: wordset -- }
1.1 anton 94: wordname find-name
95: ?dup-if
96: sp@ cell nextname create drop
1.15 anton 97: wordset wordsets search-wordlist 0= abort" wordset unknown" ,
1.1 anton 98: endif ;
1.15 anton 99:
100: : answord ( "name wordset pronounciation" -- )
101: \ check the documentation of an ans word
102: parse-name parse-name parse-name 2drop standardword ;
103:
104: : xword ( "name wordset" )
105: parse-name parse-name standardword ;
1.1 anton 106:
107: table constant answords answords set-current
108: warnings @ warnings off
1.4 jwilke 109: include ./answords.fs
1.15 anton 110: include ./xwords.fs
1.1 anton 111: warnings !
112: ans-report-words definitions
113:
114: : add-unless-present ( nt addr -- )
115: \ add nt to array described by addr 2@, unless it contains nt
116: >r ( nt )
117: r@ 2@ bounds
118: u+do ( nt )
119: dup i @ =
120: if
121: drop rdrop UNLOOP EXIT
122: endif
123: cell
124: +loop
125: r@ 2@ cell extend-mem r> 2!
126: ( nt addr ) ! ;
127:
128:
129: : note-name ( nt -- )
130: \ remember name in the appropriate wordset, unless already there
131: \ or the word is defined in the checked program
132: dup [ here ] literal > \ word defined by the application
133: over locals-buffer dup 1000 + within or \ or a local
134: if
135: drop EXIT
136: endif
137: sp@ cell answords search-wordlist ( nt xt true | nt false )
138: if \ ans word
139: >body @ >body
140: else \ non-ans word
141: [ get-order wordsets swap 1+ set-order ] non-ANS [ previous ]
142: endif
143: ( nt wordset ) cell+ add-unless-present ;
144:
145: : find¬e-name ( c-addr u -- nt/0 )
146: \ find-name replacement. Takes note of all the words used.
147: lookup @ (search-wordlist) dup
148: if
149: dup note-name
150: endif ;
151:
152: : replace-word ( xt cfa -- )
153: \ replace word at cfa with xt. !! This is quite general-purpose
154: \ and should migrate elsewhere.
1.7 anton 155: \ the following no longer works with primitive-centric hybrid threading:
156: \ dodefer: over code-address!
157: \ >body ! ;
158: dup @ docol: <> -12 and throw \ for colon defs only
1.8 anton 159: >body ['] branch xt>threaded over !
1.9 anton 160: cell+ >r >body r> ! ;
1.1 anton 161:
1.12 anton 162: : print-names ( endaddr startaddr -- )
163: space 1 -rot
164: u+do ( pos )
165: i @ name>string nip 1+ { len }
166: len + ( newpos )
167: dup cols 4 - >= if
168: cr space drop len 1+
169: endif
170: i @ .name
171: cell +loop
172: drop ;
173:
1.1 anton 174: forth definitions
175: ans-report-words
176:
177: : print-ans-report ( -- )
178: cr
179: ." The program uses the following words" cr
180: [ get-order wordsets swap 1+ set-order ] [(')] core [ previous ]
181: begin
182: dup 0<>
183: while
184: dup >r name>int >body dup @ swap cell+ 2@ dup
185: if
186: ." from " r@ .name ." :" cr
1.12 anton 187: bounds print-names cr
1.1 anton 188: else
189: 2drop
190: endif
191: rdrop
192: repeat
193: drop ;
194:
195: \ the following sequence "' replace-word forth execute" is necessary
196: \ to restore the default search order without effect on the "used
197: \ word" lists
198: ' find¬e-name ' find-name ' replace-word forth execute
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>