File:  [gforth] / gforth / glosgen.fs
Revision 1.4: download - view: text, annotated - select for diffs
Sun Mar 9 15:16:49 2003 UTC (16 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-6-1, v0-6-0, HEAD
updated copyright years

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

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>