color-ed5.f

0 [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" &amp;"     out ENDOF
     [CHAR] < OF S" &lt;"      out ENDOF
     [CHAR] > OF S" &gt;"      out ENDOF
     [CHAR] " OF S" &quot;"    out ENDOF
          169 OF S" &#169;"    out ENDOF  
     BL       OF bltally @ 0= IF S"  " ELSE S" &#160;" 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