<6>1 colscan.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: colscan.mll,v 1.5 2001/05/25 12:37:20 maranget Exp $ *)
(***********************************************************************)
{
open Lexing
15 exception Error of string
;;
let buf = Out.create_buff ()
;;
20 }
rule one = parse
' '*('0'|'1')?'.'?['0'-'9']*' '*
{let lxm = lexeme lexbuf in
float_of_string lxm}
25 | "" {raise (Error "Syntax error in color argument")}
and other = parse
' '* ',' {one lexbuf}
| "" {raise (Error "Syntax error in color argument")}
30
and three = parse
""
{let fst = one lexbuf in
let snd = other lexbuf in
35 let thrd = other lexbuf in
fst,snd,thrd}
and four = parse
""
{let fst = one lexbuf in
40 let snd = other lexbuf in
let thrd = other lexbuf in
let fourth = other lexbuf in
fst,snd,thrd,fourth}
<6>2 cut.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
{
open Lexing
open Stack
15 let header = "$Id: cut.mll,v 1.30 2001/05/25 09:07:07 maranget Exp $"
let verbose = ref 0
;;
20 let language = ref "eng"
;;
let tocbis = ref false
;;
25
exception Error of string
(* Accumulate all META, LINK and similar tags that appear in the preamble
30 in order to output them in the preamble of every generated page. *)
let header_buff = Out.create_buff ()
let common_headers = ref "";;
35 let adjoin_to_header s = Out.put header_buff s
and adjoin_to_header_char c = Out.put_char header_buff c
and finalize_header () =
40 common_headers := Out.to_string header_buff
let html_buff = Out.create_buff ()
let html_head = ref ""
and html_foot = ref ""
45
let phase = ref (-1)
;;
let name = ref "main"
50 and count = ref 0
;;
let body = ref "<BODY>"
and doctype = ref ""
55 and html = ref "<HTML>"
;;
let changed_t = Hashtbl.create 17
60 let rec check_changed name =
try
let r = Hashtbl.find changed_t name in
check_changed r
with
65 | Not_found -> name
let new_filename () =
incr count ;
let r1 = Printf.sprintf "%s%0.3d.html" !name !count in
70 let r2 = check_changed r1 in
r2
;;
let out = ref (Out.create_null ())
75 and out_prefix = ref (Out.create_null ())
and outname = ref ""
and lastclosed = ref ""
and otheroutname = ref ""
and flowname_stack = (Stack.create "flowname" : string Stack.t)
80 and flow_stack = (Stack.create "flow" : Out.t Stack.t)
;;
let toc = ref !out
and tocname = ref !outname
85 and otherout = ref !out
;;
let change_name oldname name =
if !phase <= 0 then begin
90 Thread.change oldname name ;
Cross.change oldname name ;
outname := name ;
Hashtbl.add changed_t oldname name
end
95
let start_phase name =
incr phase ;
if !verbose > 0 then
100 prerr_endline ("Starting phase number: "^string_of_int !phase);
outname := name ;
tocname := name ;
otheroutname := "" ;
count := 0 ;
105 if !phase > 0 then begin
out := (Out.create_chan (open_out name))
end ;
toc := !out
;;
110
let openlist out = Out.put out "<UL>\n"
and closelist out = Out.put out "</UL>\n"
and itemref filename s out =
Out.put out "<LI>" ;
115 Out.put out "<A HREF=\"" ;
Out.put out filename ;
Out.put out "\">" ;
Out.put out s ;
Out.put out "</A>\n"
120
and itemanchor filename label s out =
Out.put out "<LI>" ;
Out.put out "<A HREF=\"" ;
Out.put out filename ;
125 Out.put_char out '#' ;
Out.put out label ;
Out.put out "\">" ;
Out.put out s ;
Out.put out "</A>\n"
130
and putanchor label out =
Out.put out "<A NAME=\"" ;
Out.put out label ;
Out.put out "\"></A>"
135
and itemlist s out =
Out.put out "<LI>" ;
Out.put out s
;;
140
let putlink out name img alt =
Out.put out "<A HREF=\"" ;
Out.put out name ;
Out.put out "\"><IMG SRC =\"" ;
145 Out.put out img ;
Out.put out "\" ALT=\"" ;
Out.put out alt ;
Out.put out "\"></A>\n"
;;
150
let link_buff = Out.create_buff ()
let putlinks name =
let links_there = ref false in
155 if !verbose > 0 then
prerr_endline ("putlinks: "^name) ;
begin try
putlink link_buff (Thread.prev name) "previous_motif.gif"
(if !language = "fra" then "Precedent"
160 else "Previous") ;
links_there := true
with Not_found -> () end ;
begin try
putlink link_buff (Thread.up name) "contents_motif.gif"
165 (if !language = "fra" then "Index"
else "Contents") ;
links_there := true
with Not_found -> () end ;
begin try
170 putlink link_buff (Thread.next name) "next_motif.gif"
(if !language = "fra" then "Suivant"
else "Next") ;
links_there := true
with Not_found -> () end ;
175 if !links_there then
Some (Out.to_string link_buff)
else
None
180 let putlinks_start out outname = match putlinks outname with
| Some s ->
Out.put out s ;
Out.put out "<HR>\n"
| None -> ()
185
let putlinks_end out outname = match putlinks outname with
| Some s ->
Out.put out "<HR>\n" ;
Out.put out s
190 | None -> ()
let openhtml withlinks title out outname =
Out.put out !doctype ; Out.put_char out '\n' ;
195 Out.put out !html ; Out.put_char out '\n' ;
Out.put out "<HEAD>\n" ;
Out.put out !common_headers;
Out.put out "<TITLE>\n" ;
let title = Save.tagout (Lexing.from_string title) in
200 Out.put out title ;
Out.put out "\n</TITLE>\n" ;
Out.put out "</HEAD>\n" ;
Out.put out !body;
Out.put out "\n" ;
205 if withlinks then
putlinks_start out outname ;
Out.put out !html_head
210 and closehtml withlinks name out =
Out.put out !html_foot ;
if withlinks then begin
putlinks_end out name
end ;
215 Out.put out "</BODY>\n" ;
Out.put out "</HTML>\n" ;
Out.close out
;;
220 let put_sec hd title hde out =
Out.put out hd ;
Out.put_char out '\n' ;
Out.put out title ;
Out.put out hde ;
225 Out.put_char out '\n'
;;
let put s = Out.put !out s
230 and put_char c = Out.put_char !out c
;;
let cur_level = ref (Section.value "DOCUMENT")
and chapter = ref (Section.value "CHAPTER")
235 and depth = ref 2
;;
(* Open all lists in toc from chapter to sec, with sec > chapter *)
240 let rec do_open l1 l2 =
if l1 < l2 then begin
openlist !toc ;
if !tocbis then openlist !out_prefix ;
do_open (l1+1) l2
245 end
;;
(* close from l1 down to l2 *)
let rec do_close l1 l2 =
250 if l1 > l2 then begin
closelist !toc ;
if !tocbis then closelist !out_prefix ;
do_close (l1-1) l2
end else
255 cur_level := l1
;;
let anchor = ref 0
;;
260
let open_section sec name =
if !phase > 0 then begin
if !cur_level > sec then do_close !cur_level sec
else if !cur_level < sec then do_open !cur_level sec ;
265 incr anchor ;
let label = "toc"^string_of_int !anchor in
itemanchor !outname label name !toc ;
if !tocbis then itemanchor !outname label name !out_prefix ;
putanchor label !out ;
270 cur_level := sec
end else
cur_level := sec
and close_section sec =
275 if !phase > 0 then do_close !cur_level sec
else
cur_level := sec
;;
280 let close_chapter () =
if !verbose > 0 then
prerr_endline ("Close chapter out="^ !outname^" toc="^ !tocname) ;
if !phase > 0 then begin
closehtml true !outname !out ;
285 if !tocbis then begin
let real_out = open_out !outname in
Out.to_chan real_out !out_prefix ;
Out.to_chan real_out !out ;
close_out real_out
290 end else
Out.close !out ;
out := !toc
end else begin
lastclosed := !outname ;
295 outname := !tocname
end
and open_chapter name =
outname := new_filename () ;
300 if !verbose > 0 then
prerr_endline
("Open chapter out="^ !outname^" toc="^ !tocname^
" cur_level="^string_of_int !cur_level) ;
if !phase > 0 then begin
305 if !tocbis then begin
out_prefix := Out.create_buff () ;
out := !out_prefix ;
openhtml true name !out_prefix !outname
end else begin
310 out := Out.create_chan (open_out !outname) ;
openhtml true name !out !outname
end ;
itemref !outname name !toc ;
cur_level := !chapter
315 end else begin
if !verbose > 0 then
prerr_endline ("link prev="^ !lastclosed^" next="^ !outname) ;
Thread.setup !outname !tocname ;
Thread.setprevnext !lastclosed !outname ;
320 cur_level := !chapter
end
;;
let setlink set target =
if !phase = 0 && target <> "" then
325 set !outname target
let open_notes sec_notes =
if sec_notes <> !chapter || !outname = !tocname then begin
otheroutname := !outname ;
330 outname := new_filename () ;
if !phase > 0 then begin
otherout := !out ;
out := Out.create_chan (open_out !outname) ;
Out.put !out !doctype ; Out.put_char !out '\n' ;
335 Out.put !out !html ; Out.put_char !out '\n' ;
Out.put !out "<HEAD><TITLE>Notes</TITLE>\n" ;
Out.put !out !common_headers ;
Out.put !out "</HEAD>\n" ;
Out.put !out !body ;
340 Out.put !out "\n"
end
end else
otheroutname := ""
345 and close_notes () =
if !otheroutname <> "" then begin
Out.put !out "\n</BODY></HTML>\n" ;
Out.close !out ;
outname := !otheroutname ;
350 out := !otherout ;
otheroutname := ""
end
;;
355 let toc_buf = Out.create_buff ()
and arg_buf = Out.create_buff ()
;;
let stack = Stack.create "main"
360 ;;
let save_state newchapter newdepth =
if !verbose > 0 then
prerr_endline ("New state: "^string_of_int newchapter) ;
365 push stack
(!outname, Stack.save flowname_stack, Stack.save flow_stack,
!chapter,!depth,!toc,!tocname,!cur_level,!lastclosed,!out_prefix) ;
chapter := newchapter ;
depth := newdepth ;
370 tocname := !outname ;
lastclosed := "" ;
toc := !out
;;
375 let restore_state () =
if !verbose > 0 then prerr_endline ("Restore") ;
let
oldoutname, oldflowname, oldflow,
oldchapter,olddepth,oldtoc,oldtocname,
380 oldlevel,oldlastclosed,oldprefix = pop stack in
outname := oldoutname ;
Stack.restore flowname_stack oldflowname ;
Stack.restore flow_stack oldflow ;
chapter := oldchapter ;
385 depth := olddepth ;
toc := oldtoc ;
tocname := oldtocname ;
lastclosed := !lastclosed ;
cur_level := oldlevel ;
390 out_prefix := oldprefix
;;
let hevea_footer = ref false
395 let close_top lxm =
putlinks_end !toc !tocname ;
if !hevea_footer then begin
Out.put !out "<!--FOOTER-->\n" ;
begin try
400 Mysys.put_from_file
(Filename.concat Mylib.libdir ("cutfoot-"^ !language^".html"))
(Out.put !out)
with Mysys.Error s -> begin
Location.print_pos () ;
405 prerr_endline s
end
end
end ;
Out.put !toc lxm ;
410 if !tocname = "" then
Out.flush !toc
else
Out.close !toc
;;
415
let open_toc () = if !phase > 0 then openlist !toc
and close_toc () = if !phase > 0 then closelist !toc
;;
420 let close_all () =
if !cur_level > !chapter then begin
close_section !chapter ;
close_chapter () ;
close_toc ()
425 end else if !cur_level = !chapter then begin
close_chapter () ;
close_toc ()
end ;
cur_level := (Section.value "DOCUMENT")
430
let openflow title =
let new_outname = new_filename () in
push flowname_stack !outname ;
outname := new_outname ;
435 if !phase > 0 then begin
push flow_stack !out ;
out := Out.create_chan (open_out !outname) ;
openhtml false title !out !outname
end
440
and closeflow () =
if !phase > 0 then begin
closehtml false !outname !out;
Out.close !out ;
445 out := pop flow_stack
end ;
outname := pop flowname_stack
450 }
rule main = parse
| "<!--HEVEA" [^'>']* "-->" '\n'?
{let lxm = lexeme lexbuf in
455 if !phase > 0 then begin
put lxm ;
put ("<!--HACHA command line is: ") ;
for i = 0 to Array.length Sys.argv - 1 do
put Sys.argv.(i) ;
460 put_char ' '
done ;
put "-->\n"
end ;
main lexbuf}
465 | "<!--" "FLOW" ' '+
{let title = flowline lexbuf in
openflow title ;
main lexbuf}
| "<!--" "LINKS" ' '+
470 {linkline lexbuf ;
main lexbuf}
| "<!--" "END" ' '+ "FLOW" ' '* "-->" '\n'?
{closeflow () ;
main lexbuf}
475 | "<!--" "NAME" ' '+
{let name = tocline lexbuf in
change_name !outname name ;
main lexbuf}
| "<!--" ("TOC"|"toc") ' '+
480 {let arg = secname lexbuf in
let sn =
if String.uppercase arg = "NOW" then !chapter
else Section.value arg in
let name = tocline lexbuf in
485 if !verbose > 1 then begin
prerr_endline ("TOC "^arg^" "^name)
end;
if sn < !chapter then begin
if !cur_level >= !chapter then begin
490 close_section (!chapter) ;
close_chapter () ;
close_toc ()
end ;
cur_level := sn
495 end else if sn = !chapter then begin
if !cur_level < sn then begin
open_toc () ;
end else begin
close_section !chapter ;
500 close_chapter ()
end ;
open_chapter name
end else if sn <= !chapter + !depth then begin (* sn > !chapter *)
if !cur_level < !chapter then begin
505 open_toc () ;
open_chapter ""
end ;
close_section sn ;
open_section sn name
510 end ;
main lexbuf}
| "<!--CUT DEF" ' '+
{let chapter = Section.value (String.uppercase (secname lexbuf)) in
skip_blanks lexbuf;
515 let depth = intarg lexbuf in
skip_endcom lexbuf ;
save_state chapter depth ;
cur_level := Section.value "DOCUMENT" ;
main lexbuf}
520 | "<!--SEC END" ' '* "-->" '\n'?
{if !phase > 0 then begin
if !tocbis && !out == !out_prefix then
out := Out.create_buff ()
end ;
525 main lexbuf}
| "<!--CUT END" ' '* "-->" '\n'?
{close_all () ;
restore_state () ;
main lexbuf}
530 | "<!--BEGIN" ' '+ "NOTES" ' '+
{let sec_notes = secname lexbuf in
skip_endcom lexbuf ;
open_notes (Section.value sec_notes) ;
main lexbuf}
535 | "<!--END" ' '+ "NOTES" ' '* "-->" '\n'?
{if !otheroutname <> "" then
close_notes ();
main lexbuf}
| "<!--" ' '* "FRENCH" ' '* "-->"
540 {language := "fra" ;
main lexbuf}
| "<A" ' '+
{if !phase > 0 then put (lexeme lexbuf) ;
aargs lexbuf}
545 | "<!--HTML" ' '* "HEAD" ' '* "-->" '\n' ?
{let head = save_html lexbuf in
if !phase = 0 then
html_head := head
else
550 Out.put !out head;
main lexbuf}
| "<!--HTML" ' '* "FOOT" ' '* "-->" '\n' ?
{let foot = save_html lexbuf in
if !phase = 0 then
555 html_foot := foot ;
main lexbuf}
| "<!--FOOTER-->" '\n'?
{close_all () ;
if !phase > 0 then begin
560 hevea_footer := true ;
Out.put !out !html_foot
end ;
footer lexbuf}
| "<!DOCTYPE" [^'>']* '>'
565 {let lxm = lexeme lexbuf in
if !phase = 0 then
doctype := lxm
else
Out.put !out lxm;
570 main lexbuf}
| "<HTML" [^'>']* '>'
{let lxm = lexeme lexbuf in
if !phase = 0 then
html := lxm
575 else
Out.put !out lxm;
main lexbuf}
| "<BODY" [^'>']* '>'
{let lxm = lexeme lexbuf in
580 if !phase = 0 then
body := lxm
else begin
Out.put !out lxm ;
putlinks_start !out !outname
585 end ;
main lexbuf}
| "<HEAD" [^'>']* '>'
{put (lexeme lexbuf);
if !phase = 0 then begin
590 if !verbose > 0 then prerr_endline "Collect header" ;
collect_header lexbuf
end else
main lexbuf}
| "</BODY>"
595 {let lxm = lexeme lexbuf in
close_all () ;
if !phase > 0 then begin
close_top lxm
end}
600 | _
{let lxm = lexeme_char lexbuf 0 in
if !phase > 0 then put_char lxm ;
main lexbuf}
| eof
605 {raise (Error ("No </BODY> tag in input file"))}
and save_html = parse
| "<!--END" ' '* ['A'-'Z']+ ' '* "-->" '\n'?
{let s = Out.to_string html_buff in
610 if !verbose > 0 then
prerr_endline ("save_html -> ``"^s^"''");
s}
| _
{let lxm = lexeme_char lexbuf 0 in
615 Out.put_char html_buff lxm ;
save_html lexbuf}
| eof
{raise (Misc.Fatal ("End of file in save_html"))}
620 and collect_header = parse
| "</HEAD>"
{let lxm = lexeme lexbuf in
finalize_header () ;
if !verbose > 0 then begin
625 prerr_string "Header is: ``" ;
prerr_string !common_headers ;
prerr_endline "''"
end ;
main lexbuf}
630
| "<TITLE" [^'>']* '>'
{skip_title lexbuf ;
collect_header lexbuf}
| _
635 {let lxm = lexeme_char lexbuf 0 in
adjoin_to_header_char lxm;
collect_header lexbuf}
and skip_title = parse
640 | "</TITLE>" '\n'? {()}
| _ {skip_title lexbuf}
and footer = parse
"</BODY>" _*
645 {let lxm = lexeme lexbuf in
if !phase > 0 then begin
close_top lxm
end}
| _ {footer lexbuf}
650 | eof {raise (Misc.Fatal ("End of file in footer (no </BODY> tag)"))}
and secname = parse
['a'-'z' 'A'-'Z']+
{let r = lexeme lexbuf in r}
655 | "" {raise (Error "Bad section name syntax")}
and intarg = parse
['0'-'9']+ {int_of_string (lexeme lexbuf)}
| "" {!depth}
660
and tocline = parse
"-->" '\n' ? {Out.to_string toc_buf}
| _
{Out.put_char toc_buf (lexeme_char lexbuf 0) ;
665 tocline lexbuf}
and arg = parse
| "</ARG>" {Out.to_string arg_buf}
| _ {Out.put_char arg_buf (Lexing.lexeme_char lexbuf 0) ; arg lexbuf}
670 | eof {raise (Misc.Fatal "Unclosed arg")}
and flowline = parse
| "<ARG TITLE>"
{let title = arg lexbuf in
675 let _ = flowline lexbuf in
title}
| "-->" '\n'?
{""}
| eof {raise (Misc.Fatal "Unclosed comment")}
680 | _ {flowline lexbuf}
and linkline = parse
| "<ARG" ' '+ "PREV>"
{let link = arg lexbuf in
685 setlink Thread.setprev link ;
linkline lexbuf}
| "<ARG" ' '+ "NEXT>"
{let link = arg lexbuf in
setlink Thread.setnext link ;
690 linkline lexbuf}
| "<ARG" ' '+ "UP>"
{let link = arg lexbuf in
setlink Thread.setup link ;
linkline lexbuf}
695 | "-->" '\n'?
{()}
| eof {raise (Misc.Fatal "Unclosed comment")}
| _ {linkline lexbuf}
700 and aargs = parse
| ("name"|"NAME") ' '* '=' ' '*
{if !phase = 0 then begin
let name = refname lexbuf in
Cross.add name !outname
705 end else
put (lexeme lexbuf) ;
aargs lexbuf}
| ("href"|"HREF") ' '* '=' ' '*
{if !phase > 0 then begin
710 let lxm = lexeme lexbuf in
let name = refname lexbuf in
try
let newname =
if String.length name > 0 && String.get name 0 = '#' then
715 Cross.fullname !outname (String.sub name 1 (String.length name-1))
else name in
put lxm ;
put "\"" ;
put newname ;
720 put "\""
with Not_found -> ()
end ;
aargs lexbuf}
| '>'
725 {if !phase > 0 then put_char '>' ;
main lexbuf}
| _
{if !phase > 0 then put_char (lexeme_char lexbuf 0) ;
aargs lexbuf}
730 | eof
{raise (Error "Bad <A ...> tag")}
and refname = parse
| '"' [^'"']* '"'
735 {let lxm = lexeme lexbuf in
String.sub lxm 1 (String.length lxm-2)}
| ['a'-'z''A'-'Z''0'-'9''.''_''-']+
{lexeme lexbuf}
| "" {raise (Error "Bad reference name syntax")}
740
and skip_blanks = parse
' '* {()}
and skip_endcom = parse
745 ' '* "-->" '\n'? {()}
| "" {raise (Error "Bad HTML comment syntax")}
and skip_aref = parse
"</A>" {()}
| _ {skip_aref lexbuf}
<6>3 entry.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
{
open Lexing
15 let header = "$Id: entry.mll,v 1.11 1999/12/07 16:12:15 maranget Exp $"
let buff = Out.create_buff ()
;;
20 let put s =
Out.put buff s
and put_char c =
Out.put_char buff c
;;
25
type res =
| Bang of string * string
| Bar of string * string
30 | Eof of string * string
;;
let extend r i = match r with
| Bang (p,_) -> Bang (i,p)
35 | Bar (p,_) -> Bar (i,p)
| Eof (p,_) -> Eof (i,p)
;;
type key = string list * string list
40
exception Fini
exception NoGood
;;
45 }
rule entry = parse
| "\\\""
{put "\\\"" ; entry lexbuf}
| "\"!"
50 {put_char '!' ; entry lexbuf}
| "\"@"
{put_char '@' ; entry lexbuf}
| "\"|"
{put_char '|' ; entry lexbuf}
55 | '!' {Bang (Out.to_string buff,"")}
| '@' {let s = Out.to_string buff in
let r = entry lexbuf in
extend r s}
| '|' {Bar (Out.to_string buff,"")}
60 | eof {Eof (Out.to_string buff,"")}
| _
{let lxm = lexeme_char lexbuf 0 in put_char lxm ; entry lexbuf}
and idx = parse
65 | "\\indexentry"
{let key = Save.arg lexbuf in
let value = Save.arg lexbuf in
key,value}
| eof {raise Fini}
70 | _ {idx lexbuf}
{
75 let read_key lexbuf =
let bar () = match entry lexbuf with
| Eof (s,_) ->
begin match s with
80 | ""|"("|")" -> None
| s ->
if s.[0] = '(' then
Some (String.sub s 1 (String.length s - 1))
else
85 Some s
end
| _ -> raise NoGood in
let rec get_rec () = match entry lexbuf with
90 Bang (i,p) ->
let l,see = get_rec () in
(i,p)::l,see
| Bar (i,p) ->
let see = bar () in
95 [i,p],see
| Eof (i,p) -> [i,p],None in
let separe (l,see) =
let rec sep_rec = function
100 [] -> [],[]
| (x,y)::r ->
let xs,ys = sep_rec r in
x::xs,y::ys in
let xs,ys = sep_rec l in
105 ((xs,ys),see) in
separe (get_rec ())
let read_indexentry lexbuf = idx lexbuf
110 }
<6>4 get.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
{
open Misc
open Parse_opts
15 open Lexing
open Latexmacros
open Lexstate
open Stack
20 (* Compute functions *)
let header = "$Id: get.mll,v 1.24 2001/02/12 10:05:29 maranget Exp $"
exception Error of string
25 let sbool = function
| true -> "true"
| false -> "false"
let get_this = ref (fun s -> assert false)
30 and get_fun = ref (fun f lexbuf -> assert false)
and open_env = ref (fun _ -> ())
and close_env = ref (fun _ -> ())
and get_csname = ref (fun _ -> assert false)
and main = ref (fun _ -> assert false)
35 ;;
let bool_out = ref false
and int_out = ref false
40 let int_stack = Stack.create "int_stack"
and bool_stack = Stack.create "bool_stack"
and group_stack = Stack.create "group_stack"
and just_opened = ref false
45 type saved =
bool * bool Stack.saved *
bool * int Stack.saved *
(unit -> unit) Stack.saved * bool
50 let check () =
!bool_out, Stack.save bool_stack,
!int_out, Stack.save int_stack,
Stack.save group_stack,
!just_opened
55
and hot (b,bs,i,is,gs,j) =
bool_out := b ; Stack.restore bool_stack bs ;
int_out := i ; Stack.restore int_stack is ;
Stack.restore group_stack gs ;
60 just_opened := j
let push_int x =
if !verbose > 2 then
prerr_endline ("PUSH INT: "^string_of_int x) ;
65 just_opened := false ;
push int_stack x
let open_ngroups n =
let rec open_ngroups_rec = function
70 | 0 ->()
| n -> push group_stack (fun () -> ()) ; open_ngroups_rec (n-1) in
if !verbose > 2 then
prerr_endline ("OPEN NGROUPS: "^string_of_int n) ;
if n > 0 then begin
75 just_opened := true ;
open_ngroups_rec n
end
let close_ngroups n =
80 let rec close_ngroups_rec = function
| 0 -> ()
| n ->
let f = pop group_stack in
f() ; close_ngroups_rec (n-1) in
85 if !verbose > 2 then
prerr_endline ("CLOSE NGROUPS: "^string_of_int n);
close_ngroups_rec n
let open_aftergroup f s =
90 if !verbose > 2 then
prerr_endline ("OPEN AFTER: "^s) ;
just_opened := true ;
push group_stack f
95 }
let command_name =
'\\' ((['@''A'-'Z' 'a'-'z']+ '*'?) | [^ '@' 'A'-'Z' 'a'-'z'])
rule result = parse
100 (* Skip comments and spaces *)
| '%' [^ '\n'] * '\n' {result lexbuf}
| [' ' '\n']+ {result lexbuf}
(* Integers *)
| ['0'-'9']+
105 {let lxm = Lexing.lexeme lexbuf in
push_int (int_of_string lxm) ;
result lexbuf}
| '\'' ['0'-'7']+
{let lxm = lexeme lexbuf in
110 push_int
(int_of_string ("0o"^String.sub lxm 1 (String.length lxm-1))) ;
result lexbuf}
| "\"" ['0'-'9' 'a'-'f' 'A'-'F']+
{let lxm = lexeme lexbuf in
115 push_int
(int_of_string ("0x"^String.sub lxm 1 (String.length lxm-1))) ;
result lexbuf}
| '`'
{let token = !get_csname lexbuf in
120 after_quote (Lexing.from_string token) ;
result lexbuf}
| "true"
{push bool_stack true ;
result lexbuf}
125 | "false"
{push bool_stack false ;
result lexbuf}
(* Operands *)
| '+' | '-'
130 {let lxm = lexeme_char lexbuf 0 in
let unary = !just_opened in
if unary then begin
let f = pop group_stack in
open_aftergroup
135 (fun () ->
if !verbose > 2 then begin
prerr_endline ("UNARY: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
end ;
140 let x1 = pop int_stack in
let r = match lxm with
| '+' -> x1
| '-' -> 0 - x1
| _ -> assert false in
145 push_int r ; f()) "UNARY"
end else begin
close_ngroups 2 ;
open_aftergroup
(fun () ->
150 if !verbose > 2 then begin
prerr_endline ("OPPADD: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
end ;
let x2 = pop int_stack in
155 let x1 = pop int_stack in
let r = match lxm with
| '+' -> x1 + x2
| '-' -> x1 - x2
| _ -> assert false in
160 push_int r) "ADD";
open_ngroups 1 ;
end ;
result lexbuf}
| '/' | '*'
165 {let lxm = lexeme_char lexbuf 0 in
close_ngroups 1 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
170 prerr_endline ("MULTOP"^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
end ;
let x2 = pop int_stack in
let x1 = pop int_stack in
175 let r = match lxm with
| '*' -> x1 * x2
| '/' -> x1 / x2
| _ -> assert false in
push_int r) "MULT";
180 result lexbuf}
(* boolean openrands *)
| '<' | '>' | '='
{let lxm = Lexing.lexeme_char lexbuf 0 in
close_ngroups 3 ;
185 open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline ("COMP: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
190 end ;
let x2 = pop int_stack in
let x1 = pop int_stack in
push bool_stack
(match lxm with
195 | '<' -> x1 < x2
| '>' -> x1 > x2
| '=' -> x1 = x2
| _ -> assert false) ;
if !verbose > 2 then
200 Stack.pretty sbool bool_stack) "COMP" ;
open_ngroups 2 ;
result lexbuf}
(* Parenthesis for integer computing *)
205 | '('|'{'
{open_ngroups 2 ;
result lexbuf}
| ')'|'}'
{close_ngroups 2 ;
210 result lexbuf}
(* Commands *)
| '#' ['1'-'9']
{let lxm = lexeme lexbuf in
let i = Char.code (lxm.[1]) - Char.code '1' in
215 scan_arg (scan_this_arg result) i ;
result lexbuf}
| command_name
{let lxm = lexeme lexbuf in
let pat,body = Latexmacros.find lxm in
220 let args = make_stack lxm pat lexbuf in
scan_body
(function
| Subst body -> scan_this result body
| Toks l ->
225 List.iter
(scan_this result)
(List.rev l)
| CamlCode f ->
let rs = !get_fun f lexbuf in
230 scan_this result rs)
body args ;
result lexbuf}
| _ {raise (Error ("Bad character in Get.result: ``"^lexeme lexbuf^"''"))}
| eof {()}
235
and after_quote = parse
| '\\' [^ 'A'-'Z' 'a'-'z'] eof
{let lxm = lexeme lexbuf in
push_int (Char.code lxm.[1]);
240 result lexbuf}
| _ eof
{let lxm = lexeme lexbuf in
push_int (Char.code lxm.[0]);
result lexbuf}
245 | ""
{Misc.fatal "Cannot understand `-like numerical argument"}
{
let init latexget latexgetfun latexopenenv latexcloseenv latexcsname
latexmain =
250 get_this := latexget ;
get_fun := latexgetfun ;
open_env := latexopenenv ;
close_env := latexcloseenv ;
get_csname := latexcsname ;
255 main := latexmain
;;
let def_loc name f =
Latexmacros.def name zero_pat (CamlCode f) ;
260 ;;
let def_commands l =
List.map
(fun (name,f) ->
265 name,Latexmacros.replace name (Some (zero_pat,CamlCode f)))
l
let def_commands_int () =
def_commands
270 ["\\value",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
push_int (Counter.value_counter name)) ;
"\\pushint",
275 (fun lexbuf ->
let s = !get_this (save_arg lexbuf) in
scan_this result s)]
let def_commands_bool () =
280 let old_ints = def_commands_int () in
let old_commands =
def_commands
["\\(", (fun _ -> open_ngroups 7) ;
"\\)", (fun _ -> close_ngroups 7) ;
285 "\\@fileexists",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
push bool_stack
(try
290 let _ = Myfiles.open_tex name in
true
with Myfiles.Except | Myfiles.Error _ -> false)) ;
"\\@commandexists",
(fun lexbuf ->
295 let name = !get_csname lexbuf in
push bool_stack (Latexmacros.exists name)) ;
"\\or",
(fun _ ->
close_ngroups 7 ;
300 open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline "OR" ;
Stack.pretty sbool bool_stack
305 end ;
let b1 = pop bool_stack in
let b2 = pop bool_stack in
push bool_stack (b1 || b2)) "OR";
open_ngroups 6) ;
310 "\\and",
(fun _ ->
close_ngroups 6 ;
open_aftergroup
(fun () ->
315 if !verbose > 2 then begin
prerr_endline "AND" ;
Stack.pretty sbool bool_stack
end ;
let b1 = pop bool_stack in
320 let b2 = pop bool_stack in
push bool_stack (b1 && b2)) "AND";
open_ngroups 5) ;
"\\not",
(fun _ ->
325 close_ngroups 4 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline "NOT" ;
330 Stack.pretty sbool bool_stack
end ;
let b1 = pop bool_stack in
push bool_stack (not b1)) "NOT";
open_ngroups 3) ;
335 "\\boolean",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
let b = try
let r = !get_this
340 (string_to_arg ("\\if"^name^" true\\else false\\fi")) in
match r with
| "true" -> true
| "false" -> false
| _ -> raise (Misc.Fatal ("boolean value: "^r))
345 with
Latexmacros.Failed -> true in
push bool_stack b) ;
"\\isodd",
(fun lexbuf ->
350 close_ngroups 3 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline ("ISODD") ;
355 Stack.pretty string_of_int int_stack
end ;
let x = pop int_stack in
push bool_stack (x mod 2 = 1) ;
if !verbose > 2 then
360 Stack.pretty sbool bool_stack) "ISODD" ;
open_ngroups 2) ] in
let old_equal =
try Some (Latexmacros.find_fail "\\equal") with Failed -> None in
365 def_loc "\\equal"
(fun lexbuf ->
let arg1 = save_arg lexbuf in
let arg2 = save_arg lexbuf in
scan_this !main "\\begin{@norefs}" ;
370 let again = List.map (fun (name,x) -> name,Latexmacros.replace name x)
((("\\equal",old_equal)::old_ints)@old_commands) in
push bool_stack (!get_this arg1 = !get_this arg2) ;
let _ =
List.map (fun (name,x) -> Latexmacros.replace name x) again in
375 scan_this !main "\\end{@norefs}")
let first_try s =
380 let l = String.length s in
if l <= 0 then raise (Failure "first_try") ;
let rec try_rec r i =
if i >= l then r
else match s.[i] with
385 | '0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9' ->
try_rec (10*r + Char.code s.[i] - Char.code '0') (i+1)
| _ -> raise (Failure ("first_try")) in
try_rec 0 0
;;
390
let get_int {arg=expr ; subst=subst} =
if !verbose > 1 then
prerr_endline ("get_int : "^expr) ;
let r =
395 try first_try expr with Failure _ -> begin
let old_int = !int_out in
int_out := true ;
start_normal subst ;
!open_env "*int*" ;
400 let _ = def_commands_int () in
open_ngroups 2 ;
begin try scan_this result expr with
| x ->
begin
405 prerr_endline
("Error while scanning ``"^expr^"'' for integer result");
raise x
end
end ;
410 close_ngroups 2 ;
!close_env "*int*" ;
end_normal () ;
if Stack.empty int_stack then
raise (Error ("``"^expr^"'' has no value as an integer"));
415 let r = pop int_stack in
int_out := old_int ;
r end in
if !verbose > 1 then
prerr_endline ("get_int: "^expr^" = "^string_of_int r) ;
420 r
let get_bool {arg=expr ; subst=subst} =
if !verbose > 1 then
425 prerr_endline ("get_bool : "^expr) ;
let old_bool = !bool_out in
bool_out := true ;
start_normal subst ;
!open_env "*bool*" ;
430 def_commands_bool () ;
open_ngroups 7 ;
begin try scan_this result expr with
| x ->
begin
435 prerr_endline
("Error while scanning ``"^expr^"'' for boolean result");
raise x
end
end ;
440 close_ngroups 7 ;
!close_env "*bool*" ;
end_normal () ;
if Stack.empty bool_stack then
raise (Error ("``"^expr^"'' has no value as a boolean"));
445 let r = pop bool_stack in
if !verbose > 1 then
prerr_endline ("get_bool: "^expr^" = "^sbool r);
bool_out := old_bool ;
r
450
let get_length arg =
if !verbose > 1 then
prerr_endline ("get_length : "^arg) ;
let r = Length.main (Lexing.from_string arg) in
455 if !verbose > 2 then begin
prerr_string ("get_length : "^arg^" -> ") ;
prerr_endline (Length.pretty r)
end ;
r
460 }
<6>5 htmllex.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: htmllex.mll,v 1.9 2001/05/29 15:09:22 maranget Exp $ *)
(***********************************************************************)
{
open Lexing
open Lexeme
15 open Buff
let txt_level = ref 0
and txt_stack = Stack.create "htmllex"
20 exception Error of string
;;
let error msg lb =
25 raise (Error msg)
let init table (s,t)= Hashtbl.add table s t
;;
30
let block = Hashtbl.create 17
;;
List.iter (init block)
35 ["CENTER", () ; "DIV", (); "BLOCKQUOTE", () ;
"H1", () ; "H2", () ;"H3", () ;"H4", () ;"H5", () ;"H6", () ;
"PRE", () ; "TABLE", () ; "TR",() ; "TD", () ; "TH",() ;
"OL",() ; "UL",(); "P",() ; "LI",() ;
"DL",() ; "DT", () ; "DD",() ;
40 ]
;;
let ptop () =
if not (Stack.empty txt_stack) then begin
45 let pos = Stack.top txt_stack in
Location.print_this_fullpos pos ;
prerr_endline "This opening tag is pending"
end
50 let warnings = ref true
let check_nesting lb name =
try
Hashtbl.find block (String.uppercase name) ;
55 if !txt_level <> 0 && !warnings then begin
Location.print_fullpos () ;
prerr_endline
("Warning, block level element: "^name^" nested inside text-level element") ;
ptop ()
60 end
with
| Not_found -> ()
let text = Hashtbl.create 17
65 ;;
List.iter (init text)
["TT",TT ; "I",I ; "B",B ; "BIG",BIG ; "SMALL",SMALL ;
70 "STRIKE",STRIKE ; "S",S ; "U",U ; "FONT",FONT ;
"EM",EM ; "STRONG",STRONG ; "DFN",DFN ; "CODE",CODE ; "SAMP",SAMP ;
"KBD",KBD ; "VAR",VAR ; "CITE",CITE ; "ABBR",ABBR ; "ACRONYM",ACRONYM ;
"Q",Q ; "SUB",SUB ; "SUP",SUP ; "A", A ; "SPAN", SPAN ; "SCRIPT", SCRIPT]
;;
75
let is_textlevel name =
try
let _ = Hashtbl.find text (String.uppercase name) in
true
80 with
| Not_found -> false
let is_br name = "BR" = (String.uppercase name)
let is_basefont name = "BASEFONT" = (String.uppercase name)
85
let set_basefont attrs lb =
List.iter
(fun (name,v,_) -> match String.uppercase name,v with
| "SIZE",Some s ->
90 begin try
Emisc.basefont := int_of_string s
with
| _ -> error "BASEFONT syntax" lb
end
95 | _ -> ())
attrs
let get_value lb = function
| Some s -> s
100 | _ -> error "Bad attribute syntax" lb
let norm_attrs lb attrs =
List.map
(fun (name,value,txt) ->
105 match String.uppercase name with
| "SIZE" -> SIZE (get_value lb value),txt
| "COLOR" -> COLOR (get_value lb value),txt
| "FACE" -> FACE (get_value lb value),txt
| _ -> OTHER, txt)
110 attrs
let print_attrs s attrs =
print_string s ; print_string ":" ;
List.iter
115 (fun x -> match x with
| name,Some value when name=s ->
print_char ' ' ;
print_string value
| _ -> ())
120 attrs ;
print_char '\n'
let ouvre lb name attrs txt =
let uname = String.uppercase name in
125 try
let tag = Hashtbl.find text uname in
let attrs = norm_attrs lb attrs in
incr txt_level ;
Stack.push txt_stack (Location.get_pos ()) ;
130 Open (tag, attrs,txt)
with
| Not_found -> assert false
and ferme lb name txt =
135 try
let tag = Hashtbl.find text (String.uppercase name) in
decr txt_level ;
begin if not (Stack.empty txt_stack) then
let _ = Stack.pop txt_stack in ()
140 end ;
Close (tag,txt)
with
| Not_found -> Text txt
145
let unquote s =
150 let l = String.length s in
String.sub s 1 (l-2)
;;
let buff = Buff.create ()
155 and abuff = Buff.create ()
let put s = Buff.put buff s
and putc c = Buff.put_char buff c
160 let aput s = Buff.put abuff s
and aputc c = Buff.put_char abuff c
165 }
let blank = [' ''\t''\n''\r']
170 rule main = parse
| (blank|" ")+ {Blanks (lexeme lexbuf)}
| "<!--"
{put (lexeme lexbuf) ;
in_comment lexbuf ;
175 Text (Buff.to_string buff)}
| "<!"
{put (lexeme lexbuf) ;
in_tag lexbuf ;
Text (Buff.to_string buff)}
180 | '<'
{putc '<' ;
let tag = read_tag lexbuf in
if is_textlevel tag then begin
let attrs = read_attrs lexbuf in
185 ouvre lexbuf tag attrs (Buff.to_string buff)
end else if is_basefont tag then begin
let attrs = read_attrs lexbuf in
set_basefont attrs lexbuf ;
Text (Buff.to_string buff)
190 end else begin
check_nesting lexbuf tag ;
in_tag lexbuf ;
let txt = Buff.to_string buff in
if is_br tag then
195 Blanks txt
else
Text txt
end}
| "</"
200 {put "</" ;
let tag = read_tag lexbuf in
in_tag lexbuf ;
ferme lexbuf tag (Buff.to_string buff)}
| eof {Eof}
205 | _
{putc (lexeme_char lexbuf 0) ;
text lexbuf ;
Text (Buff.to_string buff)}
210 and text = parse
| [^'<']
{putc (lexeme_char lexbuf 0) ; text lexbuf}
| "" {()}
215 and read_tag = parse
| ['a'-'z''A'-'Z''0'-'9']*
{let lxm = lexeme lexbuf in
put lxm ; lxm}
220 and read_attrs = parse
| blank+
{aput (lexeme lexbuf) ; read_attrs lexbuf}
| ['a'-'z''A'-'Z''-''0'-'9']+
{let name = lexeme lexbuf in
225 aput name ;
let v = read_avalue lexbuf in
let atxt = Buff.to_string abuff in
put atxt ;
(name,v,atxt)::read_attrs lexbuf}
230 | '>' {put_char buff '>' ; []}
| "" {error "Attribute syntax" lexbuf}
and read_avalue = parse
| blank* '=' blank*
235 {let lxm = lexeme lexbuf in
aput lxm ;
Some (read_aavalue lexbuf)}
| "" {None}
240 and read_aavalue = parse
| '\''[^'\'']*'\''
| '"'[^'"']*'"'
{let lxm = lexeme lexbuf in
aput lxm ;
245 unquote lxm}
| '#'?['a'-'z''A'-'Z''0'-'9''-''+''_'':''.']+
{let lxm = lexeme lexbuf in
aput lxm ;
lxm}
250 | "" {error "Attribute syntax" lexbuf}
and in_tag = parse
| '>' {putc (lexeme_char lexbuf 0)}
| _ {putc (lexeme_char lexbuf 0) ; in_tag lexbuf}
255 | eof {error "End of file in tag" lexbuf}
and in_comment = parse
| "-->" '\n'?
{put (lexeme lexbuf)}
260 | _
{putc (lexeme_char lexbuf 0) ; in_comment lexbuf}
| eof
{error "End of file in comment" lexbuf}
265 {
let to_string = function
| Open (_,_,txt) | Close (_,txt) | Text txt | Blanks txt -> txt
| Eof -> "Eof"
270
let rec cost = function
| {tag=FONT ; attrs=attrs} -> (1,List.length attrs)
| _ -> (1,0)
275 let tok_buff = ref None
;;
let txt_buff = Buff.create ()
;;
280
let rec read_tokens blanks lb =
let t = main lb in
match t with
| Text txt -> Buff.put txt_buff txt ; read_tokens false lb
285 | Blanks txt -> Buff.put txt_buff txt ; read_tokens blanks lb
| _ ->
let txt = Buff.to_string txt_buff in
match txt with
| "" -> t
290 | _ ->
tok_buff := Some t ;
if blanks then
Blanks txt
else
295 Text txt
let reset () =
txt_level := 0 ;
Stack.reset txt_stack ;
300 Buff.reset txt_buff ;
Buff.reset buff ;
Buff.reset abuff
let next_token lb =
305 try match !tok_buff with
| Some t -> tok_buff := None ; t
| None -> read_tokens true lb
with
| e ->
310 reset () ;
raise e
}
<6>6 infoRef.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
{
let header = "$Id: infoRef.mll,v 1.22 2001/05/25 09:07:15 maranget Exp $"
;;
15
open Lexing
open Misc
20 let compat_mem tbl key =
try let _ = Hashtbl.find tbl key in true with Not_found -> false
;;
25 exception Error of string
type node_t = {
mutable name : string;
mutable comment : string;
30 mutable previous : node_t option;
mutable next : node_t option;
mutable up : node_t option;
mutable pos : int;
}
35 ;;
type menu_t = {
mutable num : int;
mutable nom : string;
40 mutable nod : node_t option;
mutable nodes : node_t list;
}
;;
45
let menu_list = ref [];;
let nodes = Hashtbl.create 17;;
let delayed = ref [];;
50 let current_node = ref None;;
let menu_num = ref 0
;;
55 let counter = ref 0
and pos_file = ref 0
;;
let abs_pos () = !counter + !pos_file
60 ;;
let cur_file = ref (Parse_opts.name_out)
;;
65
let file_number = ref 1
;;
type label_t = {
70 mutable lab_name : string;
mutable noeud : node_t option;
};;
let labels_list = ref [];;
75
let files = ref [];;
let top_node = ref false;;
let hot_start () =
80 menu_list := [];
Hashtbl.clear nodes ;
current_node := None ;
menu_num := 0 ;
counter := 0 ;
85 pos_file := 0 ;
cur_file := Parse_opts.name_out ;
files := [] ;
top_node := false ;
file_number := 1 ;
90 labels_list := []
;;
let infomenu arg =
menu_num:=!menu_num+1;
95 menu_list := {
num = !menu_num;
nom = arg;
nod = !current_node;
nodes = [];
100 } ::!menu_list;
Text.open_block "INFOLINE" "";
Text.put ("\\@menu"^string_of_int !menu_num^"\n");
Text.close_block "INFOLINE"
;;
105
let rec cherche_menu m = function
| [] -> raise (Error ("Menu ``"^m^"'' not found"))
| menu::r ->
if menu.nom = m then menu
110 else cherche_menu m r
;;
let rec cherche_menu_par_num n = function
| [] -> raise (Error ("Menu not found"))
115 | menu::r ->
if menu.num = n then menu
else cherche_menu_par_num n r
;;
120 let ajoute_node_dans_menu n m =
try
let menu = cherche_menu m !menu_list in
menu.nodes <- n :: menu.nodes;
menu.nod
125 with _ -> None
;;
let verifie name =
130 let nom = String.copy name in
for i = 0 to String.length name -1 do
match nom.[i] with
| '\t' -> nom.[i] <- ' '
| ',' -> nom.[i] <- ' '
135 | '.' -> nom.[i] <- '-'
| '\n' -> nom.[i] <- ' '
| _ -> ()
done;
nom
140 ;;
145 (* References *)
let rec cherche_label s = function
| [] -> raise Not_found
| l::r -> if l.lab_name=s then l.noeud else cherche_label s r
150 ;;
let rec change_label s = function
| [] -> Misc.warning ("Cannot change label: ``"^s^"''")
| l::r ->
155 if l.lab_name = s then
l.noeud <- !current_node
else
change_label s r
160 let loc_name s1 = (* pose un label *)
let _ =
try
let _ = cherche_label s1 !labels_list in
Misc.warning ("Multiple use of label: "^s1)
165 with Not_found -> ()
in
let l = {
lab_name = s1;
170 noeud = !current_node ;
} in
labels_list := l:: !labels_list;
Text.open_block "INFO" "" ;
175 Text.put "\\@name{" ;
Text.put s1 ;
Text.put "}" ;
Text.close_block "INFO" ;
if !verbose > 1 then prerr_endline ("InfoRef.loc_name, label="^s1);
180 ;;
(* Sortie du fichier final *)
185
let out_cur = ref (Out.create_null ())
;;
let set_out chan =
190 if !verbose >3 then prerr_endline "Set_out";
out_cur := chan
;;
let set_out_file s =
195 if !verbose >3 then prerr_endline ("Set_out_file :"^s);
cur_file := s
;;
let put s =
200 if !verbose >3 then
prerr_endline ("put :"^s);
counter:=!counter + String.length s;
Out.put !out_cur s
;;
205
let put_char c =
if !verbose >3 then
prerr_endline ("put_char :"^String.make 1 c);
counter:=!counter +1;
210 Out.put_char !out_cur c
;;
let put_credits () =
put "\n\n-------------------------------------\nThis file has been translated from LaTeX by HeVeA.\n\n";
215
and put_header () =
put "This file has been translated from LaTeX by HeVeA.\n"
;;
220 let next_file () =
Out.close !out_cur ;
file_number := !file_number +1;
cur_file := Parse_opts.name_out ^ "-" ^ string_of_int !file_number ;
if !verbose > 0 then
225 prerr_endline ("Change file to "^ !cur_file) ;
set_out (Out.create_chan (open_out !cur_file)) ;
files := (!cur_file,abs_pos ()) :: !files ;
pos_file := abs_pos () ;
put_header () ;
230 counter := 0
;;
235
let noeud_name n = n.name
;;
240
let affiche_menu num =
let menu = cherche_menu_par_num num !menu_list in
if menu.nodes <> [] then begin
put "* Menu:\n\n";
245 let rec affiche_items = function
| [] -> ()
| n::reste ->
put ("* "^noeud_name n^"::\t"^n.comment^"\n");
affiche_items reste;
250 in
affiche_items (List.rev menu.nodes);
if !verbose >1 then
prerr_endline ("Menu :"^menu.nom);
end
255 ;;
let do_affiche_tag_table s =
put ("\n\nTag table:\n"^(if s<> "" then s^"\n" else "")) ;
260 Hashtbl.iter
(fun nom n ->
put ("Node: "^noeud_name n^""^string_of_int n.pos^"\n")) nodes;
put "\nEnd tag table\n";
;;
265
let affiche_tag_table ()=
match !files with
| [_] ->
270 do_affiche_tag_table ""
| _ ->
let rec do_indirect = function
| [] -> ()
| (f,p)::reste ->
275 put (f^": "^string_of_int p^"\n");
do_indirect reste
in
Out.close !out_cur ;
set_out (Out.create_chan (open_out Parse_opts.name_out)) ;
280 put_header () ;
put "\nIndirect:\n";
do_indirect (List.rev !files);
do_affiche_tag_table "(Indirect)"
;;
285
let affiche_node nom =
if !top_node then begin
put_credits () ;
290 top_node := false
end ;
let noeud =
try Hashtbl.find nodes nom
with Not_found -> raise (Error ("Node not found :"^nom))
295 in
if not Parse_opts.filter && !counter > 50000 then begin
next_file ()
end;
noeud.pos <- abs_pos ();
300 put "\n";
put ("Node: "^noeud_name noeud);
(match noeud.next with
| None -> ()
| Some n -> put (",\tNext: "^noeud_name n));
305 (match noeud.previous with
| None -> ()
| Some n -> put (",\tPrev: "^noeud_name n));
(match noeud.up with
| None ->
310 if noeud.name = "Top" then begin
put ",\tUp: (dir)." ;
top_node := true
end
| Some n -> put (",\tUp: "^noeud_name n));
315 put_char '\n';
if !verbose >1 then
prerr_endline ("Node : "^noeud_name noeud);
;;
320
let affiche_ref key =
try
let l = cherche_label key !labels_list in
match l with
325 | None -> ()
| Some node -> put ("*Note "^noeud_name node^"::")
with
| Not_found -> () (* A warning has already been given *)
;;
330
let footNote_label = ref ""
;;
}
335
rule main = parse
| "\\@menu"
{
340 let num = numero lexbuf in
affiche_menu num;
main lexbuf}
| "\\@node"
{
345 let nom = finitLigne lexbuf in
affiche_node nom;
main lexbuf}
| "\\@reference{"
{
350 let key = arg lexbuf in
affiche_ref key;
main lexbuf}
| "\\@name{"
{let _ = arg lexbuf in
355 main lexbuf}
| eof
{affiche_tag_table ()}
| _
360 {let lxm = lexeme_char lexbuf 0 in
put_char lxm;
main lexbuf}
and numero = parse
365 ['0'-'9']+
{let lxm = lexeme lexbuf in
int_of_string lxm}
| _ {raise (Error "Syntax error in info temp file")}
370 and finitLigne = parse
[^'\n']+'\n'
{let lxm = lexeme lexbuf in
String.sub lxm 0 ((String.length lxm) -1)}
| _ {raise ( Error "Syntax error in info temp file: no node name.")}
375
and arg = parse
[^'}']+'}'
{let lxm= lexeme lexbuf in
String.sub lxm 0 ((String.length lxm) -1)}
380 | _ {raise (Error "Syntax error in info temporary file: invalid reference.")}
and labels = parse
| "\\@name{"
{let key = arg lexbuf in
385 key::labels lexbuf}
| _ {labels lexbuf}
| eof {[]}
390 {
let do_infonode opt num arg =
let n = {
name = verifie num;
395 comment = arg;
previous = None;
next = None;
up = None;
pos = 0;
400 } in
if compat_mem nodes n.name then
raise (Error ("Duplicate node name: "^n.name));
n.up <- (match opt with
"" -> None
405 | m -> ajoute_node_dans_menu n m);
Hashtbl.add nodes n.name n;
Text.open_block "INFOLINE" "";
Text.put ("\\@node"^n.name^"\n");
Text.close_block "INFOLINE";
410 current_node := Some n;
if !verbose>1 then prerr_endline ("Node added :"^n.name^", "^n.comment)
let infoextranode num nom text =
delayed := (num,nom,text) :: !delayed
415
and flushextranodes () =
let rec flush_rec = function
| [] -> ()
| (num,nom,text) :: rest ->
420 do_infonode "" num nom ;
Text.open_block "INFO" "" ;
Text.put text ;
Text.close_block "INFO" ;
let labs = labels (Lexing.from_string text) in
425 List.iter (fun lab -> change_label lab !labels_list) labs ;
flush_rec rest in
flush_rec !delayed ;
delayed := []
;;
430
let infonode opt num arg =
flushextranodes () ;
do_infonode opt num arg
435
(* finalisation des liens entre les noeuds *)
let rec do_finalize_nodes suivant = function
| [] -> ()
| n::reste ->
440 if !verbose>2 then prerr_endline ("node :"^n.name);
n.next <- suivant;
(match suivant with
| None -> ()
| Some suiv -> suiv.previous <- Some n );
445 do_finalize_nodes (Some n) reste
;;
let rec do_finalize_menus = function
| [] -> ()
450 | m::reste ->
if m.nodes <> [] then begin
do_finalize_nodes
(match m.nod with
None -> None
455 | Some n -> n.next)
m.nodes;
(match m.nod with
None -> ()
| Some n ->
460 let first_node = List.hd (List.rev m.nodes) in
n.next <- Some first_node;
first_node.previous <- Some n;
(* On descend dans l'arborescence des menus *)
let last_node = List.hd m.nodes in
465 (match last_node.next with
| None -> ()
| Some suiv -> suiv.previous <- Some n);
(* On remonte les menus au meme niveau *)
);
470 do_finalize_menus reste;
end
;;
let finalize_nodes () =
475 if !verbose>2 then prerr_endline "finalizing nodes";
flushextranodes () ;
do_finalize_menus (List.rev !menu_list);
if !verbose>2 then prerr_endline "finalizing done.";
;;
480
let dump buff =
let name,out_chan = match Parse_opts.name_out with
| "" -> "", Out.create_chan stdout
| s ->
485 let name = s^"-1" in
name, Out.create_chan (open_out name) in
if !verbose > 0 then
prerr_endline ("Final dump in "^name) ;
set_out out_chan ;
490 set_out_file name ;
put_header () ;
files := [name,abs_pos ()] ;
main buff ;
Out.close !out_cur ;
495 if !file_number = 1 then
Mysys.rename !cur_file Parse_opts.name_out
}
<6>7 latexscan.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
(* $Id: latexscan.mll,v 1.212 2001/06/06 16:52:47 maranget Exp $ *)
15 {
module type S =
sig
(* external entry points *)
val no_prelude : unit -> unit
20 val main : Lexing.lexbuf -> unit
val print_env_pos : unit -> unit
(* additional resources needed for extension modules. *)
val cur_env : string ref
25 val new_env : string -> unit
val close_env : string -> unit
val echo_toimage : unit -> bool
val echo_global_toimage : unit -> bool
30 val fun_register : (unit -> unit) -> unit
val newif_ref : string -> bool ref -> unit
val top_open_block : string -> string -> unit
val top_close_block : string -> unit
val check_alltt_skip : Lexing.lexbuf -> unit
35 val skip_pop : Lexing.lexbuf -> unit
(* ``def'' functions for initialisation only *)
val def_code : string -> (Lexing.lexbuf -> unit) -> unit
val def_name_code : string -> (string -> Lexing.lexbuf -> unit) -> unit
val def_fun : string -> (string -> string) -> unit
40 val get_this_main : string -> string
val check_this_main : string -> bool
val get_prim : string -> string
val get_prim_arg : Lexing.lexbuf -> string
val get_prim_opt : string -> Lexing.lexbuf -> string
45 val get_csname : Lexing.lexbuf -> string
end
module Make
(Dest : OutManager.S) (Image : ImageManager.S) =
50 struct
open Misc
open Parse_opts
open Element
open Lexing
55 open Myfiles
open Latexmacros
open Save
open Tabular
open Lexstate
60 open Stack
open Subst
let sbool = function
| false -> "false"
65 | true -> "true"
let last_letter name =
70 let c = String.get name (String.length name-1) in
('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
;;
let top_par n =
75 if not (!display || !in_math) then Dest.par n
;;
let if_level = ref 0
;;
80
let cur_env = ref ""
and after = ref []
and stack_env = Stack.create "stack_env"
;;
85
let echo_toimage () = get_level () = 0 && top_level ()
and echo_global_toimage () = top_level ()
let stack_env_pretty () = Stack.pretty (fun (x,_,_) -> x) stack_env
90
let fun_register f =
if get_level () > 0 then after := f :: !after
;;
95
let inc_size i =
let n = Dest.get_fontsize () in
let new_size =
if n+i <= 1 then 1
100 else if n+i >= 7 then 7
else n+i in
Dest.open_mod (Font new_size)
;;
105 let big_size () = Dest.open_mod (Font 7)
;;
(* Horizontal display *)
110 let top_open_display () =
if !display then begin
if !verbose > 1 then
prerr_endline "open display" ;
Dest.open_display ()
115 end
and top_item_display () =
if !display then begin
Dest.item_display ()
120 end
;;
let top_close_display () =
if !display then begin
125 Dest.close_display ()
end
(* Latex environment stuff *)
130
let print_env_pos () =
let _,_,pos = Stack.pop stack_env in
Location.print_this_pos pos ;
prerr_endline ("Latex environment ``"^ !cur_env^"'' is pending")
135 ;;
let new_env env =
Latexmacros.open_group () ;
push stack_env (!cur_env, !after, Location.get_pos ()) ;
140 cur_env := env ;
after := [] ;
if !verbose > 1 then begin
Location.print_pos () ;
Printf.fprintf stderr "Begin : %s <%d>" env (get_level ());
145 prerr_endline ""
end
let error_env close_e open_e =
raise
150 (Misc.Close
("Latex env error: ``"^close_e^"'' closes ``"^open_e^"''"))
let close_env env =
if !verbose > 1 then begin
155 Printf.fprintf stderr "End: %s <%d>" env (get_level ());
prerr_endline ""
end ;
if env = !cur_env then begin
let e,a,_ = pop stack_env in
160 List.iter (fun f -> f ()) !after ;
cur_env := e ;
after := a ;
Latexmacros.close_group ()
end else
165 error_env env !cur_env
;;
let env_check () = !cur_env, !after, Stack.save stack_env
and env_hot (e,a,s) =
170 cur_env := e ;
after := a ;
Stack.restore stack_env s
175 (* Top functions for blocks *)
type array_type = {math : bool ; border : bool}
type in_table = Table of array_type | NoTable | Tabbing
;;
180
let cur_format = ref [||]
and stack_format = Stack.create "stack_format"
and cur_col = ref 0
and stack_col = Stack.create "stack_col"
185 and in_table = ref NoTable
and stack_table = Stack.create_init "stack_table" NoTable
and first_col = ref false
and first_border = ref false
and stack_first = Stack.create "stack_first"
190 and stack_first_b = Stack.create "stack_first_b"
and in_multi = ref false
and stack_multi_flag = Stack.create "stack_multi_flag"
and stack_multi = Stack.create "stack_multi"
;;
195
let pretty_array_type = function
| Table {math = m ; border = b} ->
"Table math="^(if m then "+" else "-")^
200 " border="^(if b then "+" else "-")
| NoTable -> "NoTable"
| Tabbing -> "Tabbing"
let prerr_array_state () =
205 prerr_endline (pretty_array_type !in_table) ;
prerr_string " format:";
pretty_formats !cur_format ;
prerr_endline "" ;
prerr_endline (" cur_col="^string_of_int !cur_col) ;
210 prerr_endline (" first_col="^
(if !first_col then "true" else "false"))
;;
let save_array_state () =
215 push stack_format !cur_format ;
push stack_col !cur_col ;
push stack_table !in_table ;
push stack_first !first_col;
push stack_first_b !first_border;
220 push stack_multi_flag !in_multi ;
in_multi := false ;
if !verbose > 1 then begin
prerr_endline "Save array state:" ;
prerr_array_state ()
225 end
and restore_array_state () =
in_table := pop stack_table ;
cur_col := pop stack_col ;
230 cur_format := pop stack_format ;
first_col := pop stack_first ;
first_border := pop stack_first_b;
in_multi := pop stack_multi_flag ;
if !verbose > 1 then begin
235 prerr_endline "Restore array state:" ;
prerr_array_state ()
end
;;
240 let top_open_block block args =
if !verbose > 2 then prerr_endline ("Top open: "^block);
push stack_table !in_table ;
in_table := NoTable ;
begin match block with
245 | "PRE" ->
push stack_display !display ;
if !display then begin
Dest.item_display () ;
display := false
250 end ;
Dest.open_block "PRE" args
| "DISPLAY" ->
push stack_display !display ;
display := true ;
255 Dest.open_display ()
| "TABLE" ->
save_array_state () ;
in_table := NoTable ;
top_item_display () ;
260 Dest.open_block "TABLE" args
| "TR" ->
Dest.open_block "TR" args
| "TD" ->
Dest.open_block "TD" args ;
265 top_open_display ()
| _ ->
if !display then begin
Dest.item_display () ; Dest.open_block block args ;
Dest.open_display ()
270 end else
Dest.open_block block args
end
and top_close_block_aux close_fun block =
275 if !verbose > 2 then prerr_endline ("Top close: "^block) ;
in_table := pop stack_table ;
begin match block with
| "PRE" ->
display := pop stack_display ;
280 close_fun block ;
top_item_display ()
| "DISPLAY" ->
Dest.close_display () ;
display := pop stack_display
285 | "TABLE" ->
close_fun "TABLE" ;
top_item_display () ;
restore_array_state ()
| "TR" ->
290 close_fun "TR"
| "TD" ->
top_close_display () ;
close_fun "TD"
| _ ->
295 if !display then begin
Dest.close_display () ; close_fun block ; Dest.item_display ()
end else
close_fun block
end
300 ;;
let top_close_block block = top_close_block_aux Dest.close_block block
and top_erase_block block = top_close_block_aux Dest.erase_block block
305 let top_open_group () =
top_open_block "" "" ; new_env ""
and top_close_group () =
if !cur_env = "*mbox" then begin
310 top_close_block "" ;
in_math := pop stack_in_math ; display := pop stack_display ;
if !display then Dest.item_display () ;
close_env "*mbox"
end else begin
315 top_close_block "" ;
close_env ""
end
;;
320 let start_mbox () =
push stack_table !in_table ; in_table := NoTable ;
push stack_in_math !in_math ; in_math := false ;
if !display then Dest.item_display () ;
push stack_display !display ; display := false ;
325 Dest.open_block "" "" ;
new_env "*mbox"
;;
let get_fun_result f lexbuf =
330 if !verbose > 1 then
prerr_endline ("get_fun") ;
let r = Dest.to_string (fun () ->
top_open_group () ;
Dest.nostyle () ;
335 f lexbuf ;
top_close_group ()) in
if !verbose > 1 then begin
prerr_endline ("get_fun -> ``"^r^"''")
end ;
340 r
let do_get_this start_lexstate restore_lexstate
make_style lexfun {arg=s ; subst=subst} =
345 let par_val = Dest.forget_par () in
start_lexstate subst;
if !verbose > 1 then
prerr_endline ("get_this : ``"^s^"''") ;
verbose := !verbose - 1;
350 let lexer = Lexing.from_string s in
let r = Dest.to_string (fun () ->
if !display then Dest.open_display () ;
top_open_group () ;
make_style () ;
355 lexfun lexer ;
top_close_group () ;
if !display then Dest.close_display ()) in
let _ = Dest.forget_par () in
360 verbose := !verbose + 1 ;
if !verbose > 1 then begin
prerr_endline ("get_this ``"^s^"'' -> ``"^r^"''")
end ;
restore_lexstate () ;
365 Dest.par par_val ;
r
let get_this_arg =
do_get_this start_lexstate_subst restore_lexstate (fun () -> ())
370
and get_this_string main s =
do_get_this start_lexstate_subst restore_lexstate (fun () -> ())
main (string_to_arg s)
375 let more_buff = Out.create_buff ()
;;
let default_format =
Tabular.Align
380 {hor="left" ; vert = "" ; wrap = false ;
pre = "" ; post = "" ; width = Length.Default}
and center_format =
Tabular.Align
385 {hor="center" ; vert = "top" ; wrap = false ;
pre = "" ; post = "" ; width = Length.Default}
;;
390 let is_table = function
| Table _ -> true
| _ -> false
and is_noborder_table = function
395 | Table {border = b} -> not b
| _ -> false
and is_tabbing = function
| Tabbing -> true
400 | _ -> false
and math_table = function
| Table {math = m} -> m
| _ -> raise (Misc.Fatal "Array construct outside an array")
405 ;;
exception EndInside
;;
410 exception NoMulti
;;
let attribut name = function
| "" -> ""
415 | s -> " "^name^"="^s
and as_colspan = function
| 1 -> ""
| n -> " COLSPAN="^string_of_int n
420
let is_inside = function
Tabular.Inside _ -> true
| _ -> false
425 let is_border = function
| Tabular.Border _ -> true
| _ -> false
and as_wrap = function
430 | Tabular.Align {wrap = w} -> w
| _ -> false
and as_pre = function
| Tabular.Align {pre=s} -> s
435 | _ -> raise (Misc.Fatal "as_pre")
and as_post = function
| Tabular.Align {post=s} -> s
| f -> raise (Misc.Fatal ("as_post "^pretty_format f))
440 ;;
let get_col format i =
let r =
if i >= Array.length format+1 then
445 raise (Misc.ScanError ("This array/tabular column has no specification"))
else if i = Array.length format then default_format
else format.(i) in
if !verbose > 2 then begin
Printf.fprintf stderr "get_col : %d: " i ;
450 prerr_endline (pretty_format r) ;
prerr_string " <- " ;
pretty_formats format ;
prerr_newline ()
end ;
455 r
;;
(* Paragraph breaks are different in tables *)
let par_val t =
460 if is_table t then
match get_col !cur_format !cur_col with
| Tabular.Align {wrap=false} -> None
| _ -> Some 0
else
465 Some 1
let show_inside main format i closing =
(*
if !verbose > -1 then begin
470 prerr_string ("show_inside: "^string_of_int i)
end ;
*)
let t = ref i in
begin try while true do
475 begin match get_col format !t with
Tabular.Inside s ->
let saved_table = !in_table in
if math_table saved_table then
scan_this main "$"
480 else
scan_this main "{" ;
let s = get_this_string main s in
if math_table saved_table then
scan_this main "$"
485 else
scan_this main "}" ;
Dest.make_inside s !in_multi;
| Tabular.Border s ->
Dest.make_border s;
490 if !first_border then first_border := false;
| _ -> raise EndInside
end ;
t := !t+1
done with EndInside ->
495 if (!t = i) && (closing || !first_border) then
Dest.make_border " ";
end ;
(*
if !verbose > -1 then
500 prerr_endline (" -> "^string_of_int !t) ;
*)
!t
;;
505 let rec eat_inside format i b insides =
if i >= Array.length format then (i , b , insides)
else begin
let f = get_col format i in
if is_inside f then
510 eat_inside format (i+1) b (insides+1)
else if is_border f then
eat_inside format (i+1) (b+1) insides
else i, b, insides
end
515 ;;
let rec find_end n format i b insides = match n with
0 -> eat_inside format i b insides
| _ ->
520 let f = get_col format i in
if is_inside f then
find_end n format (i+1) b (insides +1)
else if is_border f then
find_end n format (i+1) (b+1) insides
525 else
find_end (n-1) format (i+1) b insides
;;
530 let find_start i = if !first_border then 0 else i
let find_align format =
let t = ref 0 in
while (is_inside (get_col format !t)) || (is_border (get_col format !t)) do
535 t := !t+1
done ;
!t
;;
540 let next_no_border format n =
let t = ref n in
while is_border (get_col format !t) do
t:= !t+1
done;
545 !t
;;
let do_open_col main format span insides =
let save_table = !in_table in
550 Dest.open_cell format span insides;
if not (as_wrap format) && math_table !in_table then begin
display := true ;
Dest.open_display ()
end ;
555 if math_table !in_table && not (as_wrap format) then begin
scan_this main "$"
end else
scan_this main "{" ;
scan_this main (as_pre format) ;
560 in_table := save_table
let open_col main =
let _ = Dest.forget_par () in
Dest.open_cell_group () ;
565 cur_col := show_inside main !cur_format !cur_col false;
let format = (get_col !cur_format !cur_col) in
do_open_col main format 1 0
;;
570 let open_first_col main =
first_col := true ;
first_border := true;
open_col main
;;
575
let erase_col main =
let old_format = get_col !cur_format !cur_col in
scan_this main (as_post old_format) ;
if math_table !in_table && not (as_wrap old_format) then
580 scan_this main "$"
else
scan_this main "}" ;
if !display then begin
Dest.close_display () ;
585 display := false
end ;
Dest.erase_cell () ;
Dest.erase_cell_group ()
;;
590
let open_row () =
cur_col := 0 ;
Dest.new_row ()
595
and close_row () = Dest.close_row ()
;;
600 let do_hline main =
if !verbose > 2 then begin
Printf.fprintf stderr "hline: %d %d" !cur_col (Array.length !cur_format) ;
prerr_newline ()
end ;
605 erase_col main ;
Dest.erase_row () ;
Dest.make_hline (Array.length !cur_format) (is_noborder_table !in_table);
open_row () ;
open_first_col main
610 ;;
let do_multi n format main =
if !verbose > 2 then begin
prerr_string
615 ("multicolumn: n="^string_of_int n^" format:") ;
pretty_formats format ;
prerr_endline ""
end ;
620 erase_col main ;
let start_span = find_start !cur_col
and k,b,insides = find_end n !cur_format !cur_col 0 0 in
let end_span = k - b in
625
in_multi := true;
let i = show_inside main format 0 true in
630 Dest.open_cell_group () ;
do_open_col main (get_col format i) (end_span - start_span) insides;
push stack_multi (!cur_format,k) ;
cur_format := format ;
cur_col := i ;
635 ;;
let close_col_aux main content is_last =
let old_format = get_col !cur_format !cur_col in
640 scan_this main (as_post old_format) ;
if math_table !in_table && not (as_wrap old_format) then
scan_this main "$"
else
scan_this main "}" ;
645 if !display then begin
Dest.close_display () ;
display := false
end ;
if is_last && Dest.is_empty () then Dest.erase_cell ()
650 else begin
if !in_multi then begin
let _ = show_inside main !cur_format (!cur_col+1) true in
in_multi := false ;
let f,n = pop stack_multi in
655 cur_format := f ;
cur_col := next_no_border f n;
cur_col := show_inside main !cur_format !cur_col false;
end else begin
cur_col := !cur_col + 1;
660 cur_col := show_inside main !cur_format !cur_col true;
end;
Dest.close_cell content;
if !first_col then begin
first_col := false;
665 first_border := false;
end
end ;
Dest.close_cell_group ()
;;
670
let close_col main content = close_col_aux main content false
and close_last_col main content = close_col_aux main content true
and close_last_row () =
675 if !first_col then
Dest.erase_row ()
else
Dest.close_row ()
;;
680
(* Compute functions *)
let get_style lexfun {arg=s ; subst=env} =
start_normal env ;
685 let lexer = Lexing.from_string s in
let r = Dest.to_style (fun () -> lexfun lexer) in
end_normal () ;
r
690 (* Image stuff *)
let iput_newpage () = Image.page ()
;;
695 let stack_entry = Stack.create "stack_entry"
and stack_out = Stack.create "stack_out"
;;
let start_other_scan env lexfun lexbuf =
700 if !verbose > 1 then begin
prerr_endline ("Start other scan ("^env^")") ;
stack_env_pretty () ;
prerr_endline ("Current env is: ``"^ !cur_env^"''") ;
pretty (fun x -> x) stack_entry
705 end;
save_lexstate () ;
push stack_entry env ;
rev stack_entry ;
lexfun lexbuf
710 ;;
let start_image_scan s image lexbuf =
start_other_scan "toimage" (fun b -> Image.dump s image b) lexbuf
;;
715
let complete_scan main lexbuf =
main lexbuf ;
close_env (pop stack_out) ;
top_close_block "" ;
720 if !verbose > 1 then begin
prerr_endline "Complete scan" ;
stack_env_pretty () ;
prerr_endline ("Current env is: ``"^ !cur_env^"''")
end
725 ;;
let stop_other_scan comment main lexbuf =
if !verbose > 1 then begin
730 prerr_endline "Stop image: env stack is" ;
stack_env_pretty () ;
prerr_endline ("Current env is: ``"^ !cur_env^"''")
end;
let _ = pop stack_entry in
735 if not comment then close_env !cur_env ;
if not (Stack.empty stack_out) then begin
complete_scan main lexbuf ;
while not (Stack.empty stack_out) do
let lexbuf = previous_lexbuf () in
740 complete_scan main lexbuf
done
end ;
restore_lexstate ()
;;
745
let includes_table = Hashtbl.create 17
and check_includes = ref false
;;
750 let add_includes l =
check_includes := true ;
List.iter (fun x -> Hashtbl.add includes_table x ()) l
;;
755
let check_include s =
not !check_includes ||
begin try
Hashtbl.find includes_table s ; true
760 with Not_found -> false
end
;;
765 let mk_out_file () = match Parse_opts.name_out,!Parse_opts.destination with
| "", Parse_opts.Info -> Out.create_buff ()
| "", _ -> Out.create_chan stdout
| x , Parse_opts.Info -> Out.create_chan (open_out (x^".tmp"))
| x , _ -> Out.create_chan (open_out x)
770 ;;
let no_prelude () =
if !verbose > 1 then prerr_endline "Filter mode" ;
flushing := true ;
775 let _ = Dest.forget_par () in () ;
Dest.set_out (mk_out_file ())
;;
let macro_depth = ref 0
780 ;;
let debug = function
| Not -> "Not"
| Macro -> "Macro"
785 | Inside -> "Inside"
;;
let rec expand_toks main = function
790 | [] -> ()
| s::rem ->
expand_toks main rem ;
scan_this main s
795 let expand_command main skip_blanks name lexbuf =
if !verbose > 2 then begin
Printf.fprintf stderr "expand_command: %s\n" name
end ;
let cur_subst = get_subst () in
800 let exec =
if !alltt_loaded then
function
| Subst body ->
if !verbose > 2 then
805 prerr_endline ("user macro: "^body) ;
let old_alltt = !alltt in
Stack.push stack_alltt old_alltt ;
alltt :=
(match old_alltt with
810 | Not -> Not
| _ -> Macro) ;
(*
Printf.fprintf stderr
"Enter: %s, %s -> %s\n" name (debug old_alltt) (debug !alltt) ;
815 *)
scan_this_may_cont main lexbuf cur_subst (string_to_arg body) ;
let _ = Stack.pop stack_alltt in
alltt :=
(match old_alltt, !alltt with
820 | Not, Inside -> Inside
| (Macro|Inside), Not -> Not
| _, _ -> old_alltt)
(*
Printf.fprintf stderr
825 "After: %s, %s -> %s\n" name (debug old_alltt) (debug !alltt)
*)
| Toks l -> expand_toks main l
| CamlCode f -> f lexbuf
else
830 function
| Subst body ->
if !verbose > 2 then
prerr_endline ("user macro: "^body) ;
scan_this_may_cont main lexbuf cur_subst (string_to_arg body)
835 | Toks l -> expand_toks main l
| CamlCode f -> f lexbuf in
let pat,body = Latexmacros.find name in
let par_before = Dest.forget_par () in
840 if
(if !in_math then Latexmacros.invisible name
else
not (effective !alltt) &&
is_subst body && last_letter name)
845 then begin
if !verbose > 2 then
prerr_endline ("skipping blanks ("^name^")");
skip_blanks lexbuf
end else begin
850 if !verbose > 2 then begin
prerr_endline ("not skipping blanks ("^name^")")
end
end ;
let par_after = Dest.forget_par () in
855 Dest.par par_before ;
let args = make_stack name pat lexbuf in
let saw_par = !Save.seen_par in
if (!verbose > 1) then begin
prerr_endline
860 ("Expanding macro "^name^" {"^(string_of_int !macro_depth)^"}") ;
macro_depth := !macro_depth + 1
end ;
scan_body exec body args ;
if (!verbose > 1) then begin
865 prerr_endline ("Cont after macro "^name^": ") ;
macro_depth := !macro_depth - 1
end ;
Dest.par par_after ;
if saw_par then begin
870 top_par (par_val !in_table)
end
;;
let count_newlines s =
875 let l = String.length s in
let rec c_rec i =
if i >= l then 0
else match s.[i] with
| '\n' -> 1 + c_rec (i+1)
880 | _ -> c_rec (i+1) in
c_rec 0
;;
let check_case s = match !case with
885 | Lower -> String.lowercase s
| Upper -> String.uppercase s
| Neutral -> s
and check_case_char c = match !case with
890 | Lower -> Char.lowercase c
| Upper -> Char.uppercase c
| Neutral -> c
}
895 let command_name = '\\' (( ['@''A'-'Z' 'a'-'z']+ '*'?) | [^ 'A'-'Z' 'a'-'z'])
rule main = parse
(* comments *)
| '%'
900 {expand_command main skip_blanks "\\@hevea@percent" lexbuf ;
main lexbuf}
(* Paragraphs *)
| '\n'
905 {expand_command main skip_blanks "\\@hevea@newline" lexbuf ;
main lexbuf}
(* subscripts and superscripts *)
| '_'
{expand_command main skip_blanks "\\@hevea@underscore" lexbuf ;
910 main lexbuf}
| '^'
{expand_command main skip_blanks "\\@hevea@circ" lexbuf ;
main lexbuf}
(* Math mode *)
915 | "$" | "$$"
{let lxm = lexeme lexbuf in
(* ``$'' has nothing special *)
let dodo = lxm <> "$" in
if effective !alltt || not (is_plain '$') then begin
920 Dest.put lxm ; main lexbuf
(* vicious case ``$x$$y$'' *)
end else if dodo && not !display && !in_math then begin
scan_this main "${}$" ;
main lexbuf
925 end else begin (* General case *)
let math_env = if dodo then "*display" else "*math" in
if !in_math then begin
in_math := pop stack_in_math ;
if dodo then begin
930 Dest.close_maths dodo
end else begin
top_close_display () ;
Dest.close_maths dodo
end ;
935 display := pop stack_display ;
if !display then begin
Dest.item_display ()
end ;
close_env math_env ;
940 main lexbuf
end else begin
push stack_in_math !in_math ;
in_math := true ;
let lexfun lb =
945 if !display then Dest.item_display () ;
push stack_display !display ;
if dodo then begin
display := true ;
Dest.open_maths dodo;
950 end else begin
Dest.open_maths dodo;
top_open_display () ;
end;
skip_blanks lb ; main lb in
955 new_env math_env ;
lexfun lexbuf
end end}
(* Definitions of simple macros *)
960 (* inside tables and array *)
| [' ''\n']* "&"
{expand_command main skip_blanks "\\@hevea@amper" lexbuf ;
main lexbuf}
(* Substitution *)
965 | '#' ['1'-'9']
{let lxm = lexeme lexbuf in
begin if effective !alltt || not (is_plain '#') then
Dest.put lxm
else
970 let i = Char.code lxm.[1] - Char.code '1' in
scan_arg
(if !alltt_loaded then
(fun arg ->
let old_alltt = !alltt in
975 alltt := Stack.pop stack_alltt ;
scan_this_may_cont main lexbuf (get_subst ()) arg ;
alltt := old_alltt ;
Stack.push stack_alltt old_alltt)
else
980 (fun arg -> scan_this_may_cont main lexbuf (get_subst ()) arg))
i
end ;
main lexbuf}
(* Commands *)
985 | command_name
{let name = lexeme lexbuf in
expand_command main skip_blanks name lexbuf ;
main lexbuf}
(* Groups *)
990 | '{'
{expand_command main skip_blanks "\\@hevea@obrace" lexbuf ;
main lexbuf}
| '}'
{expand_command main skip_blanks "\\@hevea@cbrace" lexbuf ;
995 main lexbuf}
| eof {()}
| ' '+
{if effective !alltt then
let lxm = lexeme lexbuf in Dest.put lxm
1000 else
Dest.put_char ' ';
main lexbuf}
(* Alphabetic characters *)
| ['a'-'z' 'A'-'Z']+
1005 {let lxm = lexeme lexbuf in
let lxm = check_case lxm in
if !in_math then begin
Dest.put_in_math lxm;
end else
1010 Dest.put lxm ;
main lexbuf}
(* Numbers *)
| ['0'-'9']+
{let lxm = lexeme lexbuf in
1015 Dest.put lxm;
main lexbuf}
(* Html specials *)
| '~'
{expand_command main skip_blanks "\\@hevea@tilde" lexbuf ;
1020 main lexbuf }
(* Spanish stuff *)
| '?'
{expand_command main skip_blanks "\\@hevea@question" lexbuf ;
main lexbuf}
1025 | '!'
{expand_command main skip_blanks "\\@hevea@excl" lexbuf ;
main lexbuf}
(* One character *)
| _
1030 {let lxm = lexeme_char lexbuf 0 in
let lxm = check_case_char lxm in
Dest.put (Dest.iso lxm) ;
main lexbuf}
1035 and gobble_one_char = parse
| _ {()}
| "" {fatal ("Gobble at end of file")}
and complete_newline = parse
1040 | (' '* '\n')* {lexeme lexbuf}
and latex2html_latexonly = parse
| '%' + [ ' ' '\t' ] * "\\end{latexonly}" [ ^ '\n' ] * '\n'
{ () }
1045 | _
{latex2html_latexonly lexbuf}
| eof
{fatal "End of file in latex2html_latexonly"}
1050 and latexonly = parse
'%'+ ' '* ("END"|"end") ' '+ ("LATEX"|"latex") [^'\n']* '\n'
{stop_other_scan true main lexbuf}
| '%'+ ' '* ("HEVEA"|"hevea") ' '*
{latexonly lexbuf}
1055 | '%'
{latex_comment lexbuf ; latexonly lexbuf}
| "\\end"
{let {arg=arg} = save_arg lexbuf in
if arg = "latexonly" then begin
1060 top_close_block "" ;
stop_other_scan false main lexbuf
end else if arg = top stack_entry then begin
let _ = pop stack_entry in
push stack_out arg ;
1065 begin match Latexmacros.find (end_env arg) with
_,(Subst body) ->
scan_this_may_cont latexonly lexbuf (get_subst ())
(string_to_arg body)
| _,_ ->
1070 raise (Misc.ScanError ("Bad closing macro in latexonly: ``"^arg^"''"))
end
end else
latexonly lexbuf}
| command_name | _ {latexonly lexbuf}
1075 | eof
{if empty stack_lexbuf then ()
else begin
let lexbuf = previous_lexbuf () in
latexonly lexbuf
1080 end}
and latex_comment = parse
'\n' | eof {()}
1085 | [^'\n']+ {latex_comment lexbuf}
and image = parse
1090 '%'+ ' '* ("END"|"end") ' '+ ("IMAGE"|"image") [^'\n']* '\n'
{stop_other_scan true main lexbuf}
| '%'+ ' '* ("HEVEA"|"hevea") ' '*
{image lexbuf}
| '%'
1095 {let lxm = lexeme lexbuf in
Image.put lxm ;
image_comment lexbuf ;
image lexbuf}
(* Substitution in image *)
1100 | '#' ['1'-'9']
{let lxm = lexeme lexbuf in
let i = Char.code (lxm.[1]) - Char.code '1' in