color-ed3.f

0 [IF]
  Forth to HTML converter

  Main contributors: Brad Eckert & 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.

  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.

  You can change the following bold/italic/nestable options:
 [THEN]

ONLY FORTH ALSO DEFINITIONS

0 VALUE bold                                    \ T if bold text
1 VALUE italic                                  \ T if italic comments
1 VALUE nestable                                \ T if INCLUDE nests files

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

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 ;
: ital(   ( -- )         italic IF S" <i>" out THEN ;
: )ital   ( -- )         italic IF S" </i>" out THEN ;

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

\ new and improved strings are now named
  CHAR ! namedtext emitfarhref <a href="AnsForth/!
  CHAR ! namedtext emitanchor <a name="x!
  CHAR ! namedtext emitcloseattrib ">!
  CHAR ! namedtext emitlocalhref <a href="#x!
  CHAR ! namedtext emitcolor <span style="color:#!
  CHAR ! namedtext emith1 <hr /><h1>!
  CHAR ! namedtext emitcloseh1 </h1><hr /><p>!
  CHAR ! namedtext emitclosespan </span>!

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

: fontcolor ( color -- ) BASE @ >R              \ change font color
  1 infont !
  emitcolor 0 HEX <# # # # # # # #> out
  emitcloseattrib       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
  DROP TRUE                                    \ /4/ vlinks are still purple
  IF color @ fontcolor THEN ;
DECIMAL

: closefont ( -- )
  infont @ IF
  emitclosespan 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
     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 ;

: label ( addr len -- ) /a                      \ associate a label with a word
  emitanchor outhattr
  emitcloseattrib 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 +
  emitfarhref                                  \ begin hyperlink
  COUNT 2DUP + >R  out S" #" out               \ output file name      /4/
  R> COUNT out emitcloseattrib                 \ 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
  S" <br />" outln ;                           \ new line

: ofn   ( -- addr len )                         \ output file name
  fn COUNT 2DUP [CHAR] . SCAN NIP - EPAD PLACE
  S" .htm" EPAD +PLACE   EPAD COUNT ;

: hcreate ( addr len -- )
  DUP 0= IF 2DROP S" fakename" THEN            \ in case the name is missing
  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   emitfarhref DUP COUNT + COUNT out       \ yes, put file name
       S" #" out COUNT outh S" >" out
  ELSE emitlocalhref COUNT outhattr            \ no, just use the name
       emitcloseattrib
  THEN 1 attrib ! ;