File:  [gforth] / gforth / ans-report.fs
Revision 1.3: download - view: text, annotated - select for diffs
Tue Dec 8 22:02:34 1998 UTC (20 years, 10 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c

    1: \ report words used from the various wordsets
    2: 
    3: \ Copyright (C) 1996,1998 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., 675 Mass Ave, Cambridge, MA 02139, 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:     lastxt >body
   46:     create
   47:     0 , \ link to next wordset
   48:     0 0 2, \ array of nfas
   49:     ( lastlinkp ) last @ 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 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 non-ANS
   76: ans-report-words definitions
   77: 
   78: : answord ( "name wordset pronounciation" -- )
   79:     \ check the documentaion of an ans word
   80:     name { D: wordname }
   81:     name { D: wordset }
   82:     name { D: pronounciation }
   83:     wordname find-name
   84:     ?dup-if
   85: 	sp@ cell nextname create drop
   86: 	wordset wordsets search-wordlist 0= abort" wordlist unknown" ,
   87:     endif ;
   88: 
   89: table constant answords answords set-current
   90: warnings @ warnings off
   91: include answords.fs
   92: warnings !
   93: ans-report-words definitions
   94: 
   95: : add-unless-present ( nt addr -- )
   96:     \ add nt to array described by addr 2@, unless it contains nt
   97:     >r ( nt )
   98:     r@ 2@ bounds
   99:     u+do ( nt )
  100: 	dup i @ =
  101: 	if
  102: 	    drop rdrop UNLOOP EXIT
  103: 	endif
  104: 	cell
  105:     +loop
  106:     r@ 2@ cell extend-mem r> 2!
  107:     ( nt addr ) ! ;
  108: 
  109: 
  110: : note-name ( nt -- )
  111:     \ remember name in the appropriate wordset, unless already there
  112:     \ or the word is defined in the checked program
  113:     dup [ here ] literal >		     \ word defined by the application
  114:     over locals-buffer dup 1000 + within or  \ or a local
  115:     if
  116: 	drop EXIT
  117:     endif
  118:     sp@ cell answords search-wordlist ( nt xt true | nt false )
  119:     if \ ans word
  120: 	>body @ >body
  121:     else \ non-ans word
  122: 	[ get-order wordsets swap 1+ set-order ] non-ANS [ previous ]
  123:     endif
  124:     ( nt wordset ) cell+ add-unless-present ;
  125: 
  126: : find&note-name ( c-addr u -- nt/0 )
  127:     \ find-name replacement. Takes note of all the words used.
  128:     lookup @ (search-wordlist) dup
  129:     if
  130: 	dup note-name
  131:     endif ;
  132: 
  133: : replace-word ( xt cfa -- )
  134:     \ replace word at cfa with xt. !! This is quite general-purpose
  135:     \ and should migrate elsewhere.
  136:     dodefer: over code-address!
  137:     >body ! ;
  138: 
  139: forth definitions
  140: ans-report-words
  141: 
  142: : print-ans-report ( -- )
  143:     cr
  144:     ." The program uses the following words" cr
  145:     [ get-order wordsets swap 1+ set-order ] [(')] core [ previous ]
  146:     begin
  147: 	dup 0<>
  148:     while
  149: 	dup >r name>int >body dup @ swap cell+ 2@ dup
  150: 	if
  151: 	    ." from " r@ .name ." :" cr
  152: 	    bounds
  153: 	    u+do
  154: 		i @ .name
  155: 		cell
  156: 	    +loop
  157: 	    cr
  158: 	else
  159: 	    2drop
  160: 	endif
  161: 	rdrop
  162:     repeat
  163:     drop ;
  164: 	
  165: \ the following sequence "' replace-word forth execute" is necessary
  166: \ to restore the default search order without effect on the "used
  167: \ word" lists
  168: ' find&note-name ' find-name ' replace-word forth execute

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