Annotation of gforth/wf.fs, revision 1.2
1.1 pazsan 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 ;
1.2 ! pazsan 11: : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag type 2r> /tag ;
1.1 pazsan 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 ;
1.2 ! pazsan 27: : >env ( addr u -- ) +env env env? ;
1.1 pazsan 28:
29: \ link creation
30:
31: Variable link
32: Variable link-suffix
33:
1.2 ! pazsan 34: Variable do-icon
! 35: Variable do-size
! 36:
! 37: : link-icon? ( -- ) do-icon @ 0= ?EXIT
1.1 pazsan 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:
1.2 ! pazsan 48: : link-size? ( -- ) do-size @ 0= ?EXIT
1.1 pazsan 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:
1.2 ! pazsan 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 $!
1.1 pazsan 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
1.2 ! pazsan 73: r> parse 2swap tagged ;
1.1 pazsan 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:
1.2 ! pazsan 106: : --- cr s" hr" tag ;
1.1 pazsan 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
1.2 ! pazsan 134: s" html" >env s" head" >env
1.1 pazsan 135: .' <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
1.2 ! pazsan 136: s" title" tagged cr
1.1 pazsan 137: -env ;
138:
139: \ HTML trailer
140:
141: Variable mail
142: Variable mail-name
143:
144: : .trailer
1.2 ! pazsan 145: s" address" >env s" center" >env
! 146: ." Last modified: " time&date rot 0 u.r swap 1-
1.1 pazsan 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:
1.2 ! pazsan 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>