Diff for /gforth/wf.fs between versions 1.27 and 1.29

version 1.27, 2004/08/29 20:54:48 version 1.29, 2004/12/27 18:16:47
Line 34  require string.fs Line 34  require string.fs
   
 \ character recoding  \ character recoding
   
   [IFDEF] 8-bit-io  8-bit-io  [THEN]
   \ UTF-8 IO fails with .type:
   
 : .type ( addr u -- )  : .type ( addr u -- )
     bounds ?DO  I c@      bounds ?DO  I c@
         case          case
Line 47  require string.fs Line 50  require string.fs
   
 Variable indentlevel  Variable indentlevel
 Variable tag-option  Variable tag-option
   Variable tag-class
 s" " tag-option $!  s" " tag-option $!
   s" " tag-class $!
   
 : tag ( addr u -- ) '< emit type tag-option $@ type '> emit  : tag ( addr u -- ) '< emit type
     s" " tag-option $! ;      tag-class $@len IF  .\"  class=\"" tag-class $@ type '" emit  THEN
       tag-option $@ type
       '> emit
       s" " tag-option $! s" " tag-class $! ;
 : tag/ ( addr u -- )  s"  /" tag-option $+! tag ;  : tag/ ( addr u -- )  s"  /" tag-option $+! tag ;
 : /tag ( addr u -- ) '< emit '/ emit type '> emit ;  : /tag ( addr u -- ) '< emit '/ emit type '> emit ;
 : tagged ( addr1 u1 addr2 u2 -- )  2dup 2>r tag .type 2r> /tag ;  : tagged ( addr1 u1 addr2 u2 -- )  2dup 2>r tag .type 2r> /tag ;
Line 59  s" " tag-option $! Line 67  s" " tag-option $!
     tag-option $+! s' ="' tag-option $+! tag-option $+!      tag-option $+! s' ="' tag-option $+! tag-option $+!
     s' "' tag-option $+! ;      s' "' tag-option $+! ;
 : n>string ( n -- addr u )  0 <# #S #> ;  : n>string ( n -- addr u )  0 <# #S #> ;
   : xy>string ( x y -- )  swap 0 <# #S 'x hold 2drop 0 #S 's hold #> ;
 : opt# ( n opt u -- )  rot n>string 2swap opt ;  : opt# ( n opt u -- )  rot n>string 2swap opt ;
 : href= ( addr u -- )  s" href" opt ;  : href= ( addr u -- )  s" href" opt ;
 : id= ( addr u -- )  s" id" opt ;  : id= ( addr u -- )  s" id" opt ;
Line 67  s" " tag-option $! Line 76  s" " tag-option $!
 : width=  ( n -- )  s" width" opt# ;  : width=  ( n -- )  s" width" opt# ;
 : height=  ( n -- )  s" height" opt# ;  : height=  ( n -- )  s" height" opt# ;
 : align= ( addr u -- ) s" align" opt ;  : align= ( addr u -- ) s" align" opt ;
 : class= ( addr u -- ) s" class" opt ;  : class= ( addr u -- )
       tag-class $@len IF  s"  " tag-class $+!  THEN
       tag-class $+! ;
 : indent= ( -- )  : indent= ( -- )
     indentlevel @ 0 <# #S 'p hold #> class= ;      indentlevel @ 0 <# #S 'p hold #> class= ;
 : mailto: ( addr u -- ) s'  href="mailto:' tag-option $+!  : mailto: ( addr u -- ) s'  href="mailto:' tag-option $+!
Line 126  Variable taligned Line 137  Variable taligned
   
 \ image handling  \ image handling
   
   wordlist Constant img-sizes
   
 Create imgbuf $20 allot  Create imgbuf $20 allot
   
 Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c,  Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c,
Line 161  Create jfif   $FF c, $D8 c, $FF c, $E0 c Line 174  Create jfif   $FF c, $D8 c, $FF c, $E0 c
     gif? IF  gif-size  rdrop EXIT  THEN      gif? IF  gif-size  rdrop EXIT  THEN
     jpg? IF  r> jpg-size  EXIT  THEN      jpg? IF  r> jpg-size  EXIT  THEN
     png? IF  png-size  rdrop EXIT  THEN      png? IF  png-size  rdrop EXIT  THEN
     0 0 ;      0 0 rdrop ;
   
   3 set-precision
   
   : f.size  ( r -- )
     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 ;
   
   : 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 ;
   
   : size-css ( file< > -- )
       outfile-id >r
       bl sword r/w create-file throw to outfile-id
       img-sizes wordlist-id
       BEGIN  @ dup  WHILE
               dup name>int execute
       REPEAT  drop
       outfile-id close-file throw
       r> to outfile-id
       dup 0< IF  throw  ELSE  drop  THEN ;
   
   : size-class ( x y addr u -- x y )
       2dup class=
       2dup img-sizes search-wordlist  IF  drop 2drop
       ELSE
           get-current >r img-sizes set-current
           nextname Create 2dup , , size-does>
           r> set-current
       THEN ;
   
 : .img-size ( addr u -- )  : .img-size ( addr u -- )
     r/o open-file IF  drop  EXIT  THEN  >r      r/o open-file IF  drop  EXIT  THEN  >r
     imgbuf $20 r@ read-file throw drop      imgbuf $20 r@ read-file throw drop
     r@ img-size      r@ img-size
     r> close-file throw      r> close-file throw
       2dup or IF  2dup xy>string size-class  THEN  
     ?dup IF  width=   THEN      ?dup IF  width=   THEN
     ?dup IF  height=  THEN ;      ?dup IF  height=  THEN
   ;
   
 \ link creation  \ link creation
   
Line 191  Defer parse-line Line 241  Defer parse-line
         icon-tmp $@  THEN          icon-tmp $@  THEN
     dup >r '| -$split  dup r> = IF  2swap  THEN       dup >r '| -$split  dup r> = IF  2swap  THEN 
     dup IF  2swap alt=  ELSE  2drop  THEN      dup IF  2swap alt=  ELSE  2drop  THEN
     tag-option $@len >r over c@ >align  tag-option $@len r> = 1+ /string      tag-class $@len >r over c@ >align  tag-class $@len r> = 1+ /string
     tag-option $@len >r over c@ >border tag-option $@len r> = 1+ /string      tag-class $@len >r over c@ >border tag-class $@len r> = 1+ /string
     2dup .img-size src= s" img" tag/ ;      2dup .img-size src= s" img" tag/ ;
 : >img ( -- )   '{ parse type '} parse .img ;  : >img ( -- )   '{ parse type '} parse .img ;
   
Line 571  Variable css-file Line 621  Variable css-file
   
 \ HTML trailer  \ HTML trailer
   
   Variable public-key
 Variable mail  Variable mail
 Variable mail-name  Variable mail-name
 Variable orig-date  Variable orig-date
Line 586  Variable orig-date Line 637  Variable orig-date
     .lastmod      .lastmod
  ."  by "   ."  by "
     s" Mail|@/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged      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
       THEN
     -envs ;      -envs ;
   
 \ top word  \ top word
   
 : maintainer ( -- )  : maintainer ( -- )
     '< sword -trailing mail-name $! '> sword mail $! ;      '< sword -trailing mail-name $! '> sword mail $! ;
   : pgp-key ( -- )
       bl sword -trailing public-key $! ;
 : created ( -- )  : created ( -- )
     bl sword orig-date $! ;      bl sword orig-date $! ;
 : icons  : icons

Removed from v.1.27  
changed lines
  Added in v.1.29


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