Return to wf.fs CVS log | Up to [gforth] / gforth |
Added first version of a Wiki in Forth
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: