Annotation of gforth/ds2texi.fs, revision 1.32

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

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