color-ed5.f0 [IF] Forth to XML converter
Main contributors:
Brad Eckert brad1NO@SPAMtinyboot.com Original author
Ed Beroset berosetNO@SPAMmindspring.com XML, XSLT, some fixes
Dirk Busch dirkNO@SPAMschneider-busch.de Added some features
Revision 11. See bottom for revision history.
This ANS Forth program is public domain. It translates ANS Forth to XML with
the intent that the XML is then postprocesed by XSLT to create documentation
of the Forth program.
Hyperlinks to the ANS Forth draft standard are inserted for all ANS
standard words. Hyperlinks to user definitions are included.
Usage: XML FileName Generates XML file from Forth source.
Output file is Filename with .HTM extension.
q [forth code] Outputs XML for 1 line to screen
Keep in mind that whatever path you use for the input filename will be in the
output files, so don't use a drive letter etc. if the XML is intended for
distribution on CD or a web site.
q is for debugging. You can use "linenum ?" to show the line number if an
ABORT occurs. The XML is about 6 times as big as the Forth source because of
all the links, color changes and whitespace.
INCLUDEd files produce corresponding XML pages. If a file can't be found,
it is skipped. Otherwise it is nested.
When you INCLUDE this file some redefinition complaints may occur. That's
okay since you won't be loading an application on top of this. You can make
a text version of this file by cut-and-paste to a text editor. The browser's
save-as-text function will work too. This file is only 80 columns wide. Note
that the browser may wrap after 80 columns when saving as a text file.
Users of specific Forths can extend the hyperlink table to point to anchors
in a glossary for that particular Forth.
This code has been tested under Win32forth, SwiftForth, VFX and Gforth.
You can change the following nestable options:
[THEN]
ONLY FORTH ALSO DEFINITIONS
\ ------------------------------------------------------------------------------
\ Configuration - You can change this option:
1 VALUE nestable \ T if INCLUDE nested files
\ ------------------------------------------------------------------------------
: undefined ( <name> -- f ) BL WORD FIND NIP 0= ;
undefined NOOP [IF] : NOOP ; [THEN]
undefined BOUNDS [IF] : BOUNDS OVER + SWAP ; [THEN]
undefined /STRING [IF] : /STRING TUCK - >R CHARS + R> ; [THEN]
undefined C+! [IF] : C+! SWAP OVER C@ + SWAP C! ; [THEN]
undefined FDROP [IF] : FDROP ; ( no floating point? fake it ) [THEN]
undefined >FLOAT [IF] : >FLOAT DROP C@ [CHAR] 0 [CHAR] 9 1+ WITHIN ; [THEN]
undefined SCAN [IF] : SCAN ( addr len char -- addr' len' )
>R BEGIN DUP WHILE OVER C@ R@ <> WHILE 1 /STRING REPEAT THEN R> DROP ; [THEN]
undefined SKIP [IF] : SKIP ( addr len char -- addr' len' )
>R BEGIN DUP WHILE OVER C@ R@ = WHILE 1 /STRING REPEAT THEN R> DROP ; [THEN]
: +PLACE ( addr len a -- ) 2DUP 2>R COUNT CHARS + SWAP MOVE 2R> C+! ;
: PLACE ( addr len a -- ) 0 OVER C! +PLACE ;
: UPC ( c -- C ) DUP [CHAR] a [CHAR] z 1+ WITHIN IF 32 - THEN ;
: STRING, ( addr len -- ) DUP C, HERE SWAP DUP ALLOT MOVE ;
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 \ list of hyperlinks
WORDLIST CONSTANT superlinks \ hyperlinks that can't change
CREATE quot 34 C,
: onequote ( -- ) quot 1 out ;
: quote ( c-addr -- )
onequote COUNT out onequote ;
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> -- ) [CHAR] | 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 ;
: newline ( -- ) S" <br />" outln ;
: .< ( -- ) S" <" out ;
: .> ( -- ) S" >" out ;
: ./ ( -- ) S" /" out ;
CREATE misctext \ various attribute strings
,| <a href=" | \ 0
,| <a name="x | \ 1
,| "> | \ 2
,| <a href="#x | \ 3
,| <a std="# | \ 4
,| <a file=" | \ 5
,| " href="#x | \ 6
0 C,
VARIABLE tagtype \ current tagtype
VARIABLE intag \ within tag
: <href=" misctext 0 line ;
: <anchor=" misctext 1 line ;
: "> misctext 2 line ;
: <#ref=" misctext 3 line ;
: <std=" misctext 4 line ;
: <file=" misctext 5 line ;
: with_href misctext 6 line ;
: emittag ( tagtype -- ) \ change font tagtype
1 intag !
S" <tag type=" out quote .> ;
: tag ( <tagname> <string> -- )
CREATE BL WORD COUNT STRING,
DOES> tagtype ! ;
\ NAME STRING
\ ---- ------
tag unknown unknown
tag commentary commentary
tag numeric numeric
tag errors errors
tag values values
tag userwords userwords
tag userdefiner userdefiner
tag variables variables
tag core_ws core_ws
tag core_ext_ws core_ext_ws
tag block_ws block_ws
tag double_ws double_ws
tag exception_ws exception_ws
tag facilities_ws facilities_ws
tag file_ws file_ws
tag fp_ws fp_ws
tag local_ws local_ws
tag malloc_ws malloc_ws
tag progtools_ws progtools_ws
tag searchord_ws searchord_ws
tag string_ws string_ws
CREATE begin_header \ begin of XML file
,| <?xml version="1.0"?> |
,| <forth> |
0 C,
CREATE end_header_part1 \ end of XML file part 1 /7/
,| </forth> |
0 C,
: settagtype ( -- ) \ select next tagtype
tagtype @ emittag ;
: closetag ( -- )
intag @ IF
S" </tag>" out 0 intag ! THEN ;
\ In order to represent all ASCII chars as text, some puncuation needs to be
\ changed to make it XML compatible.
VARIABLE bltally
: outh ( a n -- ) \ XMLized text output
0 bltally !
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
169 OF S" ©" out ENDOF
BL OF bltally @ 0= IF S" " ELSE S"  " THEN out
1 bltally +! ENDOF
I 1 out 0 bltally !
ENDCASE LOOP ;
: outhattr ( a n -- ) \ XMLized text output
BOUNDS ?DO I C@ CASE
[CHAR] & OF S" amp" out ENDOF
[CHAR] < OF S" lt" out ENDOF
[CHAR] > OF S" gt" out ENDOF
[CHAR] " OF S" quot" out ENDOF
[CHAR] + OF S" plus" out ENDOF
[CHAR] ! OF S" bang" out ENDOF
[CHAR] / OF S" slash" out ENDOF
[CHAR] \ OF S" backslash" out ENDOF
[CHAR] ' OF S" apos" out ENDOF
[CHAR] = OF S" equal" out ENDOF
[CHAR] - OF S" dash" out ENDOF
[CHAR] @ OF S" at" out ENDOF
[CHAR] ; OF S" semi" out ENDOF
[CHAR] * OF S" star" out ENDOF
[CHAR] ? OF S" question" out ENDOF
[CHAR] ~ OF S" tilde" out ENDOF
[CHAR] # OF S" pound" out ENDOF
[CHAR] , OF S" comma" out ENDOF
[CHAR] $ OF S" dollar" out ENDOF
[CHAR] | OF S" bar" out ENDOF
[CHAR] [ OF S" ltbracket" out ENDOF
[CHAR] ( OF S" ltparen" out ENDOF
[CHAR] { OF S" ltbrace" out ENDOF
[CHAR] ] OF S" rtbracket" out ENDOF
[CHAR] ) OF S" rtparen" out ENDOF
[CHAR] } OF S" rtbrace" out ENDOF
169 OF S" copy" out ENDOF
BL OF S" _" out ENDOF
I 1 out
ENDCASE LOOP ;
: end_header ( -- ) \ output end of XML file /7/
end_header_part1 boiler ;
: label ( addr len -- ) /a \ associate a label with a word
<anchor=" outhattr
"> 1 attrib ! ;
\ Assuming this is running on a PC, we allocate enough storage that crashes from
\ string overflows can't happen.
CREATE inbuf 260 CHARS ALLOT \ current line from file
CREATE token 260 CHARS ALLOT \ last blank delimited string
CREATE XPAD 260 CHARS ALLOT \ temporary pad for word storage
CREATE EPAD 260 CHARS ALLOT \ temporary pad for evaluation
CREATE fn 260 CHARS ALLOT \ file name
CREATE fn1 260 CHARS ALLOT \ file name backup
CREATE fn2 260 CHARS ALLOT \ global file name
CREATE fn3 260 CHARS ALLOT \ index file name
CREATE "str" 260 CHARS ALLOT \ parsed string storage
CREATE uname 260 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
\ Defining word for hyperlinks to words in XML standards files.
: std ( word 2nd_fn tagtype label -- )
CREATE ' , ' , BL WORD COUNT ,$
DOES> /a DUP >R 2 CELLS +
<std=" COUNT out "> \ place hyperlink
1 attrib !
R> 2@ SWAP EXECUTE EXECUTE ; \ extra attributes
: genXML ( -- ) \ generate pending XML
token COUNT DUP IF settagtype THEN outh closetag /a 0 token ! ;
: 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 - token +PLACE ;
: >XPAD ( -- ) token COUNT BL SKIP XPAD PLACE ; \ move to temporary pad
: hint ( addr len -- ) \ interpret one line...
BEGIN
0 token ! BL hparse token C@
WHILE unknown \ default tagtype
>XPAD XPAD COUNT superlinks SEARCH-WORDLIST 0= \ fixed hyperlink?
IF XPAD COUNT hyperlinks SEARCH-WORDLIST \ got a hyperlink for this?
ELSE TRUE
THEN
IF DEPTH >R EXECUTE
R> DEPTH <> ABORT" stack depth change in XML generator"
ELSE
XPAD COUNT BASE @ 10 = IF
>FLOAT IF FDROP numeric THEN \ valid float or integer
ELSE
isnumber? IF numeric THEN
THEN
THEN genXML
REPEAT 2DROP newline ;
: shortname ( -- )
fn COUNT 2DUP [CHAR] . SCAN NIP - EPAD PLACE ;
: ofn ( -- addr len ) \ output file name
shortname S" .xml" EPAD +PLACE EPAD COUNT ;
: hcreate ( addr len -- )
DUP 0= IF 2DROP S" fakename" THEN \ in case the name is missing
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
\ CELL pointer to index \ /9/
\ STRING name of reference word
\ STRING name of file
\ An index is a list of all of the words that call a defined word. The master
\ index is a list of indexes.
variable index 0 index ! \ index is a SLL of SLLs.
variable ulast 0 ulast ! \ last compiled definition name
variable tally 0 tally ! \ tally of defined words
\ Each index entry consists of a pointer to the previous index entry and a SLL.
\ The SLL (single linked list) starts out empty so upon creation it is 0.
\ index --> link_to_next
\ link_to_usedby_list <-- 'index
\ link to defined name structure
\ tally
: newindex ( -- 'index ) \ add an index to the list
HERE index @ , HERE SWAP 0 , index ! 0 , \ /9/
1 tally +! tally @ , ;
\ 'index -> link_to_next
\ link to usedby name structure
: newlink ( 'index -- 'index ) \ add a name to the index /9/
dup @ @ ?dup if \ non-empty sublist?
cell+ @ ulast @ = if exit then \ duplicate entry
then
HERE OVER @ @ , ulast @ , OVER @ ! ;
variable indexing
: deflink ( addr -- ) \ defined word makes hyperlink
DUP @ EXECUTE CELL+ \ set tagtype
ulast @ IF newlink THEN CELL+ \ /9/ optional addition to index
DUP COUNT + COUNT ofn COMPARE \ in an external file?
IF <file=" DUP COUNT + COUNT out \ yes, put the file name
with_href COUNT outhattr
ELSE <#ref=" COUNT outhattr \ no, just the label name
THEN
"> \ an index link needs a target
1 attrib ! ;
: defx ( a len xt -- a' len' )
newindex >R
>R genXML BL hparse >XPAD \ output defining word
XPAD COUNT 2DUP hcreate R> HERE SWAP ,
R@ CELL+ ! \ resolve link to definition name
R> , ,$ ofn ,$ \ rest of structure
DOES> deflink ;
: labelnow XPAD COUNT label genXML /a ;
: 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 ! ;
: NONE ( -- ) 0 special ! ; \ plain word
: skip) ( a len -- a' len' ) [CHAR] ) hparse ;
: skip} ( a len -- a' len' ) [CHAR] } hparse ; \ /7/
: 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 "str"
genXML [CHAR] " hparse token COUNT 1- 0 MAX "str" PLACE ; \ /10/
\ ------------------------------------------------------------------------------
\ ":" 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
ulast @ if \ ending a : definition?
uname COUNT ['] userwords defx 2DROP 0 token !
then
; CONSTANT normal_def
:NONAME
newindex >R
uname COUNT 2DUP hcreate HERE ['] userwords , R@ CELL+ ! R> , ,$ ofn ,$
DOES> deflink defdef
; CONSTANT defining_def
\ ULAST points to a data structure containing the hyperlink to the word being
\ defined. It is used when building the index because it can't wait until ;
\ resolves the definition before requiring the hyperlink.
: defunk ( a len -- a' len' ) \ starting unknown definition
hstate=1 normal_def utype ! \ save name of : definition
genXML skipw userwords token COUNT BL SKIP
2DUP label \ link to index
2DUP HERE ulast ! ['] NOOP , PAD , ,$ ofn ,$ \ save name of definition /9/
uname PLACE ;
: resunk ( -- ) \ resolve unknown defined word
genXML utype @ EXECUTE hstate=0
0 ulast ! ; \ indexing off
: created ( -- ) hstate @
IF defining_def utype ! \ make ; create a defining word
ELSE defdat \ not compiling
THEN ;
\ ------------------------------------------------------------------------------
: _incfil ( addr -- ) \ trigger file nesting /4/
nestable 0= IF DROP EXIT THEN \ don't nest files if disabled
COUNT BL SKIP 2DUP R/O OPEN-FILE \ can the file be opened?
IF DROP 2DROP \ no
ELSE CLOSE-FILE DROP \ yes
fn COUNT fn1 PLACE fn PLACE 1 nufile !
THEN ;
: incfile ( a len -- a' len' ) \ include a file
genXML skipw token _incfil ;
: "incfil ( a len -- a' len' ) \ include file from S" filename"
skipw "str" _incfil ;
: hfill ( -- len ior ) \ read next line of file
inbuf 256 BL FILL
XPAD 256 inf READ-LINE ABORT" Error reading file"
>R >R 0 XPAD R> BOUNDS ( idx . . )
?DO I C@ 9 = IF 3 RSHIFT 1+ 3 LSHIFT \ tab
ELSE I C@ OVER 255 AND CHARS inbuf + C!
1+ DUP 256 = IF CR ." Input line too long" THEN
THEN
LOOP R>
1 linenum +! ;
\ OPEN and CLOSE input files
: open ( -- ) CR ." Reading " fn COUNT TYPE ." at line " linenum @ decimal .
0 linenum !
fn COUNT R/O OPEN-FILE ABORT" Error opening source file" TO inf ;
: close ( -- ) CR ." closing " fn COUNT TYPE
inf CLOSE-FILE ABORT" Error closing file" ;
: .title ( addr len -- ) \ output as title string
BOUNDS ?DO I C@ BL = IF S" %20" out ELSE I 1 out THEN LOOP ;
\ OPEN and CLOSE output files
: ocreate ( addr len -- )
W/O CREATE-FILE ABORT" Error creating file" TO outf ;
: oopen ( -- ) \ create new output file
ofn ocreate begin_header boiler \ begin boilerplate
S" <module>" out
fn COUNT .title
S" </module>" out ; \ title
: fclose ( -- )
outf CLOSE-FILE ABORT" Error closing file" ;
: new-output ( -- ) \ start a new output file /9/
open oopen ;
\ Convert Forth source file(s) to XML
: XML ( <infile> -- )
S" /basic-links/" hyperlinks SEARCH-WORDLIST
IF EXECUTE THEN \ remove user hyperlinks
GET-CURRENT >R hyperlinks SET-CURRENT \ replace the fence
S" MARKER /basic-links/" EVALUATE
R> SET-CURRENT
0 TO outf \ no output file yet
0 TO screen-only 0 nufile ! 1 linenum ! \ force usage of file