1: \ wiki forth
2:
3: require string.fs
4:
5: \ tag handling
6:
7: : .' '' parse postpone SLiteral postpone type ; immediate
8: : s' '' parse postpone SLiteral ; immediate
9:
10: Variable tag-option
11: s" " tag-option $!
12:
13: : tag ( addr u -- ) '< emit type tag-option $@ type '> emit
14: s" " tag-option $! ;
15: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
16: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
17:
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 ;
23: : alt= ( addr u -- ) s" alt" opt ;
24: : width= ( addr u -- ) s" width" opt ;
25: : height= ( addr u -- ) s" height" opt ;
26: : align= ( addr u -- ) s" align" opt ;
27: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
28: tag-option $+! s' "' tag-option $+! ;
29:
30: \ environment handling
31:
32: Variable oldenv
33: Variable envs 10 0 [DO] 0 , [LOOP]
34:
35: : env$ ( -- addr ) envs dup @ 1+ cells + ;
36: : env ( addr u -- ) env$ $! ;
37: : env? ( -- ) envs @ oldenv @
38: 2dup > IF env$ $@ tag THEN
39: 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN
40: drop oldenv ! ;
41: : +env 1 envs +! ;
42: : -env -1 envs +! env? ;
43: : -envs envs @ 0 ?DO -env cr LOOP ;
44: : >env ( addr u -- ) +env env env? ;
45:
46: \ alignment
47:
48: : >align ( c -- )
49: CASE
50: 'l OF s" left" align= ENDOF
51: 'r OF s" right" align= ENDOF
52: 'c OF s" center" align= ENDOF
53: '< OF s" left" align= ENDOF
54: '> OF s" right" align= ENDOF
55: '| OF s" center" align= ENDOF
56: ENDCASE ;
57:
58: \ image handling
59:
60: Create imgbuf $20 allot
61:
62: Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c,
63: Create jfif $FF c, $D8 c, $FF c, $E0 c, $00 c, $10 c, $4A c, $46 c,
64: $49 c, $46 c,
65:
66: : b@ ( addr -- x ) 0 swap 4 bounds ?DO 8 lshift I c@ + LOOP ;
67: : bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ;
68:
69: : gif? ( -- flag )
70: s" GIF89a" imgbuf over compare 0=
71: s" GIF87a" imgbuf over compare 0= or ;
72: : gif-size ( -- w h )
73: imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift +
74: imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + ;
75:
76: : png? ( -- flag )
77: pngsig 8 imgbuf over compare 0= ;
78: : png-size ( -- w h )
79: imgbuf $10 + b@ imgbuf $14 + b@ ;
80:
81: : jpg? ( -- flag )
82: jfif 10 imgbuf over compare 0= ;
83: : jpg-size ( fd -- w h ) >r
84: 2. BEGIN
85: 2dup r@ reposition-file throw
86: imgbuf $10 r@ read-file throw 0<>
87: imgbuf bw@ $FFC0 $FFD0 within 0= and WHILE
88: imgbuf 2 + bw@ 2 + 0 d+ REPEAT
89: 2drop imgbuf 5 + bw@ imgbuf 7 + bw@ rdrop ;
90:
91: : img-size ( fd -- w h ) >r
92: gif? IF gif-size rdrop EXIT THEN
93: jpg? IF r> jpg-size EXIT THEN
94: png? IF png-size rdrop EXIT THEN
95: 0 0 ;
96:
97: : .img-size ( addr u -- )
98: r/o open-file throw >r
99: imgbuf $20 r@ read-file throw drop
100: r@ img-size
101: r> close-file throw
102: ?dup IF 0 <# #S #> width= THEN
103: ?dup IF 0 <# #S #> height= THEN ;
104:
105: \ link creation
106:
107: Variable link
108: Variable link-suffix
109: Variable iconpath
110:
111: Variable do-size
112:
113: Defer parse-line
114:
115: : alt-suffix ( -- )
116: link-suffix $@len 2 - link-suffix $!len
117: s" [" link-suffix 0 $ins
118: s" ]" link-suffix $+!
119: link-suffix $@ alt= ;
120:
121: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
122: link-suffix $! s" .*" link-suffix $+!
123: s" icons" open-dir throw >r
124: BEGIN
125: pad $100 r@ read-dir throw WHILE
126: pad swap 2dup link-suffix $@ filename-match
127: IF s" icons/" iconpath $! iconpath $+!
128: iconpath $@ 2dup .img-size src=
129: alt-suffix s" img" tag true
130: ELSE 2drop false THEN
131: UNTIL ELSE drop THEN
132: r> close-dir throw ;
133:
134: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
135: link $@
136: BEGIN '. $split 2swap 2drop dup WHILE
137: 2dup get-icon REPEAT 2drop ;
138:
139: : link-size? ( -- ) do-size @ 0= ?EXIT
140: link $@ r/o open-file IF drop EXIT THEN >r
141: r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)"
142: r> close-file throw ;
143:
144: : link-options ( addr u -- addr' u' )
145: do-size off
146: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
147:
148: : parse-string ( addr u -- )
149: evaluate-input cell new-tib #tib ! tib !
150: ['] parse-line catch pop-file throw ;
151:
152: : .link ( -- ) '[ parse type '] parse '| $split
153: link-options link $!
154: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
155: link-icon? link $@ href= s" a" tag
156: parse-string s" a" /tag link-size? ;
157:
158: : .img ( -- ) '{ parse type '} parse '| $split
159: dup IF 2swap alt= ELSE 2drop THEN
160: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
161: 2dup .img-size src= s" img" tag ;
162:
163: \ line handling
164:
165: : char? ( -- c ) >in @ char swap >in ! ;
166: : parse-tag ( addr u char -- )
167: >r r@ parse type
168: r> parse 2swap tagged ;
169:
170: : .text ( -- ) >in @ >r char drop
171: source r@ /string >in @ r> - nip type ;
172:
173: Create do-words $100 0 [DO] ' .text , [LOOP]
174:
175: : bind-char ( xt -- ) char cells do-words + ! ;
176:
177: : char>tag ( -- ) char >r
178: :noname bl sword postpone SLiteral r@ postpone Literal
179: postpone parse-tag postpone ; r> cells do-words + ! ;
180:
181: char>tag * b
182: char>tag _ em
183: char>tag # code
184:
185: ' .link bind-char [
186: ' .img bind-char {
187:
188: : do-word ( char -- ) cells do-words + perform ;
189:
190: :noname ( -- )
191: BEGIN char? do-word source nip >in @ = UNTIL ; is parse-line
192:
193: : parse-to ( char -- ) >r
194: BEGIN char? dup r@ <> WHILE
195: do-word source nip >in @ = UNTIL ELSE drop THEN
196: r> parse type ;
197:
198: \ paragraph handling
199:
200: : parse-par ( -- )
201: BEGIN parse-line cr refill WHILE
202: source nip 0= UNTIL THEN ;
203:
204: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
205: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
206:
207: \ handle global tags
208:
209: Variable indentlevel
210: : indent ( n -- ) indentlevel @
211: 2dup < IF 2dup swap DO -env -env LOOP THEN
212: 2dup > IF 2dup DO s" dl" >env LOOP THEN
213: 2dup = IF -env THEN
214: drop indentlevel ! s" dt" >env ;
215: : +indent ( -- ) -env s" dd" >env ;
216:
217: wordlist constant longtags
218:
219: Variable end-sec
220:
221: longtags set-current
222:
223: : --- 1 indent cr s" hr" tag cr +indent ;
224: : * 1 indent s" h1" line +indent ;
225: : ** 1 indent s" h2" line +indent ;
226: : *** 2 indent s" h3" line +indent ;
227: : - s" ul" env s" li" par ;
228: : + s" ol" env s" li" par ;
229: : << +env ;
230: : <* s" center" >env ;
231: : >> -env ;
232: : *> -env ;
233: : :: also forth interpret previous ;
234: : . end-sec on indentlevel off ;
235: : \ postpone \ ;
236:
237: definitions
238:
239: \ Table
240:
241: Variable table-format
242: Variable table#
243:
244: : |tag table-format $@ table# @ /string drop c@ >align
245: >env 1 table# +! ;
246: : |d table# @ IF -env THEN s" td" |tag ;
247: : |h table# @ IF -env THEN s" th" |tag ;
248: : |line s" tr" >env table# off ;
249: : line| -env -env cr ;
250:
251: : next-char ( -- char ) source drop >in @ + c@ ;
252:
253: longtags set-current
254:
255: : <| s" table" >env bl sword table-format $! ;
256: : |> -env ;
257: : +| |line
258: BEGIN
259: |h '| parse-to next-char '+ = UNTIL line| ;
260: : -| |line
261: BEGIN
262: |d '| parse-to next-char '- = UNTIL line| ;
263:
264: definitions
265:
266: \ parse a section
267:
268: : section-line ( -- ) >in off
269: bl sword find-name
270: ?dup IF name>int execute
271: ELSE source nip IF >in off s" p" par THEN THEN ;
272: : refill-loop ( -- ) end-sec off
273: BEGIN refill WHILE
274: section-line end-sec @ UNTIL THEN ;
275: : parse-section ( -- )
276: get-order longtags 1 set-order refill-loop set-order ;
277:
278: \ HTML head
279:
280: : .title ( addr u -- )
281: .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
282: s" html" >env s" head" >env
283: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
284: s" title" tagged cr
285: -env ;
286:
287: \ HTML trailer
288:
289: Variable mail
290: Variable mail-name
291:
292: : .trailer
293: s" address" >env s" center" >env
294: ." Last modified: " time&date rot 0 u.r swap 1-
295: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
296: 0 u.r ." by "
297: mail $@ mailto: mail-name $@ s" a" tagged
298: -envs ;
299:
300: \ top word
301:
302: : parse" ( -- addr u ) '" parse 2drop '" parse ;
303:
304: : maintainer
305: bl sword mail $! parse" mail-name $! ;
306:
307: Variable style$
308: : style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ;
309: : >style tag-option $@ style$ $! s" " tag-option $! ;
310:
311: : style style> opt >style ;
312: : background ( -- ) parse" s" background" style ;
313: : text ( -- ) parse" s" text" style ;
314: warnings @ warnings off
315: : link ( -- ) parse" s" link" style ;
316: warnings !
317: : vlink ( -- ) parse" s" vlink" style ;
318: : marginheight ( -- ) parse" s" marginheight" style ;
319:
320: : wf ( -- )
321: outfile-id >r
322: bl sword r/w create-file throw to outfile-id
323: parse" .title
324: +env style> s" body" env env?
325: ['] parse-section catch .trailer
326: outfile-id close-file throw
327: r> to outfile-id
328: dup 0< IF throw ELSE drop THEN ;
329:
330: : eval-par ( addr u -- )
331: s" wf-temp.wf" r/w create-file throw >r
332: r@ write-file r> close-file throw
333: push-file s" wf-temp.wf" r/o open-file throw loadfile !
334: parse-par parse-section
335: loadfile @ close-file swap 2dup or
336: pop-file drop throw throw
337: s" wf-temp.wf" delete-file throw ;
338:
339: \ simple text data base
340:
341: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
342: Create $lf 1 c, #lf c,
343: : get-par ( addr -- ) >r s" " r@ $+!
344: BEGIN 0 parse 2dup s" ." compare WHILE
345: r@ $@len IF $lf count r@ $+! THEN r@ $+!
346: refill 0= UNTIL ELSE 2drop THEN
347: rdrop ;
348:
349: Variable last-entry
350: Variable field#
351:
352: : table: ( xt n -- ) Create , , 1 field# !
353: DOES> 2@ >in @ >r longtags set-current
354: Create definitions swap , r> >in !
355: here last-entry !
356: dup 0 DO 0 , LOOP
357: 1 DO s" " last-entry @ I cells + $! LOOP
358: last-entry @ get-rest
359: DOES> dup cell+ swap perform ;
360:
361: : field: Create field# @ , 1 field# +!
362: DOES> @ cells last-entry @ + get-rest ;
363: : par: Create field# @ , 1 field# +!
364: DOES> @ cells last-entry @ + get-par ;
365:
366: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>