Annotation of gforth/wf.fs, revision 1.8
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.7 pazsan 24: : width= ( addr u -- ) s" width" opt ;
25: : height= ( addr u -- ) s" height" opt ;
1.3 pazsan 26: : align= ( addr u -- ) s" align" opt ;
27: : mailto: ( addr u -- ) s' href="mailto:' tag-option $+!
28: tag-option $+! s' "' tag-option $+! ;
29:
1.1 pazsan 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 ;
1.2 pazsan 44: : >env ( addr u -- ) +env env env? ;
1.1 pazsan 45:
1.6 pazsan 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:
1.7 pazsan 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<>
1.8 ! pazsan 87: imgbuf bw@ $FFC0 $FFD0 within 0= and WHILE
1.7 pazsan 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:
1.1 pazsan 105: \ link creation
106:
107: Variable link
108: Variable link-suffix
1.3 pazsan 109: Variable iconpath
1.1 pazsan 110:
1.2 pazsan 111: Variable do-size
112:
1.8 ! pazsan 113: Defer parse-line
! 114:
1.7 pazsan 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:
1.6 pazsan 121: : get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN
122: link-suffix $! s" .*" link-suffix $+!
1.1 pazsan 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
1.3 pazsan 127: IF s" icons/" iconpath $! iconpath $+!
1.7 pazsan 128: iconpath $@ 2dup .img-size src=
129: alt-suffix s" img" tag true
1.1 pazsan 130: ELSE 2drop false THEN
1.6 pazsan 131: UNTIL ELSE drop THEN
1.1 pazsan 132: r> close-dir throw ;
133:
1.6 pazsan 134: : link-icon? ( -- ) iconpath @ IF iconpath $off THEN
1.8 ! pazsan 135: link $@
! 136: BEGIN '. $split 2swap 2drop dup WHILE
! 137: 2dup get-icon REPEAT 2drop ;
1.6 pazsan 138:
1.2 pazsan 139: : link-size? ( -- ) do-size @ 0= ?EXIT
1.1 pazsan 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:
1.2 pazsan 144: : link-options ( addr u -- addr' u' )
1.3 pazsan 145: do-size off
146: over c@ '% = over 0> and IF do-size on 1 /string THEN ;
1.2 pazsan 147:
1.8 ! pazsan 148: : parse-string ( addr u -- )
! 149: evaluate-input cell new-tib #tib ! tib !
! 150: ['] parse-line catch pop-file throw ;
! 151:
1.2 pazsan 152: : .link ( -- ) '[ parse type '] parse '| $split
153: link-options link $!
1.1 pazsan 154: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
1.8 ! pazsan 155: link-icon? link $@ href= s" a" tag
! 156: parse-string s" a" /tag link-size? ;
1.1 pazsan 157:
1.4 pazsan 158: : .img ( -- ) '{ parse type '} parse '| $split
1.6 pazsan 159: dup IF 2swap alt= ELSE 2drop THEN
160: tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
1.7 pazsan 161: 2dup .img-size src= s" img" tag ;
1.4 pazsan 162:
1.1 pazsan 163: \ line handling
164:
1.4 pazsan 165: : char? ( -- c ) >in @ char swap >in ! ;
1.1 pazsan 166: : parse-tag ( addr u char -- )
167: >r r@ parse type
1.2 pazsan 168: r> parse 2swap tagged ;
1.1 pazsan 169:
1.6 pazsan 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 + ! ;
1.1 pazsan 180:
1.6 pazsan 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 ;
1.4 pazsan 189:
1.8 ! pazsan 190: :noname ( -- )
! 191: BEGIN char? do-word source nip >in @ = UNTIL ; is parse-line
1.4 pazsan 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 ;
1.1 pazsan 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:
1.8 ! pazsan 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:
1.1 pazsan 217: wordlist constant longtags
218:
219: Variable end-sec
220:
221: longtags set-current
222:
1.8 ! pazsan 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 ;
1.1 pazsan 227: : - s" ul" env s" li" par ;
228: : + s" ol" env s" li" par ;
229: : << +env ;
1.3 pazsan 230: : <* s" center" >env ;
1.1 pazsan 231: : >> -env ;
1.3 pazsan 232: : *> -env ;
1.8 ! pazsan 233: : :: also forth interpret previous ;
! 234: : . end-sec on indentlevel off ;
1.1 pazsan 235: : \ postpone \ ;
236:
237: definitions
1.3 pazsan 238:
239: \ Table
240:
241: Variable table-format
242: Variable table#
243:
1.6 pazsan 244: : |tag table-format $@ table# @ /string drop c@ >align
245: >env 1 table# +! ;
1.3 pazsan 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:
1.5 pazsan 251: : next-char ( -- char ) source drop >in @ + c@ ;
252:
1.3 pazsan 253: longtags set-current
254:
255: : <| s" table" >env bl sword table-format $! ;
256: : |> -env ;
257: : +| |line
258: BEGIN
1.5 pazsan 259: |h '| parse-to next-char '+ = UNTIL line| ;
1.3 pazsan 260: : -| |line
261: BEGIN
1.5 pazsan 262: |d '| parse-to next-char '- = UNTIL line| ;
1.3 pazsan 263:
264: definitions
1.1 pazsan 265:
266: \ parse a section
267:
1.8 ! pazsan 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 ;
1.1 pazsan 272: : refill-loop ( -- ) end-sec off
1.8 ! pazsan 273: BEGIN refill WHILE
! 274: section-line end-sec @ UNTIL THEN ;
1.1 pazsan 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
1.2 pazsan 282: s" html" >env s" head" >env
1.1 pazsan 283: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
1.2 pazsan 284: s" title" tagged cr
1.1 pazsan 285: -env ;
286:
287: \ HTML trailer
288:
289: Variable mail
290: Variable mail-name
291:
292: : .trailer
1.2 pazsan 293: s" address" >env s" center" >env
294: ." Last modified: " time&date rot 0 u.r swap 1-
1.1 pazsan 295: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
1.3 pazsan 296: 0 u.r ." by "
297: mail $@ mailto: mail-name $@ s" a" tagged
1.1 pazsan 298: -envs ;
299:
300: \ top word
301:
1.6 pazsan 302: : parse" ( -- addr u ) '" parse 2drop '" parse ;
303:
1.1 pazsan 304: : maintainer
1.6 pazsan 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 ;
1.1 pazsan 319:
320: : wf ( -- )
321: outfile-id >r
322: bl sword r/w create-file throw to outfile-id
1.6 pazsan 323: parse" .title
324: +env style> s" body" env env?
1.1 pazsan 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:
1.8 ! pazsan 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:
1.2 pazsan 339: \ simple text data base
340:
341: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
1.8 ! pazsan 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 ;
1.2 pazsan 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 ;
1.8 ! pazsan 363: : par: Create field# @ , 1 field# +!
! 364: DOES> @ cells last-entry @ + get-par ;
1.3 pazsan 365:
366: : >field ' >body @ cells postpone Literal postpone + ; immediate
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>