color-brad8.f

0 [IF]
  Forth to HTML converter

  Main contributors:
     Brad Eckert       brad1NO@SPAMtinyboot.com            Original author
     Ed Beroset      berosetNO@SPAMmindspring.com          Fixed HTML bugs
     Dirk Busch         dirkNO@SPAMschneider-busch.de      Added some features

  Revision 7. 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 for debugging. You can use "linenum ?" to show the line number if an
  ABORT occurs. The HTML is about 7 times as big as the Forth source because of
  all the links, color changes and whitespace.

  INCLUDEd files produce corresponding HTML pages. If a file can't be found,
  it is skipped. Otherwise it is nested.

  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. You can make
  a text version of this file by cut-and-paste to a text editor. The browser's
  save-as-text function will work too. This file is only 80 columns wide. Note
  that the browser may wrap after 80 columns when saving as a text file.

  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

\ ------------------------------------------------------------------------------
\ 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 /7/
CREATE  dpanspath ," .\"                          \ path to the ANS-Files   /7/
CREATE  copyright ," "                            \ copyright to output at  /7/
                                                 \ the bottom of the HTML-file
0 CONSTANT scheme ( Color scheme )                \ 0 = light background, 1=dark
\ ------------------------------------------------------------------------------

: 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            ( addr len char -- addr' len' )
  >R
  BEGIN DUP WHILE OVER C@ R@ <> WHILE 1 /STRING REPEAT THEN
  R> DROP ;                                                              [THEN]
undefined SKIP   [IF] : SKIP            ( addr len char -- addr' len' )
  >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 ;         ( no floating point? fake it )    [THEN]
undefined >FLOAT [IF] : >FLOAT DROP C@ [CHAR] 0 [CHAR] 9 1+ WITHIN ;      [THEN]
undefined UPC    [IF] : UPC             ( convert char to upper case )
  DUP [CHAR] a [CHAR] z 1+ WITHIN AND IF 32 - THEN ;                     [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                    \ list of hyperlinks
WORDLIST CONSTANT superlinks                    \ hyperlinks that can't change

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> -- )  [CHAR] | 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 misctext                                 \ various attribute strings
  ,| <a href="                                                                |
  ,| <a name="x                                                               |
  ,| ">                                                                       |
  ,| <a href="#x                                                              |
  ,| ">                                                                       |
  ,| <span style="color:#                                                     |
  ,| <hr /><h1>                                                               |
  ,| </h1><hr /><p>                                                           |
  ,| </span>                                                                  |
  ,| </a>                                                                     |
  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
scheme 0 = [IF]                                 \ light background
  808080 col unknown
  008000 col commentary
  990000 col numeric
  FF0000 col errors
  990080 col values
  000000 col userwords
  009999 col userdefiner
  CC00CC col variables
  0000FF col core_ws                           \ core is slightly lighter blue
  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
[ELSE]                                          \ black background
  808080 col unknown
  00FF00 col commentary
  FF8080 col numeric
  FF0000 col errors
  FF00FF col values
  FFFFFF col userwords
  00FFFF col userdefiner
  FF80FF col variables
  8080FF col core_ws
  8080FF 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
[THEN]
DECIMAL

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

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

CREATE end_header_part2                         \ end of HTML file part 2 /8/
  ,| <p><a href="http://www.tinyboot.com/ANS/color.htm"><font color="#C0C0C0">|
  ,| HTMLized by <u>Forth2HTML</u> ver 0.8</font></a></p>                     |
  ,| </h4>                                                                    |
  ,| </body></html>                                                           |
  0 C,


: setcolor ( -- )                               \ select next color
  color @ fontcolor ;

: 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" &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       \ /7/
     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" ltbracket" out ENDOF
     [CHAR] ( OF S" ltparen"   out ENDOF
     [CHAR] { OF S" ltbrace"   out ENDOF
     [CHAR] ] OF S" rtbracket" out ENDOF
     [CHAR] ) OF S" rtparen"   out ENDOF
     [CHAR] } OF S" rtbrace"   out ENDOF
     BL       OF S" _"         out ENDOF
     I 1 out
  ENDCASE LOOP ;

: end_header ( -- )                             \ output end of HTML file /7/
  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
  misctext 1 line outhattr
  misctext 2 line 1 attrib ! ;

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

CREATE inbuf 260 CHARS ALLOT                    \ current line from file
CREATE token 260 CHARS ALLOT                    \ 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 +
  misctext 0