color-ed1.f

\ Forth to HTML converter
\ Brad Eckert
\ Revision 2. 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. Netscape ignores the <code> attribute and is more sluggish with
\ large files.

ONLY FORTH ALSO DEFINITIONS

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

: bang PAD C@ 84 > IF ." pad overflow!" 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 href="
  text <a name="x
  text ">
  text <a href="#x
  text ">
  text <span style="color:#
  text <hr /><h1>
  text </h1><hr /><p>
  text </span>
  0 C,

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

: fontcolor ( color -- ) BASE @ >R              \ change font color
  1 infont !
  misctext 5 line 0 HEX <# # # # # # # #> out
  misctext 2 line       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.0" />
  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                               \ end of HTML file
  text </p></body>
  text </html>
  0 C,

HEX
: setcolor ( -- )                               \ select next color
  attrib @ 1 = color @ 0000FF = AND 0=         \ blue link: don't color
  IF color @ fontcolor THEN ;
DECIMAL

: closefont ( -- )
  infont @ IF
  misctext 8 line 0 infont ! THEN ;


VARIABLE bltally
: outh    ( a n -- )                            \ HTMLized text output
  999 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
     BL       OF bltally @ 0= IF S" " ELSE S"  " 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 ;

: label ( addr len -- ) /a                      \ associate a label with a word
  misctext 1 line outhattr
  misctext 2 line 1 attrib ! ;

: 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 ! 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 misctext 2 line
  1 attrib !
  R> 2@ SWAP EXECUTE EXECUTE ;                 \ extra attributes

: genHTML ( -- )                                \ generate pending HTML
  PAD COUNT DUP IF setcolor THEN outh closefont /a 0 PAD ! ;

: genHTML2 ( -- )                                \ generate pending HTML
  PAD COUNT .s DUP IF setcolor THEN outh closefont /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 ;

CREATE XPAD 260 CHARS ALLOT                     \ temporary pad for word storage
CREATE EPAD 80 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
  S" <br />" outln ;                             \ 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