color-dirk4c.f

0 [IF]
  Forth to HTML converter

  Main contributors: Brad Eckert, Ed Beroset & Dirk Busch
  Revision 4b. 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.

  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.

  Users of specific Forths can extend the hyperlink table to point to words
  in a glossary for that particular Forth.
[THEN]

ONLY FORTH ALSO DEFINITIONS

\ ------------------------------------------------------------------------------
\ Configuration - You can change the options:
1 VALUE bold                                      \ T if bold text
1 VALUE italic                                    \ T if italic comments
1 VALUE nestable                                  \ T if INCLUDE nested files
1 VALUE linksource                                \ T link to the org. file /4a/
create  dpanspath ," .\"                          \ path to the ANS-Files   /4a/
create  copyright ," "                            \ copyright to output at  /4a/
                                                 \ the bottom of the HTML-file
\ ------------------------------------------------------------------------------

: undefined ( <name> -- f ) BL WORD FIND NIP 0= ;
undefined C+!    [IF] : C+! SWAP OVER C@ + SWAP C! ;                      [THEN]
undefined BOUNDS [IF] : BOUNDS OVER + SWAP ;                              [THEN]
undefined SCAN   [IF] : SCAN
  >R
  BEGIN DUP WHILE OVER C@ R@ <> WHILE 1 /STRING REPEAT THEN
  R> DROP ;                                                              [THEN]
undefined SKIP   [IF] : SKIP
  >R
  BEGIN DUP WHILE OVER C@ R@ = WHILE 1 /STRING REPEAT THEN
  R> DROP ;                                                              [THEN]
undefined NOOP   [IF] : NOOP ;                                            [THEN]
undefined +PLACE [IF] : +PLACE 2DUP 2>R COUNT CHARS + SWAP MOVE 2R> C+! ; [THEN]
undefined PLACE  [IF] : PLACE  0 OVER C! +PLACE ;                         [THEN]
undefined FDROP  [IF] : FDROP ;                                           [THEN]
undefined >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 ;

: ,$      ( a len -- )   DUP C, BOUNDS ?DO I C@ C, LOOP ; \ text to dictionary

\ create a named text string terminated by char
\ when executed, emits the named text using out
: namedtext ( char <name> <text> -- )
  CREATE WORD COUNT BL SKIP -TRAILING ,$ \ /4c/
  DOES> COUNT out ;

\ new and improved strings are now named
  CHAR ! namedtext <a_href="    <a href="!
  CHAR ! namedtext <a_href="#x  <a href="#x!
  CHAR ! namedtext </a>         </a>!

  CHAR ! namedtext <a_name="x   <a name="x!

  CHAR ! namedtext <span_style="color:# <span style="color:#!
  CHAR ! namedtext </span>      </span>!

  CHAR ! namedtext <hr_/>       <hr />!
  CHAR ! namedtext </hr>        </hr>!

  CHAR ! namedtext <h1>         <h1>!
  CHAR ! namedtext </h1>        </h1>!

  CHAR ! namedtext <p>          <p>!
  CHAR ! namedtext </p>         </p>!

  CHAR ! namedtext <br_/>       <br />

  CHAR ! namedtext ">           ">!


WORDLIST CONSTANT hyperlinks
VARIABLE attrib
: /a     ( -- )         attrib @ IF </a> THEN 0 attrib ! ;
: <i>    ( -- )         italic IF s" <i>" out THEN ;
: </i>   ( -- )         italic IF s" </i>" out THEN ;
: <b>    ( -- )         bold IF s" <b>" out THEN ;
: </b>   ( -- )         bold IF s" </b>" out THEN ;

: text    ( <text> -- )  -1 WORD COUNT -TRAILING ,$ ;
: boiler  ( addr -- )    BEGIN COUNT DUP WHILE 2DUP + >R outln R> REPEAT 2DROP ;


VARIABLE color                                  \ current color
VARIABLE infont                                 \ within <font> tag

: fontcolor ( color -- )                        \ change font color
  1 infont !

  <span_style="color:#
  BASE @ >R 0 HEX <# # # # # # # #> out R> BASE !
  "> ;

: col ( color <name> -- )                       \ define a font color
  CREATE , DOES> @ color ! ;

HEX
808080 col unknown
008000 col commentary
CC0000 col numeric
990080 col values
000000 col userwords
009999 col userdefiner
CC00CC col variables
0000FF col core_ws
0000FF col core_ext_ws
0000FF col block_ws
0000FF col double_ws
0000FF col exception_ws
0000FF col facilities_ws
0000FF col file_ws
0000FF col fp_ws
0000FF col local_ws
0000FF col malloc_ws
0000FF col progtools_ws
0000FF col searchord_ws
0000FF col string_ws
DECIMAL

CREATE begin_header                             \ begin of HTML file part 1
  text <?xml version="1.0"?>
  text <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
  text     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  text <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
  text <head>
  text <meta http-equiv="Content-Type" content="text/xml; charset=iso-8859-1" />
  text <meta name="GENERATOR" content="Forth2HTML 0.4" />
  text <style type="text/css">
  text body {background: #FFFFEE;}
  text h1 {color: #000000;}
  text p {font-family: monospace;}
  text a {text-decoration:none;}
  text </style>
  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>
  0 C,

CREATE end_header_part1                         \ end of HTML file part 1 /4a/
  text <hr />
  text <h4 style="color:black">
  0 C,

CREATE end_header_part2                      \ end of HTML file part 2 /4a/ /4b/
  text </h4>
  text </body></html>
  0 C,

HEX
: setcolor ( -- )                               \ select next color
  attrib @ 1 = color @ 0000FF = AND 0=         \ blue link: don't color
  DROP TRUE                                    \ /4/ vlinks are still purple
  IF color @ fontcolor THEN ;
DECIMAL

: closefont ( -- )
  infont @ IF </span> 0 infont ! THEN ;

VARIABLE bltally
: outh    ( a n -- )                            \ HTMLized text output
  999 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
     [CHAR] © OF S" &copy;"    out ENDOF       \ /4a/
     BL       OF bltally @ 0= IF S"  " ELSE S" &nbsp;" THEN out
               1 bltally +!     ENDOF
     I 1 out   0 bltally !
  ENDCASE LOOP ;

: outhattr  ( a n -- )                          \ HTMLized 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" leftbracket" out ENDOF
     [CHAR] ( OF S" leftparen" out ENDOF
     [CHAR] { OF S" leftbrace" out ENDOF
     [CHAR] ] OF S" rightbracket" out ENDOF
     [CHAR] ) OF S" rightparen" out ENDOF
     [CHAR] } OF S" rightbrace" out ENDOF
     BL       OF S" _"         out ENDOF
     I 1 out   
  ENDCASE LOOP ;

: end_header ( -- )                             \ output end of HTML file /4a/
 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
  <a_name="x outhattr
  "> 1 attrib ! ;

\ Assuming this is running on a PC, we allocate enough storage that crashes from
\ string overflows can't happen.                /4/

CREATE inbuf 260 CHARS ALLOT                    \ current line from file
CREATE token 260 CHARS ALLOT                    \ the 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 "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

: std    ( word 2nd_fn color filename label -- )
  CREATE ' , ' , BL WORD COUNT ,$ BL WORD COUNT ,$
  DOES> /a DUP >R  2 CELLS +
  <a_href="                                    \ begin hyperlink
  dpanspath COUNT out                          \ output path to ANS files /4a/
  COUNT 2DUP + >R  out S" #" out               \ output file name      /4/
  R> COUNT out ">                 \ and anchor name
  1 attrib !
  R> 2@ SWAP EXECUTE EXECUTE ;                 \ extra attributes

: genHTML ( -- )                                \ generate pending HTML
  token COUNT DUP IF setcolor THEN outh closefont /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 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
  <br_/> ;                                     \ new line

: ofn