Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.1 | \ documentation source to texi format converter |
| 2 : | |||
| 3 : | \ documentation source can contain lines in the form `doc-word' and | ||
| 4 : | \ `short-word'. These are converted to appropriate full or short | ||
| 5 : | \ (without the description) glossary entries for word. | ||
| 6 : | |||
| 7 : | \ The glossary entries are generated from data present in the wordlist | ||
| 8 : | \ `documentation'. Each word resides there under its own name. | ||
| 9 : | |||
| 10 : | pazsan | 1.2 | script? [IF] |
| 11 : | warnings off | ||
| 12 : | include search-order.fs | ||
| 13 : | include struct.fs | ||
| 14 : | include debugging.fs | ||
| 15 : | [THEN] | ||
| 16 : | |||
| 17 : | anton | 1.1 | wordlist constant documentation |
| 18 : | |||
| 19 : | struct | ||
| 20 : | 2 cells: field doc-name | ||
| 21 : | 2 cells: field doc-stack-effect | ||
| 22 : | 2 cells: field doc-wordset | ||
| 23 : | 2 cells: field doc-pronounciation | ||
| 24 : | 2 cells: field doc-description | ||
| 25 : | end-struct doc-entry | ||
| 26 : | |||
| 27 : | anton | 1.4 | create description-buffer 4096 chars allot |
| 28 : | |||
| 29 : | : get-description ( -- addr u ) | ||
| 30 : | description-buffer | ||
| 31 : | begin | ||
| 32 : | refill | ||
| 33 : | while | ||
| 34 : | source nip | ||
| 35 : | while | ||
| 36 : | source swap >r 2dup r> -rot cmove | ||
| 37 : | chars + | ||
| 38 : | #lf over c! char+ | ||
| 39 : | repeat then | ||
| 40 : | description-buffer tuck - ; | ||
| 41 : | |||
| 42 : | : make-doc ( -- ) | ||
| 43 : | get-current documentation set-current | ||
| 44 : | create | ||
| 45 : | last @ name>string 2, \ name | ||
| 46 : | [char] ) parse save-string 2, \ stack-effect | ||
| 47 : | bl parse-word save-string 2, \ wordset | ||
| 48 : | bl parse-word dup \ pronounciation | ||
| 49 : | if | ||
| 50 : | save-string | ||
| 51 : | else | ||
| 52 : | 2drop last @ name>string | ||
| 53 : | endif | ||
| 54 : | 2, | ||
| 55 : | get-description save-string 2, | ||
| 56 : | set-current ; | ||
| 57 : | |||
| 58 : | anton | 1.1 | : emittexi ( c -- ) |
| 59 : | >r | ||
| 60 : | s" @{}" r@ scan 0<> | ||
| 61 : | if | ||
| 62 : | [char] @ emit | ||
| 63 : | endif | ||
| 64 : | drop r> emit ; | ||
| 65 : | |||
| 66 : | : typetexi ( addr u -- ) | ||
| 67 : | 0 | ||
| 68 : | ?do | ||
| 69 : | dup c@ emittexi | ||
| 70 : | char+ | ||
| 71 : | loop | ||
| 72 : | drop ; | ||
| 73 : | |||
| 74 : | : print-short ( doc-entry -- ) | ||
| 75 : | anton | 1.3 | >r ." @format" cr |
| 76 : | anton | 1.1 | ." @code{" r@ doc-name 2@ typetexi ." } " |
| 77 : | ." @i{" r@ doc-stack-effect 2@ type ." } " | ||
| 78 : | r@ doc-wordset 2@ type ." ``" | ||
| 79 : | anton | 1.3 | r@ doc-pronounciation 2@ type ." ''" cr ." @end format" cr |
| 80 : | anton | 1.1 | rdrop ; |
| 81 : | |||
| 82 : | : print-doc ( doc-entry -- ) | ||
| 83 : | >r | ||
| 84 : | r@ print-short | ||
| 85 : | r@ doc-description 2@ dup 0<> | ||
| 86 : | if | ||
| 87 : | type ." @*" cr | ||
| 88 : | else | ||
| 89 : | 2drop cr | ||
| 90 : | endif | ||
| 91 : | rdrop ; | ||
| 92 : | |||
| 93 : | : do-doc ( addr1 u1 addr2 u2 xt -- f ) | ||
| 94 : | \ xt is the word to be executed if addr1 u1 is a string starting | ||
| 95 : | \ with the prefix addr2 u2 and continuing with a word in the | ||
| 96 : | \ wordlist `documentation'. f is true if xt is executed. | ||
| 97 : | >r dup >r | ||
| 98 : | 3 pick over compare 0= | ||
| 99 : | if \ addr2 u2 is a prefix of addr1 u1 | ||
| 100 : | r> /string documentation search-wordlist | ||
| 101 : | if \ the rest of addr1 u1 is in documentation | ||
| 102 : | execute r> execute true | ||
| 103 : | else | ||
| 104 : | rdrop false | ||
| 105 : | endif | ||
| 106 : | else | ||
| 107 : | 2drop 2rdrop false | ||
| 108 : | endif ; | ||
| 109 : | |||
| 110 : | : process-line ( addr u -- ) | ||
| 111 : | 2dup s" doc-" ['] print-doc do-doc 0= | ||
| 112 : | if | ||
| 113 : | 2dup s" short-" ['] print-short do-doc 0= | ||
| 114 : | if | ||
| 115 : | type cr EXIT | ||
| 116 : | endif | ||
| 117 : | endif | ||
| 118 : | 2drop ; | ||
| 119 : | |||
| 120 : | 1024 constant doclinelength | ||
| 121 : | |||
| 122 : | create docline doclinelength chars allot | ||
| 123 : | |||
| 124 : | : ds2texi ( file-id -- ) | ||
| 125 : | >r | ||
| 126 : | begin | ||
| 127 : | docline doclinelength r@ read-line throw | ||
| 128 : | while | ||
| 129 : | dup doclinelength = abort" docline too long" | ||
| 130 : | docline swap process-line | ||
| 131 : | repeat | ||
| 132 : | drop rdrop ; | ||
| 133 : | pazsan | 1.2 | |
| 134 : | script? [IF] | ||
| 135 : | include prims2x.fs | ||
| 136 : | s" primitives.b" ' register-doc process-file | ||
| 137 : | pazsan | 1.5 | require doc.fd |
| 138 : | require crossdoc.fd | ||
| 139 : | pazsan | 1.2 | s" gforth.ds" r/o open-file throw ds2texi bye |
| 140 : | [THEN] |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |