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