Return to glosgen.fs CVS log

Up to [gforth] / gforth

Initial revision

    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