version 1.26, 2004/07/18 13:31:06
|
version 1.33, 2005/01/22 16:39:58
|
Line 1
|
Line 1
|
\ wiki forth |
\ wiki forth |
|
|
\ Copyright (C) 2003 Free Software Foundation, Inc. |
\ Copyright (C) 2003,2004 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 34 require string.fs
|
Line 34 require string.fs
|
|
|
\ character recoding |
\ character recoding |
|
|
|
[IFDEF] maxascii $100 to maxascii 8-bit-io [THEN] |
|
\ UTF-8 IO fails with .type: |
|
|
: .type ( addr u -- ) |
: .type ( addr u -- ) |
bounds ?DO I c@ |
bounds ?DO I c@ |
case |
case |
Line 47 require string.fs
|
Line 50 require string.fs
|
|
|
Variable indentlevel |
Variable indentlevel |
Variable tag-option |
Variable tag-option |
|
Variable tag-class |
s" " tag-option $! |
s" " tag-option $! |
|
s" " tag-class $! |
|
|
: tag ( addr u -- ) '< emit type tag-option $@ type '> emit |
: tag ( addr u -- ) '< emit type |
s" " tag-option $! ; |
tag-class $@len IF .\" class=\"" tag-class $@ type '" emit THEN |
|
tag-option $@ type |
|
'> emit |
|
s" " tag-option $! s" " tag-class $! ; |
: tag/ ( addr u -- ) s" /" tag-option $+! tag ; |
: tag/ ( addr u -- ) s" /" tag-option $+! tag ; |
: /tag ( addr u -- ) '< emit '/ emit type '> emit ; |
: /tag ( addr u -- ) '< emit '/ emit type '> emit ; |
: tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag .type 2r> /tag ; |
: tagged ( addr1 u1 addr2 u2 -- ) 2dup 2>r tag .type 2r> /tag ; |
Line 59 s" " tag-option $!
|
Line 67 s" " tag-option $!
|
tag-option $+! s' ="' tag-option $+! tag-option $+! |
tag-option $+! s' ="' tag-option $+! tag-option $+! |
s' "' tag-option $+! ; |
s' "' tag-option $+! ; |
: n>string ( n -- addr u ) 0 <# #S #> ; |
: n>string ( n -- addr u ) 0 <# #S #> ; |
|
: xy>string ( x y -- ) swap 0 <# #S 'x hold 2drop 0 #S 's hold #> ; |
: opt# ( n opt u -- ) rot n>string 2swap opt ; |
: opt# ( n opt u -- ) rot n>string 2swap opt ; |
: href= ( addr u -- ) s" href" opt ; |
: href= ( addr u -- ) s" href" opt ; |
: id= ( addr u -- ) s" id" opt ; |
: id= ( addr u -- ) s" id" opt ; |
Line 67 s" " tag-option $!
|
Line 76 s" " tag-option $!
|
: width= ( n -- ) s" width" opt# ; |
: width= ( n -- ) s" width" opt# ; |
: height= ( n -- ) s" height" opt# ; |
: height= ( n -- ) s" height" opt# ; |
: align= ( addr u -- ) s" align" opt ; |
: align= ( addr u -- ) s" align" opt ; |
: class= ( addr u -- ) s" class" opt ; |
: class= ( addr u -- ) |
|
tag-class $@len IF s" " tag-class $+! THEN |
|
tag-class $+! ; |
: indent= ( -- ) |
: indent= ( -- ) |
indentlevel @ 0 <# #S 'p hold #> class= ; |
indentlevel @ 0 <# #S 'p hold #> class= ; |
: mailto: ( addr u -- ) s' href="mailto:' tag-option $+! |
: mailto: ( addr u -- ) s' href="mailto:' tag-option $+! |
Line 126 Variable taligned
|
Line 137 Variable taligned
|
|
|
\ image handling |
\ image handling |
|
|
|
wordlist Constant img-sizes |
|
|
Create imgbuf $20 allot |
Create imgbuf $20 allot |
|
|
Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c, |
Create pngsig $89 c, $50 c, $4E c, $47 c, $0D c, $0A c, $1A c, $0A c, |
Line 161 Create jfif $FF c, $D8 c, $FF c, $E0 c
|
Line 174 Create jfif $FF c, $D8 c, $FF c, $E0 c
|
gif? IF gif-size rdrop EXIT THEN |
gif? IF gif-size rdrop EXIT THEN |
jpg? IF r> jpg-size EXIT THEN |
jpg? IF r> jpg-size EXIT THEN |
png? IF png-size rdrop EXIT THEN |
png? IF png-size rdrop EXIT THEN |
0 0 ; |
0 0 rdrop ; |
|
|
|
3 set-precision |
|
|
|
: f.size ( r -- ) |
|
f$ dup >r 0<= |
|
IF '0 emit |
|
ELSE scratch r@ min type r@ precision - zeros THEN |
|
'. emit r@ negate zeros |
|
scratch r> 0 max /string 0 max -zeros type ; |
|
|
|
: size-does> ( -- ) DOES> ( -- ) |
|
." img." dup body> >name .name |
|
2@ ." { width: " |
|
s>d d>f 13.8e f/ f.size ." em; height: " |
|
s>d d>f 13.8e f/ f.size ." em; }" cr ; |
|
|
|
: size-css ( file< > -- ) |
|
outfile-id >r |
|
bl sword r/w create-file throw to outfile-id |
|
img-sizes wordlist-id |
|
BEGIN @ dup WHILE |
|
dup name>int execute |
|
REPEAT drop |
|
outfile-id close-file throw |
|
r> to outfile-id |
|
dup 0< IF throw ELSE drop THEN ; |
|
|
|
: size-class ( x y addr u -- x y ) |
|
2dup class= |
|
2dup img-sizes search-wordlist IF drop 2drop |
|
ELSE |
|
get-current >r img-sizes set-current |
|
nextname Create 2dup , , size-does> |
|
r> set-current |
|
THEN ; |
|
|
: .img-size ( addr u -- ) |
: .img-size ( addr u -- ) |
r/o open-file IF drop EXIT THEN >r |
r/o open-file IF drop EXIT THEN >r |
imgbuf $20 r@ read-file throw drop |
imgbuf $20 r@ read-file throw drop |
r@ img-size |
r@ img-size |
r> close-file throw |
r> close-file throw |
|
2dup or IF 2dup xy>string size-class THEN |
?dup IF width= THEN |
?dup IF width= THEN |
?dup IF height= THEN ; |
?dup IF height= THEN |
|
; |
|
|
\ link creation |
\ link creation |
|
|
Line 177 Variable link
|
Line 227 Variable link
|
Variable link-sig |
Variable link-sig |
Variable link-suffix |
Variable link-suffix |
Variable iconpath |
Variable iconpath |
|
Variable icon-prefix |
|
Variable icon-tmp |
|
|
Variable do-size |
Variable do-size |
Variable do-icon |
Variable do-icon |
|
Variable do-expand |
|
|
Defer parse-line |
Defer parse-line |
|
|
: .img ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN |
: .img ( addr u -- ) |
|
dup >r '@ -$split dup r> = IF 2swap 2drop |
|
ELSE 2swap icon-tmp $! icon-prefix $@ icon-tmp $+! icon-tmp $+! |
|
icon-tmp $@ THEN |
|
dup >r '| -$split dup r> = IF 2swap THEN |
dup IF 2swap alt= ELSE 2drop THEN |
dup IF 2swap alt= ELSE 2drop THEN |
tag-option $@len >r over c@ >align tag-option $@len r> = 1+ /string |
tag-class $@len >r over c@ >align tag-class $@len r> = 1+ /string |
tag-option $@len >r over c@ >border tag-option $@len r> = 1+ /string |
tag-class $@len >r over c@ >border tag-class $@len r> = 1+ /string |
2dup .img-size src= s" img" tag/ ; |
2dup .img-size src= s" img" tag/ ; |
: >img ( -- ) '{ parse type '} parse .img ; |
: >img ( -- ) '{ parse type '} parse .img ; |
|
|
Line 198 Defer parse-line
|
Line 255 Defer parse-line
|
|
|
: get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN |
: get-icon ( addr u -- ) iconpath @ IF 2drop EXIT THEN |
link-suffix $! s" .*" link-suffix $+! |
link-suffix $! s" .*" link-suffix $+! |
s" icons" open-dir throw >r |
icon-prefix $@ open-dir throw >r |
BEGIN |
BEGIN |
pad $100 r@ read-dir throw WHILE |
pad $100 r@ read-dir throw WHILE |
pad swap 2dup link-suffix $@ filename-match |
pad swap 2dup link-suffix $@ filename-match |
IF s" icons/" iconpath $! iconpath $+! |
IF icon-prefix $@ iconpath $! s" /" iconpath $+! iconpath $+! |
iconpath $@ 2dup .img-size src= '- >border |
iconpath $@ 2dup .img-size src= '- >border |
alt-suffix s" img" tag/ true |
alt-suffix s" img" tag/ true |
ELSE 2drop false THEN |
ELSE 2drop false THEN |
Line 228 Defer parse-line
|
Line 285 Defer parse-line
|
link-sig $@ r/o open-file IF drop EXIT THEN |
link-sig $@ r/o open-file IF drop EXIT THEN |
close-file throw |
close-file throw |
." (" link-sig $@ href= s" a" tag |
." (" link-sig $@ href= s" a" tag |
s" |-icons/sig.gif" .img ." sig" s" /a" tag ." )" ; |
s" |-@/sig.gif" .img ." sig" s" /a" tag ." )" ; |
|
|
: link-warn? ( -- ) \ local links only |
: link-warn? ( -- ) \ local links only |
link $@ ': scan nip ?EXIT |
link $@ ': scan nip ?EXIT |
link $@ '# $split 2drop r/o open-file nip IF |
link $@ '# $split 2drop dup IF |
s" Dead Link '" stderr write-file throw |
r/o open-file nip IF |
link $@ stderr write-file throw |
s" Dead Link '" stderr write-file throw |
s\" ' !!!\n" stderr write-file throw |
link $@ stderr write-file throw |
THEN ; |
s\" ' !!!\n" stderr write-file throw |
|
THEN |
|
ELSE 2drop THEN ; |
|
|
: link-options ( addr u -- addr' u' ) |
: link-options ( addr u -- addr' u' ) |
do-size off do-icon on |
do-size off do-icon on do-expand off |
over c@ '% = over 0> and IF do-size on 1 /string THEN |
over c@ '% = over 0> and IF do-size on 1 /string THEN |
over c@ '\ = over 0> and IF do-icon off 1 /string THEN ; |
over c@ '\ = over 0> and IF do-icon off 1 /string THEN |
|
over c@ '* = over 0> and IF do-expand on 1 /string THEN ; |
|
|
s" Gforth" environment? [IF] s" 0.5.0" str= [IF] |
s" Gforth" environment? [IF] s" 0.5.0" str= [IF] |
: parse-string ( c-addr u -- ) \ core,block |
: parse-string ( c-addr u -- ) \ core,block |
Line 256 s" Gforth" environment? [IF] s" 0.5.0" s
|
Line 316 s" Gforth" environment? [IF] s" 0.5.0" s
|
['] parse-line catch pop-file throw ; |
['] parse-line catch pop-file throw ; |
[THEN] [THEN] |
[THEN] [THEN] |
|
|
|
Variable expand-link |
|
Variable expand-prefix |
|
Variable expand-postfix |
|
|
|
: ?expand ( addr u -- ) expand-link $! |
|
do-expand @ IF |
|
expand-prefix $@ expand-link 0 $ins |
|
expand-postfix $@ expand-link $+! THEN |
|
expand-link $@ ; |
|
|
: .link ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN |
: .link ( addr u -- ) dup >r '| -$split dup r> = IF 2swap THEN |
link-options link $! |
link-options link $! |
link $@len 0= IF 2dup link $! ( s" .html" link $+! ) THEN |
link $@len 0= IF 2dup link $! ( s" .html" link $+! ) THEN |
link $@ href= s" a" tag link-icon? |
link $@ ?expand |
|
href= s" a" tag link-icon? |
parse-string s" a" /tag link-size? link-sig? link-warn? ; |
parse-string s" a" /tag link-size? link-sig? link-warn? ; |
: >link ( -- ) '[ parse type '] parse .link ; |
: >link ( -- ) '[ parse type '] parse .link ; |
|
|
Line 332 wordlist Constant autoreplacements
|
Line 403 wordlist Constant autoreplacements
|
\ paragraph handling |
\ paragraph handling |
|
|
: parse-par ( -- ) |
: parse-par ( -- ) |
BEGIN parse-line+ cr refill WHILE |
BEGIN |
|
parse-line+ cr refill WHILE |
source nip 0= UNTIL THEN ; |
source nip 0= UNTIL THEN ; |
|
|
: par ( addr u -- ) env? |
: par ( addr u -- ) env? |
Line 399 Variable toc-index
|
Line 471 Variable toc-index
|
$@ .img swap |
$@ .img swap |
IF |
IF |
case |
case |
2 of s" ^]|-icons/arrow_up.jpg" .img endof |
2 of s" ^]|-@/arrow_up.jpg" .img endof |
3 of |
3 of |
r@ 0= IF s" *]|-icons/circle.jpg" |
r@ 0= IF s" *]|-@/circle.jpg" |
ELSE s" v]|-icons/arrow_down.jpg" THEN .img endof |
ELSE s" v]|-@/arrow_down.jpg" THEN .img endof |
endcase |
endcase |
ELSE |
ELSE |
case |
case |
0 of s" ^]|-icons/arrow_up.jpg" .img endof |
0 of s" ^]|-@/arrow_up.jpg" .img endof |
1 of s" >]|-icons/arrow_right.jpg" .img endof |
1 of s" >]|-@/arrow_right.jpg" .img endof |
2 of s" *]|-icons/circle.jpg" .img endof |
2 of s" *]|-@/circle.jpg" .img endof |
3 of s" v]|-icons/arrow_down.jpg" .img endof |
3 of s" v]|-@/arrow_down.jpg" .img endof |
endcase |
endcase |
THEN |
THEN |
s" a" /tag rdrop ." <!--" cr ." -->" |
s" a" /tag rdrop ." <!--" cr ." -->" |
Line 543 definitions
|
Line 615 definitions
|
ELSE source nip IF >in off s" p" par THEN THEN ; |
ELSE source nip IF >in off s" p" par THEN THEN ; |
: parse-section ( -- ) end-sec off |
: parse-section ( -- ) end-sec off |
BEGIN refill WHILE |
BEGIN refill WHILE |
section-par end-sec @ UNTIL THEN ; |
section-par end-sec @ UNTIL THEN ; |
|
|
\ HTML head |
\ HTML head |
|
|
Line 565 Variable css-file
|
Line 637 Variable css-file
|
|
|
\ HTML trailer |
\ HTML trailer |
|
|
|
Variable public-key |
Variable mail |
Variable mail |
Variable mail-name |
Variable mail-name |
Variable orig-date |
Variable orig-date |
Line 579 Variable orig-date
|
Line 652 Variable orig-date
|
orig-date @ IF ." Created " orig-date $@ type ." . " THEN |
orig-date @ IF ." Created " orig-date $@ type ." . " THEN |
.lastmod |
.lastmod |
." by " |
." by " |
s" Mail|icons/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged |
s" Mail|@/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged |
|
public-key @ IF |
|
public-key $@ href= s" a" tag |
|
s" PGP key|@/gpg.asc.gif" .img s" a" /tag |
|
THEN |
-envs ; |
-envs ; |
|
|
\ top word |
\ top word |
|
|
: maintainer ( -- ) |
: maintainer ( -- ) |
'< sword -trailing mail-name $! '> sword mail $! ; |
'< sword -trailing mail-name $! '> sword mail $! ; |
|
: pgp-key ( -- ) |
|
bl sword -trailing public-key $! ; |
: created ( -- ) |
: created ( -- ) |
bl sword orig-date $! ; |
bl sword orig-date $! ; |
|
: icons |
|
bl sword icon-prefix $! ; |
|
: expands '# sword expand-prefix $! bl sword expand-postfix $! ; |
|
|
|
icons icons |
|
|
Variable style$ |
Variable style$ |
: style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ; |
: style> style$ @ 0= IF s" " style$ $! THEN style$ $@ tag-option $! ; |