color-dirk1.f

\ 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 or Netscape 4.7. Netscape 6 is more sluggish with large files.

ONLY FORTH ALSO DEFINITIONS

\ path to the ANS-Files
\ create dpans-path ," ./"
create dpans-path ," C:\Programme\Win32For\V609xx - CVS\htm\"

: 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 <font color="#
  text <font color="#000000"><hr><h1>
  text </h1><hr>
  text "
  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.0">
  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

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

: "out   ( -- )                                 \ output a "
  misctext 8 line
;

: new-line ( -- )                               \ start a new line (December 30th, 2003 - dbu)
\   S" <br>" outln
   13 here dup>r C! 10 r@ char+ C! r> 2 out
;

: 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 !
  "out dpans-path count out \ write path to ANS-Files (December 30th, 2003 - dbu)
  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 "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 ;

\ size for XPAD and EPAD increased to avoid crashes in
\ files with long lines December 30th, 2003 - dbu
CREATE XPAD 1024 CHARS ALLOT                     \ temporary pad for word storage
CREATE EPAD 1024 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
  new-line ;                             \ 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 ;

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