--- gforth/wf.fs 2005/01/22 16:39:58 1.33 +++ gforth/wf.fs 2008/04/08 09:04:21 1.54 @@ -1,12 +1,12 @@ \ wiki forth -\ Copyright (C) 2003,2004 Free Software Foundation, Inc. +\ Copyright (C) 2003,2004,2005,2006,2007 Free Software Foundation, Inc. \ This file is part of Gforth. \ Gforth is free software; you can redistribute it and/or \ modify it under the terms of the GNU General Public License -\ as published by the Free Software Foundation; either version 2 +\ as published by the Free Software Foundation, either version 3 \ of the License, or (at your option) any later version. \ This program is distributed in the hope that it will be useful, @@ -15,8 +15,7 @@ \ GNU General Public License for more details. \ You should have received a copy of the GNU General Public License -\ along with this program; if not, write to the Free Software -\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. +\ along with this program. If not, see http://www.gnu.org/licenses/. require string.fs @@ -31,6 +30,7 @@ require string.fs : parse" ( -- addr u ) '" parse 2drop '" parse ; : .' '' parse postpone SLiteral postpone type ; immediate : s' '' parse postpone SLiteral ; immediate +: .upcase ( addr u -- ) bounds ?DO I c@ toupper emit LOOP ; \ character recoding @@ -42,6 +42,7 @@ require string.fs case '& of ." &" endof '< of ." <" endof +\ &164 of ." €" endof dup emit endcase LOOP ; @@ -51,20 +52,26 @@ require string.fs Variable indentlevel Variable tag-option Variable tag-class +Variable default-class s" " tag-option $! s" " tag-class $! +s" " default-class $! : tag ( addr u -- ) '< emit type tag-class $@len IF .\" class=\"" tag-class $@ type '" emit THEN tag-option $@ type '> emit - s" " tag-option $! s" " tag-class $! ; + s" " tag-option $! default-class $@ tag-class $! ; : tag/ ( addr u -- ) s" /" tag-option $+! tag ; : /tag ( addr u -- ) '< emit '/ emit type '> emit ; : tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag .type 2r> /tag ; : opt ( addr u opt u -- ) s" " tag-option $+! - tag-option $+! s' ="' tag-option $+! tag-option $+! + tag-option $+! s' ="' tag-option $+! +\ BEGIN dup WHILE '& $split >r >r tag-option $+! r> r> +\ dup IF s" %26" tag-option $+! THEN +\ REPEAT 2drop + tag-option $+! s' "' tag-option $+! ; : n>string ( n -- addr u ) 0 <# #S #> ; : xy>string ( x y -- ) swap 0 <# #S 'x hold 2drop 0 #S 's hold #> ; @@ -79,6 +86,8 @@ s" " tag-class $! : class= ( addr u -- ) tag-class $@len IF s" " tag-class $+! THEN tag-class $+! ; +: dclass= ( addr u -- ) 2dup class= + default-class $! ; : indent= ( -- ) indentlevel @ 0 <# #S 'p hold #> class= ; : mailto: ( addr u -- ) s' href="mailto:' tag-option $+! @@ -92,13 +101,14 @@ Variable envs 30 0 [DO] 0 , [LOOP] : env$ ( -- addr ) envs dup @ 1+ cells + ; : env ( addr u -- ) env$ $! ; -: env? ( -- ) envs @ oldenv @ +: env? ( -- ) envs @ oldenv @ over oldenv ! 2dup > IF env$ $@ tag THEN 2dup < IF env$ cell+ $@ /tag env$ cell+ $off THEN - drop oldenv ! ; + 2drop ; : +env 1 envs +! ; -: -env end-sec @ envs @ 2 > or IF -1 envs +! env? THEN ; +: -env end-sec @ envs @ 1 > or IF -1 envs +! env? THEN ; : -envs envs @ 0 ?DO -env cr LOOP ; +: -tenvs envs @ 1 ?DO -env cr LOOP ; : >env ( addr u -- ) +env env env? ; \ alignment @@ -182,14 +192,18 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c f$ dup >r 0<= IF '0 emit ELSE scratch r@ min type r@ precision - zeros THEN - '. emit r@ negate zeros - scratch r> 0 max /string 0 max -zeros type ; + r@ negate zeros + scratch r> 0 max /string 0 max -zeros + dup IF '. emit THEN type ; + +12.9e FConstant pixels +FVariable factor 1e factor f! : size-does> ( -- ) DOES> ( -- ) ." img." dup body> >name .name 2@ ." { width: " - s>d d>f 13.8e f/ f.size ." em; height: " - s>d d>f 13.8e f/ f.size ." em; }" cr ; + s>d d>f pixels f/ f.size ." em; height: " + s>d d>f pixels f/ f.size ." em; }" cr ; : size-css ( file< > -- ) outfile-id >r @@ -207,7 +221,10 @@ Create jfif $FF c, $D8 c, $FF c, $E0 c 2dup img-sizes search-wordlist IF drop 2drop ELSE get-current >r img-sizes set-current - nextname Create 2dup , , size-does> + nextname Create 2dup + s>d d>f factor f@ f* f>d d>s , + s>d d>f factor f@ f* f>d d>s , + size-does> r> set-current THEN ; @@ -241,7 +258,7 @@ Defer parse-line ELSE 2swap icon-tmp $! icon-prefix $@ icon-tmp $+! icon-tmp $+! icon-tmp $@ THEN dup >r '| -$split dup r> = IF 2swap THEN - dup IF 2swap alt= ELSE 2drop THEN + dup IF 2swap alt= ELSE 2drop s" " alt= THEN tag-class $@len >r over c@ >align tag-class $@len r> = 1+ /string tag-class $@len >r over c@ >border tag-class $@len r> = 1+ /string 2dup .img-size src= s" img" tag/ ; @@ -320,10 +337,15 @@ Variable expand-link Variable expand-prefix Variable expand-postfix -: ?expand ( addr u -- ) expand-link $! +: ?expand ( addr u -- addr u' ) expand-link $! do-expand @ IF expand-prefix $@ expand-link 0 $ins expand-postfix $@ expand-link $+! THEN + 0 >r + BEGIN expand-link $@ r@ /string WHILE + r> 1+ >r + c@ '& = IF s" amp;" expand-link r@ $ins THEN + REPEAT drop rdrop expand-link $@ ; : .link ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN @@ -336,7 +358,7 @@ Variable expand-postfix \ line handling -: char? ( -- c ) >in @ char swap >in ! ; +: char? ( -- c ) >in @ char swap >in ! $FF umin ; : parse-tag ( addr u char -- ) >r r@ parse .type @@ -438,9 +460,10 @@ Create nav-buf 0 c, bounds ?DO I c@ dup 'A 'Z 1+ within IF bl + nav+ ELSE dup 'a 'z 1+ within IF nav+ - ELSE dup '0 '9 1+ within IF nav+ - ELSE dup bl = swap '- = or IF '- nav+ - THEN THEN THEN THEN + ELSE dup '0 '9 1+ within IF nav+ + ELSE dup bl = over '- = or IF '- nav+ + ELSE nav+ + THEN THEN THEN THEN LOOP ; : >nav ( addr u -- addr' u' ) nav-name $! create-navs @ 0= @@ -464,31 +487,52 @@ Create nav-buf 0 c, Variable toc-name Variable toc-index 6 Value /toc-line +true Value toc-image : .toc-entry ( toc flag -- ) - swap cell+ dup @ swap cell+ dup cell+ $@ 2dup href= s" a" tag + swap cell+ dup @ swap cell+ dup cell+ $@ 2dup ?expand href= '# scan 1 /string toc-name $@ compare >r - $@ .img swap - IF - case - 2 of s" ^]|-@/arrow_up.jpg" .img endof - 3 of - r@ 0= IF s" *]|-@/circle.jpg" + $@ toc-image IF s" a" tag .img swap + IF + case + 2 of s" ^]|-@/arrow_up.jpg" .img endof + 3 of + r@ 0= IF s" *]|-@/circle.jpg" ELSE s" v]|-@/arrow_down.jpg" THEN .img endof - endcase + endcase + ELSE + case + 0 of s" ^]|-@/arrow_up.jpg" .img endof + 1 of s" >]|-@/arrow_right.jpg" .img endof + 2 of s" *]|-@/circle.jpg" .img endof + 3 of s" v]|-@/arrow_down.jpg" .img endof + endcase + THEN + s" a" /tag ." " ELSE - case - 0 of s" ^]|-@/arrow_up.jpg" .img endof - 1 of s" >]|-@/arrow_right.jpg" .img endof - 2 of s" *]|-@/circle.jpg" .img endof - 3 of s" v]|-@/arrow_down.jpg" .img endof - endcase + '[ skip 2dup '| scan nip - 2swap swap + IF + CASE + 2 OF s" up" class= ENDOF + 3 OF r@ 0= IF s" circle" ELSE s" down" THEN class= ENDOF + ENDCASE + ELSE + CASE + 0 OF s" up" class= ENDOF + 1 OF s" right" class= ENDOF + 2 OF s" circle" class= ENDOF + 3 OF s" down" class= ENDOF + ENDCASE + THEN + s" a" tag parse-string s" a" /tag ." " THEN - s" a" /tag rdrop ." " + rdrop 1 toc-index +! toc-index @ /toc-line mod 0= - IF s" br" tag/ THEN ; + IF -env cr s" p" >env THEN ; -: print-toc ( -- ) toc-index off cr s" menu" id= s" div" >env cr +: print-toc ( -- ) toc-index off cr + toc-image IF s" img-menu" ELSE s" menu" THEN id= + s" div" >env cr s" p" >env 0 parse dup 0= IF toc-name $! 0 ELSE toc-name $! toc-name $@ id= s" " s" a" tagged 2 @@ -497,7 +541,7 @@ Variable toc-index 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/ toc-index off THEN - REPEAT drop rdrop -env cr ; + REPEAT drop rdrop -env -env cr ; \ handle global tags @@ -519,9 +563,9 @@ Variable divs longtags set-current : --- 0 indent cr s" hr" tag/ cr ; -: * 1 indent s" h1" par +indent ; -: ** 1 indent s" h2" par +indent ; -: *** 2 indent s" h3" par +indent ; +: * 1 indent +indent s" h1" dclass= s" h1" par s" " dclass= ; +: ** 1 indent +indent s" h2" dclass= s" h2" par s" " dclass= ; +: *** 2 indent +indent s" h3" dclass= s" h3" par s" " dclass= ; : -- 0 indent cr print-toc ; : && 0 parse id= ; : - s" ul" env s" li" par ; @@ -530,19 +574,19 @@ longtags set-current : : s" dl" env s" dd" par ; : -<< s" ul" env env? s" li" >env ; : +<< s" ol" env env? s" li" >env ; -: ?<< s" dl" env env? s" dt" >env ; +\ : ?<< s" dl" env env? s" dt" >env ; \ not allowed : :<< s" dl" env env? s" dd" >env ; : p<< s" p" >env ; : << +env ; : <* s" center" class= ; -: env ; -: red> -env ; +: env s" #ff0000" s" color" opt s" font" >env parse-par ; +: red> -env -env ; : >> -env ; : *> ; : :: interpret ; : . end-sec on 0 indent ; : :code s" pre" >env - BEGIN source >in @ /string type cr refill WHILE + BEGIN source >in @ /string .type cr refill WHILE source s" :endcode" str= UNTIL THEN -env ; : :code-file s" pre" >env @@ -615,23 +659,54 @@ definitions ELSE source nip IF >in off s" p" par THEN THEN ; : parse-section ( -- ) end-sec off BEGIN refill WHILE - section-par end-sec @ UNTIL THEN ; + section-par end-sec @ UNTIL THEN end-sec off ; \ HTML head Variable css-file - -: .title ( addr u -- ) - .' ' cr - s" html" >env s" head" >env cr - s" Content-Type" s" http-equiv" opt - s" text/xhtml; charset=iso-8859-1" s" content" opt - s" meta" tag/ +Variable print-file +Variable ie-css-file +Variable content +Variable _charset +Variable _lang +Variable _favicon + +: lang@ ( -- addr u ) + _lang @ IF _lang $@ ELSE s" en" THEN ; +: .css ( -- ) css-file @ IF css-file $@len IF - s" StyleSheet" s" rel" opt - css-file $@ href= - s" text/css" s" type" opt s" link" tag/ - THEN THEN + s" StyleSheet" s" rel" opt + css-file $@ href= s" screen" s" media" opt + s" text/css" s" type" opt s" link" tag/ cr + THEN THEN + ie-css-file @ IF + ." " cr + THEN ; +: .print ( -- ) + print-file @ IF print-file $@len IF + s" StyleSheet" s" rel" opt + print-file $@ href= s" print" s" media" opt + s" text/css" s" type" opt s" link" tag/ cr + THEN THEN ; +: .title ( addr u -- ) 1 envs ! oldenv off + _charset $@ s" utf-8" str= 0= + IF .' ' cr THEN + .' ' cr + s" http://www.w3.org/1999/xhtml" s" xmlns" opt + lang@ s" xml:lang" opt lang@ s" lang" opt + s" html" >env cr s" head" >env cr + s" Content-Type" s" http-equiv" opt + content $@ s" content" opt + s" meta" tag/ cr .css .print + _favicon @ IF + s" shortcut icon" s" rel" opt + _favicon $@ href= + s" image/x-icon" s" type" opt + s" link" tag/ cr THEN s" title" tagged cr -env ; @@ -655,7 +730,7 @@ Variable orig-date s" Mail|@/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged public-key @ IF public-key $@ href= s" a" tag - s" PGP key|@/gpg.asc.gif" .img s" a" /tag + s" PGP key|-@/gpg.asc.gif" .img s" a" /tag THEN -envs ; @@ -665,10 +740,19 @@ Variable orig-date '< sword -trailing mail-name $! '> sword mail $! ; : pgp-key ( -- ) bl sword -trailing public-key $! ; +: charset ( -- ) s" text/xhtml; charset=" content $! + bl sword -trailing 2dup content $+! _charset $! ; + +charset iso-8859-1 + : created ( -- ) bl sword orig-date $! ; : icons bl sword icon-prefix $! ; +: lang + bl sword _lang $! ; +: favicon + bl sword _favicon $! ; : expands '# sword expand-prefix $! bl sword expand-postfix $! ; icons icons @@ -686,6 +770,8 @@ Variable style$ : vlink ( -- ) parse" s" vlink" style ; : marginheight ( -- ) parse" s" marginheight" style ; : css ( -- ) parse" css-file $! ; +: print-css ( -- ) parse" print-file $! ; +: ie-css ( -- ) parse" ie-css-file $! ; : wf ( -- ) outfile-id >r @@ -701,7 +787,7 @@ Variable style$ s" wf-temp.wf" r/w create-file throw >r r@ write-file r> close-file throw push-file s" wf-temp.wf" r/o open-file throw loadfile ! - parse-par parse-section + parse-par -env parse-section loadfile @ close-file swap 2dup or pop-file drop throw throw s" wf-temp.wf" delete-file throw ; @@ -744,4 +830,4 @@ DOES> @ cells last-entry @ + get-par ; : db-par ( -- ) LT postpone p<< postpone >r BEGIN db-line refill WHILE next-char '. = UNTIL 1 >in +! THEN - postpone rdrop LT postpone >> ; immediate + postpone rdrop ( LT postpone >> ) ; immediate