color-dirk4d.f

0 [IF]
  Forth to HTML converter

  Main contributors: Brad Eckert, Ed Beroset & Dirk Busch
  Revision 4d. 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:
0 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 ," .\win32forth-defs\"          \ path to the ANS-Files   /4a/
create  footer    ," "                            \ text 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     ( n -- )      ABORT" Error writing file" ;
: out      ( a len -- )  screen-only IF TYPE    ELSE outf WRITE-FILE werr THEN ;
: outln    ( a len -- )  screen-only IF TYPE CR ELSE outf WRITE-LINE werr THEN ;
: ,$       ( a len -- )  DUP C, BOUNDS ?DO I C@ C, LOOP ; \ text to dictionary
: text     ( <text> -- ) -1 WORD COUNT -TRAILING ,$ ;
: boiler   ( addr -- )   BEGIN COUNT DUP WHILE 2DUP + >R outln R> REPEAT 2DROP ;
: html-num ( n -- )      BASE @ >R 0 HEX <# # # # # # # #> out R> BASE ! ;

\ 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_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 <h4>         <h4 style="color:black">!
  CHAR ! namedtext </h4>        </h4>!
  CHAR ! namedtext <html>       <html>!
  CHAR ! namedtext </html>      </html>!
  CHAR ! namedtext <head>       <head>!
  CHAR ! namedtext </head>      </head>!
  CHAR ! namedtext <title>      <title>!
  CHAR ! namedtext </title>     </title>!
  CHAR ! namedtext <body>       <body>!
  CHAR ! namedtext </body>      </body>!
  CHAR ! namedtext <p>          <p>!
  CHAR ! namedtext </p>         </p>!
  CHAR ! namedtext <br>         <br />
  CHAR ! namedtext ">           ">!

VARIABLE attrib
: <a_href="   ( -- )  _<a_href="   1 attrib ! ;
: <a_href="#x ( -- )  _<a_href="#x 1 attrib ! ;
: <a_name="x  ( -- )  _<a_name="x  1 attrib ! ;
: </a>        ( -- )  attrib @ IF s" </a>" out 0 attrib ! THEN ;
: <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 ;

VARIABLE infont                                 \ within <font> tag
: fontcolor ( color -- )                        \ change font color
  1 infont !
  <span_style="color:#   html-num   "> ;

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

VARIABLE color                                  \ current color
: 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

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

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 ;

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,

: mid_header ( -- )                             \ begin of HTML file part 2
  </title>
  </head>
  <body>
;

: end_header ( -- )                             \ end of HTML file /4a/
  footer COUNT ?DUP IF <hr> <h4> outh </h4> ELSE drop THEN
  </body> </html> ;

: label ( addr len -- ) </a>                    \ associate a label with a word
  <a_name="x outhattr "> ;

\ 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
WORDLIST CONSTANT hyperlinks

: 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
  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