Annotation of gforth/ds2texi.fs, revision 1.17

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

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