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