1: \ wiki forth
2:
3: require string.fs
4:
5: \ tag handling
6:
7: : .' '' parse postpone SLiteral postpone type ; immediate
8:
9: : tag ( addr u -- ) '< emit type '> emit ;
10: : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
11: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
12:
13: \ environment handling
14:
15: Variable oldenv
16: Variable envs 10 0 [DO] 0 , [LOOP]
17:
18: : env$ ( -- addr ) envs dup @ 1+ cells + ;
19: : env ( addr u -- ) env$ $! ;
20: : env? ( -- ) envs @ oldenv @
21: 2dup > IF env$ $@ tag THEN
22: 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN
23: drop oldenv ! ;
24: : +env 1 envs +! ;
25: : -env -1 envs +! env? ;
26: : -envs envs @ 0 ?DO -env cr LOOP ;
27: : >env ( addr u -- ) +env env env? ;
28:
29: \ link creation
30:
31: Variable link
32: Variable link-suffix
33:
34: Variable do-icon
35: Variable do-size
36:
37: : link-icon? ( -- ) do-icon @ 0= ?EXIT
38: link $@ '. $split link-suffix $! 2drop s" .*" link-suffix $+!
39: s" icons" open-dir throw >r
40: BEGIN
41: pad $100 r@ read-dir throw WHILE
42: pad swap 2dup link-suffix $@ filename-match
43: IF .' <img src="icons/' type .' ">' true
44: ELSE 2drop false THEN
45: UNTIL ELSE '( emit link-suffix $@ 2 - type ') emit THEN
46: r> close-dir throw ;
47:
48: : link-size? ( -- ) do-size @ 0= ?EXIT
49: link $@ r/o open-file IF drop EXIT THEN >r
50: r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)"
51: r> close-file throw ;
52:
53: : link-options ( addr u -- addr' u' )
54: do-icon off do-size off
55: BEGIN dup 1 >= WHILE
56: over c@ CASE
57: '% OF do-size on 1 /string ENDOF
58: '& OF do-icon on 1 /string ENDOF
59: drop EXIT
60: ENDCASE
61: REPEAT ;
62:
63: : .link ( -- ) '[ parse type '] parse '| $split
64: link-options link $!
65: link $@len 0= IF 2dup link $! s" .html" link $+! THEN
66: link-icon? .' <a href="' link $@ type .' ">' type s" a" /tag
67: link-size? ;
68:
69: \ line handling
70:
71: : parse-tag ( addr u char -- )
72: >r r@ parse type
73: r> parse 2swap tagged ;
74:
75: : .bold ( -- ) s" b" '* parse-tag ;
76: : .em ( -- ) s" em" '_ parse-tag ;
77:
78: : parse-line ( -- )
79: BEGIN >in @ >r char r> >in !
80: CASE
81: '* OF .bold ENDOF
82: '_ OF .em ENDOF
83: '[ OF .link ENDOF
84: >in @ >r char drop
85: source r@ /string >in @ r> - nip type
86: ENDCASE
87: source nip >in @ = UNTIL ;
88:
89: \ paragraph handling
90:
91: : parse-par ( -- )
92: BEGIN parse-line cr refill WHILE
93: source nip 0= UNTIL THEN ;
94:
95: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
96: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
97:
98: \ handle global tags
99:
100: wordlist constant longtags
101:
102: Variable end-sec
103:
104: longtags set-current
105:
106: : --- cr s" hr" tag ;
107: : * s" h1" line ;
108: : ** s" h2" line ;
109: : *** s" h3" line ;
110: : - s" ul" env s" li" par ;
111: : + s" ol" env s" li" par ;
112: : << +env ;
113: : >> -env ;
114: : . end-sec on ;
115: : \ postpone \ ;
116:
117: definitions
118:
119: \ parse a section
120:
121: : refill-loop ( -- ) end-sec off
122: BEGIN refill WHILE >in off
123: bl sword find-name
124: ?dup IF name>int execute
125: ELSE source nip IF >in off s" p" par THEN THEN
126: end-sec @ UNTIL THEN ;
127: : parse-section ( -- )
128: get-order longtags 1 set-order refill-loop set-order ;
129:
130: \ HTML head
131:
132: : .title ( addr u -- )
133: .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
134: s" html" >env s" head" >env
135: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
136: s" title" tagged cr
137: -env ;
138:
139: \ HTML trailer
140:
141: Variable mail
142: Variable mail-name
143:
144: : .trailer
145: s" address" >env s" center" >env
146: ." Last modified: " time&date rot 0 u.r swap 1-
147: s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
148: 0 u.r
149: .' by <a href="mailto:' mail $@ type .' ">' mail-name $@ type s" a" /tag
150: -envs ;
151:
152: \ top word
153:
154: : maintainer
155: bl sword mail $! '" parse 2drop '" parse mail-name $! ;
156:
157: : wf ( -- )
158: outfile-id >r
159: bl sword r/w create-file throw to outfile-id
160: '" parse 2drop '" parse .title
161: +env s" body" env
162: ['] parse-section catch .trailer
163: outfile-id close-file throw
164: r> to outfile-id
165: dup 0< IF throw ELSE drop THEN ;
166:
167: \ simple text data base
168:
169: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
170:
171: Variable last-entry
172: Variable field#
173:
174: : table: ( xt n -- ) Create , , 1 field# !
175: DOES> 2@ >in @ >r longtags set-current
176: Create definitions swap , r> >in !
177: here last-entry !
178: dup 0 DO 0 , LOOP
179: 1 DO s" " last-entry @ I cells + $! LOOP
180: last-entry @ get-rest
181: DOES> dup cell+ swap perform ;
182:
183: : field: Create field# @ , 1 field# +!
184: DOES> @ cells last-entry @ + get-rest ;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>