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>