--- gforth/wf.fs 2001/07/29 20:19:25 1.9 +++ gforth/wf.fs 2001/08/06 20:39:48 1.11 @@ -2,6 +2,13 @@ require string.fs +: -scan ( addr u char -- addr' u' ) + >r BEGIN dup WHILE 1- 2dup + c@ r@ = UNTIL THEN + rdrop ; +: -$split ( addr u char -- addr1 u1 addr2 u2 ) + >r 2dup r@ -scan 2dup + c@ r> = negate over + >r + 2swap r> /string ; + \ tag handling : .' '' parse postpone SLiteral postpone type ; immediate @@ -19,6 +26,7 @@ s" " tag-option $! tag-option $+! s' ="' tag-option $+! tag-option $+! s' "' tag-option $+! ; : href= ( addr u -- ) s" href" opt ; +: name= ( addr u -- ) s" name" opt ; : src= ( addr u -- ) s" src" opt ; : alt= ( addr u -- ) s" alt" opt ; : width= ( addr u -- ) s" width" opt ; @@ -29,8 +37,9 @@ s" " tag-option $! \ environment handling +Variable end-sec Variable oldenv -Variable envs 10 0 [DO] 0 , [LOOP] +Variable envs 30 0 [DO] 0 , [LOOP] : env$ ( -- addr ) envs dup @ 1+ cells + ; : env ( addr u -- ) env$ $! ; @@ -39,7 +48,7 @@ Variable envs 10 0 [DO] 0 , [LOOP] 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN drop oldenv ! ; : +env 1 envs +! ; -: -env -1 envs +! env? ; +: -env end-sec @ envs @ 2 > or IF -1 envs +! env? THEN ; : -envs envs @ 0 ?DO -env cr LOOP ; : >env ( addr u -- ) +env env env? ; @@ -52,9 +61,15 @@ Variable envs 10 0 [DO] 0 , [LOOP] 'c OF s" center" align= ENDOF '< OF s" left" align= ENDOF '> OF s" right" align= ENDOF - '| OF s" center" align= ENDOF + '= OF s" center" align= ENDOF ENDCASE ; +: >border ( c -- ) + case + '- of s" 0" s" border" opt endof + '+ of s" 1" s" border" opt endof + endcase ; + \ image handling Create imgbuf $20 allot @@ -70,13 +85,13 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c s" GIF89a" imgbuf over compare 0= s" GIF87a" imgbuf over compare 0= or ; : gif-size ( -- w h ) - imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + - imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + ; + imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + + imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + ; : png? ( -- flag ) pngsig 8 imgbuf over compare 0= ; : png-size ( -- w h ) - imgbuf $10 + b@ imgbuf $14 + b@ ; + imgbuf $14 + b@ imgbuf $10 + b@ ; : jpg? ( -- flag ) jfif 10 imgbuf over compare 0= ; @@ -95,7 +110,7 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c 0 0 ; : .img-size ( addr u -- ) - r/o open-file throw >r + r/o open-file IF drop EXIT THEN >r imgbuf $20 r@ read-file throw drop r@ img-size r> close-file throw @@ -105,6 +120,7 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c \ link creation Variable link +Variable link-sig Variable link-suffix Variable iconpath @@ -113,6 +129,13 @@ Variable do-icon Defer parse-line +: .img ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN + dup IF 2swap alt= ELSE 2drop THEN + tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string + tag-option $@len >r over c@ >border tag-option $@len r> = 1+ /string + 2dup .img-size src= s" img" tag ; +: >img ( -- ) '{ parse type '} parse .img ; + : alt-suffix ( -- ) link-suffix $@len 2 - link-suffix $!len s" [" link-suffix 0 $ins @@ -126,7 +149,7 @@ Defer parse-line pad $100 r@ read-dir throw WHILE pad swap 2dup link-suffix $@ filename-match IF s" icons/" iconpath $! iconpath $+! - iconpath $@ 2dup .img-size src= + iconpath $@ 2dup .img-size src= '- >border alt-suffix s" img" tag true ELSE 2drop false THEN UNTIL ELSE drop THEN @@ -143,6 +166,13 @@ Defer parse-line r@ file-size throw $400 um/mod nip ." (" 0 u.r ." k)" r> close-file throw ; +: link-sig? ( -- ) + link $@ link-sig $! s" .sig" link-sig $+! + link-sig $@ r/o open-file IF drop EXIT THEN + close-file throw + ." (" link-sig $@ href= s" a" tag + s" |-icons/sig.gif" .img ." sig" s" /a" tag ." )" ; + : link-options ( addr u -- addr' u' ) do-size off do-icon on over c@ '% = over 0> and IF do-size on 1 /string THEN @@ -152,19 +182,13 @@ Defer parse-line evaluate-input cell new-tib #tib ! tib ! ['] parse-line catch pop-file throw ; -: .link ( addr u -- ) '| $split +: .link ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN link-options link $! link $@len 0= IF 2dup link $! s" .html" link $+! THEN - link-icon? link $@ href= s" a" tag - parse-string s" a" /tag link-size? ; + link $@ href= s" a" tag link-icon? + parse-string s" a" /tag link-size? link-sig? ; : >link ( -- ) '[ parse type '] parse .link ; -: .img ( addr u -- ) '| $split - dup IF 2swap alt= ELSE 2drop THEN - tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string - 2dup .img-size src= s" img" tag ; -: >img ( -- ) '{ parse type '} parse .img ; - \ line handling : char? ( -- c ) >in @ char swap >in ! ; @@ -238,34 +262,90 @@ wordlist Constant autoreplacements : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ; : line ( addr u -- ) env? 2dup tag parse-line+ /tag cr cr ; +\ scan strings + +: get-rest ( addr -- ) 0 parse -trailing rot $! ; +Create $lf 1 c, #lf c, +: get-par ( addr -- ) >r s" " r@ $+! + BEGIN 0 parse 2dup s" ." compare WHILE + r@ $@len IF $lf count r@ $+! THEN r@ $+! + refill 0= UNTIL ELSE 2drop THEN + rdrop ; + +\ toc handling + +Variable toc-link + +: >last ( addr link -- link' ) + BEGIN dup @ WHILE @ REPEAT ! 0 ; + +: toc, ( n -- ) , 0 parse '| -$split 2swap here 0 , $! here 0 , $! ; +: up-toc align here toc-link >last , 0 toc, ; +: top-toc align here toc-link >last , 1 toc, ; +: this-toc align here toc-link >last , 2 toc, ; +: sub-toc align here toc-link >last , 3 toc, ; + +Variable toc-name + +: .toc-entry ( toc flag -- ) + swap cell+ dup @ swap cell+ dup cell+ $@ 2dup href= s" a" tag + '# scan 1 /string toc-name $@ compare >r + $@ .img swap + IF + case + 2 of s" ^]|-icons/arrow_up.jpg" .img endof + 3 of + r@ 0= IF s" *]|-icons/circle.jpg" + ELSE s" v]|-icons/arrow_down.jpg" THEN .img endof + endcase + ELSE + case + 0 of s" ^]|-icons/arrow_up.jpg" .img endof + 1 of s" >]|-icons/arrow_right.jpg" .img endof + 2 of s" *]|-icons/circle.jpg" .img endof + 3 of s" v]|-icons/arrow_down.jpg" .img endof + endcase + THEN + s" a" /tag rdrop + ; +: print-toc ( -- ) cr 0 parse + dup 0= IF toc-name $! 0 ELSE + toc-name $! toc-name $@ name= s" " s" a" tagged 2 + THEN >r + toc-link BEGIN @ dup WHILE + dup cell+ @ 3 = r@ 0= and IF rdrop 1 >r s" br" tag cr THEN + dup cell+ @ r@ >= IF dup r@ 2 = .toc-entry THEN + dup cell+ @ 2 = r@ 2 = and IF s" br" tag cr THEN + REPEAT drop rdrop cr ; + \ handle global tags Variable indentlevel -: indent ( n -- ) indentlevel @ - 2dup < IF 2dup swap DO -env -env LOOP THEN - 2dup > IF 2dup DO s" dl" >env LOOP THEN - 2dup = IF -env THEN - drop indentlevel ! s" dt" >env ; -: +indent ( -- ) -env s" dd" >env ; +: indent ( n -- ) indentlevel @ over indentlevel ! + 2dup < IF swap DO -env -env LOOP EXIT THEN + 2dup > IF DO s" dl" >env s" dt" >env LOOP EXIT THEN + 2dup = IF drop IF -env s" dt" >env THEN THEN ; +: +indent ( -- ) indentlevel @ IF -env s" dd" >env THEN ; wordlist constant longtags -Variable end-sec - longtags set-current -: --- 1 indent cr s" hr" tag cr +indent ; +: --- 0 indent cr s" hr" tag cr +indent ; : * 1 indent s" h1" line +indent ; : ** 1 indent s" h2" line +indent ; : *** 2 indent s" h3" line +indent ; +: -- 0 indent cr print-toc ; : - s" ul" env s" li" par ; : + s" ol" env s" li" par ; : << +env ; : <* s" center" >env ; +: env ; +: red> -env ; : >> -env ; : *> -env ; : :: interpret ; -: . end-sec on indentlevel off ; +: . end-sec on 0 indent ; : :code s" pre" >env BEGIN source >in @ /string type cr refill WHILE source s" :endcode" compare 0= UNTIL THEN @@ -332,7 +412,7 @@ Variable mail-name ." Last modified: " time&date rot 0 u.r swap 1- s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type 0 u.r ." by " - mail $@ mailto: mail-name $@ s" a" tagged + s" Mail|icons/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged -envs ; \ top word @@ -376,14 +456,6 @@ Variable style$ \ simple text data base -: get-rest ( addr -- ) 0 parse -trailing rot $! ; -Create $lf 1 c, #lf c, -: get-par ( addr -- ) >r s" " r@ $+! - BEGIN 0 parse 2dup s" ." compare WHILE - r@ $@len IF $lf count r@ $+! THEN r@ $+! - refill 0= UNTIL ELSE 2drop THEN - rdrop ; - Variable last-entry Variable field#