Annotation of gforth/wf.fs, revision 1.7

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 ;
1.4       pazsan     23: : alt=  ( addr u -- )  s" alt" opt ;
1.7     ! pazsan     24: : width=  ( addr u -- )  s" width" opt ;
        !            25: : height=  ( addr u -- )  s" height" opt ;
1.3       pazsan     26: : align= ( addr u -- ) s" align" opt ;
                     27: : mailto: ( addr u -- ) s'  href="mailto:' tag-option $+!
                     28:     tag-option $+! s' "' tag-option $+! ;
                     29: 
1.1       pazsan     30: \ environment handling
                     31: 
                     32: Variable oldenv
                     33: Variable envs 10 0 [DO] 0 , [LOOP]
                     34: 
                     35: : env$ ( -- addr ) envs dup @ 1+ cells + ;
                     36: : env ( addr u -- ) env$ $! ;
                     37: : env? ( -- ) envs @ oldenv @
                     38:     2dup > IF  env$ $@ tag  THEN
                     39:     2dup < IF  env$ cell+ $@ /tag  env$ cell+ $off  THEN
                     40:     drop oldenv ! ;
                     41: : +env  1 envs +! ;
                     42: : -env -1 envs +! env? ;
                     43: : -envs envs @ 0 ?DO  -env cr  LOOP ;
1.2       pazsan     44: : >env ( addr u -- ) +env env env? ;
1.1       pazsan     45: 
1.6       pazsan     46: \ alignment
                     47: 
                     48: : >align ( c -- )
                     49:     CASE
                     50:        'l OF  s" left"   align=  ENDOF
                     51:        'r OF  s" right"  align=  ENDOF
                     52:        'c OF  s" center" align=  ENDOF
                     53:        '< OF  s" left"   align=  ENDOF
                     54:        '> OF  s" right"  align=  ENDOF
                     55:        '| OF  s" center" align=  ENDOF
                     56:     ENDCASE ;
                     57: 
1.7     ! pazsan     58: \ image handling
        !            59: 
        !            60: Create imgbuf $20 allot
        !            61: 
        !            62: Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c,
        !            63: Create jfif   $FF c, $D8 c, $FF c, $E0 c, $00 c, $10 c, $4A c, $46 c,
        !            64:               $49 c, $46 c,
        !            65: 
        !            66: : b@ ( addr -- x )   0 swap 4 bounds ?DO  8 lshift I c@ +  LOOP ;
        !            67: : bw@ ( addr -- x )  0 swap 2 bounds ?DO  8 lshift I c@ +  LOOP ;
        !            68: 
        !            69: : gif? ( -- flag )
        !            70:     s" GIF89a" imgbuf over compare 0=
        !            71:     s" GIF87a" imgbuf over compare 0= or ;
        !            72: : gif-size ( -- w h )
        !            73:     imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift +
        !            74:     imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + ;
        !            75: 
        !            76: : png? ( -- flag )
        !            77:     pngsig 8 imgbuf over compare 0= ;
        !            78: : png-size ( -- w h )
        !            79:     imgbuf $10 + b@ imgbuf $14 + b@ ;
        !            80: 
        !            81: : jpg? ( -- flag )
        !            82:     jfif 10 imgbuf over compare 0= ;
        !            83: : jpg-size ( fd -- w h )  >r
        !            84:     2.  BEGIN
        !            85:        2dup r@ reposition-file throw
        !            86:        imgbuf $10 r@ read-file throw 0<>
        !            87:        imgbuf bw@ $FFC0 <> and  WHILE
        !            88:        imgbuf 2 + bw@ 2 + 0 d+  REPEAT
        !            89:     2drop imgbuf 5 + bw@ imgbuf 7 + bw@  rdrop ;
        !            90: 
        !            91: : img-size ( fd -- w h )  >r
        !            92:     gif? IF  gif-size  rdrop EXIT  THEN
        !            93:     jpg? IF  r> jpg-size  EXIT  THEN
        !            94:     png? IF  png-size  rdrop EXIT  THEN
        !            95:     0 0 ;
        !            96: 
        !            97: : .img-size ( addr u -- )
        !            98:     r/o open-file throw >r
        !            99:     imgbuf $20 r@ read-file throw drop
        !           100:     r@ img-size
        !           101:     r> close-file throw
        !           102:     ?dup IF  0 <# #S #> width=   THEN
        !           103:     ?dup IF  0 <# #S #> height=  THEN ;
        !           104: 
1.1       pazsan    105: \ link creation
                    106: 
                    107: Variable link
                    108: Variable link-suffix
1.3       pazsan    109: Variable iconpath
1.1       pazsan    110: 
1.2       pazsan    111: Variable do-size
                    112: 
1.7     ! pazsan    113: : alt-suffix ( -- )
        !           114:     link-suffix $@len 2 - link-suffix $!len
        !           115:     s" [" link-suffix 0 $ins
        !           116:     s" ]" link-suffix $+!
        !           117:     link-suffix $@ alt= ;
        !           118: 
1.6       pazsan    119: : get-icon ( addr u -- )  iconpath @ IF  2drop  EXIT  THEN
                    120:     link-suffix $! s" .*" link-suffix $+!
1.1       pazsan    121:     s" icons" open-dir throw >r
                    122:     BEGIN
                    123:        pad $100 r@ read-dir throw  WHILE
                    124:        pad swap 2dup link-suffix $@ filename-match
1.3       pazsan    125:        IF  s" icons/" iconpath $! iconpath $+!
1.7     ! pazsan    126:            iconpath $@ 2dup .img-size src=
        !           127:            alt-suffix  s" img" tag true
1.1       pazsan    128:        ELSE  2drop  false  THEN
1.6       pazsan    129:     UNTIL  ELSE  drop  THEN
1.1       pazsan    130:     r> close-dir throw ;
                    131: 
1.6       pazsan    132: : link-icon? ( -- )  iconpath @  IF  iconpath $off  THEN
                    133:     link '. ['] get-icon $iter ;
                    134: 
1.2       pazsan    135: : link-size? ( -- )  do-size @ 0= ?EXIT
1.1       pazsan    136:     link $@ r/o open-file IF  drop  EXIT  THEN >r
                    137:     r@ file-size throw $400 um/mod nip ."  (" 0 u.r ." k)"
                    138:     r> close-file throw ;
                    139: 
1.2       pazsan    140: : link-options ( addr u -- addr' u' )
1.3       pazsan    141:     do-size off
                    142:     over c@ '% = over 0> and IF  do-size on  1 /string  THEN ;
1.2       pazsan    143: 
                    144: : .link ( -- )  '[ parse type '] parse '| $split
                    145:     link-options link $!
1.1       pazsan    146:     link $@len 0= IF  2dup link $! s" .html" link $+!  THEN
1.3       pazsan    147:     link-icon? link $@ href= s" a" tagged
1.1       pazsan    148:     link-size? ;
                    149: 
1.4       pazsan    150: : .img ( -- ) '{ parse type '} parse '| $split
1.6       pazsan    151:     dup IF  2swap alt=  ELSE  2drop  THEN
                    152:     tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string
1.7     ! pazsan    153:     2dup .img-size src= s" img" tag ;
1.4       pazsan    154: 
1.1       pazsan    155: \ line handling
                    156: 
1.4       pazsan    157: : char? ( -- c )  >in @ char swap >in ! ;
1.1       pazsan    158: : parse-tag ( addr u char -- )
                    159:     >r r@ parse type
1.2       pazsan    160:     r> parse 2swap tagged ;
1.1       pazsan    161: 
1.6       pazsan    162: : .text ( -- )         >in @ >r char drop
                    163:     source r@ /string >in @ r> - nip type ;
                    164: 
                    165: Create do-words  $100 0 [DO] ' .text , [LOOP]
                    166: 
                    167: : bind-char ( xt -- )  char cells do-words + ! ;
                    168: 
                    169: : char>tag ( -- ) char >r
                    170: :noname bl sword postpone SLiteral r@ postpone Literal
                    171:     postpone parse-tag postpone ; r> cells do-words + ! ;
1.1       pazsan    172: 
1.6       pazsan    173: char>tag * b
                    174: char>tag _ em
                    175: char>tag # code
                    176: 
                    177: ' .link bind-char [
                    178: ' .img  bind-char {
                    179: 
                    180: : do-word ( char -- )  cells do-words + perform ;
1.4       pazsan    181: 
1.1       pazsan    182: : parse-line ( -- )
1.4       pazsan    183:     BEGIN  char? do-word source nip >in @ = UNTIL ;
                    184: 
                    185: : parse-to ( char -- ) >r
                    186:     BEGIN  char? dup r@ <> WHILE
                    187:        do-word source nip >in @ = UNTIL  ELSE  drop  THEN
                    188:     r> parse type ;
1.1       pazsan    189: 
                    190: \ paragraph handling
                    191: 
                    192: : parse-par ( -- )
                    193:     BEGIN  parse-line cr refill  WHILE
                    194:        source nip 0= UNTIL  THEN ;
                    195: 
                    196: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
                    197: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
                    198: 
                    199: \ handle global tags
                    200: 
                    201: wordlist constant longtags
                    202: 
                    203: Variable end-sec
                    204: 
                    205: longtags set-current
                    206: 
1.3       pazsan    207: : --- cr s" hr" tag cr ;
1.1       pazsan    208: : * s" h1" line ;
                    209: : ** s" h2" line ;
                    210: : *** s" h3" line ;
                    211: : - s" ul" env s" li" par ;
                    212: : + s" ol" env s" li" par ;
                    213: : << +env ;
1.3       pazsan    214: : <* s" center" >env ;
1.1       pazsan    215: : >> -env ;
1.3       pazsan    216: : *> -env ;
1.1       pazsan    217: : . end-sec on ;
                    218: : \ postpone \ ;
                    219: 
                    220: definitions
1.3       pazsan    221:     
                    222: \ Table
                    223: 
                    224: Variable table-format
                    225: Variable table#
                    226: 
1.6       pazsan    227: : |tag  table-format $@ table# @ /string drop c@ >align
                    228:     >env  1 table# +! ;
1.3       pazsan    229: : |d  table# @ IF  -env  THEN  s" td" |tag ;
                    230: : |h  table# @ IF  -env  THEN  s" th" |tag ;
                    231: : |line  s" tr" >env  table# off ;
                    232: : line|  -env -env cr ;
                    233: 
1.5       pazsan    234: : next-char ( -- char )  source drop >in @ + c@ ;
                    235: 
1.3       pazsan    236: longtags set-current
                    237: 
                    238: : <| s" table" >env bl sword table-format $! ;
                    239: : |> -env ;
                    240: : +| |line
                    241:     BEGIN
1.5       pazsan    242:        |h '| parse-to next-char '+ =  UNTIL line| ;
1.3       pazsan    243: : -| |line
                    244:     BEGIN
1.5       pazsan    245:        |d '| parse-to next-char '- =  UNTIL line| ;
1.3       pazsan    246: 
                    247: definitions
1.1       pazsan    248: 
                    249: \ parse a section
                    250: 
                    251: : refill-loop ( -- )  end-sec off
                    252:     BEGIN  refill  WHILE  >in off
                    253:        bl sword find-name
                    254:        ?dup IF  name>int execute
                    255:        ELSE  source nip IF  >in off s" p" par  THEN  THEN
                    256:        end-sec @ UNTIL  THEN ;
                    257: : parse-section ( -- )
                    258:     get-order  longtags 1 set-order  refill-loop set-order ;
                    259: 
                    260: \ HTML head
                    261: 
                    262: : .title ( addr u -- )
                    263:     .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
1.2       pazsan    264:     s" html" >env s" head" >env
1.1       pazsan    265:     .'   <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
1.2       pazsan    266:     s" title" tagged cr
1.1       pazsan    267:     -env ;
                    268: 
                    269: \ HTML trailer
                    270: 
                    271: Variable mail
                    272: Variable mail-name
                    273: 
                    274: : .trailer
1.2       pazsan    275:     s" address" >env s" center" >env
                    276:     ." Last modified: " time&date rot 0 u.r swap 1-
1.1       pazsan    277:     s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
1.3       pazsan    278:     0 u.r ."  by "
                    279:     mail $@ mailto: mail-name $@ s" a" tagged
1.1       pazsan    280:     -envs ;
                    281: 
                    282: \ top word
                    283: 
1.6       pazsan    284: : parse" ( -- addr u ) '" parse 2drop '" parse ;
                    285: 
1.1       pazsan    286: : maintainer
1.6       pazsan    287:     bl sword mail $! parse" mail-name $! ;
                    288: 
                    289: Variable style$
                    290: : style> style$ @ 0= IF  s" " style$ $!  THEN  style$ $@ tag-option $! ;
                    291: : >style tag-option $@ style$ $! s" " tag-option $! ;
                    292: 
                    293: : style  style> opt >style ;
                    294: : background ( -- )  parse" s" background" style ;
                    295: : text ( -- )  parse" s" text" style ;
                    296:     warnings @ warnings off
                    297: : link ( -- )  parse" s" link" style ;
                    298:     warnings !
                    299: : vlink ( -- ) parse" s" vlink" style ;
                    300: : marginheight ( -- ) parse" s" marginheight" style ;
1.1       pazsan    301: 
                    302: : wf ( -- )
                    303:     outfile-id >r
                    304:     bl sword r/w create-file throw to outfile-id
1.6       pazsan    305:     parse" .title
                    306:     +env style> s" body" env env?
1.1       pazsan    307:     ['] parse-section catch .trailer
                    308:     outfile-id close-file throw
                    309:     r> to outfile-id
                    310:     dup 0< IF  throw  ELSE  drop  THEN ;
                    311: 
1.2       pazsan    312: \ simple text data base
                    313: 
                    314: : get-rest ( addr -- ) 0 parse -trailing rot $! ;
                    315: 
                    316: Variable last-entry
                    317: Variable field#
                    318: 
                    319: : table: ( xt n -- )  Create , ,  1 field# !
                    320:     DOES> 2@ >in @ >r longtags set-current
                    321:     Create definitions swap , r> >in !
                    322:     here last-entry !
                    323:     dup 0 DO  0 ,  LOOP
                    324:     1 DO  s" " last-entry @ I cells + $!  LOOP
                    325:     last-entry @ get-rest
                    326:     DOES> dup cell+ swap perform ;
                    327: 
                    328: : field:  Create field# @ , 1 field# +!
                    329: DOES> @ cells last-entry @ + get-rest ;
1.3       pazsan    330: 
                    331: : >field  ' >body @ cells postpone Literal postpone + ; immediate

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>