1: \ Glossary generator.
2: \ Written in ANS Forth, requires FILES wordset.
3: \ Copyright (c)1993 L.C. Benschop Eindhoven.
4: \ Permission to copy, distribute or modify this program is granted under the
5: \ conditions of the General Public Licence version 2.
6: decimal
7:
8: : \G postpone \ ; immediate
9: \G \G is an alias for \, so it is a comment till end-of-line, but
10: \G it has a special meaning for the Glossary Generator.
11:
12: \G \G comments should appear immediately above or below the definition of
13: \G the word it belongs to. The definition line should contain no more
14: \G than the definition, a stack comment and a \ comment after which
15: \G the wordset and pronounciation.
16: \G An isolated block of \G comments is placed at the beginning of the
17: \G glossary file.
18:
19: VARIABLE GLOSLIST
20: VARIABLE CURRENT-COMMENT
21: VARIABLE FIXLINE
22:
23: \ The Glossary entries in memory have the following form.
24: \ 1 cell: address of next entry, 1 cell: address of comment field
25: \ counted string: name counted string: stack picture
26: \ counted string: extra field counted string: pronunciation.
27:
28:
29: \G This command starts a fresh glossary.
30: : NEWGLOS
31: \ S" FORGET GSTART CREATE GSTART" EVALUATE
32: 0 GLOSLIST ! ;
33:
34: CREATE OLDLINE 256 CHARS ALLOT
35:
36: VARIABLE CHARPTR
37:
38:
39: \G Insert the header into the list at the alphabetically correct place.
40: : INSERT-HEADER ( addr ---)
41: CHARPTR !
42: GLOSLIST
43: BEGIN
44: DUP @
45: IF
46: DUP @ 2 CELLS + COUNT CHARPTR @ 2 CELLS + COUNT COMPARE 0<=
47: ELSE
48: 0
49: THEN
50: WHILE
51: @
52: REPEAT
53: DUP @ CHARPTR @ ! CHARPTR @ SWAP !
54: ;
55:
56: \G Scan a word on oldline through pointer charptr
57: : SCAN-WORD ( ---- addr len)
58: BEGIN
59: CHARPTR @ OLDLINE - OLDLINE C@ <= CHARPTR @ C@ BL = AND
60: WHILE
61: 1 CHARS CHARPTR +!
62: REPEAT
63: CHARPTR @ 0
64: BEGIN
65: CHARPTR @ OLDLINE - OLDLINE C@ <= CHARPTR @ C@ BL <> AND
66: WHILE
67: 1 CHARS CHARPTR +! 1+
68: REPEAT
69: ;
70:
71: : SEARCH-NAME
72: SCAN-WORD 2DROP
73: SCAN-WORD 2DUP BOUNDS ?DO
74: I C@ [CHAR] a [CHAR] { WITHIN IF I C@ 32 - I C! THEN
75: LOOP \ translate to caps.
76: DUP HERE C! HERE CHAR+ SWAP DUP 1+ CHARS ALLOT CMOVE
77: ;
78:
79: : SEARCH-STACK
80: 0 C,
81: SCAN-WORD S" (" COMPARE 0= IF
82: HERE 1 CHARS -
83: BEGIN
84: CHARPTR @ OLDLINE - OLDLINE C@ <= CHARPTR @ C@ [CHAR] ) <> AND
85: WHILE
86: CHARPTR @ C@ C,
87: DUP C@ 1+ OVER C!
88: 1 CHARS CHARPTR +!
89: REPEAT
90: DROP
91: THEN
92: ;
93:
94: : SEARCH-SETS
95: 0 C,
96: ;
97:
98: : SEARCH-PRON
99: 0 C,
100: ;
101:
102: \G Process the header information stored in OLDLINE
103: : PROCESS-HEADER
104: HERE 0 , CURRENT-COMMENT @ ,
105: OLDLINE CHARPTR !
106: SEARCH-NAME
107: SEARCH-STACK
108: SEARCH-SETS
109: SEARCH-PRON
110: INSERT-HEADER
111: ;
112:
113: \G Determine if line at HERE is glossary comment, if so.
114: \G allot it, else store into oldline.
115: : GLOS-COMMENT? ( --- flag)
116: HERE C@ 1 > HERE CHAR+ 2 S" \G" COMPARE 0= AND
117: IF
118: HERE C@ 1+ CHARS ALLOT 1 \G incorporate current line.
119: ELSE
120: FIXLINE @ 0=
121: IF
122: HERE OLDLINE HERE C@ 1+ CHARS CMOVE
123: THEN 0
124: THEN
125: ;
126:
127: \G Read lines from the file fid until \G line encountered.
128: \G Collect all adjacent \G lines and find header line.
129: \G then insert entry into list flag=0 if no entry found.
130: : MAKE-GLOSENTRY ( fid --- fid flag)
131: >R
132: HERE CURRENT-COMMENT !
133: 0 FIXLINE ! 0 OLDLINE C!
134: BEGIN
135: HERE CHAR+ 255 R@ READ-LINE THROW 0= IF
136: DROP R> 0 EXIT \ end of file.
137: THEN
138: HERE C! \ Store length at here.
139: GLOS-COMMENT?
140: UNTIL
141: OLDLINE COUNT -TRAILING NIP IF 1 FIXLINE ! THEN
142: BEGIN
143: HERE CHAR+ 255 R@ READ-LINE THROW
144: IF
145: HERE C!
146: GLOS-COMMENT?
147: ELSE
148: DROP 0
149: THEN
150: 0= UNTIL
151: R> 1
152: 0 C, ALIGN \ allocate end flag after included comment lines.
153: PROCESS-HEADER
154: ;
155:
156: \G This command reads a source file and builds glossary info
157: \G for it in memory.
158: : MAKEGLOS ( "name")
159: BL WORD COUNT R/O OPEN-FILE THROW
160: BEGIN
161: MAKE-GLOSENTRY
162: 0= UNTIL
163: CLOSE-FILE THROW
164: ;
165:
166: \G Build header line for glossary entry.
167: : BUILD-HLINE ( addr ---)
168: 79 OLDLINE C! \ Line will be 79 chars long.
169: OLDLINE CHAR+ 79 BL FILL
170: 2 CELLS +
171: COUNT 2DUP OLDLINE CHAR+ SWAP CMOVE \ place name
172: DUP >R \ save name length.
173: CHARS +
174: COUNT 2DUP OLDLINE R> 3 + CHARS + SWAP CMOVE \ move stack diagram.
175: CHARS +
176: COUNT 2DUP OLDLINE 45 CHARS + SWAP CMOVE \ move wordsets field.
177: CHARS +
178: COUNT OLDLINE 63 CHARS + SWAP CMOVE \ move pronunciation field.
179: ;
180:
181: \G write the glossary entry at address addr to file fid.
182: : WRITE-GLOSENTRY ( addr fid --- )
183: >R
184: DUP 2 CELLS + C@
185: IF
186: DUP BUILD-HLINE
187: OLDLINE CHAR+ OLDLINE C@ R@ WRITE-LINE THROW \ write header line.
188: THEN
189: CELL+ @
190: BEGIN
191: DUP C@ 1 >
192: WHILE \ write all comment lines without prefixing \G.
193: DUP 4 CHARS + OVER C@ 3 - 0 MAX R@ WRITE-LINE THROW
194: COUNT CHARS +
195: REPEAT DROP
196: HERE 0 R> WRITE-LINE THROW \ Write final empty line.
197: ;
198:
199:
200: \G This command writes the glossary info from memory to a file.
201: \G The glossary info may be collected from more source files.
202: : WRITEGLOS ( "name")
203: BL WORD COUNT W/O CREATE-FILE THROW
204: GLOSLIST
205: BEGIN
206: @ DUP
207: WHILE
208: 2DUP SWAP WRITE-GLOSENTRY
209: REPEAT DROP
210: CLOSE-FILE THROW
211: ;
212:
213: \G A typical glossary session may look like:
214: \G NEWGLOS MAKEGLOS SOURCE1.FS MAKEGLOS SOURCE2.FS WRITEGLOS GLOS.GLO
215:
216:
217: CREATE GSTART
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>