Annotation of gforth/wf.fs, revision 1.1

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 ;
        !            11: 
        !            12: \ environment handling
        !            13: 
        !            14: Variable oldenv
        !            15: Variable envs 10 0 [DO] 0 , [LOOP]
        !            16: 
        !            17: : env$ ( -- addr ) envs dup @ 1+ cells + ;
        !            18: : env ( addr u -- ) env$ $! ;
        !            19: : env? ( -- ) envs @ oldenv @
        !            20:     2dup > IF  env$ $@ tag  THEN
        !            21:     2dup < IF  env$ cell+ $@ /tag  env$ cell+ $off  THEN
        !            22:     drop oldenv ! ;
        !            23: : +env  1 envs +! ;
        !            24: : -env -1 envs +! env? ;
        !            25: : -envs envs @ 0 ?DO  -env cr  LOOP ;
        !            26: 
        !            27: \ link creation
        !            28: 
        !            29: Variable link
        !            30: Variable link-suffix
        !            31: 
        !            32: : link-icon? ( -- )
        !            33:     link $@ '. $split link-suffix $! 2drop s" .*" link-suffix $+!
        !            34:     s" icons" open-dir throw >r
        !            35:     BEGIN
        !            36:        pad $100 r@ read-dir throw  WHILE
        !            37:        pad swap 2dup link-suffix $@ filename-match
        !            38:        IF  .' <img src="icons/' type .' ">'  true
        !            39:        ELSE  2drop  false  THEN
        !            40:     UNTIL  ELSE  '( emit link-suffix $@ 2 - type ') emit  THEN
        !            41:     r> close-dir throw ;
        !            42: 
        !            43: : link-size? ( -- )
        !            44:     link $@ r/o open-file IF  drop  EXIT  THEN >r
        !            45:     r@ file-size throw $400 um/mod nip ."  (" 0 u.r ." k)"
        !            46:     r> close-file throw ;
        !            47: 
        !            48: : .link ( -- )  '[ parse type '] parse '| $split link $!
        !            49:     link $@len 0= IF  2dup link $! s" .html" link $+!  THEN
        !            50:     link-icon? .' <a href="' link $@ type .' ">' type s" a" /tag
        !            51:     link-size? ;
        !            52: 
        !            53: \ line handling
        !            54: 
        !            55: : parse-tag ( addr u char -- )
        !            56:     >r r@ parse type
        !            57:     2dup tag r> parse type /tag ;
        !            58: 
        !            59: : .bold ( -- )  s" b" '* parse-tag ;
        !            60: : .em   ( -- )  s" em" '_ parse-tag ;
        !            61: 
        !            62: : parse-line ( -- )
        !            63:     BEGIN  >in @ >r char r> >in !
        !            64:        CASE
        !            65:            '* OF .bold ENDOF
        !            66:            '_ OF .em   ENDOF
        !            67:            '[ OF .link ENDOF
        !            68:            >in @ >r char drop
        !            69:            source r@ /string >in @ r> - nip type
        !            70:        ENDCASE
        !            71:        source nip >in @ = UNTIL ;
        !            72: 
        !            73: \ paragraph handling
        !            74: 
        !            75: : parse-par ( -- )
        !            76:     BEGIN  parse-line cr refill  WHILE
        !            77:        source nip 0= UNTIL  THEN ;
        !            78: 
        !            79: : par ( addr u -- ) env? 2dup tag parse-par /tag cr cr ;
        !            80: : line ( addr u -- ) env? 2dup tag parse-line /tag cr cr ;
        !            81: 
        !            82: \ handle global tags
        !            83: 
        !            84: wordlist constant longtags
        !            85: 
        !            86: Variable end-sec
        !            87: 
        !            88: longtags set-current
        !            89: 
        !            90: : --- s" hr" tag ;
        !            91: : * s" h1" line ;
        !            92: : ** s" h2" line ;
        !            93: : *** s" h3" line ;
        !            94: : - s" ul" env s" li" par ;
        !            95: : + s" ol" env s" li" par ;
        !            96: : << +env ;
        !            97: : >> -env ;
        !            98: : . end-sec on ;
        !            99: : \ postpone \ ;
        !           100: 
        !           101: definitions
        !           102: 
        !           103: \ parse a section
        !           104: 
        !           105: : refill-loop ( -- )  end-sec off
        !           106:     BEGIN  refill  WHILE  >in off
        !           107:        bl sword find-name
        !           108:        ?dup IF  name>int execute
        !           109:        ELSE  source nip IF  >in off s" p" par  THEN  THEN
        !           110:        end-sec @ UNTIL  THEN ;
        !           111: : parse-section ( -- )
        !           112:     get-order  longtags 1 set-order  refill-loop set-order ;
        !           113: 
        !           114: \ HTML head
        !           115: 
        !           116: : .title ( addr u -- )
        !           117:     .' <!doctype html public "-//w3c//dtd html 4.0 transitional//en">' cr
        !           118:     s" html" +env env env?
        !           119:     s" head" +env env env?
        !           120:     .'   <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">' cr
        !           121:     s" title" tag type s" title" /tag cr
        !           122:     -env ;
        !           123: 
        !           124: \ HTML trailer
        !           125: 
        !           126: Variable mail
        !           127: Variable mail-name
        !           128: 
        !           129: : .trailer
        !           130:     s" address" tag
        !           131:     ." Changed last on " time&date rot 0 u.r swap 1-
        !           132:     s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type
        !           133:     0 u.r
        !           134:     .'  by <a href="mailto:' mail $@ type .' ">' mail-name $@ type s" a" /tag
        !           135:     s" address" /tag
        !           136:     -envs ;
        !           137: 
        !           138: \ top word
        !           139: 
        !           140: : maintainer
        !           141:     bl sword mail $! '" parse 2drop '" parse mail-name $! ;
        !           142: 
        !           143: : wf ( -- )
        !           144:     outfile-id >r
        !           145:     bl sword r/w create-file throw to outfile-id
        !           146:     '" parse 2drop '" parse .title
        !           147:     +env s" body" env
        !           148:     ['] parse-section catch .trailer
        !           149:     outfile-id close-file throw
        !           150:     r> to outfile-id
        !           151:     dup 0< IF  throw  ELSE  drop  THEN ;
        !           152: 

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