Annotation of gforth/glosgen.fs, revision 1.1
1.1 ! anton 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>