Annotation of gforth/ans-report.fs, revision 1.14
1.1 anton 1: \ report words used from the various wordsets
2:
1.13 anton 3: \ Copyright (C) 1996,1998,1999,2003,2005 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
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
1.6 anton 19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1 anton 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:
1.2 anton 40: \ !! ignore struct-voc stuff (dummy, [then] etc.).
41:
1.1 anton 42: vocabulary ans-report-words ans-report-words definitions
43:
44: : wordset ( "name" -- )
1.11 anton 45: latestxt >body
1.1 anton 46: create
47: 0 , \ link to next wordset
48: 0 0 2, \ array of nfas
1.11 anton 49: ( lastlinkp ) latest swap ! \ set link ptr of last wordset
1.1 anton 50: ;
51:
52: wordlist constant wordsets wordsets set-current
53: create CORE 0 , 0 0 2,
54: wordset CORE-EXT
1.14 ! anton 55: wordset CORE-EXT-obsolescent
1.1 anton 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
1.14 ! anton 76: wordset TOOLS-EXT-obsolescent
1.1 anton 77: wordset non-ANS
78: ans-report-words definitions
79:
80: : answord ( "name wordset pronounciation" -- )
81: \ check the documentaion of an ans word
82: name { D: wordname }
83: name { D: wordset }
84: name { D: pronounciation }
85: wordname find-name
86: ?dup-if
87: sp@ cell nextname create drop
88: wordset wordsets search-wordlist 0= abort" wordlist unknown" ,
89: endif ;
90:
91: table constant answords answords set-current
92: warnings @ warnings off
1.4 jwilke 93: include ./answords.fs
1.1 anton 94: warnings !
95: ans-report-words definitions
96:
97: : add-unless-present ( nt addr -- )
98: \ add nt to array described by addr 2@, unless it contains nt
99: >r ( nt )
100: r@ 2@ bounds
101: u+do ( nt )
102: dup i @ =
103: if
104: drop rdrop UNLOOP EXIT
105: endif
106: cell
107: +loop
108: r@ 2@ cell extend-mem r> 2!
109: ( nt addr ) ! ;
110:
111:
112: : note-name ( nt -- )
113: \ remember name in the appropriate wordset, unless already there
114: \ or the word is defined in the checked program
115: dup [ here ] literal > \ word defined by the application
116: over locals-buffer dup 1000 + within or \ or a local
117: if
118: drop EXIT
119: endif
120: sp@ cell answords search-wordlist ( nt xt true | nt false )
121: if \ ans word
122: >body @ >body
123: else \ non-ans word
124: [ get-order wordsets swap 1+ set-order ] non-ANS [ previous ]
125: endif
126: ( nt wordset ) cell+ add-unless-present ;
127:
128: : find¬e-name ( c-addr u -- nt/0 )
129: \ find-name replacement. Takes note of all the words used.
130: lookup @ (search-wordlist) dup
131: if
132: dup note-name
133: endif ;
134:
135: : replace-word ( xt cfa -- )
136: \ replace word at cfa with xt. !! This is quite general-purpose
137: \ and should migrate elsewhere.
1.7 anton 138: \ the following no longer works with primitive-centric hybrid threading:
139: \ dodefer: over code-address!
140: \ >body ! ;
141: dup @ docol: <> -12 and throw \ for colon defs only
1.8 anton 142: >body ['] branch xt>threaded over !
1.9 anton 143: cell+ >r >body r> ! ;
1.1 anton 144:
1.12 anton 145: : print-names ( endaddr startaddr -- )
146: space 1 -rot
147: u+do ( pos )
148: i @ name>string nip 1+ { len }
149: len + ( newpos )
150: dup cols 4 - >= if
151: cr space drop len 1+
152: endif
153: i @ .name
154: cell +loop
155: drop ;
156:
1.1 anton 157: forth definitions
158: ans-report-words
159:
160: : print-ans-report ( -- )
161: cr
162: ." The program uses the following words" cr
163: [ get-order wordsets swap 1+ set-order ] [(')] core [ previous ]
164: begin
165: dup 0<>
166: while
167: dup >r name>int >body dup @ swap cell+ 2@ dup
168: if
169: ." from " r@ .name ." :" cr
1.12 anton 170: bounds print-names cr
1.1 anton 171: else
172: 2drop
173: endif
174: rdrop
175: repeat
176: drop ;
177:
178: \ the following sequence "' replace-word forth execute" is necessary
179: \ to restore the default search order without effect on the "used
180: \ word" lists
181: ' find¬e-name ' find-name ' replace-word forth execute
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to ans-report.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth