0
[IF]
Forth to HTML converter
Written by Brad Eckert
Modifications by Dirk Busch
Revision 3. See bottom for revision history.
This ANS Forth program is public domain. It translates ANS Forth to colorized
HTML. Hyperlinks to the ANS Forth draft standard are inserted for all ANS
standard words. Hyperlinks to user definitions are included.
Usage: HTML FileName Generates HTML file from Forth source
output file is Filename with .HTM extension
Q [forth code] Outputs HTML for 1 line to screen
Q is used for debugging. You can use "linenum ?" to show the line number if an
ABORT occurs. The HTML is about 10 times as big as the Forth source because of
all the links, color changes and whitespace.
INCLUDEd files produce corresponding HTML pages. Most browsers get severely
bogged down with large files. If you're converting a large Forth program to
HTML, try to keep the source files under 500 lines each by splitting long
source into multiple INCLUDE files. HTML pages are best viewed with Internet
Explorer or Netscape 4.7. Netscape 6 is more sluggish with large files.
When you INCLUDE this file some redefinition complaints will occur. That's
okay since you won't be loading an application on top of this.
[THEN]
ONLY
FORTH
ALSO
DEFINITIONS
\
------------------------------------------------------------------------------
\
Configuration:
\
Hyperlink to the original file, or not.
\
Output at the TOP of the HTML-File
1
VALUE
LINK-TO-ORG-FILE
\
Copyright string.
\
Output at the BOTTOM of the HTML-File
\
create COPYRIGHT ," "
create
COPYRIGHT
,"
Copyright
©
2003-2004
by
Dirk
Busch"
\
path to the ANS-Files
\
create DPANS-PATH ," ./"
create
DPANS-PATH
,"
.\win32forth-defs\"
\
------------------------------------------------------------------------------
:
[undef]
( <name> -- f )
BL
WORD
FIND
NIP
0=
;
[undef]
+PLACE
[IF]
:
+PLACE
2DUP
2>R
COUNT
CHARS
+
SWAP
MOVE
2R>
C+!
;
[THEN]
[undef]
PLACE
[IF]
:
PLACE
0
OVER
C!
+PLACE
;
[THEN]
[undef]
FDROP
[IF]
:
FDROP
;
[THEN]
[undef]
>FLOAT
[IF]
:
>FLOAT
DROP
C@
[CHAR] 0
[CHAR] 9
1+
WITHIN
;
[THEN]
0
VALUE
outf
\
output to file
1
VALUE
screen-only
\
screen is for testing
:
werr
ABORT"
Error writing file"
;
:
out
screen-only
IF
type
ELSE
outf
WRITE-FILE
werr
THEN
;
:
outln
screen-only
IF
type
cr
ELSE
outf
WRITE-LINE
werr
THEN
;
WORDLIST
CONSTANT
hyperlinks
VARIABLE
attrib
:
/a
( -- )
attrib
@
IF
S"
</a>"
out
THEN
0
attrib
!
;
:
(,$)
( a len -- )
DUP
C,
BOUNDS
?DO
I
C@
C,
LOOP
;
\
text to dictionary
:
text
( <text> -- )
-1
WORD
COUNT
-TRAILING
(,$)
;
:
line
( a line# -- )
0
?DO
COUNT
+
LOOP
COUNT
out
;
\
output one string
:
boiler
( addr -- )
BEGIN
COUNT
DUP
WHILE
2DUP
+
>R
outln
R>
REPEAT
2DROP
;
CREATE
misctext
\
various attribute strings
text
<a
style="text-decoration:none"
href=
text
<a
name="
text
">
text
<a
href="#
text
"
style="text-decoration:none">
text
<font
color="#
text
<font
color="#000000"><center><hr><h1>
text
</h1><hr></center>
text
"
text
<a
href="
text
</a>
0
c,
VARIABLE
color
\
current color
VARIABLE
active-color
\
active color
:
fontcolor
( color -- )
\
change font color (only if needed)
dup
active-color
@
<>
if
dup
active-color
!
BASE
@
>R
misctext
5
line
0
HEX
<#
#
#
#
#
#
#
#>
out
misctext
2
line
R>
BASE
!
else
drop
then
;
:
fcol
( color <name> -- )
\
define a font color
CREATE
,
DOES>
@
color
!
;
HEX
808080
fcol
unknown
008000
fcol
commentary
CC0000
fcol
numeric
990080
fcol
values
000000
fcol
userwords
009999
fcol
userdefiner
CC00CC
fcol
variables
0000FF
fcol
core_ws
0000FF
fcol
core_ext_ws
0000FF
fcol
block_ws
0000FF
fcol
double_ws
0000FF
fcol
exception_ws
0000FF
fcol
facilities_ws
0000FF
fcol
file_ws
0000FF
fcol
fp_ws
0000FF
fcol
local_ws
0000FF
fcol
malloc_ws
0000FF
fcol
progtools_ws
0000FF
fcol
searchord_ws
0000FF
fcol
string_ws
DECIMAL
CREATE
begin_header
\
begin of HTML file part 1
text
<!DOCTYPE
HTML
PUBLIC
"-//W3C//DTD
HTML
4.0
Transitional//EN">
text
<html><head>
text
<meta
http-equiv="Content-Type"
content="text/html;">
text
<meta
name="GENERATOR"
content="Forth2HTML
0.3">
text
<title>
0
C,
\
body defaults: the most common link color (blue) is made the default color
\
the most common plain text color (green) is made default.
CREATE
mid_header
\
begin of HTML file part 2
text
</title></head>
text
<body
bgcolor="#FFFFEE"
link="0000FF"
vlink="0000FF"
alink="0000FF">
text
<pre><p>
0
C,
HEX
:
setcolor
( -- )
\
select next color
attrib
@
1
=
color
@
0000FF
=
AND
0=
\
blue link: don't color
IF
color
@
fontcolor
THEN
;
DECIMAL
:
outh
( a n -- )
\
HTMLized text output
BOUNDS
?DO
I
C@
CASE
[CHAR] &
OF
S"
&"
out
ENDOF
[CHAR] <
OF
S"
<"
out
ENDOF
[CHAR] >
OF
S"
>"
out
ENDOF
[CHAR] "
OF
S"
""
out
ENDOF
[CHAR] ©
OF
S"
©"
out
ENDOF
I
1
out
ENDCASE
LOOP
;
CREATE
end_header_part1
\
end of HTML file part 1
text
</p></pre>
text
<center><hr>
text
<font
color="#000000">
0
C,
CREATE
end_header_part2
\
end of HTML file part 2
text
</center>
text
</body></html>
0
C,
:
end_header
( -- )
\
output end of HTML file
end_header_part1
boiler
COPYRIGHT
count
?dup
if
outh
else
drop
then
end_header_part2
boiler
;
:
label
( addr len -- )
/a
\
associate a label with a word
misctext
1
line
outh
misctext
2
line
1
attrib
!
;
:
"out
( -- )
\
output a "
misctext
8
line
;
:
new-line
( -- )
\
start a new line (December 30th, 2003 - dbu)
S"
"
outln
\
13 here dup>r C! 10 r@ char+ C! r> 2 out
;
:
std
( word color <string> -- )
CREATE
'
,
'
,
BL
WORD
COUNT
(,$)
DOES>
/a
DUP
>R
2
CELLS
+
misctext
0
line
\
begin hyperlink
BASE
@
>R
DECIMAL
COUNT
0
0
2OVER
>NUMBER
2DROP
D>S
R>
BASE
!
"out
DPANS-PATH
count
out
\
write path to ANS-Files (December 30th, 2003 - dbu)
CASE
\
choose file name
6
OF
S"
dpans6.htm#"
out
ENDOF
7
OF
S"
dpans7.htm#"
out
ENDOF
8
OF
S"
dpans8.htm#"
out
ENDOF
9
OF
S"
dpans9.htm#"
out
ENDOF
10
OF
S"
dpans10.htm#"
out
ENDOF
11
OF
S"
dpans11.htm#"
out
ENDOF
12
OF
S"
dpans12.htm#"
out
ENDOF
13
OF
S"
dpans13.htm#"
out
ENDOF
14
OF
S"
dpans14.htm#"
out
ENDOF
15
OF
S"
dpans15.htm#"
out
ENDOF
16
OF
S"
dpans16.htm#"
out
ENDOF
17
OF
S"
dpans17.htm#"
out
ENDOF
ABORT"
Undefined source file"
ENDCASE
out
"out
s"
>"
out
1
attrib
!
R>
2@
SWAP
EXECUTE
EXECUTE
;
\
extra attributes
:
genHTML
( -- )
\
generate pending HTML
PAD
COUNT
DUP
IF
setcolor
THEN
outh
/a
0
PAD
!
;
:
isnumber?
( addr len -- f )
\
string converts to number?
0
0
2SWAP
>NUMBER
NIP
NIP
NIP
0=
;
:
hparse
( a len char -- a' len' )
>R
2DUP
R@
SKIP
R>
SCAN
BL
SCAN
2SWAP
2
PICK
-
PAD
+PLACE
;
\
size for XPAD and EPAD increased to avoid crashes in
\
files with long lines December 30th, 2003 - dbu
CREATE
XPAD
1024
CHARS
ALLOT
\
temporary pad for word storage
CREATE
EPAD
1024
CHARS
ALLOT
\
temporary pad for evaluation
:
>XPAD
( -- )
PAD
COUNT
BL
SKIP
XPAD
PLACE
;
\
move to temporary pad
:
hint
( addr len -- )
\
interpret one line...
BEGIN
0
PAD
!
BL
hparse
PAD
C@
WHILE
unknown
\
default color
>XPAD
XPAD
COUNT
hyperlinks
SEARCH-WORDLIST
\
got a hyperlink for this?
IF
DEPTH
>R
EXECUTE
R>
DEPTH
<>
ABORT"
stack depth change in HTML generator"
ELSE
XPAD
COUNT
BASE
@
10
=
IF
>FLOAT
IF
FDROP
numeric
THEN
\
valid float or integer
ELSE
isnumber?
IF
numeric
THEN
THEN
THEN
genHTML
REPEAT
2DROP
new-line
;
\
new line
CREATE
inbuf
260
CHARS
ALLOT
CREATE
fn
128
CHARS
ALLOT
\
file name
CREATE
fn1
128
CHARS
ALLOT
\
file name backup
CREATE
pstr
128
CHARS
ALLOT
\
parsed string storage
CREATE
uname
64
CHARS
ALLOT
\
: definition name
0
VALUE
inf
VARIABLE
nufile
\
T if nesting a file
VARIABLE
utype
\
type of defined word
VARIABLE
hstate
VARIABLE
linenum
VARIABLE
special
\
special action, 0=none
:
ofn
( -- addr len )
\
output file name
fn
COUNT
2DUP
[CHAR] .
SCAN
NIP
-
EPAD
PLACE
S"
.htm"
EPAD
+PLACE
EPAD
COUNT
;
:
hcreate
( addr len -- )
S"
CREATE "
EPAD
PLACE
EPAD
+PLACE
GET-CURRENT
>R
hyperlinks
SET-CURRENT
EPAD
COUNT
EVALUATE
R>
SET-CURRENT
;
\
create a hyperlink generator
\
The user defined words use the following data structure:
\
CELL xt of coloring word
\
STRING name of reference word
\
STRING name of file
:
deflink
( addr -- )
\
make hyperlink from data structure
DUP
@
EXECUTE
CELL+
\
set color
DUP
COUNT
+
COUNT
ofn
COMPARE
\
in an external file?
IF
misctext
0
line
DUP
COUNT
+
COUNT
out
\
yes, put file name
S"
#"
out
COUNT
outh
S"
>"
out
ELSE
misctext
3
line
COUNT
outh
\
no, just use the name
misctext
4
line
THEN
1
attrib
!
;
:
defx
( a len xt -- a' len' )
>R
genHTML
BL
hparse
>XPAD
\
output defining word
XPAD
COUNT
2DUP
hcreate
R>
,
(,$)
ofn
(,$)
DOES>
deflink
;
:
labelnow
genHTML
XPAD
COUNT
label
;
:
defdat
[']
numeric
defx
numeric
labelnow
;
:
defvar
[']
variables
defx
variables
labelnow
;
:
defusr
[']
userwords
defx
userwords
labelnow
;
:
defval
[']
values
defx
values
labelnow
;
:
defdef
[']
userdefiner
defx
userdefiner
labelnow
;
:
hstate=0
( -- )
0
hstate
!
;
:
hstate=1
( -- )
1
hstate
!
;
:
spec=zero
( -- )
1
special
!
;
:
skip)
( a len -- a' len' )
[CHAR] )
hparse
;
:
skip}
( a len -- a' len' )
[CHAR] }
hparse
;
:
skipw
( a len -- a' len' )
BL
hparse
;
:
skipc
( a len -- a len )
hstate
@
0=
IF
numeric
skipw
THEN
;
:
skip"
( a len -- a' len' )
\
copy string to pstr
genHTML
[CHAR] "
hparse
PAD
COUNT
1-
pstr
PLACE
;
\
------------------------------------------------------------------------------
\
":" definitions might be defining words, so they can't be assumed to be defusr
\
types. ":" makes a label and saves the name for later use by ";" which makes
\
a hyperlink or a hyperlink defining word.
:NONAME
\
normal : definition
uname
COUNT
[']
userwords
defx
2DROP
0
PAD
!
;
CONSTANT
normal_def
:NONAME
uname
COUNT
2DUP
hcreate
[']
userwords
,
(,$)
ofn
(,$)
DOES>
deflink
defdef
;
CONSTANT
defining_def
:
defunk
( a len -- a' len' )
\
starting unknown definition
hstate=1
normal_def
utype
!
\
save name of : definition
genHTML
skipw
userwords
PAD
COUNT
BL
SKIP
2DUP
uname
PLACE
label
;
:
resunk
( -- )
\
resolve unknown defined word
genHTML
utype
@
EXECUTE
hstate=0
\
; cleanup
GET-ORDER
hyperlinks
1
SET-ORDER
S"
L#O#C#A#L"
EVALUATE
\
forget locals
SET-ORDER
;
:
created
( -- )
hstate
@
IF
defining_def
utype
!
\
make ; create a defining word