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