Annotation of gforth/wf.fs, revision 1.6
1.1 pazsan 1: \ wiki forth
2:
3: require string.fs
4:
5: \ tag handling
6:
7: : .' '' parse postpone SLiteral postpone type ; immediate
1.3 pazsan 8: : s' '' parse postpone SLiteral ; immediate
1.1 pazsan 9:
1.3 pazsan 10: Variable tag-option
11: s" " tag-option $!
12:
13: : tag ( addr u -- ) '< emit type tag-option $@ type '> emit
14: s" " tag-option $! ;
1.1 pazsan 15: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
1.2 pazsan 16: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
1.1 pazsan 17:
1.3 pazsan 18: : opt ( addr u opt u -- ) s" " tag-option $+!
19: tag-option $+! s' ="' tag-option $+! tag-option $+!
20: s' "' tag-option $+! ;
21: : href= ( addr u -- ) s" href" opt ;
22: : src= ( addr u -- ) s" src" opt ;
1.4 pazsan 23: : alt= ( addr u -- ) s" alt" opt ;
1.3 pazsan 24: : align= ( addr u -- ) s" align" opt ;
25: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
26: tag-option $+! s' "' tag-option $+! ;
27:
1.1 pazsan 28: \ environment handling
29:
30: Variable oldenv
31: Variable envs 10 0 [DO] 0 , [LOOP]
32:
33: : env$ ( -- addr ) envs dup @ 1+ cells + ;
34: : env ( addr u -- ) env$ $! ;
35: : env? ( -- ) envs @ oldenv @
36: 2dup > IF env$ $@ tag THEN
37: 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN
38: drop oldenv ! ;
39: : +env 1 envs +! ;
40: : -env -1 envs +! env? ;
41: : -envs envs @ 0 ?DO -env cr LOOP ;
1.2 pazsan 42: : >env ( addr u -- ) +env env env? ;
1.1 pazsan 43:
1.6 ! pazsan 44: \ alignment
! 45:
! 46: : >align ( c -- )
! 47: CASE
! 48: 'l OF s" left" align= ENDOF
! 49: 'r OF s" right" align= ENDOF
! 50: 'c OF s" center" align= ENDOF
! 51: '< OF s" left" align= ENDOF
! 52: '> OF s" right" align= ENDOF
! 53: '| OF s" center" align= ENDOF
! 54: ENDCASE ;
! 55:
1.1 pazsan 56: \ link creation
57:
58: Variable link
59: Variable link-suffix
1.3 pazsan 60: Variable iconpath
1.1 pazsan 61:
1.2 pazsan 62: Variable do-size
63:
1.6 ! pazsan 64: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
! 65: link-suffix $! s" .*" link-suffix $+!
1.1 pazsan 66: s" icons" open-dir throw >r
67: BEGIN
68: pad $100 r@ read-dir throw WHILE
69: pad swap 2dup link-suffix $@ filename-match
1.3 pazsan 70: IF s" icons/" iconpath $! iconpath $+!
71: iconpath $@ src= s" img" tag true
1.1 pazsan 72: ELSE 2drop false THEN
1.6 ! pazsan 73: UNTIL ELSE drop THEN
1.1 pazsan 74: r> close-dir throw ;
75:
1.6 ! pazsan 76: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
! 77: link '. ['] get-icon $iter ;
! 78:
1.2 pazsan 79: : link-size? ( -- ) do-size @ 0= ?EXIT
1.1 pazsan 80: link $@ r/o open-file IF drop EXIT THEN >r
81: r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)"
82: r> close-file throw ;
83:
1.2 pazsan 84: : link-options ( addr u -- addr' u' )
1.3 pazsan 85: do-size off
86: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
1.2 pazsan 87:
88: : .link ( -- ) '[ parse type '] parse '| $split
89: link-options link $!
1.1 pazsan 90: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
1.3 pazsan 91: link-icon? link $@ href= s" a" tagged
1.1 pazsan 92: link-size? ;
93:
1.4 pazsan 94: : .img ( -- ) '{ parse type '} parse '| $split
1.6 ! pazsan 95: dup IF 2swap alt= ELSE 2drop THEN
! 96: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
! 97: src= s" img" tag ;
1.4 pazsan 98:
1.1 pazsan 99: \ line handling
100:
1.4 pazsan 101: : char? ( -- c ) >in @ char swap >in ! ;
1.1 pazsan 102: : parse-tag ( addr u char -- )
103: >r r@ parse type
1.2 pazsan 104: r> parse 2swap tagged ;
1.1 pazsan 105:
1.6 ! pazsan 106: : .text ( -- ) >in @ >r char drop
! 107: source r@ /string >in @ r> - nip type ;
! 108:
! 109: Create do-words $100 0 [DO] ' .text , [LOOP]
! 110:
! 111: : bind-char ( xt -- ) char cells do-words + ! ;
! 112:
! 113: : char>tag ( -- ) char >r
! 114: :noname bl sword postpone SLiteral r@ postpone Literal
! 115: postpone parse-tag postpone ; r> cells do-words + ! ;
1.1 pazsan 116:
1.6 ! pazsan 117: char>tag * b
! 118: char>tag _ em
! 119: char>tag # code
! 120:
! 121: ' .link bind-char [
! 122: ' .img bind-char {
! 123:
! 124: : do-word ( char -- ) cells do-words + perform ;
1.4 pazsan 125:
1.1 pazsan 126: : parse-line ( -- )
1.4 pazsan 127: BEGIN char? do-word source nip >in @ = UNTIL ;
128:
129: : parse-to ( char -- ) >r
130: BEGIN char? dup r@ <> WHILE
131: do-word source nip >in @ = UNTIL ELSE drop THEN
132: r> parse type ;
1.1 pazsan 133:
134: \ paragraph handling
135:
136: : parse-par ( -- )
137: BEGIN parse-line cr refill WHILE
138: source nip 0= UNTIL THEN ;
139:
140: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
141: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
142:
143: \ handle global tags
144:
145: wordlist constant longtags
146:
147: Variable end-sec
148:
149: longtags set-current
150:
1.3 pazsan 151: : --- cr s" hr" tag cr ;
1.1 pazsan 152: : * s" h1" line ;
153: : ** s" h2" line ;
154: : *** s" h3" line ;
155: : - s" ul" env s" li" par ;
156: : + s" ol" env s" li" par ;
157: : << +env ;
1.3 pazsan 158: : <* s" center" >env ;
1.1 pazsan 159: : >> -env ;
1.3 pazsan 160: : *> -env ;
1.1 pazsan 161: : . end-sec on ;
162: : \ postpone \ ;
163:
164: definitions
1.3 pazsan 165:
166: \ Table
167:
168: Variable table-format
169: Variable table#
170:
1.6 ! pazsan 171: : |tag table-format $@ table# @ /string drop c@ >align
! 172: >env 1 table# +! ;
1.3 pazsan 173: : |d table# @ IF -env THEN s" td" |tag ;
174: : |h table# @ IF -env THEN s" th" |tag ;
175: : |line s" tr" >env table# off ;
176: : line| -env -env cr ;
177:
1.5 pazsan 178: : next-char ( -- char ) source drop >in @ + c@ ;
179:
1.3 pazsan 180: longtags set-current
181:
182: : <| s" table" >env bl sword table-format $! ;
183: : |> -env ;
184: : +| |line
185: BEGIN
1.5 pazsan 186: |h '| parse-to next-char '+ = UNTIL line| ;
1.3 pazsan 187: : -| |line
188: BEGIN
1.5 pazsan 189: |d '| parse-to next-char '- = UNTIL line| ;
1.3 pazsan 190:
191: definitions
1.1 pazsan 192:
193: \ parse a section
194:
195: : refill-loop ( -- ) end-sec off
196: BEGIN refill WHILE >in off
197: bl sword find-name
198: ?dup IF name>int execute
199: ELSE source nip IF >in off s" p" par THEN THEN
200: end-sec @ UNTIL THEN ;
201: : parse-section ( -- )
202: get-order longtags 1 set-order refill-loop set-order ;
203:
204: \ HTML head
205:
206: : .title ( addr u -- )
207: .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
1.2 pazsan 208: s" html" >env s" head" >env
1.1 pazsan 209: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
1.2 pazsan 210: s" title" tagged cr
1.1 pazsan 211: -env ;
212:
213: \ HTML trailer
214:
215: Variable mail
216: Variable mail-name
217:
218: : .trailer
1.2 pazsan 219: s" address" >env s" center" >env
220: ." Last modified: " time&date rot 0 u.r swap 1-
1.1 pazsan 221: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
1.3 pazsan 222: 0 u.r ." by "
223: mail $@ mailto: mail-name $@ s" a" tagged
1.1 pazsan 224: -envs ;
225:
226: \ top word
227:
1.6 ! pazsan 228: : parse" ( -- addr u ) '" parse 2drop '" parse ;
! 229:
1.1 pazsan 230: : maintainer
1.6 ! pazsan 231: bl sword mail $! parse" mail-name $! ;
! 232:
! 233: Variable style$
! 234: : style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ;
! 235: : >style tag-option $@ style$ $! s" " tag-option $! ;
! 236:
! 237: : style style> opt >style ;
! 238: : background ( -- ) parse" s" background" style ;
! 239: : text ( -- ) parse" s" text" style ;
! 240: warnings @ warnings off
! 241: : link ( -- ) parse" s" link" style ;
! 242: warnings !
! 243: : vlink ( -- ) parse" s" vlink" style ;
! 244: : marginheight ( -- ) parse" s" marginheight" style ;
1.1 pazsan 245:
246: : wf ( -- )
247: outfile-id >r
248: bl sword r/w create-file throw to outfile-id
1.6 ! pazsan 249: parse" .title
! 250: +env style> s" body" env env?
1.1 pazsan 251: ['] parse-section catch .trailer
252: outfile-id close-file throw
253: r> to outfile-id
254: dup 0< IF throw ELSE drop THEN ;
255:
1.2 pazsan 256: \ simple text data base
257:
258: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
259:
260: Variable last-entry
261: Variable field#
262:
263: : table: ( xt n -- ) Create , , 1 field# !
264: DOES> 2@ >in @ >r longtags set-current
265: Create definitions swap , r> >in !
266: here last-entry !
267: dup 0 DO 0 , LOOP
268: 1 DO s" " last-entry @ I cells + $! LOOP
269: last-entry @ get-rest
270: DOES> dup cell+ swap perform ;
271:
272: : field: Create field# @ , 1 field# +!
273: DOES> @ cells last-entry @ + get-rest ;
1.3 pazsan 274:
275: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>