color-brad10.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 10. 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

  Keep in mind that whatever path you use for the input filename will be in the
  output files, so don't use a drive letter etc. if the HTML is intended for
  distribution on CD or a web site.

  A framed version of the output file has a "_f.htm" extension. The left frame
  is an index of words and the words that use them. The right frame is source.
  If you open the index file (_i.htm extension) and click on links, source will
  be in a separate window. Still usable but frames are easier.

  Q is for debugging. You can use "linenum ?" to show the line number if an
  ABORT occurs. The HTML is about 8 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 anchors
  in a glossary for that particular Forth.

  This code has been tested under Win32forth, SwiftForth, VFX and Gforth.

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

ONLY FORTH ALSO DEFINITIONS
\ ------------------------------------------------------------------------------
\ Configuration - You can change the options:
0 VALUE bold                                      \ T if bold text
0 VALUE italic                                    \ T if italic comments
1 VALUE nestable                                  \ T if INCLUDE nested files
1 VALUE linksource                                \ T link to the org. file /7/
1 VALUE frames                                    \ T if using frames /9/
: dpanspath S" .\" ;                              \ path to the ANS-Files   /7/
: copyright S" "   ;                              \ 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 NOOP   [IF] : NOOP ;                                            [THEN]
undefined BOUNDS [IF] : BOUNDS OVER + SWAP ;                              [THEN]
undefined /STRING [IF] : /STRING TUCK - >R CHARS + R> ;                   [THEN]
undefined C+!    [IF] : C+! SWAP OVER C@ + SWAP C! ;                      [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 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]
: +PLACE        ( addr len a -- ) 2DUP 2>R COUNT CHARS + SWAP MOVE 2R> C+! ;
: PLACE         ( addr len a -- ) 0 OVER C! +PLACE ;
: UPC           ( c -- C )  DUP [CHAR] a [CHAR] z 1+ WITHIN IF 32 - 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 ;
: newline ( -- )         S" <br />" outln ;
: xcr     ( -- )         S" " outln ;           \ /9/

CREATE misctext                                 \ various attribute strings
  ,| <a href="                                                         | \ 0
  ,| <a name="x                                                        |
  ,| ">                                                                |
  ,| <a href="#x                                                       |
  ,| "                                                                 |
  ,| <span style="color:#                                              |
  ,| <hr /><h1>                                                        |
  ,| </h1><hr />                                                       |
  ,| </span>                                                           |
  ,| </a>                                                              |
  ,| <HEAD><TITLE>                                                     | \ 10
  ,| </TITLE></HEAD>                                                   |
  ,| <FRAMESET cols="25%,75%">                                         |
  ,| <FRAME SRC="                                                      |
  ,| " name="idx"  target="_self">                                     |
  ,| " name="main" target="_self">                                     |
  ,| </FRAMESET>                                                       |
  ,| " target="main">                                                  | \ 17
  ,| " target="idx">                                                   |
  0 C,

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

: <href="       misctext 0 line ;
: ">            misctext 2 line ;

: fontcolor ( color -- )                        \ change font color
  1 infont !
  misctext 5 line 0 HEX <# # # # # # # #> out "> ;

: 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 ver 10" />                    |
  ,| <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,

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/
  ,| </p><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 10</font></a></p>                      |
  ,| </h4>                                                                    |
  ,| </body></html>                                                           |
  0 C,

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

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

\ In order to represent all ASCII chars as text, some puncuation needs to be
\ changed to make it HTML compatible.

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 ?DUP IF outh ELSE drop THEN
  end_header_part2 boiler ;

: label ( addr len -- ) /a                      \ associate a label with a word
  misctext 1 line outhattr
  "> 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