Return to ds2texi.fs CVS log

Up to [gforth] / gforth

updated copyright year after changing license notice

    1: \ documentation source to texi format converter
    2: 
    3: \ Copyright (C) 1995,1996,1997,1998,1999,2003,2005,2007 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: \ documentation source can contain lines in the form `doc-word' and
   21: \ `short-word'. These are converted to appropriate full or short
   22: \ (without the description) glossary entries for word.
   23: 
   24: \ The glossary entries are generated from data present in the wordlist
   25: \ `documentation'. Each word resides there under its own name.
   26: 
   27: script? [IF]
   28:     warnings off
   29:     require search.fs
   30:     require extend.fs
   31:     require glocals.fs
   32:     require float.fs
   33:     require struct.fs
   34:     require debugs.fs
   35: [THEN]
   36: 
   37: wordlist constant documentation
   38: 
   39: struct
   40:     cell% 2* field doc-name
   41:     cell% 2* field doc-stack-effect
   42:     cell% 2* field doc-wordset
   43:     cell% 2* field doc-pronounciation
   44:     cell% 2* field doc-description
   45: end-struct doc-entry
   46: 
   47: create description-buffer 4096 chars allot
   48: 
   49: : get-description ( -- addr u )
   50:     description-buffer
   51:     begin
   52: 	refill
   53:     while
   54: 	source nip
   55:     while
   56: 	source swap >r 2dup r> -rot cmove
   57: 	chars +
   58: 	#lf over c! char+
   59:     repeat then
   60:     description-buffer tuck - ;
   61: 
   62: : skip-prefix ( c-addr1 u1 -- c-addr2 u2 )
   63:     2dup s" --" string-prefix?
   64:     IF
   65: 	[char] - skip [char] - scan 1 /string
   66:     THEN ;
   67: 
   68: : replace-_ ( c-addr u -- )
   69:     \ replaces _ with -
   70:     chars bounds
   71:     +DO
   72: 	i c@ [char] _ =
   73: 	if
   74: 	    [char] - i c!
   75: 	endif
   76: 	1 chars
   77:     +loop ;
   78:     
   79: : condition-stack-effect ( c-addr1 u1 -- c-addr2 u2 )
   80:     save-mem 2dup replace-_ ;
   81:     
   82: : condition-wordset ( c-addr1 u1 -- c-addr2 u2 )
   83:     dup 0=
   84:     if
   85: 	2drop s" unknown"
   86:     else
   87: 	save-mem
   88:     endif ;
   89: 
   90: : condition-pronounciation ( c-addr1 u1 -- c-addr2 u2 )
   91:     save-mem 2dup replace-_ ;
   92: 
   93: : make-doc ( -- )
   94:     get-current documentation set-current
   95:     create
   96: 	latest name>string skip-prefix 2,		\ name
   97: 	[char] ) parse save-mem 2,	\ stack-effect
   98: 	bl sword condition-wordset 2,	\ wordset
   99: 	bl sword dup	\ pronounciation
  100: 	if
  101: 	    condition-pronounciation
  102: 	else
  103: 	    2drop latest name>string skip-prefix
  104: 	endif
  105: 	2,
  106: 	get-description save-mem 2,
  107:     set-current ;
  108: 
  109: : emittexi ( c -- )
  110:     >r
  111:     s" @{}" r@ scan 0<>
  112:     if
  113: 	[char] @ emit
  114:     endif
  115:     drop r> emit ;
  116: 
  117: : typetexi ( addr u -- )
  118:     0
  119:     ?do
  120: 	dup c@ emittexi
  121: 	char+
  122:     loop
  123:     drop ;
  124: 
  125: : print-short ( doc-entry -- )
  126:     >r
  127:     ." @findex "
  128:     r@ doc-name 2@ typetexi
  129:     ."  @var{ " r@ doc-stack-effect 2@ type ."  }  "
  130:     r@ doc-wordset 2@ type
  131:     cr
  132:     ." @cindex "
  133:     ." @code{" r@ doc-name 2@ typetexi ." }"
  134:     cr
  135:     r@ doc-name 2@ drop c@ [char] : <> if
  136: 	\ cut out words starting with :, info-lookup cannot handle them
  137: 	\ !! deal with : by replacing it here and in info-lookup?
  138: 	." @kindex "
  139: 	r@ doc-name 2@ typetexi
  140: 	cr
  141:     endif
  142:     ." @format" cr
  143:     ." @code{" r@ doc-name 2@ typetexi ." }       "
  144:     ." @i{" r@ doc-stack-effect 2@ type ." }       "
  145:     r@ doc-wordset 2@ type ."        ``"
  146:     r@ doc-pronounciation 2@ type ." ''" cr ." @end format" cr
  147:     rdrop ;
  148: 
  149: : print-doc ( doc-entry -- )
  150:     >r
  151:     r@ print-short
  152:     r@ doc-description 2@ dup 0<>
  153:     if
  154: 	\ ." @iftex" cr ." @vskip-0ex" cr ." @end iftex" cr
  155: 	type cr cr
  156: 	\ ." @ifinfo" cr ." @*" cr ." @end ifinfo" cr cr
  157:     else
  158: 	2drop cr
  159:     endif
  160:     rdrop ;
  161: 
  162: : do-doc ( addr1 u1 addr2 u2 xt -- f )
  163:     \ xt is the word to be executed if addr1 u1 is a string starting
  164:     \ with the prefix addr2 u2 and continuing with a word in the
  165:     \ wordlist `documentation'. f is true if xt is executed.
  166:     >r dup >r
  167:     3 pick over str=
  168:     if \ addr2 u2 is a prefix of addr1 u1
  169: 	r> /string -trailing documentation search-wordlist
  170: 	if \ the rest of addr1 u1 is in documentation
  171: 	    execute r> execute true
  172: 	else
  173: 	    rdrop false
  174: 	endif
  175:     else
  176: 	2drop 2rdrop false
  177:     endif ;
  178: 
  179: : process-line ( addr u -- )
  180:     2dup s" doc-" ['] print-doc do-doc 0=
  181:     if
  182: 	2dup s" short-" ['] print-short do-doc 0=
  183: 	if
  184: 	    type cr EXIT
  185: 	endif
  186:     endif
  187:     2drop ;
  188: 
  189: 1024 constant doclinelength
  190: 
  191: create docline doclinelength chars allot
  192: 
  193: : ds2texi ( file-id -- )
  194:     >r
  195:     begin
  196: 	docline doclinelength r@ read-line throw
  197:     while
  198: 	dup doclinelength = abort" docline too long"
  199: 	docline swap process-line
  200:     repeat
  201:     drop rdrop ;
  202: 
  203: : compare-ci ( addr1 u1 addr2 u2 -- n )
  204:     \ case insensitive string compare
  205:     \ !! works correctly only for comparing for equality
  206:     2 pick swap -
  207:     ?dup-0=-if
  208:         capscomp
  209:     else
  210: 	nip nip nip
  211: 	0<
  212: 	if
  213: 	    -1
  214: 	else
  215: 	    1
  216: 	endif
  217:     endif  ;
  218: 
  219: : answord ( "name wordset pronounciation" -- )
  220:     \ check the documentaion of an ans word
  221:     name { D: wordname }
  222:     name { D: wordset }
  223:     name { D: pronounciation }
  224:     wordname documentation search-wordlist
  225:     if
  226: 	execute { doc }
  227: 	wordset doc doc-wordset 2@ compare-ci
  228: 	if 
  229: 	    ." wordset: " wordname type ." : '"  doc doc-wordset 2@ type ." ' instead of '" wordset type ." '" cr
  230: 	endif
  231: 	pronounciation doc doc-pronounciation 2@ compare-ci
  232: 	if
  233: 	    ." pronounciation: " wordname type ." : '" doc doc-pronounciation 2@ type ." ' instead of '" pronounciation type ." '" cr
  234: 	endif
  235:     else
  236: 	." undocumented: " wordname type cr
  237:     endif ;