Menu
▾
▴
[Win32forth-cvs] win32forth/src/tools DexH-Glossary.f,NONE,1.1 DexH.f,NONE,1.1 W32fdexh.f,NONE,1.1
|
From: Dirk B. <db...@us...> - 2005-12-20 18:01:04
|
Update of /cvsroot/win32forth/win32forth/src/tools In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv18932/src/tools Added Files: DexH-Glossary.f DexH.f W32fdexh.f Log Message: DexH added --- NEW FILE: DexH-Glossary.f --- \ Word2Table.f \ Written June 13th, 2003 by di...@sc... (dbu) \ last changed on June 15th, 2003 - 10:15 (dbu) \ last changed on June 29th, 2003 - 10:16 (dbu) create OutputFile ," w32f-Glossary.txt" \ **************************************************************************** \ helper words \ **************************************************************************** [UNDEFINED] 2+ [if] CODE 2+ ( n1 -- n2 ) \ add two to n1 inc ebx inc ebx next c; [then] [UNDEFINED] 2- [if] CODE 2- ( n1 -- n2 ) \ sub two from n1 dec ebx dec ebx next c; [then] : "minus-path" { a1 n1 -- a2 n2 } \ remove path from filename \ scan to last '\' in filename a1 n1 + n1 [CHAR] \ -SCAN ?dup if n1 swap - 1- swap 1+ swap else drop a1 n1 then ; \ **************************************************************************** \ write output file \ **************************************************************************** [UNDEFINED] OutputFileHandle [if] 0 value OutputFileHandle \ hold's the handle of the output file [then] : output-close ( -- ) \ close output file OutputFileHandle ?dup if close-file drop 0 to OutputFileHandle then ; : output-open ( -- falg ) \ open output-file output-close OutputFile count r/w open-file swap to OutputFileHandle dup INVALID_HANDLE_VALUE = if drop OutputFile count r/w create-file swap to OutputFileHandle else drop OutputFileHandle file-append then ; : output-string ( addr count -- ) \ write a string to the output-file OutputFileHandle write-file drop ; : output-char ( char -- ) \ write a char to the output-file here c! here 1 output-string ; : output-tab ( -- ) \ write TAB to the output-file 9 output-char ; : output-cr ( -- ) \ write CR to the output-file 13 output-char 10 output-char ; : output-header ( -- ) \ write the header line to the output-file s" Name" output-string output-tab s" Stack" output-string output-tab s" Comment" output-string output-tab s" Type" output-string output-tab s" Class" output-string output-tab s" File" output-string output-cr ; \ **************************************************************************** \ parse input file \ **************************************************************************** 99 value definition-type create $definition-name 260 allot $definition-name off create $class-name 260 allot $class-name off false value InClass? : IsClass? ( -- f ) definition-type 8 = \ :class ? definition-type 9 = \ :object ? or ; : IsCloseingClass? ( -- f ) definition-type 10 = \ ;class ? definition-type 11 = \ ;object ? or ; : save-definition-name ( addr len f -- addr len ) if 2dup $definition-name place then IsClass? if 2dup $class-name place then IsCloseingClass? if $class-name off then ; : print-line { addr count char fSaveName -- addr' count' } \ write line to output file; stop on char count 0> if addr count char scan dup 0<> if 1- swap 1+ swap dup count swap - addr swap char bl = if 1- then fSaveName save-definition-name \ save name output-string else 2drop addr count fSaveName save-definition-name \ save name output-string addr 0 \ preevent stack underflow then else addr 0 \ preevent stack underflow then ; : print-definition-name ( addr count -- addr' count' ) \ write word name output file bl scan bl skip bl IsClass? print-line ; : print-stack-comment ( addr count -- addr' count' ) \ write stack-comment output file ?dup if bl skip dup if over c@ [char] ( = if [char] ) false print-line else over c@ [char] { = if [char] } false print-line then then then else 0 \ preevent stack underflow then ; : print-comment ( addr count -- ) \ write comment to output file ?dup if bl skip dup if over c@ [char] \ = if [char] \ skip bl skip output-string else 2drop then else 2drop then else drop then ; : print-definition-type ( -- ) \ write type of definition to output file definition-type case 0 of s" COLON" endof 1 of s" CODE" endof 2 of s" CONSTANT" endof 3 of s" DEFER" endof 4 of s" CREATE" endof 5 of s" VARIABLE" endof 6 of s" VALUE" endof 7 of s" METHOD" endof 8 of s" CLASS" endof 9 of s" OBJECT" endof 10 of s" ;CLASS" endof 11 of s" ;OBJECT" endof 99 of s" ?" endof endcase output-string ; : print-file-name ( #ancor -- ) \ write input file name to output file $infile lcount output-string s" #" output-string s>d (D.) output-string ; : is-definition-type ( addr1 len1 addr2 len2 -- f ) \ 4dup cr tab . space drop . drop \ 4dup cr tab type \ cr tab type COMPARE 0= ; : +word ( a1 n1 -- a2 n2 a3 n3 ) bl skip 2dup bl scan 2dup 2>r nip - 2r> 2swap ; : set-definition-type ( addr len n -- ) to definition-type 2drop ; : get-definition-type ( addr len -- ) \ get type of definition \ cr ." get-definition-type for: " 2dup type 99 to definition-type \ default: unkonwen 2dup upper +word 2nip -trailing 2dup s" :" is-definition-type if 0 set-definition-type exit then 2dup s" CODE" is-definition-type if 1 set-definition-type exit then 2dup s" CONSTANT" is-definition-type if 2 set-definition-type exit then 2dup s" DEFER" is-definition-type if 3 set-definition-type exit then 2dup s" CREATE" is-definition-type if 4 set-definition-type exit then 2dup s" VARIABLE" is-definition-type if 5 set-definition-type exit then 2dup s" VALUE" is-definition-type if 6 set-definition-type exit then 2dup s" :M" is-definition-type if 7 set-definition-type exit then 2dup s" :CLASS" is-definition-type if 8 set-definition-type true to InClass? exit then 2dup s" :OBJECT" is-definition-type if 9 set-definition-type true to InClass? exit then 2dup s" ;CLASS" is-definition-type if 10 set-definition-type false to InClass? exit then 2dup s" ;OBJECT" is-definition-type if 11 set-definition-type false to InClass? exit then ; \ 2drop ; : print-class-name ( -- ) InClass? IsClass? 0= and if $class-name count else s" " then output-string ; : process-word ( #ancor addr count -- ) \ process on line of the input file ?dup if print-definition-name output-tab ( #ancor addr' count' ) print-stack-comment output-tab ( #ancor addr' count' ) print-comment output-tab ( #ancor ) print-definition-type output-tab ( #ancor ) print-class-name output-tab ( #ancor ) print-file-name output-cr ( -- ) else 2drop then ; --- NEW FILE: W32fdexh.f --- \ $Id: W32fdexh.f,v 1.1 2005/12/20 18:00:50 dbu_de Exp $ needs tools/dexh create W32Fheader ,| <html> | ,| <head> | ,| <meta http-equiv="Content-Language" content="en-gb"> | ,| <meta name="GENERATOR" content="dexh00"> | ,| <meta name="ProgId" content="FrontPage.Editor.Document"> | ,| <meta http-equiv="Content-Type" content="text/html; charset=windows-1252"> | ,| <title> | 0 c, create W32FHeaderA ,| </title><style><!-- | ,| h1 { font-family: Tahoma; font-size: 24pt; font-weight: bold } | ,| h2 { font-family: Tahoma; font-size: 18pt; font-weight: bold } --> | ,| </style> | ,| </head> | ,| <body><h1 align="center"> | ,| <a href="mailto:win...@ya...?subject=DOC:Doc error in $Id: W32fdexh.f,v 1.1 2005/12/20 18:00:50 dbu_de Exp $"> | ,| <img border="0" src="TELLUS.gif" align="left" width="32" height="32"></a> | ,| <img border="0" src="FORTHPRO.gif" | ,| width="32" height="32"> Win32Forth</h1> | 0 c, create W32FClassheaderA ,| </title><style><!-- | ,| h1 { font-family: Tahoma; font-size: 24pt; font-weight: bold } | ,| h2 { font-family: Tahoma; font-size: 18pt; font-weight: bold } --> | ,| </style> | ,| </head> | ,| <body><h1 align="center"> | ,| <a href="mailto:win...@ya...?subject=DOC:Doc error in $Id: W32fdexh.f,v 1.1 2005/12/20 18:00:50 dbu_de Exp $"> | ,| <img border="0" src="../TELLUS.gif" align="left" width="32" height="32"></a> | ,| <img border="0" src="../FORTHPRO.gif" | ,| width="32" height="32"> Win32Forth</h1> | 0 c, create W32FTrailer ,| <hr><p>Document $Id: W32fdexh.f,v 1.1 2005/12/20 18:00:50 dbu_de Exp $</p> | ,| </body></html> | 0 c, : W32FDocs ( -- ) W32Fheader to HtmlHeader W32FheaderA to HtmlheaderA W32FTrailer to HtmlTrailer ; : W32FClassDocs ( -- ) W32Fheader to HtmlHeader W32FClassheaderA to HtmlheaderA W32FTrailer to HtmlTrailer ; : DexDocs ( -- ) DexHTMLheader to HTMLheader DexHTMLheaderA to HTMLheaderA DexHTMLtrailer to HTMLtrailer ; cr .( DexH -- Document Extractor loaded ) cr cr .( Usage:" dex <filename> ) --- NEW FILE: DexH.f --- \ $Id: DexH.f,v 1.1 2005/12/20 18:00:50 dbu_de Exp $ ( *! dexh DexH ) ( *T DexH -- Document Extractor, HTML output ) \ *Q Version 3 \ ** Primary contributors: Brad Eckert br...@SP... ( *Q Abstract ) ( ** DexH is a simple literate programming tool inspired by MPE's DOCGEN. DexH ) ( ** can also be used to write articles about Forth featuring a mixture of ) ( ** documentation and source code. DexH is a standalone program that processes) ( ** a Forth source file. The following command does the conversion: \n ) ( ** \bDEX input_filename\d ) ( *S Commands ) ( *P Commands are embedded within comments. You can use the following formats, ) ( ** with either starting at the first column. ) \ *B ( ?? ... ) where ?? is the command, or \ *B \ ?? ... ( *P You can append HTML to created files by DEXing any number of source files ) ( ** but you should use a *Z command to complete the HTML. ) ( *L |c||l| ) ( *| Command | Effect | ) ( *| ** | continuation of G, E or P | ) ( *| *! | create and select a new output file | ) ( *| *> | select an existing file to add text to | ) ( *| *T | Title | ) ( *| *Q | Quotation or abstract | ) ( *| *S | Section | ) ( *| *N | Sub-section | ) ( *| *P | Paragraph | ) ( *| *E | Paragraph which is a code example | ) ( *| *B | Bullet entry | ) ( *| *G | Glossary entry for the previous line | ) ( *| *R | raw LaTeX | ) ( *| *W | raw HTML | ) ( *| *Z | End output | ) ( *| *+ | Include source code as document text | ) ( *| *- | Turn off source code inclusion | ) anew -DexH.f internal \ Set to true when a seperate glossary.txt should be created \ Still work in progress... (dbu) 0 constant create-glossary-file? external ( *P DexH is ANS Forth except for the need for BOUNDS, SCAN, SKIP and LCOUNT. ) ( ** They are commonly used words but redefined here for completeness. ) ( *+ ) \ : BOUNDS OVER + SWAP ; \ : SCAN ( addr len char -- addr' len' ) \ >R BEGIN DUP WHILE OVER C@ R@ <> \ WHILE 1 /STRING REPEAT THEN R> DROP ; \ : SKIP ( addr len char -- addr' len' ) \ >R BEGIN DUP WHILE OVER C@ R@ = \ WHILE 1 /STRING REPEAT THEN R> DROP ; \ : LCOUNT ( addr -- addr' len ) DUP CELL+ SWAP @ ; ( *P Some files use very long lines, which is desirable for long sections of ) ( ** documentation. You can allocate buffers for lines longer than 2000 chars ) ( ** by changing the following line: ) 2000 CHARS CONSTANT max$ ( *- ) CREATE inbuf max$ 2 CELLS + ALLOT \ current line CREATE prevline max$ 2 CELLS + ALLOT \ previous line CREATE XPAD max$ 2 CELLS + ALLOT \ temporary ( *+ ) ( *P HTML needs some canned boilerplate. This is created by ,| since HTML ) ( ** doesn't use | characters. ) : (,$) ( a len -- ) DUP C, 0 ?DO COUNT C, LOOP DROP ; : ,| ( <text> -- ) [CHAR] | WORD COUNT -TRAILING (,$) ; CREATE DexHTMLheader ,| <?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="DexH v03" /> | ,| <style type="text/css"> | ,| </style> | ,| <title> | 0 C, ( *- ) DexHTMLheader value HTMLheader CREATE DexHTMLheaderA ,| </title> | ,| </head> | ,| <body> | 0 C, DexHTMLheaderA value HTMLheaderA CREATE DexHTMLtrailer ,| <hr /> | ,| </body></html> | 0 C, DexHTMLtrailer value HTMLtrailer 0 VALUE outfile \ The current output file 0 VALUE infile 0 VALUE echoing 0 value plain \ Echo the code as output 0 VALUE mode 0 VALUE gl-outfile \ The glossary current output file ( *P All output is via OUT and OUTLN, which can be sent to the screen for ) ( ** debugging purposes. ) ( *+ ) 0 VALUE testing \ screen is for testing : werr ( n -- ) ABORT" Error writing file" ; : out ( a len -- ) testing IF TYPE ELSE outfile WRITE-FILE werr THEN ; : outln ( a len -- ) testing IF TYPE CR ELSE outfile WRITE-LINE werr THEN ; ( *- ) : boiler ( addr -- ) BEGIN COUNT DUP WHILE 2DUP + >R outln R> REPEAT 2DROP ; : tag| ( <name><str> -- ) CREATE ,| DOES> COUNT out ( ln ) ; tag| +t <table border="1"> | \ table tag| -t </table> | tag| +b <ul><li> | \ bullets tag| -b </li></ul> | tag| ~b </li><li> | tag| +e <pre> | \ code paragraph tag| -e </pre> | tag| +p <p> | \ paragraph tag| -p </p> | tag| +g <pre><b> | \ preformatted bold glossary tag| -g </b></pre> | tag| hr <hr /> | \ rule tag| +h1 <h1> | \ title tag| -h1 </h1> | tag| +h2 <h2> | \ section tag| -h2 </h2> | tag| +h3 <h3> | \ sub-section tag| -h3 </h3> | tag| +qu <h3><i> | \ quotation or abstract tag| -qu </i></h3> | tag| +au <h4><i> | \ Author tag| -au </i></h4> | tag| -a </a> tag| +n <a name=" | tag| -n "> | tag| +href <a href=" | tag| -href "> | ( *P Some characters are replaced by special strings so they can't be ) ( ** interpreted as tags. Also, runs of blanks need special treatment. ) ( ** Some escape sequences are supported: ) ( *L |c||l| ) ( *| \bseq\d | \bEscape command \d | ) ( *| \\i | Italics | ) ( *| \\b | Bold | ) ( *| \\t | Typewriter | ) \ *| \\^ | Superscript (i.e. ax\\^2\\d+bx+c=0) | \ *| \\_ | Subscript | \ *| \\d | Default font (ends italic, superscript, etc.) | ( *| \\n | Line break | ) ( *| \\r | Horizontal rule | ) ( *| \\p | Page break | ) ( *| \\\\ | \ | ) \ *P Sample usage: \ ** "ax\\^2\\d + bx + w\\_0\\d = 0" displays ax\^2\d + bx + w\_0\d = 0 \ *P "Try \\bbold, \\iitalic \\dand \\ttypewriter.\\d" displays \ ** "Try \bbold, \iitalic \dand \ttypewriter\d." VARIABLE bltally \ counts runs of blanks VARIABLE thisfont \ current font attributes VARIABLE escape \ escape sequence in progress? VARIABLE captive \ ESC sequence not allowed : no-escape ( -- ) S" \" out 0 escape ! ; ( *+ ) : new-font ( n -- ) \ switch to a new font thisfont @ SWAP thisfont ! CASE [CHAR] i OF S" </i>" out ENDOF [CHAR] b OF S" </b>" out ENDOF [CHAR] t OF S" </code>" out ENDOF [CHAR] ^ OF S" </sup>" out ENDOF [CHAR] _ OF S" </sub>" out ENDOF ENDCASE ; : outh ( addr len -- ) \ HTMLized text output 999 bltally ! BOUNDS ?DO I C@ escape @ IF CASE [CHAR] \ OF S" \" out ENDOF [CHAR] n OF S" <br />" out ENDOF [CHAR] r OF hr ENDOF [CHAR] i OF I C@ new-font S" <i>" out ENDOF [CHAR] b OF I C@ new-font S" <b>" out ENDOF [CHAR] t OF I C@ new-font S" <code>" out ENDOF [CHAR] ^ OF I C@ new-font S" <sup>" out ENDOF [CHAR] _ OF I C@ new-font S" <sub>" out ENDOF [CHAR] d OF 0 new-font ENDOF no-escape I 1 out ENDCASE 0 escape ! ELSE CASE [CHAR] \ OF captive @ IF no-escape ELSE 1 escape ! THEN ENDOF [CHAR] & OF S" &" out ENDOF [CHAR] < OF S" <" out ENDOF [CHAR] > OF S" >" out ENDOF [CHAR] " OF S" "" out ENDOF [CHAR] © OF S" ©" out ENDOF BL OF bltally @ IF S" " ELSE S" " THEN out 1 bltally +! ENDOF I 1 out 0 bltally ! ENDCASE THEN LOOP escape @ IF no-escape THEN \ trailing \ S" " outln ; ( *- ) : outt ( a n -- ) out ; \ output as title string \ : lastchar ( a n -- a n c ) \ 2DUP 1- CHARS + C@ ; : line ( -- a len ) inbuf LCOUNT 5 /STRING \ remove ( ** and ) or \ ** inbuf CELL+ C@ [CHAR] ( = IF lastchar [CHAR] ) = IF 1- THEN THEN -TRAILING ; : _parse ( $line char -- $line' $ ) >R 2DUP R@ SKIP R> SCAN BL SCAN \ parse out a substring 2SWAP 2 PICK - ; : closeout ( -- ) outfile ?DUP IF CLOSE-FILE DROP THEN 0 TO outfile ; : end ( -- ) \ insert end tags mode CASE [CHAR] P OF -p ENDOF [CHAR] E OF -e ENDOF [CHAR] B OF -b ENDOF [CHAR] L OF -t ENDOF ENDCASE BL TO mode ; CREATE $infile max$ 2 CELLS + ALLOT \ file name 0 value #gl-ancor : switchfile ( -- $other $name io ) end closeout line BL _parse \ get filename (minus extension) >R XPAD R@ MOVE S" .htm" XPAD R@ CHARS + SWAP MOVE \ add file extension xpad R@ 4 CHARS + $infile lplace \ save file name 0 to #gl-ancor \ reset ancor XPAD R> 4 CHARS + w/o ; : pgraph ( -- ) +p line outh [CHAR] P TO mode ; : egraph ( -- ) +e line outh [CHAR] E TO mode ; : iscommand? ( $ -- ) inbuf CELL+ 3 COMPARE 0= ; \ *P The fields in a table are separated by | (vertical bar) and end in |. : table| ( -- ) \ add line to a table line BEGIN [CHAR] | _parse BL SKIP 1- 0 MAX -TRAILING DUP IF S" <td>" out outh S" </td>" outln ELSE 2DROP 2DROP EXIT THEN AGAIN ; fload tools/DexH-Glossary.f : gl-open ( -- ) \ *G Open glossary File create-glossary-file? if output-open drop then ; : gl-close ( -- ) \ *G Close glossary File create-glossary-file? if output-close then ; : gl-ancor ( -- ) \ *G Write ancor number #gl-ancor s>d (D.) out ; CREATE $line max$ 2 CELLS + ALLOT \ previous line : gl-get-type ( addr len - f ) $line lplace $line lcount get-definition-type definition-type 99 <> ; : gl-entry ( addr len -- ) cr 2dup type 2dup gl-get-type if $line lplace #gl-ancor $line lcount process-word else 2drop cr ." Line: " $line lcount type ." skipped" then ; \ debug gl-entry : gl-create-entry ( -- ) \ cr ." gl-create-entry: " prevline LCOUNT type \ *G Create a glossary entry +n gl-ancor -n prevline LCOUNT outh -a create-glossary-file? if prevline LCOUNT gl-entry 1 +to #gl-ancor then ; : command ( c -- ) plain IF -e 0 TO plain THEN \ terminate plain text CASE [CHAR] * OF line outh ENDOF [CHAR] ! OF switchfile create-file abort" Can't create file" TO outfile \ create and select a new file HTMLheader boiler outt \ add title HTMLheaderA boiler ENDOF [CHAR] > OF switchfile open-file abort" Can't open file" TO outfile 2DROP outfile FILE-SIZE DROP outfile REPOSITION-FILE DROP ENDOF [CHAR] T OF end hr +h1 line outh -h1 hr ENDOF [CHAR] S OF end +h2 line outh -h2 ENDOF [CHAR] N OF end +h3 line outh -h3 ENDOF [CHAR] A OF end +au line outh -au +p [CHAR] P TO mode ENDOF [CHAR] Q OF end +qu line outh -qu +p [CHAR] P TO mode ENDOF [CHAR] P OF end pgraph ENDOF [CHAR] E OF end egraph ENDOF [CHAR] B OF mode [CHAR] B <> IF end +b ELSE ~b THEN line outh [CHAR] B TO mode ENDOF [CHAR] G OF end +g gl-create-entry -g pgraph ENDOF [CHAR] W OF end line outln ENDOF [CHAR] + OF end +e 1 TO plain 1 TO echoing ENDOF [CHAR] - OF end 0 TO echoing ENDOF [CHAR] L OF end +t [CHAR] L TO mode ENDOF [CHAR] | OF S" <tr>" out table| S" </tr>" outln ENDOF [CHAR] Z OF end HTMLtrailer boiler ENDOF ENDCASE ; : process-line ( -- ) \ process INBUF S" ( *" iscommand? S" \ *" iscommand? OR inbuf @ 3 > AND IF 0 captive ! inbuf 3 CHARS + CELL+ C@ command \ a command ELSE end echoing \ not a command IF plain 0= IF 1 TO plain +e THEN 1 captive ! inbuf LCOUNT outh THEN THEN inbuf prevline OVER @ CELL+ MOVE ; \ save the old line ( *W <hr /> ) ( *S Glossary ) :noname ( <filename> -- ) ( *G Convert a file or files to HTML. Output filenames are included in the ) ( ** source file. ) 0 TO testing \ output to file 0 TO echoing 0 TO plain 0 TO mode \ reset modes 0 escape ! BL PARSE 2dup cr ." Processing file: " type R/O OPEN-FILE ABORT" Missing input file" TO infile gl-open prevline max$ BLANK BEGIN inbuf max$ BL FILL \ convert tabs to spaces XPAD max$ infile READ-LINE ABORT" Error reading file" >R >R 0 XPAD R> BOUNDS ( idx . . ) ?DO I C@ 9 = IF 3 RSHIFT 1+ 3 LSHIFT \ tab ELSE I C@ OVER CHARS CELL+ inbuf + C! 1+ DUP max$ = IF CR ." Input line too long" THEN THEN LOOP R> ( len eof ) WHILE inbuf ! process-line REPEAT DROP closeout infile CLOSE-FILE DROP \ close files \in-system-ok gl-close ; is dexh ' dexh alias dex : q ( <string> -- ) ( *G Test a single line of text, outputting to the screen. ) 1 TO testing -1 PARSE inbuf OVER ! inbuf CELL+ SWAP MOVE process-line ; \ *W <hr /><p>This file generated by <a href="dexh03.F">DexH</a></p> \ *Z module |
