color-brad2.f

0 [IF]
  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.

  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

: [undef] ( <name> -- f ) BL WORD FIND NIP 0= ;
[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 ;

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 style="text-decoration:none" href=
  text <a name="
  text ">
  text <a href="#
  text " style="text-decoration:none">
  text <font color="#
  text <font color="#000000"><hr><h1><code>
  text </code></h1><hr>
  0 c,

VARIABLE color                                  \ current color

: fontcolor ( color -- ) BASE @ >R              \ change font color
  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 <html> <head>
  text <meta http-equiv="Content-Type" content="text/html;">
  text <meta name="GENERATOR" content="Forth2HTML 0.2">
  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 bgcolor="#FFFFEE" link="0000FF" vlink="0000FF" alink="0000FF">
  text <pre>
  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

: outh    ( a n -- )                            \ HTMLized text output
  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
     I 1 out
  ENDCASE LOOP ;

: label ( addr len -- ) /a                      \ associate a label with a word
  misctext 1 line outh
  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 s" >" out
  1 attrib !
  R> 2@ SWAP EXECUTE EXECUTE ;                 \ extra attributes

: genHTML ( -- )                                \ generate pending HTML
  PAD COUNT DUP IF setcolor THEN outh /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 260 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" " 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   \ yes, put file name
       S" #" out COUNT outh S" >" out
  ELSE misctext 3 line COUNT outh              \ no, just use the name
       misctext 4 line
  THEN 1 attrib ! ;

: defx ( a len xt -- a' len' )
  >R genHTML BL hparse >XPAD                   \ output defining word
  XPAD COUNT 2DUP hcreate R> , ,$ ofn ,$
  DOES> deflink ;

: labelnow   genHTML XPAD COUNT label ;
: defdat ['] numeric   defx numeric   labelnow ;
: defvar ['] variables defx variables labelnow ;
: defusr ['] userwords defx userwords labelnow ;
: defval ['] values    defx values    labelnow ;
: defdef ['] userdefiner defx userdefiner labelnow ;

: hstate=0 ( -- )             0 hstate ! ;
: hstate=1 ( -- )             1 hstate ! ;
: spec=zero ( -- )            1 special ! ;
: skip) ( a len -- a' len' ) [CHAR] ) hparse ;
: skipw ( a len -- a' len' ) BL hparse ;
: skipc ( a len -- a len )   hstate @ 0= IF numeric skipw THEN ;
: skip" ( a len -- a' len' )                   \ copy string to pstr
  genHTML [CHAR] " hparse PAD COUNT 1- pstr PLACE ;

\ ------------------------------------------------------------------------------
\ ":" definitions might be defining words, so they can't be assumed to be defusr
\ types. ":" makes a label and saves the name for later use by ";" which makes
\ a hyperlink or a hyperlink defining word.

:NONAME                                         \ normal : definition
  uname COUNT ['] userwords defx 2DROP 0 PAD !
; CONSTANT normal_def

:NONAME
  uname COUNT 2DUP hcreate ['] userwords , ,$ ofn ,$
  DOES> deflink defdef
; CONSTANT defining_def

: defunk ( a len -- a' len' )                   \ starting unknown definition
  hstate=1 normal_def utype !                 \ save name of : definition
  genHTML skipw userwords PAD COUNT BL SKIP 2DUP uname PLACE label ;

: resunk ( -- )                                 \ resolve unknown defined word
  genHTML utype @ EXECUTE
  hstate=0                                     \ ; cleanup
  GET-ORDER hyperlinks 1 SET-ORDER
  S" L#O#C#A#L" EVALUATE                       \ forget locals
  SET-ORDER ;

: created ( -- ) hstate @
  IF   defining_def utype !                    \ make ; create a defining word
  ELSE defdat                                  \ not compiling
  THEN ;

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

: header ( addr len -- )                       \ output big header text
  misctext 6 line out misctext 7 line ;

: _incfil ( addr -- )                           \ trigger file nesting
  fn COUNT fn1 PLACE COUNT BL SKIP fn place 1 nufile ! ;

: incfile ( a len -- a' len' )                  \ include a file
  genHTML skipw PAD _incfil ;

: "incfil ( a len -- a' len' )                  \ include file from S" filename"
  skipw pstr _incfil ;

: hfill ( -- len )                             \ read next line of file
  inbuf 256 inf READ-LINE ABORT" Error reading file"
  1 linenum +! ;

: open ( -- ) cr ." Reading " fn COUNT type ." at line " linenum @ .
  1 linenum !
  fn COUNT R/O OPEN-FILE ABORT" Error opening source file" to inf ;

: close ( -- ) cr ." closing " fn COUNT type
  inf CLOSE-FILE ABORT" Error closing file" ;

: oopen ( -- )
  ofn W/O CREATE-FILE ABORT" Error creating file" to outf
  begin_header boiler                          \ begin boilerplate
  fn COU