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&note-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&note-name ' find-name ' replace-word forth execute

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>