File:  [gforth] / gforth / wf.fs
Revision 1.2: download - view: text, annotated - select for diffs
Tue Jul 17 11:39:21 2001 UTC (17 years, 10 months ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Improvements of wiki for Forth
Added small text data base

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

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