version 1.15, 2002/07/26 08:35:15
|
version 1.20, 2003/07/14 20:57:07
|
Line 1
|
Line 1
|
\ wiki forth |
\ wiki forth |
|
|
|
\ Copyright (C) 2003 Free Software Foundation, Inc. |
|
|
|
\ This file is part of Gforth. |
|
|
|
\ Gforth is free software; you can redistribute it and/or |
|
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation; either version 2 |
|
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program; if not, write to the Free Software |
|
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
require string.fs |
require string.fs |
|
|
: -scan ( addr u char -- addr' u' ) |
: -scan ( addr u char -- addr' u' ) |
Line 99 Create jfif $FF c, $D8 c, $FF c, $E0 c
|
Line 117 Create jfif $FF c, $D8 c, $FF c, $E0 c
|
: bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ; |
: bw@ ( addr -- x ) 0 swap 2 bounds ?DO 8 lshift I c@ + LOOP ; |
|
|
: gif? ( -- flag ) |
: gif? ( -- flag ) |
s" GIF89a" imgbuf over compare 0= |
s" GIF89a" imgbuf over str= |
s" GIF87a" imgbuf over compare 0= or ; |
s" GIF87a" imgbuf over str= or ; |
: gif-size ( -- w h ) |
: gif-size ( -- w h ) |
imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + |
imgbuf 8 + c@ imgbuf 9 + c@ 8 lshift + |
imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + ; |
imgbuf 6 + c@ imgbuf 7 + c@ 8 lshift + ; |
|
|
: png? ( -- flag ) |
: png? ( -- flag ) |
pngsig 8 imgbuf over compare 0= ; |
pngsig 8 imgbuf over str= ; |
: png-size ( -- w h ) |
: png-size ( -- w h ) |
imgbuf $14 + b@ imgbuf $10 + b@ ; |
imgbuf $14 + b@ imgbuf $10 + b@ ; |
|
|
: jpg? ( -- flag ) |
: jpg? ( -- flag ) |
jfif 10 imgbuf over compare 0= ; |
jfif 10 imgbuf over str= ; |
: jpg-size ( fd -- w h ) >r |
: jpg-size ( fd -- w h ) >r |
2. BEGIN |
2. BEGIN |
2dup r@ reposition-file throw |
2dup r@ reposition-file throw |
Line 175 Defer parse-line
|
Line 193 Defer parse-line
|
: link-icon? ( -- ) do-icon @ 0= ?EXIT |
: link-icon? ( -- ) do-icon @ 0= ?EXIT |
iconpath @ IF iconpath $off THEN |
iconpath @ IF iconpath $off THEN |
link $@ + 1- c@ '/ = IF s" index.html" ELSE link $@ THEN |
link $@ + 1- c@ '/ = IF s" index.html" ELSE link $@ THEN |
|
'# $split 2drop |
BEGIN '. $split 2swap 2drop dup WHILE |
BEGIN '. $split 2swap 2drop dup WHILE |
2dup get-icon REPEAT 2drop ; |
2dup get-icon REPEAT 2drop ; |
|
|
Line 195 Defer parse-line
|
Line 214 Defer parse-line
|
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 ; |
|
|
s" Gforth" environment? [IF] s" 0.5.0" compare 0= [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 |
loadfilename# @ >r |
s" *evaluated string*" loadfilename>r |
1 loadfilename# ! \ "*evaluated string*" |
|
push-file #tib ! >tib ! |
push-file #tib ! >tib ! |
>in off blk off loadfile off -1 loadline ! |
>in off blk off loadfile off -1 loadline ! |
['] parse-line catch |
['] parse-line catch |
pop-file r> loadfilename# ! throw ; |
pop-file r>loadfilename throw ; |
[ELSE] |
[ELSE] |
: parse-string ( addr u -- ) |
: parse-string ( addr u -- ) |
evaluate-input cell new-tib #tib ! tib ! |
evaluate-input cell new-tib #tib ! tib ! |
Line 211 s" Gforth" environment? [IF] s" 0.5.0" c
|
Line 229 s" Gforth" environment? [IF] s" 0.5.0" c
|
|
|
: .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 $@ href= s" a" tag link-icon? |
parse-string s" a" /tag link-size? link-sig? ; |
parse-string s" a" /tag link-size? link-sig? ; |
: >link ( -- ) '[ parse type '] parse .link ; |
: >link ( -- ) '[ parse type '] parse .link ; |
Line 297 wordlist Constant autoreplacements
|
Line 315 wordlist Constant autoreplacements
|
: get-rest ( addr -- ) 0 parse -trailing rot $! ; |
: get-rest ( addr -- ) 0 parse -trailing rot $! ; |
Create $lf 1 c, #lf c, |
Create $lf 1 c, #lf c, |
: get-par ( addr -- ) >r s" " r@ $+! |
: get-par ( addr -- ) >r s" " r@ $+! |
BEGIN 0 parse 2dup s" ." compare WHILE |
BEGIN 0 parse 2dup s" ." str= 0= WHILE |
r@ $@len IF $lf count r@ $+! THEN r@ $+! |
r@ $@len IF $lf count r@ $+! THEN r@ $+! |
refill 0= UNTIL ELSE 2drop THEN |
refill 0= UNTIL ELSE 2drop THEN |
rdrop ; |
rdrop ; |
Line 405 longtags set-current
|
Line 423 longtags set-current
|
: . end-sec on 0 indent ; |
: . end-sec on 0 indent ; |
: :code s" pre" >env |
: :code s" pre" >env |
BEGIN source >in @ /string type cr refill WHILE |
BEGIN source >in @ /string type cr refill WHILE |
source s" :endcode" compare 0= UNTIL THEN |
source s" :endcode" str= UNTIL THEN |
-env ; |
-env ; |
: \ postpone \ ; |
: \ postpone \ ; |
|
|
Line 463 Variable mail
|
Line 481 Variable mail
|
Variable mail-name |
Variable mail-name |
Variable orig-date |
Variable orig-date |
|
|
|
: .lastmod |
|
." Last modified: " time&date rot 0 u.r swap 1- |
|
s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type |
|
0 u.r ; |
|
|
: .trailer |
: .trailer |
s" address" >env s" center" >env |
s" address" >env s" center" >env |
orig-date @ IF ." Created " orig-date $@ type ." . " THEN |
orig-date @ IF ." Created " orig-date $@ type ." . " THEN |
." Last modified: " time&date rot 0 u.r swap 1- |
.lastmod |
s" janfebmaraprmayjunjulaugsepoctnovdec" rot 3 * /string 3 min type |
." by " |
0 u.r ." by " |
|
s" Mail|icons/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged |
s" Mail|icons/mail.gif" .img mail $@ mailto: mail-name $@ s" a" tagged |
-envs ; |
-envs ; |
|
|