color-brad0.f

\ Forth to HTML converter
\ Brad Eckert
\ Revision 0. 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.

ONLY FORTH ALSO DEFINITIONS

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

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 </title></head><body bgcolor="#FFFFEE" text="#808080"><code>
  text <font color="#
  text <font color="#000000"><hr><h1>
  text </h1><hr>
  0 c,

VARIABLE color                                  \ current color
VARIABLE oldcolor -1 oldcolor !                 \ previous color

: fontcolor ( color -- ) BASE @ >R              \ change font color
  misctext 6 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
  text <html> <head>
  text <meta http-equiv="Content-Type" content="text/html;">
  text <meta name="GENERATOR" content="Forth2HTML 0.0">
  text <title>
  0 C,

CREATE end_header                               \ end of HTML file
  text </code></body>
  text </html>
  0 C,

: setcolor ( -- )                               \ select next color
  color @ DUP oldcolor @ <>
  DROP TRUE \ always select a color so viewed hyperlinks don't change color
  IF DUP fontcolor THEN oldcolor ! ;

VARIABLE bltally
: outh    ( a n -- )                            \ HTMLized text output
  999 bltally !
  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
     BL       OF bltally @ 0= IF S" " ELSE S"  " THEN out
               1 bltally +!     ENDOF
     I 1 out   0 bltally !
  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 80 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" <br>" 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

: 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 ! ;
: skip) ( a len -- a' len' ) [CHAR] ) hparse ;
: skipw ( a len -- a' len' ) BL hparse ;
: 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 ;

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

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

: header ( addr len -- )                       \ output big header text
  misctext 7 line outln misctext 8 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" ;

: open ( -- ) cr ." Reading " fn COUNT type ." at line " linenum @ .
  0 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 COUNT outln misctext 5 line              \ title and end boilerplate
  fn COUNT header ;

: HTML          ( <infile> -- )
  0 TO screen-only 0 nufile