color-ed2.f

0 [IF]
  Forth to HTML converter

  Written by Brad Eckert
  Modifications by Dirk Busch and Ed Beroset

  Revision 4. 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 or Netscape 4.7. Netscape 6 is more sluggish with large files.

  When you INCLUDE this file some redefinition complaints will occur. That's
  okay since you won't be loading an application on top of this.
[THEN]

ONLY FORTH ALSO DEFINITIONS

\ ------------------------------------------------------------------------------
\ Configuration:

\ Hyperlink to the original file, or not.
\ Output at the TOP of the HTML-File

1 VALUE LINK-TO-ORG-FILE

\ path to the ANS-Files
CREATE DPANS-PATH ," http://www.tinyboot.com/ANS/"

\ ------------------------------------------------------------------------------


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

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

: fontcolor ( color -- )                        \ change font color
  DUP active-color @ <> IF
     DUP active-color !
     1 infont !
     BASE @ >R
     misctext 5 line 0 HEX <# # # # # # # #> out
     misctext 2 line       
     R> BASE !
  ELSE DROP
  THEN ;

: 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

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                               \ end of HTML file
  text </pre></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 ( -- )
  /a
  infont @ IF
  misctext 8 line 0 infont ! THEN ;
   

: outh    ( 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
     I 1 out   
  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 ! ;

: "out   ( -- )                                 \ output a "
  misctext 9 line ;

: new-line ( -- )                               \ start a new line
   S" " outln ;

: 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 !
  DPANS-PATH COUNT out                         \ write path to ANS files
  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 0 PAD ! ;

: genHTML2 ( -- )                                \ generate pending HTML
  PAD COUNT DUP IF setcolor THEN outh closefont 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 1024 CHARS ALLOT                    \ temporary pad for word storage
CREATE EPAD 1024 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
  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 ;

( TODO: fix the pad overrun in defx! )
: 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
\