File:  [gforth] / gforth / ans-report.fs
Revision 1.20: download - view: text, annotated - select for diffs
Thu Dec 31 15:32:35 2009 UTC (14 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

    1: \ report words used from the various wordsets
    2: 
    3: \ Copyright (C) 1996,1998,1999,2003,2005,2006,2007,2009 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: wordset X:number-prefixes
   86: wordset X:structures
   87: wordset X:ftrunc
   88: 
   89: wordset non-ANS
   90: 
   91: ans-report-words definitions
   92: 
   93: : standardword { D: wordname D: wordset -- }
   94:     wordname find-name
   95:     ?dup-if
   96: 	sp@ cell nextname create drop
   97: 	wordset wordsets search-wordlist 0= abort" wordset unknown" ,
   98:     endif ;
   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 ;
  106: 
  107: table constant answords answords set-current
  108: warnings @ warnings off
  109: include ./answords.fs
  110: include ./xwords.fs
  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.
  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
  159:     >body ['] branch xt>threaded over !
  160:     cell+ >r >body r> ! ;
  161: 
  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: 
  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
  187: 	    bounds print-names cr
  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>