<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
scan_arg (scan_this_arg image) i ;
image lexbuf}
1105 | "\\end"
{let lxm = lexeme lexbuf in
Save.start_echo () ;
let {arg=arg} = save_arg lexbuf in
let true_arg = Save.get_echo () in
1110 if arg = "toimage" then begin
top_close_block "" ;
stop_other_scan false main lexbuf
end else if arg = top stack_entry then begin
let _ = pop stack_entry in
1115 push stack_out arg ;
begin match Latexmacros.find (end_env arg) with
_,(Subst body) ->
scan_this_may_cont image lexbuf (get_subst ())
(string_to_arg body)
1120 | _,_ -> raise (Misc.ScanError ("Bad closing macro in image: ``"^arg^"''"))
end
end else begin
Image.put lxm ; Image.put true_arg ;
image lexbuf
1125 end}
| command_name
{let lxm = lexeme lexbuf in
begin match lxm with
(* Definitions of simple macros, bodies are not substituted *)
1130 | "\\def" | "\\gdef" ->
Save.start_echo () ;
skip_csname lexbuf ;
skip_blanks lexbuf ;
let _ = Save.defargs lexbuf in
1135 let _ = save_arg lexbuf in
Image.put lxm ;
let saved = Save.get_echo () in
Image.put saved
| "\\renewcommand" | "\\newcommand" | "\\providecommand"
1140 | "\\renewcommand*" | "\\newcommand*" | "\\providecommand*" ->
Save.start_echo () ;
let _ = save_arg lexbuf in
let _ = save_opts ["0" ; ""] lexbuf in
let _ = save_arg lexbuf in
1145 Image.put lxm ;
let saved = Save.get_echo () in
Image.put saved
| "\\newenvironment" | "\\renewenvironment"
| "\\newenvironment*" | "\\renewenvironment*" ->
1150 Save.start_echo () ;
let _ = save_arg lexbuf in
let _ = save_opts ["0" ; ""] lexbuf in
let _ = save_arg lexbuf in
let _ = save_arg lexbuf in
1155 Image.put lxm ;
Image.put (Save.get_echo ())
| _ -> Image.put lxm end ;
image lexbuf}
| _
1160 {let s = lexeme lexbuf in
Image.put s ;
image lexbuf}
| eof
{if empty stack_lexbuf then begin
1165 if not filter && top_lexstate () then
raise (Misc.ScanError ("No \\end{document} found"))
end else begin
let lexbuf = previous_lexbuf () in
image lexbuf
1170 end}
and image_comment = parse
'\n' {Image.put_char '\n'}
1175 | eof {()}
| [^'\n']+
{let lxm = lexeme lexbuf in
Image.put lxm ;
image_comment lexbuf}
1180
and mbox_arg = parse
| ' '+ | '\n' {mbox_arg lexbuf}
| eof
{if not (empty stack_lexbuf) then begin
1185 let lexbuf = previous_lexbuf () in
if !verbose > 2 then begin
prerr_endline "Poping lexbuf in mbox_arg" ;
pretty_lexbuf lexbuf
end ;
1190 mbox_arg lexbuf
end else raise (Misc.ScanError "End of file in \\mbox argument")}
| '{' | ("\\bgroup" ' '* '\n'? ' '*)
{start_mbox ()}
| ""
1195 {raise (Misc.ScanError "Cannot find a \\mbox argument here, use braces")}
and no_skip = parse
| "" {()}
1200 and skip_blanks_pop = parse
' '+ {skip_blanks_pop lexbuf}
| '\n' {more_skip_pop lexbuf}
| "" {()}
| eof
1205 {if not (empty stack_lexbuf) then begin
let lexbuf = previous_lexbuf () in
if !verbose > 2 then begin
prerr_endline "Poping lexbuf in skip_blanks" ;
pretty_lexbuf lexbuf
1210 end ;
skip_blanks_pop lexbuf
end else ()}
and more_skip_pop = parse
1215 '\n'+ {top_par (par_val !in_table)}
| "" {skip_blanks_pop lexbuf}
| eof
{if not (empty stack_lexbuf) then begin
let lexbuf = previous_lexbuf () in
1220 if !verbose > 2 then begin
prerr_endline "Poping lexbuf in skip_blanks" ;
pretty_lexbuf lexbuf
end ;
more_skip_pop lexbuf
1225 end else ()}
and to_newline = parse
| '\n' {()}
| _ {Out.put_char more_buff (Lexing.lexeme_char lexbuf 0) ;
1230 to_newline lexbuf}
| eof
{if not (empty stack_lexbuf) then
let lexbuf = previous_lexbuf () in
to_newline lexbuf}
1235
and skip_blanks = parse
' '+ {skip_blanks lexbuf}
| '\n' {more_skip lexbuf}
| "" {()}
1240
and more_skip = parse
'\n'+ {top_par (par_val !in_table)}
| "" {skip_blanks lexbuf}
1245 and skip_spaces = parse
' ' * {()}
| eof {()}
1250 and skip_false = parse
| '%'
{if is_plain '%' then skip_comment lexbuf ;
skip_false lexbuf}
| "\\ifthenelse"
1255 {skip_false lexbuf}
| "\\if" ['a'-'z' 'A'-'Z''@']+
{if_level := !if_level + 1 ;
skip_false lexbuf}
| "\\else" ['a'-'z' 'A'-'Z''@']+
1260 {skip_false lexbuf}
| "\\else"
{if !if_level = 0 then skip_blanks lexbuf
else skip_false lexbuf}
| "\\fi" ['a'-'z' 'A'-'Z']+
1265 {skip_false lexbuf}
| "\\fi"
{if !if_level = 0 then begin
skip_blanks lexbuf
end else begin
1270 if_level := !if_level -1 ;
skip_false lexbuf
end}
| _ {skip_false lexbuf}
| "" {raise (Error "End of entry while skipping TeX conditional macro")}
1275
and comment = parse
| ['%'' ']* ("BEGIN"|"begin") ' '+ ("IMAGE"|"image")
{skip_comment lexbuf ; start_image_scan "" image lexbuf}
(* Backward compatibility with latex2html *)
1280 | [ ' ' '\t' ] * "\\begin{latexonly}"
{latex2html_latexonly lexbuf}
| ['%'' ']* ("HEVEA"|"hevea") ' '*
{()}
| ['%'' ']* ("BEGIN"|"begin") ' '+ ("LATEX"|"latex")
1285 {skip_to_end_latex lexbuf}
| ""
{skip_comment lexbuf ; more_skip lexbuf}
and skip_comment = parse
1290 | [^ '\n']* '\n'
{if !verbose > 1 then
prerr_endline ("Comment:"^lexeme lexbuf) ;
if !flushing then Dest.flush_out () }
| "" {raise (Misc.ScanError "Latex comment is not terminated")}
1295
and skip_to_end_latex = parse
| '%' ['%'' ']* ("END"|"end") ' '+ ("LATEX"|"latex")
{skip_comment lexbuf ; skip_spaces lexbuf}
| _
1300 {skip_to_end_latex lexbuf}
| eof {fatal ("End of file in %BEGIN LATEX ... %END LATEX")}
{
let _ = ()
;;
1305 (* A few subst definitions, with 2 optional arguments *)
def "\\makebox" (latex_pat ["" ; ""] 3)
(Subst "\\warning{makebox}\\mbox{#3}") ;
def "\\framebox" (latex_pat ["" ; ""] 3)
1310 (Subst "\\warning{framebox}\\fbox{#3}")
;;
let check_alltt_skip lexbuf =
1315 if not (effective !alltt) then skip_blanks lexbuf
and skip_pop lexbuf =
save_lexstate () ;
skip_blanks_pop lexbuf ;
1320 restore_lexstate ()
;;
let def_code name f = def_init name f
let def_name_code name f = def_init name (f name)
1325 ;;
def_code "\\@hevea@percent"
(fun lexbuf ->
1330 if effective !alltt || not (is_plain '%') then begin
let lxm = lexeme lexbuf in
Dest.put lxm ;
main lexbuf
end else begin
1335 comment lexbuf
end)
;;
def_code "\\@hevea@newline"
1340 (fun lexbuf ->
let lxm = complete_newline lexbuf in
let nlnum = count_newlines lxm in
if !Lexstate.withinLispComment
then begin
1345 if !verbose > 2 then prerr_endline "NL caught after LispComment" ;
raise (Misc.EndOfLispComment nlnum) (* QNC *)
end else begin
if effective !alltt then begin
Dest.put_char '\n' ;
1350 Dest.put lxm
end else if nlnum >= 1 then
expand_command main skip_blanks "\\par" lexbuf
else
Dest.put_separator ()
1355 end)
;;
let sub_sup lxm lexbuf =
if effective !alltt || not (is_plain lxm) then Dest.put_char lxm
1360 else if not !in_math then begin
warning ("``"^Char.escaped lxm^"''occuring outside math mode") ;
Dest.put_char lxm
end else begin
let sup,sub = match lxm with
1365 '^' ->
let sup = save_arg lexbuf in
let sub = save_sub lexbuf in
sup,unoption sub
| '_' ->
1370 let sub = save_arg lexbuf in
let sup = save_sup lexbuf in
unoption sup,sub
| _ -> assert false in
Dest.standard_sup_sub (scan_this_arg main) (fun () -> ()) sup sub !display
1375 end
;;
def_code "\\@hevea@underscore" (fun lexbuf -> sub_sup '_' lexbuf) ;
def_code "\\@hevea@circ" (fun lexbuf -> sub_sup '^' lexbuf)
1380 ;;
def_code "\\mathop"
(fun lexbuf ->
let symbol = save_arg lexbuf in
1385 let {limits=limits ; sup=sup ; sub=sub} = save_sup_sub lexbuf in
begin match limits with
| (Some Limits|None) when !display ->
Dest.limit_sup_sub
(scan_this_arg main)
1390 (fun _ -> scan_this_arg main symbol) sup sub !display
| (Some IntLimits) when !display ->
Dest.int_sup_sub true 3
(scan_this_arg main)
(fun () -> scan_this_arg main symbol)
1395 sup sub !display
| _ ->
scan_this_arg main symbol ;
Dest.standard_sup_sub
(scan_this_arg main)
1400 (fun _ -> ()) sup sub !display
end)
;;
1405 def_code "\\@hevea@obrace"
(fun _ ->
if !activebrace && is_plain '{' then
top_open_group ()
else begin
1410 Dest.put_char '{'
end) ;
def_code "\\bgroup"
(fun lexbuf ->
1415 top_open_group () ;
check_alltt_skip lexbuf)
;;
def_code "\\@hevea@cbrace"
1420 (fun _ ->
if !activebrace && is_plain '}' then begin
top_close_group ()
end else begin
Dest.put_char '}'
1425 end) ;
def_code "\\egroup"
(fun lexbuf ->
top_close_group () ;
check_alltt_skip lexbuf)
1430 ;;
def_code "\\@hevea@tilde"
(fun lexbuf ->
1435 if effective !alltt || not (is_plain '~') then
Dest.put_char '~'
else Dest.put_nbsp ())
;;
1440 def_code "\\@hevea@question"
(fun lexbuf ->
if if_next_char '`' lexbuf then begin
gobble_one_char lexbuf ;
if effective !alltt then Dest.put "?`"
1445 else
Dest.put (Dest.iso '')
end else
Dest.put_char '?')
;;
1450 def_code "\\@hevea@excl"
(fun lexbuf ->
if if_next_char '`' lexbuf then begin
gobble_one_char lexbuf ;
if effective !alltt then Dest.put "!`"
1455 else Dest.put (Dest.iso '')
end else
Dest.put_char '!')
;;
1460 let get_this_main arg = get_this_string main arg
let check_this_main s =
if !verbose > 1 then
prerr_endline ("check_this: ``"^s^"''");
1465 start_normal (get_subst ()) ;
let save_par = Dest.forget_par () in
Dest.open_block "TEMP" "";
let r =
try
1470 scan_this main s ;
true
with
| x -> false in
Dest.erase_block "TEMP" ;
1475 Dest.par save_par ;
end_normal () ;
if !verbose > 1 then
prerr_endline ("check_this: ``"^s^"'' = "^sbool r);
r
1480
let get_prim_onarg arg =
let plain_sub = is_plain '_'
and plain_sup = is_plain '^'
and plain_dollar = is_plain '$'
1485 and plain_amper = is_plain '&' in
unset_plain '_' ; unset_plain '^' ; unset_plain '$' ; unset_plain '&' ;
let r = do_get_this
start_normal end_normal
Dest.nostyle
1490 main arg in
plain_back plain_sub '_' ; plain_back plain_sup '^' ;
plain_back plain_dollar '$' ; plain_back plain_amper '&' ;
r
1495 let get_prim s = get_prim_onarg (string_to_arg s)
let get_prim_arg lexbuf =
let arg = save_arg lexbuf in
get_prim_onarg arg
1500
and get_prim_opt def lexbuf =
let arg = save_opt def lexbuf in
get_prim_onarg arg
1505
let get_csname lexbuf =
protect_save_string
(fun lexbuf -> Save.csname lexbuf get_prim Subst.subst_this)
lexbuf
1510
let def_fun name f =
def_code name
(fun lexbuf ->
1515 let arg = subst_arg lexbuf in
scan_this main (f arg))
;;
(* Paragraphs *)
1520 let do_unskip () =
let _ = Dest.forget_par () in
Dest.unskip ()
;;
1525 def_code "\\unskip"
(fun lexbuf ->
do_unskip () ;
check_alltt_skip lexbuf)
;;
1530
def_code "\\par"
(fun lexbuf ->
match par_val !in_table with
| None ->
1535 Dest.put_char ' ' ;
check_alltt_skip lexbuf
| pval ->
top_par pval ;
check_alltt_skip lexbuf)
1540
;;
(* Styles and packages *)
let do_documentclass command lexbuf =
1545 Save.start_echo () ;
let {arg=opt_arg} = save_opt "" lexbuf in
let {arg=arg} = save_arg lexbuf in
let real_args = Save.get_echo () in
begin try if not !styleloaded then
1550 input_file 0 main (arg^".hva")
with
Myfiles.Except | Myfiles.Error _ ->
raise (Misc.ScanError ("No base style"))
end ;
1555 if command = "\\documentstyle" then begin
let rec read_packages = function
| [] -> ()
| pack :: rest ->
scan_this main ("\\usepackage{"^pack^"}") ;
1560 read_packages rest in
read_packages
(Save.cite_arg (Lexing.from_string ("{"^opt_arg^"}")))
end ;
Image.start () ;
1565 Image.put command ;
Image.put real_args ;
Image.put_char '\n' ;
Dest.set_out (mk_out_file ()) ;
Dest.stop ()
1570 ;;
def_name_code "\\documentstyle" do_documentclass ;
def_name_code "\\documentclass" do_documentclass
;;
1575
let do_input lxm lexbuf =
Save.start_echo () ;
let arg = get_prim_arg lexbuf in
1580 let echo_arg = Save.get_echo () in
if lxm <> "\\include" || check_include arg then begin
let filename =
if lxm = "\\bibliography" then Parse_opts.base_in^".bbl"
else arg in
1585
begin try input_file !verbose main filename
with Myfiles.Except ->
Image.put lxm ;
Image.put echo_arg ;
1590 Image.put "\n" ;
| Myfiles.Error _ -> ()
end
end
;;
1595
def_code "\\input" (do_input "\\input") ;
def_code "\\include" (do_input "\\include") ;
def_code "\\bibliography" (do_input "\\bibliography")
;;
1600
(* Command definitions *)
let do_newcommand lxm lexbuf =
Save.start_echo () ;
1605 let name = get_csname lexbuf in
let nargs = save_opts ["0" ; ""] lexbuf in
let body = subst_body lexbuf in
let echo () =
if echo_toimage () && lxm <> "\\@forcecommand" then begin
1610 Image.put lxm ;
Image.put (Save.get_echo ()) ;
Image.put_char '\n'
end in
let nargs,(def,defval) = match nargs with
1615 [a1 ; a2] ->
Get.get_int (from_ok a1),
(match a2 with
| {arg=No s ; subst=env} -> false,mkarg s env
| {arg=Yes s ; subst=env} -> true,mkarg s env)
1620 | _ -> assert false in
let pat =
latex_pat (if def then [do_subst_this defval] else []) nargs in
match lxm with
| "\\@forcecommand" -> Latexmacros.def name pat (Subst body)
1625 | "\\newcommand"|"\\newcommand*" ->
echo () ;
if Latexmacros.exists name then
warning ("Ignoring (re-)definition of ``"^name^"'' by \\newcommand")
else begin
1630 Latexmacros.def name pat (Subst body)
end
| "\\renewcommand"|"\\renewcommand*" ->
if not (Latexmacros.exists name) then begin
warning ("Defining ``"^name^"'' by \\renewcommand")
1635 end else
echo () ;
Latexmacros.def name pat (Subst body)
| _ ->
echo () ;
1640 if not (Latexmacros.exists name) then
Latexmacros.def name pat (Subst body)
;;
def_name_code "\\renewcommand" do_newcommand ;
1645 def_name_code "\\renewcommand*" do_newcommand ;
def_name_code "\\newcommand" do_newcommand ;
def_name_code "\\newcommand*" do_newcommand ;
def_name_code "\\providecommand" do_newcommand ;
def_name_code "\\providecommand*" do_newcommand ;
1650 def_name_code "\\@forcecommand" do_newcommand
;;
def_name_code "\\newcolumntype"
(fun lxm lexbuf ->
1655 Save.start_echo () ;
let old_raw = !raw_chars in
raw_chars := true ;
let name = get_prim_arg lexbuf in
raw_chars := old_raw ;
1660 let nargs = save_opt "0" lexbuf in
let body = subst_body lexbuf in
let rest = Save.get_echo () in
if echo_toimage () then
Image.put (lxm^rest^"\n") ;
1665 let col_cmd = Misc.column_to_command name in
if Latexmacros.exists col_cmd then
warning
("Not (re)-defining column type ``"^name^"'' with \\newcolumntype")
else
1670 Latexmacros.def
col_cmd
(latex_pat [] (Get.get_int nargs))
(Subst body))
;;
1675
let do_newenvironment lxm lexbuf =
Save.start_echo () ;
let name = get_prim_arg lexbuf in
let nargs,optdef = match save_opts ["0" ; ""] lexbuf with
1680 | [x ; y ] -> x,y
| _ -> assert false in
let body1 = subst_body lexbuf in
let body2 = subst_body lexbuf in
if echo_toimage () then
1685 Image.put (lxm^Save.get_echo ()^"\n") ;
let do_defs () =
Latexmacros.def
(start_env name)
1690 (latex_pat
(match optdef with
| {arg=No _} -> []
| {arg=Yes s ; subst=env} -> [do_subst_this (mkarg s env)])
(match nargs with
1695 | {arg=No _} -> 0
| {arg=Yes s ; subst=env} -> Get.get_int (mkarg s env)))
(Subst body1) ;
Latexmacros.def (end_env name) zero_pat (Subst body2) in
1700 if lxm = "\\newenvironment" || lxm = "\\newenvironment*" then
if
Latexmacros.exists (start_env name) ||
Latexmacros.exists (start_env name)
then
1705 warning
("Not (re)-defining environment ``"^name^"'' with "^lxm)
else
do_defs ()
else begin
1710 if
not (Latexmacros.exists (start_env name) &&
Latexmacros.exists (start_env name))
then
warning
1715 ("Defining environment ``"^name^"'' with "^lxm) ;
do_defs ()
end
;;
1720 def_name_code "\\newenvironment" do_newenvironment ;
def_name_code "\\newenvironment*" do_newenvironment ;
def_name_code "\\renewenvironment" do_newenvironment ;
def_name_code "\\renewenvironment*" do_newenvironment
;;
1725
let do_newcounter name within =
try
Counter.def_counter name within ;
Latexmacros.global_def
1730 ("\\the"^name) zero_pat (Subst ("\\arabic{"^name^"}"))
with
| Failed -> ()
let do_newtheorem lxm lexbuf =
1735 Save.start_echo () ;
let name = get_prim_arg lexbuf in
let numbered_like = match save_opts [""] lexbuf with
| [x] -> x
| _ -> assert false in
1740 let caption = subst_arg lexbuf in
let within = match save_opts [""] lexbuf with
| [x] -> x
| _ -> assert false in
if echo_global_toimage () then
1745 Image.put (lxm^Save.get_echo ()^"\n") ;
let cname = match numbered_like,within with
{arg=No _},{arg=No _} ->
do_newcounter name "" ; name
| _,{arg=Yes _} ->
1750 let within = get_prim_onarg (from_ok within) in
do_newcounter name within ; name
| {arg=Yes _},_ ->
get_prim_onarg (from_ok numbered_like) in
Latexmacros.global_def
1755 (start_env name) (latex_pat [""] 1)
(Subst
("\\begin{flushleft}\\refstepcounter{"^cname^"}{\\bf "^caption^"~"^
"\\the"^cname^"}\\quad\\ifoptarg{\\purple[#1]\\quad}\\fi\\em")) ;
Latexmacros.global_def
1760 (end_env name) zero_pat
(Subst "\\end{flushleft}")
;;
def_name_code "\\newtheorem" do_newtheorem ;
1765 def_name_code "\\renewtheorem" do_newtheorem
;;
(* Command definitions, TeX style *)
1770 let do_def global lxm lexbuf =
Save.start_echo () ;
let name = get_csname lexbuf in
Save.skip_blanks_init lexbuf ;
let name,args_pat,body =
1775 if top_level () then
let args_pat = Save.defargs lexbuf in
let {arg=body} = save_arg lexbuf in
name,args_pat,body
else
1780 let args_pat =
Save.defargs
(Lexing.from_string
(subst_this (Save.get_defargs lexbuf))) in
let body = subst_body lexbuf in
1785 name,args_pat,body in
let real_args = Save.get_echo () in
if echo_toimage () || (global && echo_global_toimage ()) then begin
Image.put (lxm^real_args) ;
Image.put_char '\n'
1790 end ;
(if global then global_def else def)
name ([],args_pat) (Subst body)
;;
1795 def_name_code "\\def" (do_def false) ;
def_name_code "\\gdef" (do_def true)
;;
let do_let global lxm lexbuf =
1800 Save.start_echo () ;
let name = get_csname lexbuf in
Save.skip_equal lexbuf ;
let alt = get_csname lexbuf in
let real_args = Save.get_echo () in
1805 try
let nargs,body = Latexmacros.find_fail alt in
(if global then global_def else def)
name nargs body ;
if echo_toimage () || (global && echo_global_toimage ()) then begin
1810 Image.put lxm ;
Image.put real_args ;
Image.put "\n"
end
with
1815 | Failed ->
warning ("Not binding "^name^" with "^lxm^", command "^alt^" does not exist")
;;
def_name_code "\\let" (do_let false) ;
1820 ;;
let do_global lxm lexbuf =
let next = subst_arg lexbuf in
begin match next with
1825 | "\\def" -> do_def true (lxm^next) lexbuf
| "\\let" -> do_let true (lxm^next) lexbuf
| _ -> warning "Ignored \\global"
end
;;
1830
def_name_code "\\global" do_global
;;
1835
(* TeXisms *)
def_code "\\noexpand"
(fun lexbuf ->
let arg = subst_arg lexbuf in
1840 Dest.put arg)
;;
def_code "\\execafter"
(fun lexbuf ->
1845 let arg = save_arg lexbuf in
let next_arg = save_arg lexbuf in
let cur_subst = get_subst () in
scan_this_may_cont main lexbuf cur_subst next_arg ;
scan_this_may_cont main lexbuf cur_subst arg)
1850 ;;
def_code "\\csname"
(fun lexbuf ->
1855 skip_blanks lexbuf ;
let name = "\\"^get_prim (Save.incsname lexbuf) in
check_alltt_skip lexbuf ;
expand_command main skip_blanks name lexbuf)
;;
1860
def_code "\\string"
(fun lexbuf ->
let arg = subst_arg lexbuf in
Dest.put arg)
1865 ;;
let get_num_arg lexbuf =
Save.num_arg lexbuf (fun s -> Get.get_int (string_to_arg s))
;;
1870
let top_plain c =
if not (is_plain c) then begin
set_plain c ;
1875 fun_register (fun () -> unset_plain c)
end
and top_unplain c =
if is_plain c then begin
1880 unset_plain c ;
fun_register (fun () -> set_plain c)
end
;;
1885 def_code "\\catcode"
(fun lexbuf ->
let char = Char.chr
(Get.get_int (save_arg_with_delim "=" lexbuf)) in
let code = get_num_arg lexbuf in
1890 begin match char,code with
| ('\\',0) | ('{',1) | ('}',2) | ('$',3) | ('&' ,4) |
('#',6) | ('^',7) | ('_',8) | ('~',13) |
('%',14) -> top_plain char
| ('{',(11|12)) | ('}',(11|12)) | ('$',(11|12)) | ('&' ,(11|12)) |
1895 ('#',(11|12)) | ('^',(11|12)) | ('_',(11|12)) | ('~',(11|12)) |
('%',(11|12)) | ('\\',(11|12)) -> top_unplain char
| _ ->
warning "This \\catcode operation is not permitted"
end ;
1900 main lexbuf)
;;
def_code "\\chardef"
(fun lexbuf ->
1905 let csname = get_csname lexbuf in
Save.skip_equal lexbuf ;
let i = get_num_arg lexbuf in
Latexmacros.def csname zero_pat (Subst (string_of_int i)))
;;
1910
(* Complicated use of output blocks *)
def_code "\\left"
(fun lexbuf ->
let dprev = !display in
1915 Stack.push stack_display dprev ;
display := true ;
if not dprev then
top_open_display () ;
let delim = subst_arg lexbuf in
1920 let {sub=sub ; sup=sup} = save_sup_sub lexbuf in
Dest.left delim
(fun vsize ->
Dest.int_sup_sub false vsize
(scan_this_arg main) (fun () -> ()) sup sub true))
1925 ;;
(* Display is true *)
def_code "\\right"
(fun lexbuf ->
1930 let delim = subst_arg lexbuf in
let vsize = Dest.right delim in
let {sup=sup ; sub=sub} = save_sup_sub lexbuf in
let do_what = (fun () -> ()) in
Dest.int_sup_sub false vsize
1935 (scan_this_arg main) do_what sup sub !display ;
let dprev = Stack.pop stack_display in
if not dprev then top_close_display () ;
display := dprev)
;;
1940
def_code "\\over"
(fun lexbuf ->
Dest.over !display lexbuf;
skip_blanks lexbuf)
1945 ;;
let check_not = function
| "\\in" -> "\\notin"
| "=" -> "\\neq"
1950 | "\\subset" -> "\\notsubset"
| s -> "\\neg\\:"^s
;;
def_fun "\\not" check_not
1955 ;;
def_code "\\uppercase"
(fun lexbuf ->
let arg = save_arg lexbuf in
1960 let old_case = !case in
case := Upper ;
scan_this_arg main arg ;
case := old_case) ;
def_code "\\lowercase"
1965 (fun lexbuf ->
let arg = save_arg lexbuf in
let old_case = !case in
case := Lower ;
scan_this_arg main arg ;
1970 case := old_case)
;;
(* list items *)
def_code "\\@li" (fun _ -> Dest.item ()) ;
1975 def_code "\\@linum" (fun _ -> Dest.nitem ()) ;
def_code "\\@dt"
(fun lexbuf ->
let arg = subst_arg lexbuf in
Dest.ditem (scan_this main) arg ;
1980 check_alltt_skip lexbuf)
;;
(* Html primitives *)
1985 def_code "\\@open"
(fun lexbuf ->
let tag = get_prim_arg lexbuf in
let arg = get_prim_arg lexbuf in
top_open_block tag arg)
1990 ;;
def_code "\\@insert"
(fun lexbuf ->
let tag = get_prim_arg lexbuf in
1995 let arg = get_prim_arg lexbuf in
Dest.insert_block tag arg )
;;
def_code "\\@close"
2000 (fun lexbuf ->
let tag = get_prim_arg lexbuf in
top_close_block tag)
;;
2005 def_code "\\@print"
(fun lexbuf ->
let {arg=arg} = save_arg lexbuf in
Dest.put arg) ;
;;
2010
def_code "\\@printnostyle"
(fun lexbuf ->
let {arg=arg} = save_arg lexbuf in
top_open_group () ;
2015 Dest.nostyle () ;
Dest.put arg ;
top_close_group ())
;;
2020 def_code "\\@getprintnostyle"
(fun lexbuf ->
top_open_group () ;
Dest.nostyle () ;
let arg = get_prim_arg lexbuf in
2025 Dest.put arg ;
top_close_group ())
;;
def_code "\\@getprint"
2030 (fun lexbuf ->
let arg = get_prim_arg lexbuf in
let buff = Lexing.from_string arg in
Dest.put (Save.tagout buff)) ;
;;
2035
def_code "\\@subst"
(fun lexbuf ->
let arg = subst_arg lexbuf in
Dest.put arg)
2040 ;;
def_code "\\@notags"
(fun lexbuf ->
let arg = save_arg lexbuf in
2045 let arg = get_this_arg main arg in
let r =
let buff = Lexing.from_string arg in
Save.tagout buff in
Dest.put r)
2050 ;;
def_code "\\@anti"
(fun lexbuf ->
let arg = save_arg lexbuf in
let envs = get_style main arg in
2055 if !verbose > 2 then begin
prerr_string ("Anti result: ") ;
List.iter
(fun s ->
prerr_string (Element.pretty_text s^", ")) envs ;
2060 prerr_endline ""
end ;
Dest.erase_mods envs)
;;
def_code "\\@style"
2065 (fun lexbuf ->
let arg = get_prim_arg lexbuf in
Dest.open_mod (Style arg) )
;;
def_code "\\@fontcolor"
2070 (fun lexbuf ->
let arg = get_prim_arg lexbuf in
Dest.open_mod (Color arg))
;;
def_code "\\@fontsize"
2075 (fun lexbuf ->
let arg = save_arg lexbuf in
Dest.open_mod (Font (Get.get_int arg)) )
;;
def_code "\\@nostyle"
2080 (fun lexbuf -> Dest.nostyle () ; check_alltt_skip lexbuf)
;;
def_code "\\@clearstyle"
(fun lexbuf -> Dest.clearstyle () ; check_alltt_skip lexbuf)
;;
2085 def_code "\\@incsize"
(fun lexbuf ->
let arg = save_arg lexbuf in
inc_size (Get.get_int arg) )
;;
2090 def_code "\\htmlcolor"
(fun lexbuf ->
let arg = get_prim_arg lexbuf in
Dest.open_mod (Color ("\"#"^arg^"\"")) )
;;
2095
def_code "\\usecounter"
(fun lexbuf ->
let arg = get_prim_arg lexbuf in
Counter.set_counter arg 0 ;
2100 scan_this main ("\\let\\@currentlabel\\the"^arg) ;
Dest.set_dcount arg )
;;
def_code "\\@fromlib"
(fun lexbuf ->
2105 let arg = get_prim_arg lexbuf in
start_lexstate ();
Mysys.put_from_file (Filename.concat Mylib.libdir arg) Dest.put;
restore_lexstate ())
;;
2110 def_code "\\@imageflush"
(fun lexbuf ->
iput_newpage () ;
check_alltt_skip lexbuf)
;;
2115 def_code "\\textalltt"
(fun lexbuf ->
let opt = get_prim_opt "CODE" lexbuf in
let arg = save_arg lexbuf in
let old = !alltt in
2120 scan_this main "\\mbox{" ;
alltt := Inside ;
Dest.open_group opt ;
scan_this_arg main arg ;
Dest.close_group () ;
2125 scan_this main "}" ;
alltt := old )
;;
def_code "\\@itemdisplay"
(fun lexbuf -> Dest.force_item_display ())
2130 ;;
def_code "\\@br"
(fun lexbuf -> Dest.skip_line ())
;;
2135
(* TeX conditionals *)
let testif cell lexbuf =
if !cell then check_alltt_skip lexbuf
else skip_false lexbuf
2140
let setif cell b lexbuf =
let old = !cell in
fun_register (fun () -> cell := old) ;
cell := b ;
2145 check_alltt_skip lexbuf
;;
let extract_if name =
let l = String.length name in
2150 if l <= 3 || String.sub name 0 3 <> "\\if" then
raise (Error ("Bad newif: "^name)) ;
String.sub name 3 (l-3)
;;
2155 let def_and_register name f =
def name zero_pat (CamlCode f)
;;
let tverb name cell lexbuf =
2160 if !verbose > 1 then
Printf.fprintf stderr
"Testing %s -> %b\n" name !cell ;
testif cell lexbuf
;;
2165
let newif_ref name cell =
def_and_register ("\\if"^name) (tverb name cell) ;
def_and_register ("\\"^name^"true") (setif cell true) ;
def_and_register ("\\"^name^"false") (setif cell false) ;
2170 register_cell name cell ;
fun_register (fun () -> unregister_cell name)
;;
let newif lexbuf =
2175 let arg = get_csname lexbuf in
let saw_par = !Save.seen_par in
begin try
let name = extract_if arg in
let cell = ref false in
2180 newif_ref name cell ;
with Latexmacros.Failed -> ()
end ;
if saw_par then begin
top_par (par_val !in_table)
2185 end
;;
exception FailedFirst
;;
2190
def_code "\\ifx"
(fun lexbuf ->
let arg1 = get_csname lexbuf in
let arg2 = get_csname lexbuf in
2195 let r =
try
let m1 =
try Latexmacros.find_fail arg1 with
| Failed -> raise FailedFirst in
2200 let m2 = Latexmacros.find_fail arg2 in
m1 = m2
with
| FailedFirst ->
begin
2205 try let _ = Latexmacros.find_fail arg2 in false
with Failed -> true
end
| Failed -> false in
if r then
2210 check_alltt_skip lexbuf
else
skip_false lexbuf)
;;
def_code "\\ifu"
2215 (fun lexbuf ->
let arg1 = get_csname lexbuf in
try
let _ = Latexmacros.find_fail arg1 in
skip_false lexbuf
2220 with
| Failed -> check_alltt_skip lexbuf)
;;
def_code "\\newif" newif
2225 ;;
def_code "\\else" (fun lexbuf -> skip_false lexbuf)
;;
2230 def_code "\\fi" (fun lexbuf -> check_alltt_skip lexbuf)
;;
let sawdocument = ref false
2235 ;;
newif_ref "symb" symbols ;
newif_ref "iso" iso ;
newif_ref "raw" raw_chars ;
2240 newif_ref "silent" silent;
newif_ref "math" in_math ;
newif_ref "mmode" in_math ;
newif_ref "display" display ;
newif_ref "french" french ;
2245 newif_ref "html" html;
newif_ref "text" text;
newif_ref "info" text;
newif_ref "mathml" Parse_opts.mathml;
newif_ref "entities" Parse_opts.entities;
2250 newif_ref "optarg" optarg;
newif_ref "styleloaded" styleloaded;
newif_ref "activebrace" activebrace;
newif_ref "pedantic" pedantic ;
newif_ref "fixpoint" fixpoint ;
2255 newif_ref "alltt@loaded" alltt_loaded ;
newif_ref "filter" (ref filter) ;
newif_ref "@sawdocument" sawdocument ;
def_code "\\iftrue" (testif (ref true)) ;
def_code "\\iffalse" (testif (ref false))
2260 ;;
def_code "\\if@toplevel"
(fun lexbuf ->
if echo_global_toimage () then check_alltt_skip lexbuf
2265 else skip_false lexbuf)
;;
2270 (* Bibliographies *)
let bib_ref s1 s2 =
scan_this main ("\\@bibref{"^s1^"}{"^s2^"}")
;;
2275 def_code "\\cite"
(fun lexbuf ->
let opt = save_opt "" lexbuf in
check_alltt_skip lexbuf ;
let args = List.map subst_this (Save.cite_arg lexbuf) in
2280 Dest.put_char '[' ;
Dest.open_group "CITE" ;
let rec do_rec = function
[] -> ()
| [x] -> bib_ref x (Auxx.bget true x)
2285 | x::rest ->
bib_ref x (Auxx.bget true x) ;
Dest.put ", " ;
do_rec rest in
do_rec args ;
2290 if opt.arg <> "" then begin
Dest.put ", " ;
scan_this_arg main opt ;
end ;
Dest.close_group () ;
2295 Dest.put_char ']' )
;;
(* Includes *)
def_code "\\includeonly"
2300 (fun lexbuf ->
let arg = Save.cite_arg lexbuf in
add_includes arg )
;;
2305 (* Foot notes *)
def_code "\\@stepanchor"
(fun lexbuf ->
let mark = Get.get_int (save_arg lexbuf) in
2310 Foot.step_anchor mark) ;
def_code "\\@anchorval"
(fun lexbuf ->
let mark = Get.get_int (save_arg lexbuf) in
Dest.put (string_of_int (Foot.get_anchor mark)))
2315 ;;
def_code "\\@footnotetext"
(fun lexbuf ->
start_lexstate () ;
2320 let mark = Get.get_int (save_arg lexbuf) in
let text = save_arg lexbuf in
let text =
do_get_this
start_normal end_normal Dest.clearstyle
2325 main text in
Foot.register
mark
(get_this_string main ("\\@fnmarknote{"^string_of_int mark^"}"))
text ;
2330 restore_lexstate ())
;;
def_code "\\@footnoteflush"
(fun lexbuf ->
2335 let sec_here = get_prim_arg lexbuf
and sec_notes = get_prim "\\@footnotelevel" in
start_lexstate () ;
Foot.flush (scan_this main) sec_notes sec_here ;
restore_lexstate ())
2340 ;;
(* Opening and closing environments *)
2345 def_code "\\begin"
(fun lexbuf ->
let cur_subst = get_subst () in
let env = get_prim_arg lexbuf in
new_env env ;
2350 top_open_block "" "" ;
let macro = start_env env in
let old_envi = save stack_entry in
push stack_entry env ;
begin try
2355 expand_command main no_skip macro lexbuf
with
| e ->
restore stack_entry old_envi ;
raise e
2360 end ;
restore stack_entry old_envi)
;;
2365 def_code "\\@begin"
(fun lexbuf ->
let env = get_prim_arg lexbuf in
new_env env ;
top_open_block "" "")
2370 ;;
def_code "\\end"
(fun lexbuf ->
let env = get_prim_arg lexbuf in
2375 expand_command main no_skip ("\\end"^env) lexbuf ;
close_env env ;
top_close_block "")
;;
2380 def_code "\\@raise@enddocument"
(fun _ ->
if not !sawdocument then
fatal ("\\end{document} with no \\begin{document}")
else if not (Stack.empty stack_env) then
2385 error_env "document" !cur_env
else
raise Misc.EndDocument)
;;
2390 def_code "\\@end"
(fun lexbuf ->
let env = get_prim_arg lexbuf in
top_close_block "" ;
close_env env)
2395 ;;
let little_more lexbuf =
to_newline lexbuf ;
Out.to_string more_buff
2400 ;;
def_code "\\endinput" (fun lexbuf ->
let reste = little_more lexbuf in
scan_this main reste ;
2405 raise Misc.EndInput)
;;
(* Boxes *)
2410 def_code "\\mbox" (fun lexbuf -> mbox_arg lexbuf)
;;
2415 def_code "\\newsavebox"
(fun lexbuf ->
let name = get_csname lexbuf in
try
let _ = find_fail name in
2420 warning ("Not (re-)defining ``"^name^"'' with \\newsavebox")
with
| Failed ->
global_def name zero_pat (CamlCode (fun _ -> ())))
;;
2425
def_code "\\providesavebox"
(fun lexbuf ->
let name = get_csname lexbuf in
try
2430 let _ = find_fail name in ()
with
| Failed ->
global_def name zero_pat (CamlCode (fun _ -> ())))
;;
2435
let caml_print s = CamlCode (fun _ -> Dest.put s)
let do_sbox global name body =
if not (Latexmacros.exists name) then
2440 warning ("\\sbox on undefined bin ``"^name^"''") ;
start_mbox () ;
let to_print = get_this_arg main body in
top_close_group () ;
(if global then global_def else def) name zero_pat (caml_print to_print)
2445 ;;
def_code "\\savebox"
(fun lexbuf ->
let name = get_csname lexbuf in
2450 warning "savebox";
skip_opt lexbuf ;
skip_opt lexbuf ;
let body = save_arg lexbuf in
do_sbox false name body)
2455 ;;
def_code "\\sbox"
(fun lexbuf ->
let name = get_csname lexbuf in
2460 let body = save_arg lexbuf in
do_sbox false name body) ;
def_code "\\gsbox"
(fun lexbuf ->
2465 let name = get_csname lexbuf in
let body = save_arg lexbuf in
do_sbox true name body) ;
;;
2470 def_code "\\usebox"
(fun lexbuf ->
let name = get_csname lexbuf in
top_open_group () ;
Dest.nostyle () ;
2475 expand_command main skip_blanks name lexbuf ;
top_close_group ())
;;
def_code "\\lrbox"
2480 (fun lexbuf ->
close_env "lrbox" ;
push stack_display !display ;
display := false ;
let name = get_csname lexbuf in
2485 Dest.open_aftergroup
(fun s ->
def name zero_pat (caml_print s) ;
"") ;
start_mbox ())
2490 ;;
def_code "\\endlrbox"
(fun _ ->
top_close_group () ; (* close mbox *)
2495 Dest.close_group () ; (* close after group *)
display := pop stack_display ;
new_env "lrbox")
;;
2500
(* chars *)
def_code "\\char"
(fun lexbuf ->
let arg = get_num_arg lexbuf in
2505 if not !silent && (arg < 32 || (arg > 127 && arg < 161)) then begin
Location.print_pos () ;
prerr_endline ("Warning: \\char, check output");
end ;
Dest.put (Dest.iso (Char.chr arg)) ;
2510 if not (effective !alltt) then check_alltt_skip lexbuf)
;;
def_code "\\symbol"
(fun lexbuf ->
2515 let arg = get_prim_arg lexbuf in
scan_this main ("\\char"^arg))
;;
(* labels *)
2520
(* Counters *)
let alpha_of_int i = String.make 1 (Char.chr (i-1+Char.code 'a'))
and upalpha_of_int i = String.make 1 (Char.chr (i-1+Char.code 'A'))
;;
2525
let rec roman_of_int = function
0 -> ""
| 1 -> "i"
| 2 -> "ii"
2530 | 3 -> "iii"
| 4 -> "iv"
| 9 -> "ix"
| i ->
if i < 9 then "v"^roman_of_int (i-5)
2535 else
let d = i / 10 and u = i mod 10 in
String.make d 'x'^roman_of_int u
;;
2540 let uproman_of_int i = String.uppercase (roman_of_int i)
;;
let fnsymbol_of_int = function
0 -> " "
2545 | 1 -> "*"
| 2 -> "#"
| 3 -> "%"
| 4 -> "\167"
| 5 -> "\182"
2550 | 6 -> "||"
| 7 -> "**"
| 8 -> "##"
| 9 -> "%%"
| i -> alpha_of_int (i-9)
2555 ;;
let def_printcount name f =
def_code name
(fun lexbuf ->
2560 let cname = get_prim_arg lexbuf in
let cval = Counter.value_counter cname in
Dest.put (f cval))
;;
2565 def_printcount "\\arabic" string_of_int ;
def_printcount "\\alph" alpha_of_int ;
def_printcount "\\Alph" upalpha_of_int ;
def_printcount "\\roman" roman_of_int;
def_printcount "\\Roman" uproman_of_int;
2570 def_printcount "\\fnsymbol" fnsymbol_of_int
;;
let pad p l s =
for i = l-String.length s downto 1 do
2575 Dest.put (Dest.iso_string p)
done
;;
def_code "\\@pad"
2580 (fun lexbuf ->
let p = get_prim_arg lexbuf in
let l = Get.get_int (save_arg lexbuf) in
let arg = get_prim_arg lexbuf in
pad p l arg ;
2585 Dest.put (Dest.iso_string arg))
;;
def_code "\\newcounter"
(fun lexbuf ->
2590 Save.start_echo () ;
let name = get_prim_arg lexbuf in
let within = get_prim_opt "" lexbuf in
let real_args = Save.get_echo () in
if echo_global_toimage () then begin
2595 Image.put "\\newcounter" ;
Image.put real_args ;
Image.put_char '\n'
end ;
do_newcounter name within)
2600 ;;
def_code "\\addtocounter"
(fun lexbuf ->
Save.start_echo () ;
2605 let name = get_prim_arg lexbuf in
let arg = save_arg lexbuf in
let real_args = Save.get_echo () in
if echo_global_toimage () then begin
Image.put "\\addtocounter" ;
2610 Image.put real_args ;
Image.put_char '\n'
end ;
Counter.add_counter name (Get.get_int arg))
;;
2615
def_code "\\setcounter"
(fun lexbuf ->
Save.start_echo () ;
let name = get_prim_arg lexbuf in
2620 let arg = save_arg lexbuf in
let real_args = Save.get_echo () in
if echo_global_toimage () then begin
Image.put "\\setcounter" ;
Image.put real_args ;
2625 Image.put_char '\n'
end ;
Counter.set_counter name (Get.get_int arg) )
;;
2630 def_code "\\stepcounter"
(fun lexbuf ->
Save.start_echo () ;
let name = get_prim_arg lexbuf in
let real_args = Save.get_echo () in
2635 if echo_global_toimage () then begin
Image.put "\\stepcounter" ;
Image.put real_args ;
Image.put_char '\n'
end ;
2640 Counter.step_counter name)
;;
(* terminal output *)
def_code "\\typeout"
2645 (fun lexbuf ->
let what = get_prim_arg lexbuf in
prerr_endline what )
;;
2650 def_code "\\warning"
(fun lexbuf ->
let what = subst_arg lexbuf in
warning what )
;;
2655
(* spacing *)
let stack_closed = Stack.create "stack_closed"
;;
2660
def_code "\\@saveclosed"
(fun lexbuf ->
push stack_closed (Dest.get_last_closed ()) ;
check_alltt_skip lexbuf)
2665 ;;
def_code "\\@restoreclosed"
(fun lexbuf ->
Dest.set_last_closed (pop stack_closed) ;
2670 check_alltt_skip lexbuf)
;;
exception Cannot
;;
2675
def_code "\\@getlength"
(fun lexbuf ->
let arg = get_prim_arg lexbuf in
let pxls =
2680 match Get.get_length arg with
| Length.Pixel n -> n
| Length.Char n -> Length.char_to_pixel n
| _ -> 0 in
Dest.put (string_of_int (pxls/2)))
2685 ;;
let do_space vert lexbuf =
let arg = subst_arg lexbuf in
begin try
2690 let n = match Length.main (Lexing.from_string arg) with
| Length.Char n -> n
| Length.Pixel n -> Length.pixel_to_char n
| _ -> raise Cannot in
if vert then
2695 for i=1 to n do
Dest.skip_line ()
done
else
for i=1 to n do
2700 Dest.put_nbsp (); (* " "*)
done
with Cannot ->
warning ((if vert then "\\vspace" else "\\hspace")^
" with arg ``"^arg^"''")
2705 end
;;
def_code "\\hspace" (fun lexbuf -> do_space false lexbuf) ;
def_code "\\vspace" (fun lexbuf -> do_space true lexbuf)
2710 ;;
(* Explicit groups *)
def_code "\\begingroup"
(fun lexbuf ->
2715 new_env "command-group" ; top_open_block "" "" ;
check_alltt_skip lexbuf)
;;
def_code "\\endgroup"
2720 (fun lexbuf ->
top_close_block "" ; close_env !cur_env ;
check_alltt_skip lexbuf)
;;
2725 (* alltt *)
register_init "alltt"
(fun () ->
def_code "\\alltt"
2730 (fun _ ->
if !verbose > 1 then prerr_endline "begin alltt" ;
alltt := Inside ;
fun_register (fun () -> alltt := Not) ;
Dest.close_block "" ; Dest.open_block "PRE" "") ;
2735
def_code "\\endalltt"
(fun _ ->
if !verbose > 1 then prerr_endline "end alltt" ;
Dest.close_block "PRE" ; Dest.open_block "" ""))
2740 ;;
(* Multicolumn *)
def_code "\\multicolumn"
2745 (fun lexbuf ->
if not (is_table !in_table) then
raise (ScanError "\\multicolumn should occur in some array") ;
let n = Get.get_int (save_arg lexbuf) in
let format = Tabular.main (save_arg lexbuf) in
2750 do_multi n format main)
;;
def_code "\\hline"
(fun lexbuf ->
2755 if not (is_table !in_table) then
raise (ScanError "\\hline should occur in some array") ;
do_hline main ;
skip_blanks_pop lexbuf ;
let _ = Dest.forget_par () in
2760 ())
;;
(* inside tabbing *)
let do_tabul lexbuf =
2765 if is_tabbing !in_table then begin
do_unskip () ;
Dest.close_cell ""; Dest.open_cell default_format 1 0
end ;
skip_blanks_pop lexbuf
2770 ;;
def_code "\\>" do_tabul ;
def_code "\\=" do_tabul
;;
2775
def_code "\\kill"
(fun lexbuf ->
if is_tabbing !in_table then begin
do_unskip () ;
2780 Dest.close_cell "";
Dest.erase_row () ;
Dest.new_row () ;
Dest.open_cell default_format 1 0
end ;
2785 skip_blanks_pop lexbuf)
;;
(* Tabular and arrays *)
2790
let check_width = function
| Length.Char x ->
" WIDTH="^string_of_int (Length.char_to_pixel x)
2795 | Length.Pixel x ->
" WIDTH="^string_of_int x
| Length.Percent x ->
" WIDTH=\""^string_of_int x^"%\""
| _ -> ""
2800 ;;
let get_table_attributes border len =
let attrs = get_prim
(if border then
2805 "\\@table@attributes@border"
else
"\\@table@attributes") in
attrs^check_width len
2810
let open_tabbing lexbuf =
let lexbuf = Lexstate.previous_lexbuf in
let lexfun lb =
Dest.open_table false "border=0 cellspacing=0 cellpadding=0" ;
2815 Dest.new_row ();
Dest.open_cell default_format 1 0 in
push stack_table !in_table ;
in_table := Tabbing ;
new_env "tabbing" ;
2820 def "\\a" zero_pat
(CamlCode
(fun lexbuf ->
let acc = subst_arg lexbuf in
let arg = subst_arg lexbuf in
2825 scan_this main ("\\"^acc^arg))) ;
lexfun lexbuf
;;
def_code "\\tabbing" open_tabbing
2830 ;;
let close_tabbing _ =
Dest.do_close_cell ();
Dest.close_row ();
2835 Dest.close_table ();
in_table := pop stack_table ;
close_env "tabbing" ;
;;
2840 def_code "\\endtabbing" close_tabbing
;;
let open_array env lexbuf =
save_array_state ();
2845 Tabular.border := false ;
let len = match env with
| "tabular*"|"Tabular*" ->
let arg = save_arg lexbuf in
begin match Get.get_length (get_prim_onarg arg) with
2850 | Length.No s ->
warning ("``tabular*'' with length argument: "^
do_subst_this arg) ;
Length.Default
| width -> width
2855 end
| _ -> Length.Default in
let attributes = match env with
| "Tabular*" | "Array" | "Tabular" -> get_prim_opt "" lexbuf
| _ -> skip_opt lexbuf ; "" in
2860 skip_opt lexbuf ;
let format = save_arg lexbuf in
let format = Tabular.main format in
cur_format := format ;
push stack_in_math !in_math ;
2865 in_table := Table
{math = (env = "array") ;
border = !Tabular.border} ;
if !display then Dest.item_display () ;
in_math := false ;
2870 push stack_display !display ;
display := false ;
begin match attributes with
| "" ->
if !Tabular.border then
2875 Dest.open_table true (get_table_attributes true len)
else
Dest.open_table false (get_table_attributes false len);
| _ ->
Dest.open_table !Tabular.border (attributes^check_width len)
2880 end ;
open_row() ;
open_first_col main ;
skip_blanks_pop lexbuf ;
;;
2885
def_code "\\@array" (open_array "array") ;
def_code "\\@tabular" (open_array "tabular") ;
def_code "\\@tabular*" (open_array "tabular*")
;;
2890 def_code "\\@Array" (open_array "Array") ;
def_code "\\@Tabular" (open_array "Tabular") ;
def_code "\\@Tabular*" (open_array "Tabular*")
;;
2895
let close_array _ =
do_unskip () ;
close_last_col main "" ;
close_last_row () ;
2900 Dest.close_table () ;
restore_array_state () ;
in_math := pop stack_in_math ;
display := pop stack_display;
if !display then Dest.item_display () ;
2905 ;;
def_code "\\end@array" close_array ;
def_code "\\end@tabular" close_array ;
def_code "\\end@tabular*" close_array ;
2910 def_code "\\end@Array" close_array ;
def_code "\\end@Tabular" close_array ;
def_code "\\end@Tabular*" close_array ;
;;
2915
let do_amper lexbuf =
if effective !alltt || not (is_plain '&') then begin
let lxm = lexeme lexbuf in
for i = 0 to String.length lxm -1 do
2920 Dest.put (Dest.iso lxm.[i])
done
end else if is_table !in_table then begin
close_col main " ";
open_col main
2925 end ;
if not (effective !alltt) && is_plain '&' then skip_blanks_pop lexbuf
and do_bsbs lexbuf =
do_unskip () ;
2930 skip_opt lexbuf ;
if is_table !in_table then begin
close_col main " " ; close_row () ;
open_row () ; open_first_col main
end else if is_tabbing !in_table then begin
2935 Dest.close_cell "";
Dest.close_row () ;
Dest.new_row () ;
Dest.open_cell default_format 1 0
end else begin
2940 if !display then
warning "\\\\ in display mode, ignored"
else
Dest.skip_line ()
end ;
2945 skip_blanks_pop lexbuf ;
let _ = Dest.forget_par () in ()
;;
def_code "\\@hevea@amper" do_amper ;
2950 def_code "\\\\" do_bsbs ;
def_code "\\@HEVEA@amper" do_amper ;
def_code "\\@HEVEA@bsbs" do_bsbs ; ()
;;
2955
(* Other scanners *)
def_code "\\latexonly"
(fun lexbuf ->
2960 start_other_scan "latexonly" latexonly lexbuf)
;;
def_code "\\toimage"
(fun lexbuf ->
2965 start_image_scan "" image lexbuf)
;;
def_code "\\@stopimage"
(fun lexbuf ->
2970 Image.stop () ;
check_alltt_skip lexbuf)
;;
def_code "\\@restartimage"
2975 (fun lexbuf ->
Image.restart () ;
check_alltt_skip lexbuf)
;;
2980
def_code "\\@stopoutput"
(fun lexbuf ->
Dest.stop () ;
2985 check_alltt_skip lexbuf)
;;
def_code "\\@restartoutput"
(fun lexbuf ->
2990 Dest.restart () ;
check_alltt_skip lexbuf)
;;
2995 (* Info format specific *)
def_code "\\@infomenu"
(fun lexbuf ->
let arg = get_prim_arg lexbuf in
3000 Dest.infomenu arg)
;;
def_code "\\@infonode"
(fun lexbuf ->
3005 let opt = get_prim_opt "" lexbuf in
let num = get_prim_arg lexbuf in
let nom = get_prim_arg lexbuf in
Dest.infonode opt num nom)
;;
3010
def_code "\\@infoextranode"
(fun lexbuf ->
let num = get_prim_arg lexbuf in
let nom = get_prim_arg lexbuf in
3015 let text = get_prim_arg lexbuf in
Dest.infoextranode num nom text)
;;
def_code "\\@infoname"
3020 (fun lexbuf ->
let arg = get_prim_arg lexbuf in
Dest.loc_name arg)
;;
3025 let safe_len = function
| Length.No _ -> Length.Default
| l -> l
;;
3030 def_code "\\@printHR"
(fun lexbuf ->
let arg = get_prim_arg lexbuf in
let taille = safe_len (Get.get_length (get_prim_arg lexbuf)) in
Dest.horizontal_line arg taille (Length.Pixel 2))
3035 ;;
def_code"\\@hr"
(fun lexbuf ->
let attr = subst_opt "" lexbuf in
3040 let width = safe_len (Get.get_length (get_prim_arg lexbuf)) in
let height = safe_len (Get.get_length (get_prim_arg lexbuf)) in
Dest.horizontal_line attr width height)
;;
3045 (* Accents *)
let aigu = function
"a" -> "" | "e" -> "e" | "i" | "\\i" | "\\i " -> ""
| "o" -> "" | "u" -> ""
| "A" -> "" | "E" -> "E" | "I" | "\\I" | "\\I " -> ""
3050 | "O" -> "" | "U" -> ""
| "y" -> "" | "Y" -> ""
| "" | " " -> "'"
| s -> s
3055 and grave = function
"a" -> "a" | "e" -> "e" | "i" -> ""
| "o" -> "" | "u" -> "" | "\\i" | "\\i " -> ""
| "A" -> "A" | "E" -> "E" | "I" -> ""
| "O" -> "" | "U" -> "" | "\\I" | "\\I " -> ""
3060 | "" | " " -> "`"
| s -> s
and circonflexe = function
"a" -> "a" | "e" -> "e" | "i" -> "i"
| "o" -> "o" | "u" -> "u" | "\\i" | "\\i " -> "i"
3065 | "A" -> "A" | "E" -> "E" | "I" -> "I"
| "O" -> "O" | "U" -> "U" | "\\I" | "\\I " -> "I"
| "" | " " -> "\\@print{^}"
| s -> s
3070 and trema = function
"a" -> "" | "e" -> "e" | "i" -> "i"
| "o" -> "" | "u" -> "u" | "\\i" | "\\i " -> "i"
| "A" -> "" | "E" -> "E" | "I" -> "I"
| "O" -> "" | "U" -> "U" | "\\I" | "\\I " -> "I"
3075 | "" | " " -> ""
| s -> s
and cedille = function
"c" -> "c"
3080 | "C" -> "C"
| s -> s
and tilde = function
"a" -> "" | "A" -> ""
3085 | "o" -> "" | "O" -> ""
| "n" -> "" | "N" -> ""
| "" | " " -> "\\@print{~}"
| s -> s
;;
3090
def_fun "\\'" aigu ;
def_fun "\\`" grave ;
3095 def_fun "\\^" circonflexe ;
def_fun "\\\"" trema ;
def_fun "\\c" cedille ;
def_fun "\\~" tilde
;;
3100
Get.init
get_prim_onarg
get_fun_result
new_env close_env
3105 get_csname
main
;;
def_code "\\@primitives"
3110 (fun lexbuf ->
let pkg = get_prim_arg lexbuf in
exec_init pkg)
;;
3115 (* try e1 with _ -> e2 *)
def_code "\\@try"
(fun lexbuf ->
let saved_location = Location.check ()
3120 and env_saved = env_check ()
and saved = Hot.checkpoint ()
and saved_lexstate = Lexstate.check_lexstate ()
and saved_out = Dest.check ()
and saved_get = Get.check ()
3125 and saved_aux = Auxx.check () in
let e1 = save_arg lexbuf in
let e2 = save_arg lexbuf in
try
top_open_block "TEMP" "" ;
3130 scan_this_arg main e1 ;
top_close_block "TEMP"
with e -> begin
Location.hot saved_location ;
env_hot env_saved ;
3135 Misc.print_verb 0
("\\@try caught exception : "^Printexc.to_string e) ;
Lexstate.hot_lexstate saved_lexstate ;
Dest.hot saved_out ;
Get.hot saved_get ;
3140 Auxx.hot saved_aux ;
Hot.start saved ;
scan_this_arg main e2
end)
;;
3145
def_code "\\@heveafail"
(fun lexbuf ->
let s = get_prim_arg lexbuf in
raise (Misc.Purposly s))
3150 ;;
(*
(* A la TeX ouput (more or less...) *)
3155 def_code "\\newwrite"
(fun lexbuf ->
let cmd = save_arg lexbuf in
let file = ref stderr in
def_code cmd
3160 (fun lexbuf ->
let op = save_arg lexbuf in
try
match op with
| "\\write" ->
3165 let what = subst_arg subst lexbuf in
output_string !file what ;
output_char !file '\n'
| "\\closeout" ->
close_out !file
3170 | "\\openout" ->
let name = get_this_nostyle main (save_filename lexbuf) in
file := open_out name
| _ ->
warning ("Unkown file operation: "^op)
3175 with Sys_error s ->
warning ("TeX file error : "^s)))
;;
let def_fileop me =
3180 def_code me
(fun lexbuf ->
let cmd = subst_arg lexbuf in
scan_this_may_cont main lexbuf (cmd^me))
;;
3185
def_fileop "\\write" ;
def_fileop "\\openout" ;
def_fileop "\\closeout"
;;
3190 *)
end}
<6>8 length.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: length.mll,v 1.13 2001/06/06 16:52:52 maranget Exp $ *)
(***********************************************************************)
{
open Lexing
15 let header = "$Id: length.mll,v 1.13 2001/06/06 16:52:52 maranget Exp $"
exception Cannot
;;
20 let font = 10
;;
let font_float = float font
;;
25 type t =
Char of int | Pixel of int | Percent of int | No of string | Default
let pretty = function
| Char x -> string_of_int x^" chars"
30 | Pixel x -> string_of_int x^" pxls"
| Percent x -> string_of_int x^"%"
| Default -> "default"
| No s -> "*"^s^"*"
35 let pixel_to_char x = (100 * x + 50)/(100 * font)
and char_to_pixel x = font * x
let mk_char x = Char (truncate (0.5 +. x))
let mk_pixel x = Pixel (truncate (0.5 +. x))
40 and mk_percent x = Percent (truncate x)
;;
let convert unit x = match unit with
| "ex"|"em" -> mk_char x
45 | "pt" -> mk_pixel x
| "in" -> mk_char ((x *. 72.27) /. font_float)
| "cm" -> mk_char ((x *. 28.47) /. font_float)
| "mm" -> mk_char ((x *. 2.847) /. font_float)
| "pc" -> mk_char ((x *. 12.0) /. font_float)
50 | "@percent" -> mk_percent (100.0 *. x)
| _ -> No unit
;;
}
55
rule main_rule = parse
'-' {let x,unit = positif lexbuf in convert unit (0.0 -. x)}
| "" {let x,unit = positif lexbuf in convert unit x}
60 and positif = parse
| ['0'-'9']*'.'?['0'-'9']+
{let lxm = lexeme lexbuf in
float_of_string lxm,unit lexbuf}
| "@percent" {1.0, "@percent"}
65 | "" {raise Cannot}
and unit = parse
| [' ''\n''\t''\r']+ {unit lexbuf}
| [^' ''\n''\t''\r']* {lexeme lexbuf}
70 {
open Lexing
let main lexbuf =
try main_rule lexbuf with
75 | Cannot ->
let sbuf = lexbuf.lex_buffer in
No (String.sub sbuf 0 lexbuf.lex_buffer_len)
}
<6>9 save.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 Misc
15
let header = "$Id: save.mll,v 1.60 2001/02/12 10:05:39 maranget Exp $"
let rec if_next_char c lb =
if lb.lex_eof_reached then
20 false
else
let pos = lb.lex_curr_pos
and len = lb.lex_buffer_len in
if pos >= len then begin
25 warning "Refilling buffer" ;
lb.refill_buff lb ;
if_next_char c lb
end else
lb.lex_buffer.[pos] = c
30
let rec if_next_string s lb =
if s = "" then
true
else
35 let pos = lb.lex_curr_pos
and len = lb.lex_buffer_len
and slen = String.length s in
if pos + slen - 1 >= len then begin
if lb.lex_eof_reached then begin
40 false
end else begin
lb.refill_buff lb ;
if_next_string s lb
end
45 end else
String.sub lb.lex_buffer pos slen = s
let verbose = ref 0 and silent = ref false
;;
50
let set_verbose s v =
silent := s ; verbose := v
;;
55 exception Error of string
;;
exception Delim of string
;;
60 let seen_par = ref false
;;
let brace_nesting = ref 0
65 and arg_buff = Out.create_buff ()
and echo_buff = Out.create_buff ()
and tag_buff = Out.create_buff ()
;;
70
let echo = ref false
;;
let get_echo () = echo := false ; Out.to_string echo_buff
75 and start_echo () = echo := true ; Out.reset echo_buff
and stop_echo () = echo := false ; Out.reset echo_buff
;;
let empty_buffs () =
80 brace_nesting := 0 ; Out.reset arg_buff ;
echo := false ; Out.reset echo_buff ;
Out.reset tag_buff
;;
85 let error s =
empty_buffs () ;
raise (Error s)
;;
90 let my_int_of_string s =
try int_of_string s
with Failure "int_of_string" ->
error ("Integer argument expected: ``"^s^"''")
95 exception Eof
;;
exception NoOpt
;;
100 let put_echo s =
if !echo then Out.put echo_buff s
and put_echo_char c =
if !echo then Out.put_char echo_buff c
and blit_echo lb =
105 if !echo then Out.blit echo_buff lb
;;
let put_both s =
put_echo s ; Out.put arg_buff s
110 ;;
let blit_both lexbuf =
blit_echo lexbuf ; Out.blit arg_buff lexbuf
let put_both_char c =
115 put_echo_char c ; Out.put_char arg_buff c
;;
type kmp_t = Continue of int | Stop of string
120 let rec kmp_char delim next i c =
if i < 0 then begin
Out.put_char arg_buff c ;
Continue 0
end else if c = delim.[i] then begin
125 if i >= String.length delim - 1 then
Stop (Out.to_string arg_buff)
else
Continue (i+1)
end else begin
130 if next.(i) >= 0 then
Out.put arg_buff (String.sub delim 0 (i-next.(i))) ;
kmp_char delim next next.(i) c
end
}
135 let command_name = '\\' (( ['@''A'-'Z' 'a'-'z']+ '*'?) | [^ 'A'-'Z' 'a'-'z'])
let space = [' ''\t''\r']
rule opt = parse
| space* '\n'? space* '['
140 {put_echo (lexeme lexbuf) ;
opt2 lexbuf}
| eof {raise Eof}
| "" {raise NoOpt}
145
and opt2 = parse
| '{' {incr brace_nesting;
put_both_char '{' ; opt2 lexbuf}
| '}' { decr brace_nesting;
150 if !brace_nesting >= 0 then begin
put_both_char '}' ; opt2 lexbuf
end else begin
error "Bad brace nesting in optional argument"
end}
155 | ']'
{if !brace_nesting > 0 then begin
put_both_char ']' ; opt2 lexbuf
end else begin
put_echo_char ']' ;
160 Out.to_string arg_buff
end}
| _
{let s = lexeme_char lexbuf 0 in
put_both_char s ; opt2 lexbuf }
165
and skip_comment = parse
| eof {()}
| '\n' space* {()}
| _ {skip_comment lexbuf}
170
and check_comment = parse
| '%' {skip_comment lexbuf}
| "" {()}
175 and arg = parse
space+ | '\n'+ {put_echo (lexeme lexbuf) ; arg lexbuf}
| '{'
{incr brace_nesting;
put_echo_char '{' ;
180 arg2 lexbuf}
| '%'
{skip_comment lexbuf ; arg lexbuf}
| "\\box" '\\' (['A'-'Z' 'a'-'z']+ '*'? | [^ 'A'-'Z' 'a'-'z'])
{let lxm = lexeme lexbuf in
185 put_echo lxm ;
lxm}
| command_name
{blit_both lexbuf ;
skip_blanks lexbuf}
190 | '#' ['1'-'9']
{let lxm = lexeme lexbuf in
put_echo lxm ; lxm}
| [^ '}']
{let c = lexeme_char lexbuf 0 in
195 put_both_char c ;
Out.to_string arg_buff}
| eof {raise Eof}
| "" {error "Argument expected"}
200
and first_char = parse
| _
{let lxm = lexeme_char lexbuf 0 in
put_echo_char lxm ;
205 lxm}
| eof {raise Eof}
and rest = parse
| _ * eof
210 {let lxm = lexeme lexbuf in
put_echo lxm ;
lxm}
and skip_blanks = parse
215 | space* '\n'
{seen_par := false ;
put_echo (lexeme lexbuf) ;
more_skip lexbuf}
| space*
220 {put_echo (lexeme lexbuf) ; Out.to_string arg_buff}
and more_skip = parse
(space* '\n' space*)+
{seen_par := true ;
225 put_echo (lexeme lexbuf) ;
more_skip lexbuf}
| ""
{Out.to_string arg_buff}
230 and skip_equal = parse
space* '='? space* {()}
and arg2 = parse
'{'
235 {incr brace_nesting;
put_both_char '{' ;
arg2 lexbuf}
| '}'
{decr brace_nesting;
240 if !brace_nesting > 0 then begin
put_both_char '}' ; arg2 lexbuf
end else begin
put_echo_char '}' ;
Out.to_string arg_buff
245 end}
| "\\{" | "\\}" | "\\\\"
{blit_both lexbuf ; arg2 lexbuf }
| eof
{error "End of file in argument"}
250
| [^'\\''{''}']+
{blit_both lexbuf ; arg2 lexbuf }
| _
255 {let c = lexeme_char lexbuf 0 in
put_both_char c ; arg2 lexbuf}
and csname = parse
(space|'\n')+
260 {(fun get_prim subst ->
blit_echo lexbuf ; csname lexbuf get_prim subst)}
| '{'? "\\csname" space*
{(fun get_prim subst_fun ->
blit_echo lexbuf ;
265 let r = incsname lexbuf in
"\\"^get_prim r)}
| "" {fun get_prim subst -> let r = arg lexbuf in subst r}
and incsname = parse
270 "\\endcsname" '}'?
{let lxm = lexeme lexbuf in
put_echo lxm ; Out.to_string arg_buff}
| _
{put_both_char (lexeme_char lexbuf 0) ;
275 incsname lexbuf}
| eof {error "End of file in command name"}
and cite_arg = parse
space* '{' {cite_args_bis lexbuf}
280 | "" {error "No opening ``{'' in citation argument"}
and cite_args_bis = parse
(space|[^'}''\n''%'','])* {let lxm = lexeme lexbuf in lxm::cite_args_bis lexbuf}
| '%' [^'\n']* '\n' {cite_args_bis lexbuf}
285 | ',' {cite_args_bis lexbuf}
| (space|'\n')+ {cite_args_bis lexbuf}
| '}' {[]}
| "" {error "Bad syntax for \\cite argument"}
290 and num_arg = parse
| (space|'\n')+ {(fun get_int -> num_arg lexbuf get_int)}
| ['0'-'9']+
{fun get_int ->
let lxm = lexeme lexbuf in
295 my_int_of_string lxm}
| "'" ['0'-'7']+
{fun get_int ->let lxm = lexeme lexbuf in
my_int_of_string ("0o"^String.sub lxm 1 (String.length lxm-1))}
| '"' ['0'-'9' 'a'-'f' 'A'-'F']+
300 {fun get_int ->let lxm = lexeme lexbuf in
my_int_of_string ("0x"^String.sub lxm 1 (String.length lxm-1))}
| '`' '\\' _
{fun get_int ->let c = lexeme_char lexbuf 2 in
Char.code c}
305 | '`' '#' ['1'-'9']
{fun get_int ->
let lxm = lexeme lexbuf in
get_int (String.sub lxm 1 2)}
| '`' _
310 {fun get_int ->let c = lexeme_char lexbuf 1 in
Char.code c}
| ""
{fun get_int ->
let s = arg lexbuf in
315 get_int s}
and filename = parse
[' ''\n']+ {put_echo (lexeme lexbuf) ; filename lexbuf}
320 | [^'\n''{'' ']+ {let lxm = lexeme lexbuf in put_echo lxm ; lxm}
| "" {arg lexbuf}
and get_limits = parse
space+ {get_limits lexbuf}
325 | "\\limits" {Some Limits}
| "\\nolimits" {Some NoLimits}
| "\\intlimits" {Some IntLimits}
| eof {raise Eof}
| "" {None}
330
and get_sup = parse
| space* '^' {try Some (arg lexbuf) with Eof -> error "End of file after ^"}
| eof {raise Eof}
| "" {None}
335
and get_sub = parse
| space* '_' {try Some (arg lexbuf) with Eof -> error "End of file after _"}
| eof {raise Eof}
340 | "" {None}
and defargs = parse
| '#' ['1'-'9']
{let lxm = lexeme lexbuf in
345 put_echo lxm ;
lxm::defargs lexbuf}
| [^'{'] | "\\{"
{blit_both lexbuf ;
let r = in_defargs lexbuf in
350 r :: defargs lexbuf}
| "" {[]}
and in_defargs = parse
| "\\{" | "\\#" {blit_both lexbuf ; in_defargs lexbuf}
355 | [^'{''#'] {put_both_char (lexeme_char lexbuf 0) ; in_defargs lexbuf}
| "" {Out.to_string arg_buff}
and get_defargs = parse
[^'{']* {let r = lexeme lexbuf in r}
360
and tagout = parse
| "<BR>" {Out.put_char tag_buff ' ' ; tagout lexbuf}
| '<' {intag lexbuf}
| " " {Out.put tag_buff " " ; tagout lexbuf}
365 | ">" {Out.put tag_buff ">" ; tagout lexbuf}
| "<" {Out.put tag_buff "<" ; tagout lexbuf}
| _ {Out.blit tag_buff lexbuf ; tagout lexbuf}
| eof {Out.to_string tag_buff}
370 and intag = parse
'>' {tagout lexbuf}
| '"' {instring lexbuf}
| _ {intag lexbuf}
| eof {Out.to_string tag_buff}
375
and instring = parse
'"' {intag lexbuf}
| '\\' '"' {instring lexbuf}
| _ {instring lexbuf}
380 | eof {Out.to_string tag_buff}
and checklimits = parse
"\\limits" {true}
385 | "\\nolimits" {false}
| "" {false}
and eat_delim_init = parse
| eof {raise Eof}
390 | '{'
{fun delim next _ ->
put_echo_char '{' ;
incr brace_nesting ;
let r = arg2 lexbuf in
395 check_comment lexbuf ;
if if_next_string delim lexbuf then begin
skip_delim_rec lexbuf delim 0 ;
r
end else begin
400 Out.put_char arg_buff '{' ;
Out.put arg_buff r ;
Out.put_char arg_buff '}' ;
eat_delim_rec lexbuf delim next 0
end}
405 | "" {eat_delim_rec lexbuf}
and eat_delim_rec = parse
| "\\{"
{fun delim next i ->
410 put_echo "\\{" ;
match kmp_char delim next i '\\' with
| Stop _ ->
error "Delimitors cannot end with ``\\''"
| Continue i -> match kmp_char delim next i '{' with
415 | Stop s -> s
| Continue i -> eat_delim_rec lexbuf delim next i}
| '{'
{fun delim next i ->
420 put_echo_char '{' ;
Out.put arg_buff (if i > 0 then String.sub delim 0 i else "") ;
Out.put_char arg_buff '{' ;
incr brace_nesting ;
let r = arg2 lexbuf in
425 Out.put arg_buff r ;
Out.put_char arg_buff '}' ;
eat_delim_rec lexbuf delim next 0}
| _
{fun delim next i ->
430 let c = lexeme_char lexbuf 0 in
put_echo_char c ;
match kmp_char delim next i c with
| Stop s -> s
| Continue i -> eat_delim_rec lexbuf delim next i}
435 | eof
{error ("End of file in delimited argument, read:
"^
Out.to_string echo_buff)}
440 and skip_delim_init = parse
| space|'\n' {skip_delim_init lexbuf}
| "" {skip_delim_rec lexbuf}
and skip_delim_rec = parse
445 | _
{fun delim i ->
let c = lexeme_char lexbuf 0 in
put_echo_char c ;
if c <> delim.[i] then
450 raise (Delim delim) ;
if i+1 < String.length delim then
skip_delim_rec lexbuf delim (i+1)}
| eof
{fun delim i ->
455 error ("End of file checking delimiter ``"^delim^"''")}
and check_equal = parse
| '=' {true}
| "" {false}
460 {
let init_kmp s =
let l = String.length s in
let r = Array.create l (-1) in
465 let rec init_rec i j =
if i+1 < l then begin
if j = -1 || s.[i]=s.[j] then begin
r.(i+1) <- j+1 ;
470 init_rec (i+1) (j+1)
end else
init_rec i r.(j)
end in
init_rec 0 (-1) ;
475 r
let with_delim delim lexbuf =
let next = init_kmp delim in
check_comment lexbuf ;
480 let r = eat_delim_init lexbuf delim next 0 in
r
and skip_delim delim lexbuf =
check_comment lexbuf ;
485 skip_delim_init lexbuf delim 0
let skip_blanks_init lexbuf =
let _ = skip_blanks lexbuf in
()
490
let arg_verbatim lexbuf = match first_char lexbuf with
| '{' ->
incr brace_nesting ;
arg2 lexbuf
495 | c ->
let delim = String.make 1 c in
with_delim delim lexbuf
}
<6>10 subst.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: subst.mll,v 1.14 2001/05/25 12:37:29 maranget Exp $ *)
(***********************************************************************)
{
open Misc
open Lexstate
15 open Lexing
let subst_buff = Out.create_buff ()
;;
20 }
let command_name = '\\' ((['@''A'-'Z' 'a'-'z']+ '*'?) | [^ 'A'-'Z' 'a'-'z'])
rule subst = parse
| '#' ['1'-'9']
25 {let lxm = lexeme lexbuf in
if is_plain '#' then begin
let i = Char.code (lxm.[1]) - Char.code '1' in
scan_arg
(fun arg -> scan_this_arg subst arg) i
30 end else
Out.put subst_buff lxm ;
subst lexbuf}
| '#' '#'
{let lxm = lexeme lexbuf in
35 if is_plain '#' then
Out.put_char subst_buff '#'
else
Out.put subst_buff lxm ;
subst lexbuf}
40 | "\\#" | '\\' | [^'\\' '#']+
{Out.blit subst_buff lexbuf ; subst lexbuf}
| "\\@print"
{let lxm = lexeme lexbuf in
Save.start_echo () ;
45 let _ = Save.arg lexbuf in
let real_arg = Save.get_echo () in
Out.put subst_buff lxm ;
Out.put subst_buff real_arg ;
subst lexbuf}
50 | command_name
{Out.blit subst_buff lexbuf ;
subst lexbuf}
| eof {()}
| "" {raise (Error "Empty lexeme in subst")}
55
{
let do_subst_this ({arg=arg ; subst=env} as x) =
if not (is_top env) then begin
60 try
let _ = String.index arg '#' in
if !verbose > 1 then begin
Printf.fprintf stderr "subst_this : [%s]\n" arg ;
prerr_args ()
65 end ;
let _ = scan_this_arg subst x in
let r = Out.to_string subst_buff in
if !verbose > 1 then
prerr_endline ("subst_this ["^arg^"] = "^r);
70 r
with Not_found -> arg
end else
arg
;;
75
let subst_this s = do_subst_this (mkarg s (get_subst ()))
let subst_arg lexbuf = do_subst_this (save_arg lexbuf)
and subst_opt def lexbuf = do_subst_this (save_opt def lexbuf)
80
let subst_body = subst_arg
}
<6>11 tabular.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: tabular.mll,v 1.26 2001/03/01 22:17:00 maranget Exp $ *)
{
open Misc
15 open Lexing
open Table
open Lexstate
open Subst
20 exception Error of string
;;
type align =
{hor : string ; mutable vert : string ; wrap : bool ;
25 mutable pre : string ; mutable post : string ; width : Length.t}
let make_hor = function
'c' -> "center"
| 'l' -> "left"
30 | 'r' -> "right"
| 'p'|'m'|'b' -> "left"
| _ -> raise (Misc.Fatal "make_hor")
and make_vert = function
35 | 'c'|'l'|'r' -> ""
| 'p' -> "top"
| 'm' -> "middle"
| 'b' -> "bottom"
| _ -> raise (Misc.Fatal "make_vert")
40
type format =
Align of align
| Inside of string
| Border of string
45 ;;
(* Patch vertical alignment (for HTML) *)
let check_vert f =
try
50 for i = 0 to Array.length f-1 do
match f.(i) with
| Align {vert=s} when s <> "" -> raise Exit
| _ -> ()
done ;
55 f
with Exit -> begin
for i = 0 to Array.length f-1 do
match f.(i) with
| Align ({vert=""} as f) ->
60 f.vert <- "top"
| _ -> ()
done ;
f
end
65
(* Compute missing length (for text) *)
and check_length f =
for i = 0 to Array.length f - 1 do
match f.(i) with
70 | Align ({wrap=true ; width=Length.No _} as r) ->
f.(i) <-
Align
{r with
width =
75 Length.Percent
(truncate (100.0 /. float (Array.length f)))}
| _ -> ()
done
80 let border = ref false
let push s e = s := e:: !s
85 and pop s = match !s with
[] -> raise (Misc.Fatal "Empty stack in Latexscan")
| e::rs -> s := rs ; e
let out_table = Table.create (Inside "")
90
let pretty_format = function
| Align {vert = v ; hor = h ; pre = pre ; post = post ; wrap = b ; width = w}
->
"[>{"^pre^"}"^
95 ", h="^h^", v="^v^
", <{"^post^"}"^(if b then ", wrap" else "")^
", w="^Length.pretty w^"]"
| Inside s -> "@{"^s^"}"
| Border s -> s
100
let pretty_formats f =
Array.iter (fun f -> prerr_string (pretty_format f) ; prerr_string "; ") f
105 }
rule tfone = parse
'>'
{let pre = subst_arg lexbuf in
110 tfmiddle lexbuf ;
try
apply out_table (function
| Align a as r -> a.pre <- pre
| _ -> raise (Error "Bad syntax in array argument (>)"))
115 with Table.Empty ->
raise (Error "Bad syntax in array argument (>)")}
| "" {tfmiddle lexbuf}
and tfmiddle = parse
120 | [' ''\t''\n''\r'] {tfmiddle lexbuf}
| ['c''l''r']
{let f = Lexing.lexeme_char lexbuf 0 in
let post = tfpostlude lexbuf in
emit out_table
125 (Align {hor = make_hor f ; vert = make_vert f ; wrap = false ;
pre = "" ; post = post ; width = Length.Default})}
| ['p''m''b']
{let f = Lexing.lexeme_char lexbuf 0 in
let width = subst_arg lexbuf in
130 let my_width = Length.main (Lexing.from_string width) in
let post = tfpostlude lexbuf in
emit out_table
(Align {hor = make_hor f ; vert = make_vert f ; wrap = true ;
pre = "" ; post = post ; width = my_width})}
135 | '#' ['1'-'9']
{let lxm = lexeme lexbuf in
let i = Char.code (lxm.[1]) - Char.code '1' in
Lexstate.scan_arg (scan_this_arg tfmiddle) i}
| [^'|' '@' '<' '>' '!' '#']
140 {let lxm = lexeme lexbuf in
let name = column_to_command lxm in
let pat,body = Latexmacros.find name in
let args = Lexstate.make_stack name pat lexbuf in
Lexstate.scan_body
145 (function
| Lexstate.Subst body -> scan_this lexformat body ;
| _ -> assert false)
body args ;
let post = tfpostlude lexbuf in
150 if post <> "" then
try
Table.apply out_table
(function
| Align f -> f.post <- post
155 | _ -> Misc.warning ("``<'' after ``@'' in tabular arg scanning"))
with
| Table.Empty ->
raise (Error ("``<'' cannot start tabular arg"))}
| eof {()}
160 | ""
{let rest =
String.sub lexbuf.lex_buffer lexbuf.lex_curr_pos
(lexbuf.lex_buffer_len - lexbuf.lex_curr_pos) in
raise (Error ("Syntax of array format near: "^rest))}
165
and tfpostlude = parse
'<' {subst_arg lexbuf}
| "" {""}
170
and lexformat = parse
'*'
{let ntimes = save_arg lexbuf in
let what = save_arg lexbuf in
175 let rec do_rec = function
0 -> lexformat lexbuf
| i ->
scan_this_arg lexformat what ; do_rec (i-1) in
do_rec (Get.get_int ntimes)}
180 | '|' {border := true ; emit out_table (Border "|") ; lexformat lexbuf}
| '@'|'!'
{let lxm = Lexing.lexeme_char lexbuf 0 in
let inside = subst_arg lexbuf in
if lxm = '!' || inside <> "" then emit out_table (Inside inside) ;
185 lexformat lexbuf}
| '#' ['1'-'9']
{let lxm = lexeme lexbuf in
let i = Char.code (lxm.[1]) - Char.code '1' in
Lexstate.scan_arg (scan_this_arg lexformat) i ;
190 lexformat lexbuf}
| eof {()}
| "" {tfone lexbuf ; lexformat lexbuf}
195
{
open Parse_opts
let main {arg=s ; subst=env} =
200 if !verbose > 1 then prerr_endline ("Table format: "^s);
start_normal env ;
lexformat (Lexing.from_string s) ;
end_normal () ;
let r = check_vert (trim out_table) in
205 begin match !destination with
| (Text | Info) -> check_length r
| Html -> ()
end ;
if !verbose > 1 then begin
210 prerr_string "Format parsed: " ;
pretty_formats r ;
prerr_endline ""
end ;
r
215 }
<6>12 verb.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: verb.mll,v 1.55 2001/06/05 13:18:41 maranget Exp $ *)
(***********************************************************************)
{
exception VError of string
15 module type S = sig end
;;
module Make
(Dest : OutManager.S) (Image : ImageManager.S)
(Scan : Latexscan.S) : S =
20 struct
open Misc
open Lexing
open Save
open Lexstate
25 open Latexmacros
open Stack
open Scan
open Subst
30 exception Eof of string
;;
(* For file verbatim scanning *)
let input_verb = ref false
35 ;;
(* For scanning by line *)
let verb_delim = ref (Char.chr 0)
and line_buff = Out.create_buff ()
40 and process = ref (fun () -> ())
and finish = ref (fun () -> ())
;;
let env_extract s =
45 let i = String.index s '{'
and j = String.rindex s '}' in
String.sub s (i+1) (j-i-1)
and newlines_extract s =
50 let rec do_rec i =
if i < String.length s then begin
if s.[i] = '\n' then
1+do_rec (i+1)
else
55 0
end else
0 in
do_rec 0
60 (* For scanning the ``listings'' way *)
let lst_process_error _ lxm =
warning ("listings, unknown character: ``"^Char.escaped lxm^"''")
65 let lst_char_table = Array.create 256 lst_process_error
;;
let lst_init_char c f =
lst_char_table.(Char.code c) <- f
70
let lst_init_chars s f =
let last = String.length s - 1 in
for i = 0 to last do
lst_char_table.(Char.code s.[i]) <- f
75 done
let lst_init_save_char c f =
let old = lst_char_table.(Char.code c) in
lst_char_table.(Char.code c) <- f old
80
let lst_init_save_chars s f =
let last = String.length s - 1 in
for i = 0 to last do
lst_init_save_char s.[i] f
85 done
(* Output functions *)
let lst_gobble = ref 0
and lst_nlines = ref 0
90 and lst_first = ref 1
and lst_last = ref 9999
and lst_print = ref true
and lst_string_spaces = ref true
and lst_texcl = ref false
95 and lst_extended = ref false
and lst_sensitive = ref true
and lst_mathescape = ref false
and lst_directives = ref false
and lst_showlines = ref false
100
let lst_effective_spaces = ref false (* false => spaces are spaces *)
and lst_save_spaces = ref false
let lst_buff = Out.create_buff ()
105
let lst_last_char = ref ' '
and lst_finish_comment = ref 0
let lst_put c =
110 lst_last_char := c ;
Out.put_char lst_buff c
and lst_direct_put c =
lst_last_char := c ;
115 Dest.put_char c
type lst_scan_mode =
| Letter | Other | Empty | Start
| Directive of bool (* bool flags some letter read *)
120
let lst_scan_mode = ref Empty
type comment_type =
| Nested of int
125 | Balanced of (char -> string -> bool)
| Line
type lst_top_mode =
| Skip
130 | String of (char * (char * (Lexing.lexbuf -> char -> unit)) list)
| Normal | Comment of comment_type
| Delim of int * (char * (Lexing.lexbuf -> char -> unit)) list
| Gobble of lst_top_mode * int
| Escape of lst_top_mode * char * bool (* bool flags mathescape *)
135
let string_of_top_mode = function
| Delim (i,_) -> "Delim: "^string_of_int i
| Skip -> "Skip"
| Comment (Balanced _) -> "Balanced"
140 | Comment (Nested n) -> "(Nested "^string_of_int n^")"
| _ -> "?"
let lst_top_mode = ref Skip
145
let lst_ptok s = prerr_endline (s^": "^Out.to_string lst_buff)
(* Final ouput, with transformations *)
let dest_string s =
150 for i = 0 to String.length s - 1 do
Dest.put (Dest.iso s.[i])
done
(* Echo, with case change *)
155 let dest_case s =
Dest.put
(match !case with
| Upper -> String.uppercase s
| Lower -> String.lowercase s
160 | _ -> s)
(* Keywords *)
let def_print s =
165 Latexmacros.def "\\@tmp@lst" zero_pat
(CamlCode (fun _ -> dest_case s)) ;
Latexmacros.def "\\@tmp@lst@print" zero_pat
(CamlCode (fun _ -> dest_string s))
;;
170
let lst_output_other () =
if not (Out.is_empty lst_buff) then begin
let arg = Out.to_string lst_buff in
match !lst_top_mode with
175 | Normal ->
def_print arg ;
scan_this Scan.main
("\\lst@output@other{\\@tmp@lst}{\\@tmp@lst@print}")
| _ ->
180 scan_this main "\\@NewLine" ;
dest_string arg
end
and lst_output_letter () =
185 if not (Out.is_empty lst_buff) then begin
match !lst_top_mode with
| Normal ->
let arg = Out.to_string lst_buff in
def_print arg ;
190 scan_this Scan.main ("\\lst@output{\\@tmp@lst}{\\@tmp@lst@print}")
| _ ->
scan_this main "\\@NewLine" ;
dest_string (Out.to_string lst_buff)
end
195
and lst_output_directive () =
if not (Out.is_empty lst_buff) then begin
match !lst_top_mode with
| Normal ->
200 let arg = Out.to_string lst_buff in
def_print arg ;
scan_this Scan.main ("\\lst@output@directive{\\@tmp@lst}{\\@tmp@lst@print}")
| _ ->
scan_this main "\\@NewLine" ;
205 dest_string (Out.to_string lst_buff)
end
let lst_output_token () =
match !lst_scan_mode with
210 | Letter -> lst_output_letter ()
| Other -> lst_output_other ()
| Directive _ -> lst_output_directive ()
| Empty|Start -> scan_this main "\\@NewLine"
215
let lst_finalize inline =
scan_this main "\\lst@forget@lastline" ;
if inline || !lst_showlines then
lst_output_token ()
220
(* Process functions *)
let lst_do_gobble mode n =
225 if n > 1 then
lst_top_mode := Gobble (mode,n-1)
else
lst_top_mode := mode
230 let lst_do_escape mode endchar math lb lxm =
if lxm = endchar then begin
scan_this main "\\begingroup\\lst@escapebegin" ;
if math then scan_this main "$" ;
scan_this main (Out.to_string lst_buff) ;
235 if math then scan_this main "$" ;
scan_this main "\\lst@escapeend\\endgroup" ;
lst_top_mode := mode
end else
Out.put_char lst_buff lxm
240
let rec lst_process_newline lb c =
if !verbose > 1 then
245 Printf.fprintf stderr "lst_process_newline\n" ;
match !lst_top_mode with
| Skip ->
if !lst_nlines = !lst_first - 1 then begin
lst_top_mode := Normal ;
250 scan_this Scan.main "\\let\\old@br\\@br\\def\\@br{
} " ;
lst_process_newline lb c ;
scan_this Scan.main "\\let\\@br\\old@br"
end else
255 incr lst_nlines
| Gobble (mode,_) ->
lst_top_mode := mode ;
lst_process_newline lb c
| Escape (mode,cc,math) ->
260 lst_do_escape (Comment Line) cc math lb c ;
if !lst_top_mode = Comment Line then
lst_process_newline lb c
| Comment Line ->
lst_output_token () ;
265 scan_this Scan.main "\\endgroup" ;
lst_top_mode := Normal ;
lst_process_newline lb c
| mode ->
scan_this Scan.main "\\lsthk@InitVarEOL\\lsthk@EOL" ;
270 begin match !lst_scan_mode with
| Empty -> lst_scan_mode := Start
| Start -> ()
| _ ->
lst_output_token () ;
275 lst_scan_mode := Start
end ;
incr lst_nlines ;
if !lst_nlines <= !lst_last then begin
scan_this Scan.main
280 "\\lsthk@InitVarBOL\\lsthk@EveryLine" ;
if !lst_gobble > 0 then
lst_top_mode := Gobble (mode,!lst_gobble)
end else
lst_top_mode := Skip
285
let lst_process_letter lb lxm =
if !verbose > 1 then Printf.fprintf stderr "lst_process_letter: %c\n" lxm ;
match !lst_top_mode with
| Skip -> ()
290 | Gobble (mode,n) -> lst_do_gobble mode n
| Escape (mode,c,math) -> lst_do_escape mode c math lb lxm
| _ -> match !lst_scan_mode with
| Letter -> lst_put lxm
| Directive true ->
295 lst_put lxm
| Directive false ->
lst_scan_mode := Directive true ;
lst_put lxm
| Empty|Start ->
300 lst_scan_mode := Letter ;
lst_put lxm
| Other ->
lst_output_other () ;
lst_scan_mode := Letter ;
305 lst_put lxm
let lst_process_digit lb lxm =
if !verbose > 1 then
Printf.fprintf stderr "lst_process_digit: %c\n" lxm ;
310 match !lst_top_mode with
| Skip -> ()
| Gobble (mode,n) -> lst_do_gobble mode n
| Escape (mode,c,math) -> lst_do_escape mode c math lb lxm
| _ -> match !lst_scan_mode with
315 | Letter|Other -> lst_put lxm
| Directive _ ->
lst_output_directive () ;
lst_scan_mode := Other ;
lst_put lxm
320 | Empty|Start ->
lst_scan_mode := Other ;
lst_put lxm
let lst_process_other lb lxm =
325 if !verbose > 1 then
Printf.fprintf stderr "process_other: %c\n" lxm ;
match !lst_top_mode with
| Skip -> ()
| Gobble (mode,n) -> lst_do_gobble mode n
330 | Escape (mode,c,math) -> lst_do_escape mode c math lb lxm
| _ -> match !lst_scan_mode with
| Other -> lst_put lxm
| Empty|Start ->
lst_scan_mode := Other ;
335 lst_put lxm
| Directive _ ->
lst_output_directive () ;
lst_scan_mode := Other ;
lst_put lxm
340 | Letter ->
lst_output_letter () ;
lst_scan_mode := Other ;
lst_put lxm
345 (* Caml code for \stepcounter{lst@space} *)
let lst_output_space () = Counter.step_counter "lst@spaces"
let lst_process_space lb lxm =
if !verbose > 1 then
350 Printf.fprintf stderr "process_space: ``%c''\n" lxm ;
match !lst_top_mode with
| Skip -> ()
| Gobble (mode,n) -> lst_do_gobble mode n
| Escape (mode,c,math) -> lst_do_escape mode c math lb lxm
355 | _ ->
begin match !lst_scan_mode with
| Other ->
lst_output_other () ;
lst_scan_mode := Empty
360 | Letter|Directive true ->
lst_output_token () ;
lst_scan_mode := Empty
| Empty|Directive false -> ()
| Start ->
365 lst_scan_mode := Empty
end ;
lst_output_space ()
let lst_process_start_directive old_process lb lxm =
370 match !lst_top_mode with
| Normal -> begin match !lst_scan_mode with
| Start ->
lst_scan_mode := Directive false
| _ -> old_process lb lxm
375 end
| _ -> old_process lb lxm
380 exception EndVerb
let lst_process_end endstring old_process lb lxm =
if !verbose > 1 then
Printf.fprintf stderr "process_end: ``%c''\n" lxm ;
385 if
(not !input_verb || Stack.empty stack_lexbuf)
&& if_next_string endstring lb then begin
Save.skip_delim endstring lb ;
raise EndVerb
390 end else
old_process lb lxm
let lst_init_char_table inline =
lst_init_chars
395 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ@_$"
lst_process_letter ;
lst_init_chars "!\"#%&'()*+,-./:;<=>?[\\]^{}|`~" lst_process_other ;
lst_init_chars "0123456789" lst_process_digit ;
lst_init_chars " \t" lst_process_space ;
400 if inline then
lst_init_char '\n' lst_process_space
else
lst_init_char '\n' lst_process_newline
;;
405
(* TeX escapes *)
let start_escape mode endchar math =
lst_output_token () ;
lst_top_mode := Escape (mode, endchar, math)
410
let lst_process_escape math ec old_process lb lxm =
if !verbose > 1 then
Printf.fprintf stderr "lst_process_escape: %c\n" lxm ;
match !lst_top_mode with
415 | Skip -> ()
| Gobble (mode,n) -> lst_do_gobble mode n
| Escape _ -> old_process lb lxm
| mode -> start_escape mode ec math
420
(* Strings *)
let rec restore_char_table to_restore =
let rec do_rec = function
| [] -> ()
425 | (c,f)::rest ->
lst_init_char c f ;
do_rec rest in
do_rec to_restore
430 let lst_bs_string old_process lb lxm =
old_process lb lxm ;
let saved = Array.copy lst_char_table in
let process_quoted _ lxm =
lst_put lxm ;
435 Array.blit saved 0 lst_char_table 0 (Array.length saved) in
Array.fill lst_char_table 0 (Array.length lst_char_table) process_quoted
let lst_init_quote s =
440 let r = ref [] in
for i = 0 to String.length s-1 do
if s.[i] = 'b' then begin
r := ('\\',lst_char_table.(Char.code '\\')) :: !r ;
lst_init_save_char '\\' lst_bs_string
445 end
done ;
!r
let lst_process_stringizer quote old_process lb lxm = match !lst_top_mode with
450 | Normal ->
lst_output_token () ;
let to_restore = lst_init_quote quote in
lst_top_mode := String (lxm, to_restore) ;
lst_save_spaces := !lst_effective_spaces ;
455 lst_effective_spaces := !lst_string_spaces ;
scan_this Scan.main "\\begingroup\\lst@string@style" ;
old_process lb lxm
| String (c,to_restore) when lxm = c ->
old_process lb lxm ;
460 lst_output_token () ;
scan_this Scan.main "\\endgroup" ;
restore_char_table to_restore ;
lst_effective_spaces := !lst_save_spaces ;
lst_top_mode := Normal
465 | _ -> old_process lb lxm
(* Comment *)
470
let chars_string c s =
let rec do_rec r i =
if i < String.length s then
if List.mem s.[i] r then
475 do_rec r (i+1)
else
do_rec (s.[i]::r) (i+1)
else
r in
480 do_rec [c] 0
let init_char_table_delim chars wrapper =
List.map
(fun c ->
485 let old_process = lst_char_table.(Char.code c) in
lst_init_save_char c wrapper ;
(c,old_process))
chars
490
let eat_delim k new_mode old_process lb c s =
let chars = chars_string c s in
let wrapper old_process lb c = match !lst_top_mode with
| Delim (n,to_restore) ->
495 old_process lb c ;
if n = 1 then begin
lst_output_token () ;
lst_top_mode := new_mode ;
restore_char_table to_restore ;
500 k ()
end else
lst_top_mode := Delim (n-1,to_restore)
| _ -> assert false in
let to_restore = init_char_table_delim chars wrapper in
505 lst_top_mode := Delim (1+String.length s, to_restore) ;
wrapper old_process lb c
let begin_comment () =
lst_output_token () ;
510 scan_this Scan.main "\\begingroup\\lst@comment@style"
let lst_process_BNC _ s old_process lb c = match !lst_top_mode with
| Normal when if_next_string s lb ->
begin_comment () ;
515 eat_delim (fun () -> ()) (Comment (Nested 0)) old_process lb c s
| Comment (Nested n) when if_next_string s lb ->
eat_delim (fun () -> ()) (Comment (Nested (n+1))) old_process lb c s
| _ -> old_process lb c
520 and lst_process_ENC s old_process lb c = match !lst_top_mode with
| Comment (Nested 0) when if_next_string s lb ->
eat_delim
(fun () -> scan_this Scan.main "\\endgroup")
Normal
525 old_process
lb c s
| Comment (Nested n) when if_next_string s lb ->
eat_delim
(fun () -> ())
530 (Comment (Nested (n-1)))
old_process lb c s
| _ -> old_process lb c
let lst_process_BBC check s old_process lb c = match !lst_top_mode with
535 | Normal when if_next_string s lb ->
begin_comment () ;
eat_delim
(fun () -> ())
(Comment (Balanced check))
540 old_process lb c s
| _ -> old_process lb c
and lst_process_EBC s old_process lb c = match !lst_top_mode with
| Comment (Balanced check) when
545 check c s && if_next_string s lb ->
eat_delim
(fun () -> scan_this Scan.main "\\endgroup")
Normal
old_process
550 lb c s
| _ -> old_process lb c
let lst_process_LC s old_process lb c = match !lst_top_mode with
| Normal when if_next_string s lb ->
555 begin_comment () ;
eat_delim
(fun () -> ())
(if !lst_texcl then Escape (Normal,'\n', false) else Comment Line)
old_process lb c s
560 | _ -> old_process lb c
}
565 rule inverb = parse
| _
{(fun put -> let c = lexeme_char lexbuf 0 in
if c = !verb_delim then begin
Dest.close_group () ;
570 end else begin
put c ;
inverb lexbuf put
end)}
| eof
575 {(fun put -> if not (empty stack_lexbuf) then
let lexbuf = previous_lexbuf () in
inverb lexbuf put
else
raise (VError ("End of file after \\verb")))}
580
and start_inverb = parse
| _
{(fun put -> let c = lexeme_char lexbuf 0 in
verb_delim := c ;
585 inverb lexbuf put)}
| eof
{(fun put ->
if not (empty stack_lexbuf) then
let lexbuf = previous_lexbuf () in
590 start_inverb lexbuf put
else
raise (VError ("End of file after \\verb")))}
and scan_byline = parse
595 "\\end" [' ''\t']* '{' [^'}']+ '}'
{let lxm = lexeme lexbuf in
let env = env_extract lxm in
if
(not !input_verb || Stack.empty stack_lexbuf)
600 && env = !Scan.cur_env then begin
!finish () ;
scan_this Scan.main ("\\end"^env) ;
Scan.top_close_block "" ;
Scan.close_env !Scan.cur_env ;
605 Scan.check_alltt_skip lexbuf
end else begin
Out.put line_buff lxm ;
scan_byline lexbuf
end}
610 | '\n'
{!process () ; scan_byline lexbuf}
| _
{let lxm = lexeme_char lexbuf 0 in
Out.put_char line_buff lxm ;
615 scan_byline lexbuf}
| eof
{if not (Stack.empty stack_lexbuf) then begin
let lexbuf = previous_lexbuf () in
scan_byline lexbuf
620 end else begin
!finish () ;
raise
(Eof "scan_byline")
end}
625
and listings = parse
| eof
{if not (Stack.empty stack_lexbuf) then begin
let lexbuf = previous_lexbuf () in
630 listings lexbuf
end else begin
raise
(Eof "listings")
end}
635 | _
{let lxm = lexeme_char lexbuf 0 in
lst_char_table.(Char.code lxm) lexbuf lxm ;
listings lexbuf}
640 and eat_line = parse
| eof
{if not (Stack.empty stack_lexbuf) then begin
let lexbuf = previous_lexbuf () in
eat_line lexbuf
645 end else begin
raise
(Eof "eat_line")
end}
| [^'\n'] {eat_line lexbuf}
650 | '\n' {lst_process_newline lexbuf '\n'}
and get_line = parse
| eof
{if not (Stack.empty stack_lexbuf) then begin
655 let lexbuf = previous_lexbuf () in
get_line lexbuf
end else begin
raise
(Eof "get_line")
660 end}
| [^'\n']
{let lxm = lexeme_char lexbuf 0 in
Out.put_char line_buff lxm ;
get_line lexbuf}
665 | '\n' {Out.to_string line_buff}
and do_escape = parse
| eof {}
| "\\esc"
670 {let arg = save_arg lexbuf in
scan_this main "\\mbox{" ;
scan_this_arg Scan.main arg ;
scan_this main "}" ;
do_escape lexbuf}
675 | _
{let lxm = Lexing.lexeme_char lexbuf 0 in
Dest.put (Dest.iso lxm) ;
do_escape lexbuf}
{
680 let _ = ()
;;
let put_char_star = function
| ' '|'\t' -> Dest.put_char '_' ;
| c -> Dest.put (Dest.iso c)
685
and put_char = function
| '\t' -> Dest.put_char ' '
| c -> Dest.put (Dest.iso c)
;;
690
let open_verb put lexbuf =
Dest.open_group "CODE" ;
start_inverb lexbuf put
695 ;;
def_code "\\verb" (open_verb (fun c -> Dest.put (Dest.iso c)));
def_code "\\verb*" (open_verb put_char_star);
();;
700
let put_line_buff_verb () =
Out.iter put_char line_buff ;
Out.reset line_buff
705 and put_line_buff_verb_star () =
Out.iter put_char_star line_buff ;
Out.reset line_buff
;;
710 let noeof lexer lexbuf =
try lexer lexbuf
with
| Eof s ->
raise
715 (Misc.Close
("End of file in environment: ``"^ !Scan.cur_env^"'' ("^s^")"))
| EndVerb -> ()
let open_verbenv star =
720 Scan.top_open_block "PRE" "" ;
process :=
if star then
(fun () -> put_line_buff_verb_star () ; Dest.put_char '\n')
else
725 (fun () -> put_line_buff_verb () ; Dest.put_char '\n') ;
finish :=
if star then
put_line_buff_verb_star
else
730 put_line_buff_verb
and close_verbenv _ = Scan.top_close_block "PRE"
let put_html () =
735 Out.iter (fun c -> Dest.put_char c) line_buff ;
Out.reset line_buff
;;
let open_rawhtml lexbuf =
740 begin match !Parse_opts.destination with
| Parse_opts.Html -> ()
| _ -> Misc.warning "rawhtml detected"
end ;
process :=
745 (fun () -> put_html () ; Dest.put_char '\n') ;
finish := put_html ;
noeof scan_byline lexbuf
and close_rawhtml _ = ()
750
let open_forget lexbuf =
process := (fun () -> Out.reset line_buff) ;
finish := (fun () -> Out.reset line_buff) ;
noeof scan_byline lexbuf
755
and close_forget _ = ()
let open_tofile chan lexbuf =
process :=
760 (fun () ->
output_string chan (Out.to_string line_buff) ;
output_char chan '\n') ;
finish :=
(fun () ->
765 output_string chan (Out.to_string line_buff) ;
close_out chan) ;
noeof scan_byline lexbuf
and close_tofile lexbuf = ()
770
let put_line_buff_image () =
Out.iter (fun c -> Image.put_char c) line_buff ;
Out.reset line_buff
775
let open_verbimage lexbuf =
process := (fun () -> put_line_buff_image () ; Image.put_char '\n') ;
finish := put_line_buff_image ;
noeof scan_byline lexbuf
780
and close_verbimage _ = ()
;;
785 def_code "\\verbatim"
(fun lexbuf ->
open_verbenv false ;
noeof scan_byline lexbuf) ;
def_code "\\endverbatim" close_verbenv ;
790
def_code "\\verbatim*"
(fun lexbuf ->
open_verbenv true ;
795 noeof scan_byline lexbuf) ;
def_code "\\endverbatim*" close_verbenv ;
def_code "\\rawhtml" open_rawhtml ;
def_code "\\endrawhtml" close_forget ;
800 def_code "\\verblatex" open_forget ;
def_code "\\endverblatex" Scan.check_alltt_skip ;
def_code "\\verbimage" open_verbimage ;
def_code "\\endverbimage" Scan.check_alltt_skip ;
()
805 ;;
let init_verbatim () =
(* comment clashes with the ``comment'' package *)
Latexmacros.def "\\comment" zero_pat (CamlCode open_forget) ;
810 Latexmacros.def "\\endcomment" zero_pat (CamlCode Scan.check_alltt_skip) ;
()
;;
register_init "verbatim" init_verbatim
815 ;;
(* The program package for JJL que j'aime bien *)
let look_escape () =
820 let lexbuf = Lexing.from_string (Out.to_string line_buff) in
do_escape lexbuf
;;
let init_program () =
825 def_code "\\program"
(fun lexbuf ->
Scan.top_open_block "PRE" "" ;
process :=
(fun () -> look_escape () ; Dest.put_char '\n') ;
830 finish := look_escape ;
noeof scan_byline lexbuf) ;
def_code "\\endprogram" close_verbenv
;;
835 register_init "program" init_program
;;
(* The moreverb package *)
840 let tab_val = ref 8
let put_verb_tabs () =
let char = ref 0 in
Out.iter
845 (fun c -> match c with
| '\t' ->
let limit = !tab_val - !char mod !tab_val in
for j = 1 to limit do
Dest.put_char ' ' ; incr char
850 done ;
| c -> Dest.put (Dest.iso c) ; incr char)
line_buff ;
Out.reset line_buff
855 let open_verbenv_tabs () =
Scan.top_open_block "PRE" "" ;
process := (fun () -> put_verb_tabs () ; Dest.put_char '\n') ;
finish := put_verb_tabs
860 and close_verbenv_tabs lexbuf =
Scan.top_close_block "PRE" ;
Scan.check_alltt_skip lexbuf
;;
865 let line = ref 0
and interval = ref 1
;;
870 let output_line inter_arg star =
if !line = 1 || !line mod inter_arg = 0 then
scan_this Scan.main ("\\listinglabel{"^string_of_int !line^"}")
else
Dest.put " " ;
875 if star then
put_line_buff_verb_star ()
else
put_verb_tabs () ;
incr line
880
let open_listing start_arg inter_arg star =
Scan.top_open_block "PRE" "" ;
line := start_arg ;
885 let first_line = ref true in
let inter = if inter_arg <= 0 then 1 else inter_arg in
process :=
(fun () ->
if !first_line then begin
890 first_line := false ;
if not (Out.is_empty line_buff) then
output_line inter_arg star ;
end else
output_line inter_arg star ;
895 Dest.put_char '\n') ;
finish :=
(fun () ->
if not (Out.is_empty line_buff) then
output_line inter_arg star)
900
and close_listing lexbuf =
Scan.top_close_block "PRE" ;
Scan.check_alltt_skip lexbuf
;;
905
register_init "moreverb"
(fun () ->
def_code "\\verbatimwrite"
910 (fun lexbuf ->
let name = Scan.get_prim_arg lexbuf in
Scan.check_alltt_skip lexbuf ;
let chan = open_out name in
open_tofile chan lexbuf) ;
915
def_code "\\endverbatimwrite" Scan.check_alltt_skip ;
def_code "\\verbatimtab"
(fun lexbuf ->
920 let opt = Get.get_int (save_opt "\\verbatimtabsize" lexbuf) in
tab_val := opt ;
open_verbenv_tabs () ;
Lexstate.save_lexstate () ;
let first = get_line lexbuf in
925 Lexstate.restore_lexstate () ;
scan_this Scan.main first ;
Dest.put_char '\n' ;
noeof scan_byline lexbuf) ;
def_code "\\endverbatimtab" close_verbenv_tabs ;
930 (*
def_code "\\verbatimtabinput"
(fun lexbuf ->
let opt = Get.get_int (save_opt "\\verbatimtabsize" lexbuf) in
tab_val := opt ;
935 let name = Scan.get_prim_arg lexbuf in
open_verbenv_tabs () ;
verb_input scan_byline name ;
close_verbenv_tabs lexbuf) ;
*)
940 def_code "\\listinglabel"
(fun lexbuf ->
let arg = Get.get_int (save_arg lexbuf) in
Dest.put (Printf.sprintf "%4d " arg)) ;
945 def_code "\\listing"
(fun lexbuf ->
let inter = Get.get_int (save_opt "1" lexbuf) in
let start = Get.get_int (save_arg lexbuf) in
interval := inter ;
950 open_listing start inter false ;
noeof scan_byline lexbuf) ;
def_code "\\endlisting" close_listing ;
(*
def_code "\\listinginput"
955 (fun lexbuf ->
let inter = Get.get_int (save_opt "1" lexbuf) in
let start = Get.get_int (save_arg lexbuf) in
let name = Scan.get_prim_arg lexbuf in
interval := inter ;
960 open_listing start inter false ;
verb_input scan_byline name ;
close_listing lexbuf) ;
*)
def_code "\\listingcont"
965 (fun lexbuf ->
open_listing !line !interval false ;
noeof scan_byline lexbuf) ;
def_code "\\endlistingcont" close_listing ;
970 def_code "\\listing*"
(fun lexbuf ->
let inter = Get.get_int (save_opt "1" lexbuf) in
let start = Get.get_int (save_arg lexbuf) in
interval := inter ;
975 open_listing start inter true ;
noeof scan_byline lexbuf) ;
def_code "\\endlisting*" close_listing ;
def_code "\\listingcont*"
980 (fun lexbuf ->
Scan.check_alltt_skip lexbuf ;
open_listing !line !interval false ;
noeof scan_byline lexbuf) ;
def_code "\\endlistingcont*" close_listing ;
985 ())
(* The comment package *)
let init_comment () =
990 def_code "\\@excludecomment" open_forget ;
def_code "\\end@excludecomment" Scan.check_alltt_skip ;
;;
register_init "comment" init_comment
995 ;;
(* The listings package *)
(*
1000 Caml code for
\def\lst@spaces
{\whiledo{\value{lst@spaces}>0}{~\addtocounter{lst@spaces}{-1}}}
*)
let code_spaces lexbuf =
1005 let n = Counter.value_counter "lst@spaces" in
if !lst_effective_spaces then
for i = n-1 downto 0 do
Dest.put_char '_'
done
1010 else
for i = n-1 downto 0 do
Dest.put_nbsp ()
done ;
Counter.set_counter "lst@spaces" 0
1015 ;;
let code_double_comment process_B process_E lexbuf =
let lxm_B = get_prim_arg lexbuf in
let lxm_E = get_prim_arg lexbuf in
1020 if lxm_B <> "" && lxm_E <> "" then begin
let head_B = lxm_B.[0]
and rest_B = String.sub lxm_B 1 (String.length lxm_B-1)
and head_E = lxm_E.[0]
and rest_E = String.sub lxm_E 1 (String.length lxm_E-1) in
1025 lst_init_save_char head_B
(process_B
(fun c s ->
c = head_E && s = rest_E)
rest_B) ;
1030 lst_init_save_char head_E (process_E rest_E)
end
let code_line_comment lexbuf =
let lxm_LC = get_prim_arg lexbuf in
1035 if lxm_LC <> "" then begin
let head = lxm_LC.[0]
and rest = String.sub lxm_LC 1 (String.length lxm_LC-1) in
lst_init_save_char head (lst_process_LC rest)
end
1040
let code_stringizer lexbuf =
let mode = Scan.get_prim_arg lexbuf in
let schars = Scan.get_prim_arg lexbuf in
lst_init_save_chars schars (lst_process_stringizer mode)
1045 ;;
let open_lst inline keys lab =
scan_this Scan.main ("\\lsthk@PreSet\\lstset{"^keys^"}") ;
(* For inline *)
1050 if inline then
scan_this Scan.main "\\lsthk@InlineUnsave" ;
(* Ignoring output *)
lst_gobble := Get.get_int (string_to_arg "\\lst@gobble") ;
lst_first := Get.get_int (string_to_arg "\\lst@first") ;
1055 lst_last := Get.get_int (string_to_arg "\\lst@last") ;
lst_nlines := 0 ;
lst_init_char_table inline ;
scan_this Scan.main "\\lsthk@SelectCharTable" ;
if !lst_extended then
1060 for i = 128 to 255 do
lst_init_char (Char.chr i) lst_process_letter
done ;
scan_this Scan.main "\\lsthk@Init" ;
(* Directives *)
1065 if !lst_directives then begin
lst_init_save_char '#' lst_process_start_directive
end ;
(* Print key *)
if not !lst_print then begin
1070 lst_last := -2 ; lst_first := -1
end ;
(* Strings *)
(* Escapes to TeX *)
if !lst_mathescape then begin
1075 lst_init_save_char '$' (lst_process_escape true '$')
end ;
let begc = Scan.get_this_main "\\@getprintnostyle{\\lst@BET}"
and endc = Scan.get_this_main "\\@getprintnostyle{\\lst@EET}" in
if begc <> "" && endc <> "" then begin
1080 lst_init_save_char begc.[0] (lst_process_escape false endc.[0])
end ;
scan_this Scan.main "\\lsthk@InitVar" ;
lst_scan_mode := Empty ;
if inline then
1085 lst_top_mode := Normal
else
lst_top_mode := Skip
and close_lst inline =
1090 lst_finalize inline ;
while !Scan.cur_env = "command-group" do
scan_this Scan.main "\\endgroup"
done ;
scan_this Scan.main "\\lsthk@DeInit"
1095 ;;
let lst_boolean lexbuf =
let b = get_prim_arg lexbuf in
Dest.put
1100 (match b with
| "" -> "false"
| s when s.[0] = 't' || s.[0] = 'T' -> "true"
| _ -> "false")
;;
1105
def_code "\\@callopt"
(fun lexbuf ->
let csname = Scan.get_csname lexbuf in
let old_raw = !raw_chars in
1110 let all_arg = get_prim_arg lexbuf in
let lexarg = Lexing.from_string all_arg in
let opt = Subst.subst_opt "" lexarg in
let arg = Save.rest lexarg in
let exec = csname^"["^opt^"]{"^arg^"}" in
1115 scan_this Scan.main exec)
;;
let init_listings () =
Scan.newif_ref "lst@print" lst_print ;
Scan.newif_ref "lst@extendedchars" lst_extended ;
1120 Scan.newif_ref "lst@texcl" lst_texcl ;
Scan.newif_ref "lst@sensitive" lst_sensitive ;
Scan.newif_ref "lst@mathescape" lst_mathescape ;
Scan.newif_ref "lst@directives" lst_directives ;
Scan.newif_ref "lst@stringspaces" lst_string_spaces ;
1125 Scan.newif_ref "lst@showlines" lst_showlines ;
def_code "\\lst@spaces" code_spaces ;
def_code "\\lst@boolean" lst_boolean ;
def_code "\\lst@def@stringizer" code_stringizer ;
def_code "\\lst@AddTo"
1130 (fun lexbuf ->
let sep = Scan.get_prim_arg lexbuf in
let name = Scan.get_csname lexbuf in
let old =
try match Latexmacros.find_fail name with
1135 | _, Subst s -> s
| _,_ -> ""
with
| Latexmacros.Failed -> "" in
let toadd = get_prim_arg lexbuf in
1140 Latexmacros.def name zero_pat
(Subst (if old="" then toadd else old^sep^toadd))) ;
def_code "\\lst@lExtend"
(fun lexbuf ->
let name = Scan.get_csname lexbuf in
1145 try
match Latexmacros.find_fail name with
| _, Subst body ->
let toadd = Subst.subst_arg lexbuf in
Latexmacros.def name zero_pat (Subst (body^"%\n"^toadd))
1150 | _, _ ->
warning ("Cannot \\lst@lExtend ``"^name^"''")
with
| Latexmacros.Failed ->
warning ("Cannot \\lst@lExtend ``"^name^"''")) ;
1155 def_code "\\lstlisting"
(fun lexbuf ->
Image.stop () ;
let keys = Subst.subst_opt "" lexbuf in
let lab = Scan.get_prim_arg lexbuf in
1160 let lab = if lab = " " then "" else lab in
if lab <> "" then
def "\\lst@intname" zero_pat (CamlCode (fun _ -> Dest.put lab)) ;
open_lst false keys lab ;
scan_this Scan.main "\\lst@pre\\@open@lstbox" ;
1165 scan_this Scan.main "\\lst@basic@style" ;
(* Eat first line *)
save_lexstate () ;
noeof eat_line lexbuf ;
restore_lexstate () ;
1170 (* For detecting endstring, must be done after eat_line *)
lst_init_save_char '\\' (lst_process_end "end{lstlisting}") ;
noeof listings lexbuf ;
close_lst false ;
scan_this Scan.main "\\@close@lstbox\\lst@post" ;
1175 Scan.top_close_block "" ;
Scan.close_env !Scan.cur_env ;
Image.restart () ;
Scan.check_alltt_skip lexbuf) ;
(* Init comments from .hva *)
1180 def_code "\\lst@balanced@comment"
(fun lexbuf ->
code_double_comment lst_process_BBC lst_process_EBC lexbuf) ;
def_code "\\lst@nested@comment"
(fun lexbuf ->
1185 code_double_comment lst_process_BNC lst_process_ENC lexbuf) ;
def_code "\\lst@line@comment" code_line_comment ;
def_code "\\lstinline"
(fun lexbuf ->
1190 let keys = Subst.subst_opt "" lexbuf in
let {arg=arg} = save_verbatim lexbuf in
Scan.new_env "*lstinline*" ;
scan_this main "\\mbox{" ;
open_lst true keys "" ;
1195 Dest.open_group "CODE" ;
begin try
scan_this listings arg
with
| Eof _ -> ()
1200 end ;
close_lst true ;
Dest.close_group () ;
scan_this main "}" ;
Scan.close_env "*lstinline*") ;
1205
def_code "\\lst@definelanguage"
(fun lexbuf ->
let dialect = get_prim_opt "" lexbuf in
let language = get_prim_arg lexbuf in
1210 let base_dialect = get_prim_opt "!*!" lexbuf in
match base_dialect with
| "!*!" ->
let keys = subst_arg lexbuf in
1215 let _ = save_opt "" lexbuf in
scan_this main
("\\lst@definelanguage@{"^language^"}{"^
dialect^"}{"^keys^"}")
| _ ->
1220 let base_language = get_prim_arg lexbuf in
let keys = subst_arg lexbuf in
let _ = save_opt "" lexbuf in
scan_this main
("\\lst@derivelanguage@{"^
1225 language^"}{"^ dialect^"}{"^
base_language^"}{"^base_dialect^"}{"^
keys^"}"))
;;
1230 register_init "listings" init_listings
;;
let init_fancyvrb () =
1235 def_code "\\@Verbatim"
(fun lexbuf ->
open_verbenv false ;
noeof scan_byline lexbuf) ;
def_code "\\@endVerbatim" close_verbenv
1240 ;;
register_init "fancyvrb" init_fancyvrb
;;
1245
def_code "\\@scaninput"
(fun lexbuf ->
1250 let pre = save_arg lexbuf in
let file = get_prim_arg lexbuf in
let {arg=post ; subst=post_subst} = save_arg lexbuf in
try
let true_name,chan = Myfiles.open_tex file in
1255 if !verbose > 0 then
message ("Scan input file: "^true_name) ;
let filebuff = Lexing.from_channel chan in
start_lexstate () ;
let old_input = !input_verb in
1260 if old_input then warning "Nested \\@scaninput" ;
input_verb := true ;
Location.set true_name filebuff ;
begin try
record_lexbuf (Lexing.from_string post) post_subst ;
1265 scan_this_may_cont Scan.main filebuff top_subst
pre ;
with e ->
restore_lexstate () ;
Location.restore () ;
1270 close_in chan ;
raise e
end ;
restore_lexstate () ;
Location.restore () ;
1275 close_in chan ;
input_verb := old_input
with
| Myfiles.Except ->
warning ("Not opening file: "^file)
1280 | Myfiles.Error s ->
warning s)
end
}
<6>13 videoc.mll
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* Christian Queinnec, Universite Paris IV *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
10 (* *)
(***********************************************************************)
(* <Christian.Queinnec@lip6.fr>
The plugin for HeVeA that implements the VideoC style.
$Id: videoc.mll,v 1.26 2001/05/25 12:37:35 maranget Exp $
15 *)
{
module type T =
sig
20 end;;
module Make
(Dest : OutManager.S)
(Image : ImageManager.S)
25 (Scan : Latexscan.S) =
struct
open Misc
open Parse_opts
open Lexing
30 open Myfiles
open Lexstate
open Latexmacros
open Subst
open Scan
35
let header =
"$Id: videoc.mll,v 1.26 2001/05/25 12:37:35 maranget Exp $"
(* So I can synchronize my changes from Luc's ones *)
40 let qnc_header =
"30 oct 2000"
exception EndSnippet
;;
45 exception EndTeXInclusion
;;
(* Re-link with these variables inserted in latexscan. *)
50 let withinSnippet = ref false;;
let withinTeXInclusion = ref false;;
let endSnippetRead = ref false;;
(* Snippet global defaults *)
55
let snippetLanguage = ref "";;
let enableLispComment = ref false;;
let enableSchemeCharacters = ref false;;
60 (* Snippet Environment: run a series of hooks provided they exist as
user macros. *)
let runHook prefix parsing name =
let run name = begin
65 if !verbose > 2 then prerr_endline ("Trying to run hook " ^ name);
if Latexmacros.exists name
then begin Lexstate.scan_this parsing name; () end
end in
let rec iterate name suffix =
70 run name;
if suffix <> ""
then iterate (name ^ (String.make 1 (String.get suffix 0)))
(String.sub suffix 1 ((String.length suffix) - 1))
in iterate (prefix ^ name ^ "Hook") !snippetLanguage;;
75
let snippetRunHook parsing name =
runHook "\\snippet" parsing name;;
let snipRunHook parsing name =
80 runHook "\\snip" parsing name;;
(* Hack for mutual recursion between modules: *)
let handle_command = ref
85 ((function lexbuf -> function s -> ())
: (Lexing.lexbuf -> string -> unit));;
(* Convert a reference to a hint such as "3" "annote.ann" "premier indice"
into "3_annote_ann". This is needed for the annote tool. *)
90
let compute_hint_id number filename notename =
let result = number ^ "_" ^ filename in
let rec convert i = begin
if i<String.length(result)
95 then let c = String.get result i in
if true || ('a' <= c && c <= 'z') (* test *)
|| ('A' <= c && c <= 'z')
|| ('0' <= c && c <= '9')
then ()
100 else String.set result i '_';
convert (i+1);
end in
convert 0;
result;;
105
let increment_internal_counter =
let counter = ref 99 in
function () ->
begin
110 counter := !counter + 1;
!counter
end;;
}
115
let command_name = '\\' ((['@''A'-'Z' 'a'-'z']+ '*'?) | [^ 'A'-'Z' 'a'-'z'])
rule snippetenv = parse
| eof { () }
120 | command_name
{let csname = lexeme lexbuf in
let pat,body = Latexmacros.find csname in
begin match pat with
| [],[] ->
125 let args = make_stack csname pat lexbuf in
let cur_subst = get_subst () in
let exec = function
| Subst body ->
if !verbose > 2 then
130 prerr_endline ("user macro in snippet: "^body) ;
Lexstate.scan_this_may_cont Scan.main
lexbuf cur_subst (string_to_arg body)
| Toks l ->
List.iter
135 (fun s -> scan_this Scan.main s)
(List.rev l)
| CamlCode f -> f lexbuf in
scan_body exec body args
| _ ->
140 raise (Misc.ScanError ("Command with arguments inside snippet"))
end ;
snippetenv lexbuf}
| '\n'
{Dest.put_tag "<BR>";
145 Dest.put_char '\n';
snippetRunHook Scan.main "AfterLine";
snippetRunHook Scan.main "BeforeLine";
snippetenv lexbuf}
| ' '|'\t'
150 {Dest.put_nbsp ();
snippetenv lexbuf}
| ';' +
{Dest.put (lexeme lexbuf);
Dest.put_char ' ';
155 if !enableLispComment
then begin
if !verbose > 1 then
prerr_endline "Within snippet: Lisp comment entered";
Lexstate.withinLispComment := true;
160 Scan.top_open_block "SPAN"
("class=\"" ^ !snippetLanguage ^ "Comment\"");
snippetRunHook Scan.main "BeforeComment";
try Scan.main lexbuf with (* until a \n is read *)
| exc -> begin
165 snippetRunHook Scan.main "AfterComment";
Scan.top_close_block "SPAN";
Lexstate.withinLispComment := false;
(* re-raise every exception but EndOfLispComment *)
try raise exc with
170 | Misc.EndOfLispComment nlnum -> begin
let addon = (if !endSnippetRead then "\\endsnippet" else "") in
if !verbose > 1 then
Printf.fprintf stderr "%d NL after LispComment %s\n"
nlnum ((if !endSnippetRead then "and " else "")^addon);
175 let _ = Lexstate.scan_this snippetenv
((String.make (1+nlnum) '\n')^addon) in
()
end;
end;
180 end;
snippetenv lexbuf}
| '#'
{Dest.put_char '#';
if !enableSchemeCharacters
185 then begin
if !verbose > 1 then
prerr_endline "Within snippet: scheme characters enabled";
schemecharacterenv lexbuf
end;
190 snippetenv lexbuf}
| _
{Dest.put (Dest.iso (lexeme_char lexbuf 0));
snippetenv lexbuf}
195 (* Scheme characters are written as #\A or #\Newspace *)
and schemecharacterenv = parse
| command_name
{let csname = lexeme lexbuf in
200 Dest.put csname}
| ""
{ () }
(* Swallow characters until the end of the line. *)
205
and skip_blanks_till_eol_included = parse
| ' ' +
{skip_blanks_till_eol_included lexbuf}
| '\n'
210 { () }
| ""
{ () }
(* Parse a succession of things separated by commas. *)
215
and comma_separated_values = parse
| [ ^ ',' ] * ','
{let lxm = lexeme lexbuf in
let s = String.sub lxm 0 (String.length lxm - 1) in
220 if !verbose > 2 then prerr_endline ("CSV" ^ s);
s :: comma_separated_values lexbuf}
| eof
{ [] }
225 (* Trailer: Register local macros as global. *)
{
let caml_print s = CamlCode (fun _ -> Dest.put s)
let snippet_def name d = Latexmacros.def name zero_pat (CamlCode d)
230
let rec do_endsnippet _ =
if !Lexstate.withinLispComment then begin
endSnippetRead := true;
raise (Misc.EndOfLispComment 0)
235 end;
if !Scan.cur_env = "snippet" then
raise EndSnippet
else
raise (Misc.ScanError ("\\endsnippet without opening \\snippet"))
240
and do_texinclusion lexbuf =
Scan.top_open_block "SPAN"
("class=\"" ^ !snippetLanguage ^ "Inclusion\"");
snippetRunHook Scan.main "BeforeTeX";
245 withinTeXInclusion := true;
begin (* Until a \] is read *)
try Scan.main lexbuf with
| exc -> begin
snippetRunHook Scan.main "AfterTeX";
250 Scan.top_close_block "SPAN";
snippetRunHook Scan.main "Restart";
(* Re-raise every thing but EndTeXInclusion *)
try raise exc with
| EndTeXInclusion -> ()
255 end;
end ;
and do_texexclusion _ =
if !withinSnippet then begin
260 if !verbose > 2 then prerr_endline "\\] caught within TeX escape";
withinTeXInclusion := false;
raise EndTeXInclusion
end else
raise (Misc.ScanError ("\\] without opening \\[ in snippet"))
265
and do_backslash_newline _ =
Dest.put "\\\n";
Lexstate.scan_this snippetenv "\n"
270 and do_four_backslashes _ = Dest.put "\\"
(* HACK: Define a macro with a body that is obtained via substitution.
This is a kind of restricted \edef as in TeX.
Syntax: \@EDEF\macroName{#2#1..} *)
275
and do_edef lxm lexbuf =
let name = Scan.get_csname lexbuf in
let body = subst_arg lexbuf in
if Scan.echo_toimage () then
280 Image.put ("\\def"^name^"{"^body^"}\n") ;
Latexmacros.def name zero_pat (caml_print body);
()
(* Syntax: \@MULEDEF{\macroName,\macroName,...}{#1#3...}
285 This is an awful hack extending the \@EDEF command. It locally
rebinds the (comma-separated) \macronames to the corresponding
(comma-separated) expansion of second argument. All \macronames
should be a zero-ary macro. *)
290 and do_muledef lxm lexbuf =
let names = subst_arg lexbuf in
let bodies = subst_arg lexbuf in
let rec bind lasti lastj =
try let i = String.index_from names lasti ',' in
295 try let j = String.index_from bodies lastj ',' in
let name = String.sub names lasti (i - lasti) in
let body = String.sub bodies lastj (j - lastj) in
if !verbose > 2 then prerr_endline (lxm ^ name ^ ";" ^ body);
Latexmacros.def name zero_pat (caml_print body);
300 bind (i+1) (j+1)
with Not_found -> failwith "Missing bodies for \\@MULEDEF"
with Not_found ->
let name = String.sub names lasti (String.length names - lasti) in
let body = String.sub bodies lastj (String.length bodies - lastj) in
305 if !verbose > 2 then prerr_endline (lxm ^ name ^ ";" ^ body);
Latexmacros.def name zero_pat (caml_print body) ;
in bind 0 0;
()
310
(* The command that starts the \snippet inner environment: *)
and do_snippet lexbuf =
if !withinSnippet
315 then raise (Misc.ScanError "No snippet within snippet.")
else begin
(* Obtain the current TeX value of \snippetDefaultLanguage *)
let snippetDefaultLanguage = "\\snippetDefaultLanguage" in
let language = get_prim_opt snippetDefaultLanguage lexbuf in
320 let language = if language = "" then snippetDefaultLanguage
else language in
skip_blanks_till_eol_included lexbuf;
Dest.put "<BR>\n";
Scan.top_open_block "DIV" ("class=\"div" ^ language ^ "\"");
325 Dest.put "\n";
Scan.new_env "snippet";
(* Define commands local to \snippet *)
snippet_def "\\endsnippet" do_endsnippet;
snippet_def "\\[" do_texinclusion ;
330 snippet_def "\\]" do_texexclusion ;
snippet_def "\\\\" do_four_backslashes ;
snippet_def "\\\n" do_backslash_newline ;
snippetLanguage := language;
335 enableLispComment := false;
enableSchemeCharacters := false;
withinSnippet := true;
snippetRunHook Scan.main "Before";
try snippetenv lexbuf with
340 exc -> begin
snippetRunHook Scan.main "AfterLine";
snippetRunHook Scan.main "After";
withinSnippet := false;
Scan.close_env "snippet";
345 Scan.top_close_block "DIV";
(* Re-raise all exceptions but EndSnippet *)
try raise exc with
EndSnippet -> ()
end;
350 end
and do_enable_backslashed_chars lexbuf =
let def_echo s = snippet_def s (fun _ -> Dest.put s) in
let chars = subst_arg lexbuf in begin
355 if !verbose > 2 then prerr_endline ("\\enableBackslashedChar "^chars);
for i=0 to (String.length chars - 1) do
let charcommandname = "\\" ^ (String.sub chars i 1) in
def_echo charcommandname;
done;
360 end;
()
and do_enableLispComment lexbuf =
enableLispComment := true;
365 ()
and do_disableLispComment lexbuf =
enableLispComment := false;
()
370
and do_enableSchemeCharacters lexbuf =
enableSchemeCharacters := true;
()
375 and do_disableSchemeCharacters lexbuf =
enableSchemeCharacters := false;
()
and do_snippet_run_hook lexbuf =
380 let name = subst_arg lexbuf in begin
snippetRunHook Scan.main name;
()
end
385 and do_snip_run_hook lexbuf =
let name = subst_arg lexbuf in begin
snipRunHook Scan.main name;
()
end
390
(* These macros are defined in Caml since they are not nullary macros.
They require some arguments but they cannot get them in the snippet
environment. So I code them by hand. *)
395 and do_vicanchor lexbuf = begin
let {arg=style} = Lexstate.save_opt "" lexbuf in
if !verbose > 2 then prerr_endline ("\\vicanchor"^style);
let {arg=nfn} = Lexstate.save_opt "0,filename,notename" lexbuf in
if !verbose > 2 then prerr_endline ("\\vicanchor"^style^nfn);
400 let fields =
comma_separated_values (Lexing.from_string (nfn ^ ",")) in
match fields with
| [number;filename;notename] ->
begin
405 let uniqueNumber = (* Would be better: truncate(Unix.gettimeofday()) *)
increment_internal_counter()
and hintId = compute_hint_id number filename notename in
Dest.put_tag ("<A id=\"a" ^ string_of_int(uniqueNumber)
^ "__" ^ hintId
410 ^ "\" href=\"javascript: void showMessage('"
^ hintId ^ "')\" class=\"mousable\"><SPAN style=\""
^ style ^ "\"><!-- " ^ nfn ^ " -->");
()
end
415 | _ -> failwith "Missing comma-separated arguments"
end
and do_vicendanchor lexbuf = begin
let {arg=nfn} = Lexstate.save_opt "0,filename,notename" lexbuf in
420 if !verbose > 2 then prerr_endline ("\\vicendanchor"^nfn);
let fields =
comma_separated_values (Lexing.from_string (nfn ^ ",")) in
match fields with
| [number;filename;notename] -> begin
425 Dest.put_tag ("</SPAN></A>");
()
end
| _ -> failwith "Missing comma-separated arguments"
end
430
and do_vicindex lexbuf = begin
let nfn = Lexstate.save_opt "0,filename,notename" lexbuf in
Dest.put_char ' ';
()
435 end
;;
(* This is the initialization function of the plugin: *)
440
let init = function () ->
begin
(* Register global TeX macros: *)
def_code "\\snippet" do_snippet;
445 def_name_code "\\@EDEF" do_edef;
def_name_code "\\@MULEDEF" do_muledef;
def_code "\\ViCEndAnchor" do_vicendanchor;
def_code "\\ViCAnchor" do_vicanchor;
450 def_code "\\ViCIndex" do_vicindex;
def_code "\\enableLispComment" do_enableLispComment;
def_code "\\disableLispComment" do_disableLispComment;
def_code "\\enableSchemeCharacters" do_enableSchemeCharacters;
455 def_code "\\disableSchemeCharacters" do_disableSchemeCharacters;
def_code "\\enableBackslashedChars" do_enable_backslashed_chars;
def_code "\\snippetRunHook" do_snippet_run_hook;
def_code "\\snipRunHook" do_snip_run_hook;
()
460 end;;
register_init "videoc" init
;;
465 end}
<6>14 auxx.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val rset : string -> string -> unit
val rget : string -> string
val bset : string -> string -> unit
15 val bget : bool -> string -> string
val init : string -> unit
val finalize : bool -> bool
val bwrite : string -> string -> unit
val rwrite : string -> string -> unit
20
val hot_start : unit -> unit
type saved
25 val check : unit -> saved
val hot : saved -> unit
<6>15 buff.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: buff.mli,v 1.4 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
type t
val create : unit -> t
15 val put_char : t -> char -> unit
val put : t -> string -> unit
val to_string : t -> string
val reset : t -> unit
<6>16 color.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val compute : string -> string -> string
val define : string -> string -> string -> unit
val define_named : string -> string -> string -> unit
15 val retrieve : string -> string
val remove : string -> unit
type saved
val checkpoint : unit -> saved
20 val hot_start : saved -> unit
<6>17 colscan.mli
(***********************************************************************)
(* *)
(* 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.mli,v 1.5 2001/05/25 12:37:20 maranget Exp $ *)
(***********************************************************************)
exception Error of string
val one : Lexing.lexbuf -> float
val three : Lexing.lexbuf -> float * float * float
15 val four : Lexing.lexbuf -> float * float * float * float
<6>18 counter.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type saved
val checkpoint : unit -> saved
val hot_start : saved -> unit
15
val value_counter : string -> int
val def_counter: string -> string -> unit
val set_counter: string -> int -> unit
val add_counter:string -> int -> unit
20 val step_counter: string -> unit
val number_within: string -> string -> unit
<6>19 cross.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val add : string -> string -> unit
val fullname : string -> string -> string
val change : string -> string -> unit
<6>20 element.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type text =
Style of string
| Font of int
15 | Color of string
val pretty_text : text -> string
<6>21 emisc.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: emisc.mli,v 1.1 2001/05/29 09:23:30 maranget Exp $ *)
(***********************************************************************)
val basefont : int ref
val reset : unit -> unit
<6>22 entry.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type key = string list * string list
exception NoGood
exception Fini
15
val read_key : Lexing.lexbuf -> key * string option
val read_indexentry : Lexing.lexbuf -> string * string
<6>23 esponja.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: esponja.mli,v 1.1 2001/05/25 12:37:21 maranget Exp $ *)
(***********************************************************************)
val pess : bool ref
val move : bool ref
15 val process : string -> in_channel -> out_channel -> bool
val file : string -> bool
<6>24 explode.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: explode.mli,v 1.4 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
val trees : Lexeme.style Tree.t list -> Htmltext.style Tree.t list
<6>25 foot.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type saved
val checkpoint : unit -> saved
val hot_start : saved -> unit
15
val step_anchor : int -> unit
val get_anchor : int -> int
val register : int -> string -> string -> unit
20 val flush : (string -> unit) -> string -> string -> unit
val some : bool ref
<6>26 get.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: get.mli,v 1.12 2001/05/25 12:37:22 maranget Exp $ *)
(***********************************************************************)
open Lexstate
exception Error of string
15
val init :
(string arg -> string) ->
((Lexing.lexbuf -> unit) -> Lexing.lexbuf -> string) ->
(string -> unit) -> (string -> unit) ->
20 (Lexing.lexbuf -> string) ->
(Lexing.lexbuf -> unit) -> unit
type saved
val check : unit -> saved
25 val hot : saved -> unit
val get_int : string arg -> int
val get_bool : string arg -> bool
val get_length : string -> Length.t
<6>27 hot.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: hot.mli,v 1.3 2001/05/25 12:37:23 maranget Exp $ *)
(***********************************************************************)
type saved
val checkpoint : unit -> saved
15 val start : saved -> unit
<6>28 htmllex.mli
(***********************************************************************)
(* *)
(* 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.mli,v 1.4 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
exception Error of string
val ptop : unit -> unit
15 val to_string : Lexeme.token -> string
val cost : Lexeme.style -> int * int
val reset : unit -> unit
val next_token : Lexing.lexbuf -> Lexeme.token
<6>29 html.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
exception Error of string
type block
15
val iso : char -> string
val iso_string : string -> string
val set_out : Out.t -> unit
20 val stop : unit -> unit
val restart : unit -> unit
val get_last_closed : unit -> block
val set_last_closed : block -> unit
val is_empty : unit -> bool
25
val get_fontsize : unit -> int
val nostyle : unit -> unit
val clearstyle : unit -> unit
val open_mod : Element.text -> unit
30 val erase_mods : Element.text list -> unit
val par : int option -> unit
val forget_par : unit -> int option
val open_block : string -> string -> unit
val close_block : string -> unit
35 val force_block : string -> string -> unit
val insert_block : string -> string -> unit
val insert_attr : string -> string -> unit
val open_maths : bool -> unit
40 val close_maths : bool -> unit
val open_display : unit -> unit
val close_display : unit -> unit
val item_display : unit -> unit
val force_item_display : unit -> unit
45 val erase_display : unit -> unit
val standard_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val limit_sup_sub :
50 (string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val int_sup_sub :
bool -> int ->
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
55 val over : bool -> Lexing.lexbuf -> unit
val left : string -> (int -> unit) -> unit
val right : string -> int
val set_dcount : string -> unit
60 val item : unit -> unit
val nitem : unit -> unit
val ditem : (string -> unit) -> string -> unit
val erase_block : string -> unit
val open_group : string -> unit
65 val open_aftergroup : (string -> string) -> unit
val close_group : unit -> unit
val put : string -> unit
val put_char : char -> unit
val flush_out : unit -> unit
70 val skip_line : unit -> unit
val loc_name : string -> unit
val open_chan : out_channel -> unit
75 val close_chan : unit -> unit
val to_string : (unit -> unit) -> string
val to_style : (unit -> unit) -> Element.text list
val get_current_output : unit -> string
80 val finalize : bool -> unit
val horizontal_line : string -> Length.t -> Length.t -> unit
val put_separator : unit -> unit
val unskip : unit -> unit
85 val put_tag : string -> unit
val put_nbsp : unit -> unit
val put_open_group : unit -> unit
val put_close_group : unit -> unit
val put_in_math : string -> unit
90
val open_table : bool -> string -> unit
val new_row : unit -> unit
val open_cell : Tabular.format -> int -> int -> unit
95 val erase_cell : unit -> unit
val close_cell : string -> unit
val do_close_cell : unit -> unit
val open_cell_group : unit -> unit
val close_cell_group : unit -> unit
100 val erase_cell_group : unit -> unit
val close_row : unit -> unit
val erase_row : unit -> unit
val close_table : unit -> unit
val make_border : string -> unit
105 val make_inside : string -> bool -> unit
val make_hline : int -> bool -> unit
val infomenu : string -> unit
val infonode : string -> string -> string -> unit
110 val infoextranode : string -> string -> string -> unit
val image : string -> string -> unit
type saved
115 val check : unit -> saved
val hot : saved -> unit
<6>30 htmlparse.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: htmlparse.mli,v 1.4 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
exception Error of string
val reset : unit -> unit
15 val main : Lexing.lexbuf -> Lexeme.style Tree.t list
<6>31 htmltext.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: htmltext.mli,v 1.5 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
exception No
type tsize = Int of int | Big | Small
15 type nat =
Style of Lexeme.tag
| Size of tsize
| Color of string
| Face of string
20 | Other
type t_style = { nat : nat; txt : string; ctxt : string; }
type style = t_style list
25 val cost : style -> int * int
exception NoProp
val get_prop : nat -> (nat -> bool)
val is_font : nat -> bool
val font_props : (nat -> bool) list
30 val neutral_prop : (nat -> bool) -> bool
val same_style : t_style -> t_style -> bool
type env = t_style list
exception Split of t_style * env
35
val add_style : Lexeme.style -> env -> env
val blanksNeutral : t_style -> bool
<6>32 imageManager.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
module type S =
sig
15 val start : unit -> unit
val stop : unit -> unit
val restart : unit -> unit
val put_char : char -> unit
20 val put : string -> unit
val dump : string -> (Lexing.lexbuf -> unit) -> Lexing.lexbuf -> unit
val page : unit -> unit
25 val finalize : bool -> bool
end
<6>33 image.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val start : unit -> unit
val stop : unit -> unit
val restart : unit -> unit
15
val put_char : char -> unit
val put : string -> unit
20 val dump : string -> (Lexing.lexbuf -> unit) -> Lexing.lexbuf -> unit
val page : unit -> unit
val finalize : bool -> bool
<6>34 index.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val newindex : string -> string -> string -> string -> unit
val changename : string -> string -> unit
val treat: string -> string -> string -> string
15 val print: (string -> unit) -> string -> unit
val finalize : bool -> bool
<6>35 info.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
exception Error of string
type block
15
val iso : char -> string
val iso_string : string -> string
val set_out : Out.t -> unit
20 val stop : unit -> unit
val restart : unit -> unit
val get_last_closed : unit -> block
val set_last_closed : block -> unit
val is_empty : unit -> bool
25
val get_fontsize : unit -> int
val nostyle : unit -> unit
val clearstyle : unit -> unit
val open_mod : Element.text -> unit
30 val erase_mods : Element.text list -> unit
val par : int option -> unit
val forget_par : unit -> int option
val open_block : string -> string -> unit
val close_block : string -> unit
35 val force_block : string -> string -> unit
val insert_block : string -> string -> unit
val insert_attr : string -> string -> unit
val open_maths : bool -> unit
40 val close_maths : bool -> unit
val open_display : unit -> unit
val close_display : unit -> unit
val item_display : unit -> unit
val force_item_display : unit -> unit
45 val erase_display : unit -> unit
val standard_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val limit_sup_sub :
50 (string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val int_sup_sub :
bool -> int ->
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
55 val over : bool -> Lexing.lexbuf -> unit
val left : string -> (int -> unit) -> unit
val right : string -> int
val set_dcount : string -> unit
60 val item : unit -> unit
val nitem : unit -> unit
val ditem : (string -> unit) -> string -> unit
val erase_block : string -> unit
val open_group : string -> unit
65 val open_aftergroup : (string -> string) -> unit
val close_group : unit -> unit
val put : string -> unit
val put_char : char -> unit
val flush_out : unit -> unit
70 val skip_line : unit -> unit
val loc_name : string -> unit
val open_chan : out_channel -> unit
75 val close_chan : unit -> unit
val to_string : (unit -> unit) -> string
val to_style : (unit -> unit) -> Element.text list
val get_current_output : unit -> string
80 val finalize : bool -> unit
val horizontal_line : string -> Length.t -> Length.t -> unit
val put_separator : unit -> unit
val unskip : unit -> unit
85 val put_tag : string -> unit
val put_nbsp : unit -> unit
val put_open_group : unit -> unit
val put_close_group : unit -> unit
val put_in_math : string -> unit
90
val open_table : bool -> string -> unit
val new_row : unit -> unit
val open_cell : Tabular.format -> int -> int -> unit
95 val erase_cell : unit -> unit
val close_cell : string -> unit
val do_close_cell : unit -> unit
val open_cell_group : unit -> unit
val close_cell_group : unit -> unit
100 val erase_cell_group : unit -> unit
val close_row : unit -> unit
val erase_row : unit -> unit
val close_table : unit -> unit
val make_border : string -> unit
105 val make_inside : string -> bool -> unit
val make_hline : int -> bool -> unit
val infomenu : string -> unit
val infonode : string -> string -> string -> unit
110 val infoextranode : string -> string -> string -> unit
val image : string -> string -> unit
type saved
115 val check : unit -> saved
val hot : saved -> unit
<6>36 latexmacros.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
exception Failed
15 type saved
val checkpoint : unit -> saved
val hot_start : saved -> unit
val pretty_table : unit -> unit
20 val register_init : string -> (unit -> unit) -> unit
val exec_init : string -> unit
val open_group : unit -> unit
val close_group : unit -> unit
25 val get_level : unit -> int
val exists : string -> bool
val find : string -> Lexstate.pat * Lexstate.action
val pretty_macro : Lexstate.pat -> Lexstate.action -> unit
30 val def : string -> Lexstate.pat -> Lexstate.action -> unit
val global_def : string -> Lexstate.pat -> Lexstate.action -> unit
(******************)
(* For inside use *)
35 (******************)
(* raises Failed if already defined *)
val def_init : string -> (Lexing.lexbuf -> unit) -> unit
(* raises Failed if not defined *)
40 val find_fail : string -> Lexstate.pat * Lexstate.action
(*
replace name new,
Send back the Some (old definition for name) or None
45
- if new is Some (def)
then def replaces the old definition, or a definition is created
- if new is None, then undefine the last local binding for name.
*)
50 val replace : string -> (Lexstate.pat * Lexstate.action) option ->
(Lexstate.pat * Lexstate.action) option
55 val invisible : string -> bool
<6>37 latexscan.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
module type S =
sig
15 (* external entry points *)
val no_prelude : unit -> unit
val main : Lexing.lexbuf -> unit
val print_env_pos : unit -> unit
20 (* additional resources needed for extension modules. *)
val cur_env : string ref
val new_env : string -> unit
val close_env : string -> unit
val echo_toimage : unit -> bool
25 val echo_global_toimage : unit -> bool
val fun_register : (unit -> unit) -> unit
val newif_ref : string -> bool ref -> unit
val top_open_block : string -> string -> unit
30 val top_close_block : string -> unit
val check_alltt_skip : Lexing.lexbuf -> unit
val skip_pop : Lexing.lexbuf -> unit
(* ``def'' functions for initialisation only *)
val def_code : string -> (Lexing.lexbuf -> unit) -> unit
35 val def_name_code : string -> (string -> Lexing.lexbuf -> unit) -> unit
val def_fun : string -> (string -> string) -> unit
val get_this_main : string -> string
val check_this_main : string -> bool
val get_prim : string -> string
40 val get_prim_arg : Lexing.lexbuf -> string
val get_prim_opt : string -> Lexing.lexbuf -> string
val get_csname : Lexing.lexbuf -> string
end
45 module Make (Dest : OutManager.S) (Image : ImageManager.S) : S
<6>38 length.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: length.mli,v 1.6 2001/05/25 12:37:26 maranget Exp $ *)
(***********************************************************************)
val font : int
type t = Char of int | Pixel of int | Percent of int | No of string | Default
15 val pretty : t -> string
val font : int
val pixel_to_char : int -> int
val char_to_pixel : int -> int
20 val main: Lexing.lexbuf -> t
<6>39 lexeme.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: lexeme.mli,v 1.4 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
type tag =
| TT |I |B |BIG |SMALL
| STRIKE | S |U |FONT
15 | EM |STRONG |DFN |CODE |SAMP
| KBD |VAR |CITE |ABBR |ACRONYM
| Q |SUB |SUP | A | SCRIPT | SPAN
type atag =
20 | SIZE of string | COLOR of string | FACE of string | OTHER
type attr = atag * string
type attrs = attr list
25
type token =
| Open of tag * attrs * string
| Close of tag * string
| Text of string
30 | Blanks of string
| Eof
type style =
{tag : tag ; attrs : attrs ; txt : string ; ctxt : string}
<6>40 lexstate.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type action =
| Subst of string
15 | Toks of string list
| CamlCode of (Lexing.lexbuf -> unit)
val pretty_action : action -> unit
20 type pat = string list * string list
val pretty_pat : pat -> unit
val is_subst : action -> bool
val latex_pat: string list -> int -> pat
val zero_pat : pat
25 val one_pat : pat
type subst
type 'a arg = {arg : 'a ; subst : subst }
val mkarg : 'a -> subst -> 'a arg
30 val string_to_arg : 'a -> 'a arg
val top_subst : subst
val get_subst : unit -> subst
35 exception Error of string
type alltt = Not | Inside | Macro
val effective : alltt -> bool
val raw_chars : bool ref
40 val display : bool ref
val in_math : bool ref
val alltt : alltt ref
val french : bool ref
val optarg : bool ref
45 val styleloaded : bool ref
val activebrace : bool ref
val html : bool ref
val text : bool ref
val alltt_loaded : bool ref
50
val is_plain : char -> bool
val set_plain : char -> unit
val unset_plain : char -> unit
val plain_back : bool -> char -> unit
55
val withinLispComment : bool ref
val afterLispCommentNewlines : int ref
type case = Upper | Lower | Neutral
60
val case : case ref
type closenv
val top_level : unit -> bool
65 val is_top : subst -> bool
val prerr_args : unit -> unit
val full_pretty_subst : subst -> unit
70 val pretty_lexbuf : Lexing.lexbuf -> unit
val scan_arg : (string arg -> 'a) -> int -> 'a
val scan_body :
75 (action -> 'a) -> action -> subst -> 'a
val stack_lexbuf : Lexing.lexbuf Stack.t
val previous_lexbuf : unit -> Lexing.lexbuf
val record_lexbuf : Lexing.lexbuf -> subst -> unit
80 val top_lexstate : unit -> bool
(* Saving and restoring lexstates on a stack *)
val protect_save_string : (Lexing.lexbuf -> string) -> Lexing.lexbuf -> string
val save_lexstate : unit -> unit
85 val restore_lexstate : unit -> unit
val start_lexstate : unit -> unit
val start_lexstate_subst : subst -> unit
(* Total checkpoint of lexstate *)
90 type saved_lexstate
val check_lexstate : unit -> saved_lexstate
val hot_lexstate : saved_lexstate -> unit
val flushing : bool ref
95 val stack_in_math : bool Stack.t
val stack_display : bool Stack.t
val stack_alltt : alltt Stack.t
val start_normal: subst -> unit
100 val end_normal : unit -> unit
(* Super/Sub-script parsing *)
type sup_sub = {
limits : Misc.limits option;
105 sup : string arg;
sub : string arg;
}
val unoption : string arg option -> string arg
110 val save_sup_sub : Lexing.lexbuf -> sup_sub
val save_sup : Lexing.lexbuf -> string arg option
val save_sub : Lexing.lexbuf -> string arg option
(* Argument parsing *)
type ok = | No of string | Yes of string
115 val from_ok : ok arg -> string arg
val save_arg : Lexing.lexbuf -> string arg
val save_filename : Lexing.lexbuf -> string arg
val save_verbatim : Lexing.lexbuf -> string arg
120 val save_opt : string -> Lexing.lexbuf -> string arg
val save_opts : string list -> Lexing.lexbuf -> ok arg list
val save_arg_with_delim : string -> Lexing.lexbuf -> string arg
val pretty_ok : ok -> string
val skip_opt : Lexing.lexbuf -> unit
125 val skip_csname : Lexing.lexbuf -> unit
val make_stack : string -> pat -> Lexing.lexbuf -> subst
130
val scan_this : (Lexing.lexbuf -> 'a ) -> string -> 'a
val scan_this_arg : (Lexing.lexbuf -> 'a ) -> string arg -> 'a
val scan_this_may_cont :
(Lexing.lexbuf -> 'a ) -> Lexing.lexbuf -> subst -> string arg -> 'a
135
val real_input_file :
int -> (Lexing.lexbuf -> unit) -> string -> in_channel -> unit
val input_file : int -> (Lexing.lexbuf -> unit) -> string -> unit
140 val register_cell : string -> bool ref -> unit
val unregister_cell : string -> unit
type saved
val checkpoint : unit -> saved
145 val hot_start : saved -> unit
<6>41 location.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type saved
val check : unit -> saved
val hot : saved -> unit
15
val get : unit -> string
val set : string -> Lexing.lexbuf -> unit
val restore : unit -> unit
20 type t
val get_pos : unit -> t
val print_pos : unit -> unit
val print_fullpos : unit -> unit
val print_this_pos : t -> unit
25 val print_this_fullpos : t -> unit
<6>42 misc.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
exception Fatal of string
exception NoSupport of string
exception Purposly of string
15 exception ScanError of string
exception UserError of string
exception EndInput
exception EndDocument
exception Close of string
20 exception EndOfLispComment of int (* QNC *)
val hot_start : unit -> unit
val verbose : int ref
val readverb : int ref
25 val silent : bool ref
val column_to_command : string -> string
val warning : string -> unit
val print_verb : int -> string -> unit
val message : string -> unit
30 val fatal : string -> 'a
val not_supported : string -> 'a
(* Copying hash tables, not very nice at present *)
val copy_hashtbl : (string, 'a) Hashtbl.t -> (string, 'a) Hashtbl.t -> unit
35 val clone_hashtbl : (string, 'a) Hashtbl.t -> (string, 'a) Hashtbl.t
val copy_int_hashtbl : (int, 'a) Hashtbl.t -> (int, 'a) Hashtbl.t -> unit
val clone_int_hashtbl : (int, 'a) Hashtbl.t -> (int, 'a) Hashtbl.t
val start_env : string -> string
40 val end_env : string -> string
type limits = Limits | NoLimits | IntLimits
<6>43 myfiles.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
exception Error of string
exception Except
15 val open_tex : string -> string * in_channel
val find : string -> string
val changed : string -> string -> bool
<6>44 mylib.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val static_libdir : string
val libdir : string
<6>45 mysys.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
exception Error of string
val put_from_file : string -> (string -> unit) -> unit
val copy_from_lib : string -> string -> unit
15 val rename : string -> string -> unit
val remove : string -> unit
<6>46 noimage.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val start : unit -> unit
val stop : unit -> unit
val restart : unit -> unit
15
val put_char : char -> unit
val put : string -> unit
20 val dump : string -> (Lexing.lexbuf -> unit) -> Lexing.lexbuf -> unit
val page : unit -> unit
val finalize : bool -> bool
<6>47 outManager.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
module type S =
sig
exception Error of string
15 type block
val iso : char -> string
val iso_string : string -> string
20 val set_out : Out.t -> unit
val stop : unit -> unit
val restart : unit -> unit
val get_last_closed : unit -> block
val set_last_closed : block -> unit
25 val is_empty : unit -> bool
val get_fontsize : unit -> int
val nostyle : unit -> unit
val clearstyle : unit -> unit
30 val open_mod : Element.text -> unit
val erase_mods : Element.text list -> unit
val par : int option -> unit
val forget_par : unit -> int option
val open_block : string -> string -> unit
35 val close_block : string -> unit
val force_block : string -> string -> unit
val insert_block : string -> string -> unit
val insert_attr : string -> string -> unit
40 val open_maths : bool -> unit
val close_maths : bool -> unit
val open_display : unit -> unit
val close_display : unit -> unit
val item_display : unit -> unit
45 val force_item_display : unit -> unit
val erase_display : unit -> unit
val standard_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
50 val limit_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val int_sup_sub :
bool -> int ->
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
55
val over : bool -> Lexing.lexbuf -> unit
val left : string -> (int -> unit) -> unit
val right : string -> int
60 val set_dcount : string -> unit
val item : unit -> unit
val nitem : unit -> unit
val ditem : (string -> unit) -> string -> unit
val erase_block : string -> unit
65 val open_group : string -> unit
val open_aftergroup : (string -> string) -> unit
val close_group : unit -> unit
val put : string -> unit
val put_char : char -> unit
70 val flush_out : unit -> unit
val skip_line : unit -> unit
val loc_name : string -> unit
75 val open_chan : out_channel -> unit
val close_chan : unit -> unit
val to_string : (unit -> unit) -> string
val to_style : (unit -> unit) -> Element.text list
val get_current_output : unit -> string
80
val finalize : bool -> unit
val horizontal_line : string -> Length.t -> Length.t -> unit
val put_separator : unit -> unit
85 val unskip : unit -> unit
val put_tag : string -> unit
val put_nbsp : unit -> unit
val put_open_group : unit -> unit
val put_close_group : unit -> unit
90 val put_in_math : string -> unit
val open_table : bool -> string -> unit
val new_row : unit -> unit
95 val open_cell : Tabular.format -> int -> int -> unit
val erase_cell : unit -> unit
val close_cell : string -> unit
val do_close_cell : unit -> unit
val open_cell_group : unit -> unit
100 val close_cell_group : unit -> unit
val erase_cell_group : unit -> unit
val close_row : unit -> unit
val erase_row : unit -> unit
val close_table : unit -> unit
105 val make_border : string -> unit
val make_inside : string -> bool -> unit
val make_hline : int -> bool -> unit
val infomenu : string -> unit
110 val infonode : string -> string -> string -> unit
val infoextranode : string -> string -> string -> unit
val image : string -> string -> unit
115 type saved
val check : unit -> saved
val hot : saved -> unit
end
<6>48 out.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type t
val free : t -> unit
15 val create_buff : unit -> t
val create_chan : out_channel -> t
val create_null : unit -> t
val is_null : t -> bool
val is_empty : t -> bool
20
val reset : t -> unit
val is_empty: t -> bool
val put : t -> string -> unit
25 val blit : t -> Lexing.lexbuf -> unit
val put_char : t -> char -> unit
val flush: t -> unit
val get_pos : t -> int
val erase_start : int -> t -> unit
30
val iter : (char -> unit) -> t -> unit
val to_string : t -> string
val to_chan : out_channel -> t -> unit
val copy : t -> t -> unit
35 val copy_fun : (string -> string) -> t -> t -> unit
val copy_no_tag : t -> t -> unit
val close : t -> unit
val debug : out_channel -> t -> unit
40 val unskip : t -> unit
<6>49 package.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* Luc Maranget, projet PARA, INRIA Rocquencourt *)
5 (* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(* *)
10 (***********************************************************************)
(* $Id: package.mli,v 1.2 1999/10/13 08:21:26 maranget Exp $ *)
module type S = sig end
15
module Make
(Dest : OutManager.S) (Image : ImageManager.S)
(Scan : Latexscan.S) : S
<6>50 parse_opts.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
type input = File of string | Prog of string
val symbols : bool ref
15 val iso : bool ref
type language = Francais | English
val language : language ref
type destination = Html | Text | Info
val destination : destination ref
20 val mathml : bool ref
val entities : bool ref
val pedantic : bool ref
val fixpoint : bool ref
val optimize : bool ref
25 val width : int ref
val except : string list ref
val path : string list ref
val filter : bool
30 val styles : input list
val base_in : string
val name_in : string
val base_out : string
val name_out : string
<6>51 pp.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: pp.mli,v 1.4 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
val ptree : out_channel -> Lexeme.style Tree.t -> unit
val ptrees : out_channel -> Lexeme.style Tree.t list -> unit
15 val tree : out_channel -> Htmltext.style Tree.t -> unit
val trees : out_channel -> Htmltext.style Tree.t list -> unit
<6>52 save.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val if_next_char : char -> Lexing.lexbuf -> bool
val if_next_string : string -> Lexing.lexbuf -> bool
15 exception Error of string
exception Delim of string
val empty_buffs : unit -> unit
val set_verbose : bool -> int -> unit
val seen_par : bool ref
20
exception Eof
exception NoOpt
val get_echo : unit -> string
val start_echo : unit -> unit
25 val opt : Lexing.lexbuf -> string
val arg : Lexing.lexbuf -> string
val arg_verbatim : Lexing.lexbuf -> string
val csname : Lexing.lexbuf ->
(string -> string) -> (string -> string) -> string
30 val incsname : Lexing.lexbuf -> string
val cite_arg : Lexing.lexbuf -> string list
val rest : Lexing.lexbuf -> string
val num_arg : Lexing.lexbuf -> (string -> int) -> int
val skip_equal : Lexing.lexbuf -> unit
35 val check_equal : Lexing.lexbuf -> bool
val filename : Lexing.lexbuf -> string
(* Superscript and subscripts *)
val get_limits : Lexing.lexbuf -> Misc.limits option
val get_sup : Lexing.lexbuf -> string option
40 val get_sub : Lexing.lexbuf -> string option
val defargs : Lexing.lexbuf -> string list
val get_defargs : Lexing.lexbuf -> string
val tagout : Lexing.lexbuf -> string
45 val checklimits : Lexing.lexbuf -> bool
val skip_delim : string -> Lexing.lexbuf -> unit
val with_delim : string -> Lexing.lexbuf -> string
val skip_blanks_init : Lexing.lexbuf -> unit
<6>53 section.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val value: string -> int
<6>54 stack.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: stack.mli,v 1.8 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
exception Fatal of string
type 'a t
15 val create : string -> 'a t
val create_init : string -> 'a -> 'a t
val reset : 'a t -> unit
val name : 'a t -> string
20 val push : 'a t -> 'a -> unit
val pop : 'a t -> 'a
val top : 'a t -> 'a
val pretty : ('a -> string) -> 'a t -> unit
val length : 'a t -> int
25 val empty : 'a t -> bool
val rev : 'a t -> unit
val map : 'a t -> ('a -> 'a) -> unit
type 'a saved
30 val empty_saved : 'a saved
val save : 'a t -> 'a saved
val restore : 'a t -> 'a saved -> unit
val finalize : 'a t -> ('a -> bool) -> ('a -> unit) -> unit
(*
35 finalize now p f
apply f to now elements until
now is empty or p is true for one element
*)
<6>55 subst.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: subst.mli,v 1.6 2001/05/25 12:37:29 maranget Exp $ *)
(***********************************************************************)
open Lexstate
val do_subst_this : string arg -> string
val subst_this : string -> string
15 val subst_arg : Lexing.lexbuf -> string
val subst_opt : string -> Lexing.lexbuf -> string
val subst_body : Lexing.lexbuf -> string
<6>56 symb.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val put_delim : (unit -> unit) -> (string -> unit) -> string -> int -> unit
<6>57 table.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
exception Empty
type 'a t
15 val create : 'a -> 'a t
val reset : 'a t -> unit
val emit : 'a t -> 'a -> unit
val apply : 'a t -> ('a -> unit) -> unit
20 val trim : 'a t -> 'a array
val remove_last : 'a t -> unit
val get_size : 'a t -> int
<6>58 tabular.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: tabular.mli,v 1.11 2001/05/25 12:37:29 maranget Exp $ *)
(***********************************************************************)
exception Error of string
type align =
15 {hor : string ; mutable vert : string ; wrap : bool ;
mutable pre : string ; mutable post : string ; width : Length.t}
type format =
Align of align
| Inside of string
20 | Border of string
val border : bool ref
val pretty_format : format -> string
25 val pretty_formats : format array -> unit
val main : string Lexstate.arg -> format array
<6>59 text.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
open Lexstate
exception Error of string
type block
15 val iso : char -> string
val iso_string : string -> string
val set_out : Out.t -> unit
val stop : unit -> unit
20 val restart : unit -> unit
val get_last_closed : unit -> block
val set_last_closed : block -> unit
val is_empty : unit -> bool
25 val get_fontsize : unit -> int
val nostyle : unit -> unit
val clearstyle : unit -> unit
val open_mod : Element.text -> unit
val erase_mods : Element.text list -> unit
30 val par : int option -> unit
val forget_par : unit -> int option
val open_block : string -> string -> unit
val close_block : string -> unit
val force_block : string -> string -> unit
35 val insert_block : string -> string -> unit
val insert_attr : string -> string -> unit
val open_maths : bool -> unit
val close_maths : bool -> unit
40 val open_display : unit -> unit
val close_display : unit -> unit
val item_display : unit -> unit
val force_item_display : unit -> unit
val erase_display : unit -> unit
45
val standard_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val limit_sup_sub :
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
50 val int_sup_sub :
bool -> int ->
(string arg -> unit) -> (unit -> unit) -> string arg -> string arg -> bool -> unit
val over : bool -> Lexing.lexbuf -> unit
55 val left : string -> (int -> unit) -> unit
val right : string -> int
val set_dcount : string -> unit
val item : unit -> unit
60 val nitem : unit -> unit
val ditem : (string -> unit) -> string -> unit
val erase_block : string -> unit
val open_group : string -> unit
val open_aftergroup : (string -> string) -> unit
65 val close_group : unit -> unit
val put : string -> unit
val put_char : char -> unit
val flush_out : unit -> unit
val skip_line : unit -> unit
70
val loc_name : string -> unit
val open_chan : out_channel -> unit
val close_chan : unit -> unit
75 val to_string : (unit -> unit) -> string
val to_style : (unit -> unit) -> Element.text list
val get_current_output : unit -> string
val finalize : bool -> unit
80
val horizontal_line : string -> Length.t -> Length.t -> unit
val put_separator : unit -> unit
val unskip : unit -> unit
val put_tag : string -> unit
85 val put_nbsp : unit -> unit
val put_open_group : unit -> unit
val put_close_group : unit -> unit
val put_in_math : string -> unit
90
val open_table : bool -> string -> unit
val new_row : unit -> unit
val open_cell : Tabular.format -> int -> int -> unit
val erase_cell : unit -> unit
95 val close_cell : string -> unit
val do_close_cell : unit -> unit
val open_cell_group : unit -> unit
val close_cell_group : unit -> unit
val erase_cell_group : unit -> unit
100 val close_row : unit -> unit
val erase_row : unit -> unit
val close_table : unit -> unit
val make_border : string -> unit
val make_inside : string -> bool -> unit
105 val make_hline : int -> bool -> unit
val infomenu : string -> unit
val infonode : string -> string -> string -> unit
val infoextranode : string -> string -> string -> unit
110
val image : string -> string -> unit
type saved
val check : unit -> saved
115 val hot : saved -> unit
<6>60 thread.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val setup : string -> string -> unit
val setprev : string -> string -> unit
val setnext : string -> string -> unit
15 val setprevnext : string -> string -> unit
val next : string -> string
val prev : string -> string
val up : string -> string
20
val change : string -> string -> unit
<6>61 tree.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: tree.mli,v 1.4 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
open Lexeme
15
type 'a t =
| Text of string
| Blanks of string
| Node of 'a * ('a t) list
20 | ONode of string * string * ('a t) list
<6>62 ultra.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: ultra.mli,v 1.4 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
val verbose : int ref
val main : out_channel -> Lexeme.style Tree.t list -> unit
<6>63 util.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: util.mli,v 1.5 2001/05/28 17:28:56 maranget Exp $ *)
(***********************************************************************)
val cost : ('a -> int * int) -> 'a Tree.t -> int * int
val costs : ('a -> int * int) -> 'a Tree.t list -> int * int
15 val cost_compare : int * int -> int * int -> int
val there : Htmltext.t_style -> Htmltext.style -> bool
val inter : Htmltext.style -> Htmltext.style -> Htmltext.style
val union : Htmltext.style -> Htmltext.style -> Htmltext.style
val sub : Htmltext.style -> Htmltext.style -> Htmltext.style
20 val neutral : Htmltext.style -> Htmltext.style * Htmltext.style
val is_blank : 'a Tree.t -> bool
val is_blanks : 'a Tree.t list -> bool
val nodes :
Htmltext.style -> Htmltext.style Tree.t list -> Htmltext.style Tree.t list
25 val node :
Htmltext.style -> Htmltext.style Tree.t list -> Htmltext.style Tree.t
<6>64 verb.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: verb.mli,v 1.9 2001/05/25 12:37:32 maranget Exp $ *)
(***********************************************************************)
exception VError of string
module type S = sig end
15
module Make
(Dest : OutManager.S) (Image : ImageManager.S)
(Scan : Latexscan.S) : S
<6>65 version.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1998 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (***********************************************************************)
val version : string
<6>66 videoc.mli
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* Christian Queinnec, Universite Paris IV *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
10 (* *)
(***********************************************************************)
(* <Christian.Queinnec@lip6.fr>
The plugin for HeVeA that implements the VideoC style.
15 $Id: videoc.mli,v 1.7 2001/05/25 12:37:34 maranget Exp $
*)
module type T =
sig
20 end;;
module Make
(Dest : OutManager.S) (Image : ImageManager.S)
(Scan : Latexscan.S) : T
<6>67 auxx.ml
(***********************************************************************)
(* *)
(* 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
let header = "$Id: auxx.ml,v 1.14 2001/05/25 09:07:06 maranget Exp $"
15
let rtable = Hashtbl.create 17
;;
let rset name value =
20 Hashtbl.add rtable name value
;;
let rget name =
25 try Hashtbl.find rtable name with Not_found -> begin
warning ("Undefined label: ``"^name^"''") ; "??"
end
;;
30 let btable = Hashtbl.create 17
;;
let bset name value = Hashtbl.add btable name value
;;
35
let bget warn name =
let r =
try Hashtbl.find btable name with Not_found ->
begin
40 if warn then warning ("Undefined citation: ``"^name^"''") ;
"\\@verbarg{"^name^"}"
end in
r
;;
45
let auxfile = ref None
and auxname = ref ""
and something = ref false
and changed = ref false
50 ;;
let rseen = Hashtbl.create 17
and bseen = Hashtbl.create 17
;;
55
let init base =
let filename = base^".haux" in
try
let file = open_out filename in
60 auxname := filename ;
auxfile := Some file
with Sys_error s ->
warning ("Cannot open out file: "^filename^" : "^s)
65 (* result is true when another run is needed *)
and finalize check =
match !auxfile with
| None -> false
70 | Some file ->
close_out file ;
if not !something then
Mysys.remove !auxname;
if check then begin
75 let check_disappear table seen =
Hashtbl.iter
(fun key _ ->
try Hashtbl.find seen key
with Not_found ->
80 Misc.warning ("Disappear: "^key) ;
changed := true)
table in
if not !changed then begin
check_disappear rtable rseen ;
85 check_disappear btable bseen
end ;
if !changed then
Misc.message
"HeVeA Warning: Label(s) may have changed. Rerun me to get cross-references right." ;
90 !changed
end else
false
;;
95 let write table output_fun key pretty = match !auxfile with
| None -> ()
| Some file ->
something := true ;
changed :=
100 !changed ||
(try let olds = Hashtbl.find_all table key in
match olds with
| [] -> true
| [old] -> pretty <> old
105 | _ -> false (* In that case, can't tell *)
with Not_found -> true) ;
output_fun file
;;
110
let bcheck key =
try
let _ = Hashtbl.find bseen key in
warning ("Multiple definitions for citation: "^key) ;
115 false
with
| Not_found ->
Hashtbl.add bseen key () ;
true
120
let rcheck key =
try
let _ = Hashtbl.find rseen key in
warning ("Multiple definitions for label: "^key) ;
125 false
with
| Not_found ->
Hashtbl.add rseen key () ;
true
130
let bwrite key pretty =
if bcheck key then
write btable
135 (fun file ->
output_string file "\\bibcite{" ;
output_string file key ;
output_string file "}{" ;
output_string file pretty ;
140 output_string file "}\n") key pretty
and rwrite key pretty =
if rcheck key then
write rtable
145 (fun file ->
output_string file "\\newlabel{" ;
output_string file key ;
output_string file "}{{" ;
output_string file pretty ;
150 output_string file "}{X}}\n") key pretty
;;
type saved =
(string, string) Hashtbl.t * (string, unit) Hashtbl.t *
155 (string, string) Hashtbl.t * (string, unit) Hashtbl.t *
out_channel option * string * bool * bool
let check () =
Misc.clone_hashtbl rtable, Misc.clone_hashtbl rseen,
160 Misc.clone_hashtbl btable, Misc.clone_hashtbl bseen,
!auxfile, !auxname, !something, !changed
let hot
(srtable, srseen, sbtable, sbseen,
165 sauxfile, sauxname, ssomething, schanged) =
Misc.copy_hashtbl srtable rtable ; Misc.copy_hashtbl srseen rseen ;
Misc.copy_hashtbl sbtable btable ; Misc.copy_hashtbl sbseen bseen ;
auxfile := sauxfile ;
auxname := sauxname ;
170 something := ssomething ;
changed := schanged
(* Valid only juste before reading main input file *)
let hot_start () =
175 Hashtbl.clear rtable ; Hashtbl.clear rseen ;
Hashtbl.clear btable ; Hashtbl.clear bseen ;
auxfile := None ;
auxname := "" ;
something := false ;
180 changed := false
<6>68 buff.ml
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: buff.ml,v 1.4 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
type t = {mutable t : string ; mutable p : int}
;;
15 let create () = {t = String.create 64 ; p = 0}
let rec realloc d b =
let l = String.length b.t in
if b.p + d-1 >= l then begin
20 let new_t = String.create (2*l) in
String.blit b.t 0 new_t 0 b.p ;
b.t <- new_t ;
realloc d b
end
25
let put_char b c =
realloc 1 b ;
b.t.[b.p] <- c ;
30 b.p <- b.p + 1
let put b s =
let l = String.length s in
realloc l b ;
35 String.blit s 0 b.t b.p l ;
b.p <- b.p + l
let to_string b =
let r = String.sub b.t 0 b.p in
40 b.p <- 0 ;
r
let reset b = b.p <- 0
<6>69 color.ml
(***********************************************************************)
(* *)
(* 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: color.ml,v 1.9 2000/01/19 20:10:58 maranget Exp $"
let default_color = "#000000"
15 ;;
let table = Hashtbl.create 17
;;
type saved = (string, string) Hashtbl.t
20
let checkpoint () =
let ctable = Hashtbl.create 17 in
Misc.copy_hashtbl table ctable ;
ctable
25
and hot_start ctable = Misc.copy_hashtbl ctable table
let to_hex x =
Printf.sprintf "%02x" (truncate (255.0 *. x))
30 ;;
let cmyk_to_rgb c m y k =
1.0 -. min 1.0 (c *. (1.0 -. k) +. k),
1.0 -. min 1.0 (m *. (1.0 -. k) +. k),
35 1.0 -. min 1.0 (y *. (1.0 -. k) +. k)
;;
let hls_to_rgb h l s =
let rgb q1 q2 hue =
40 let hue =
if hue > 360.0 then hue -. 360.0
else if hue < 0.0 then hue +. 360.0
else hue in
if hue < 60.0 then
45 q1 +. (q2 -. q1) /. 60.0
else if hue < 180.0 then
q2
else if hue < 240.0 then
q1 +. (q2 -. q1) *. (240.0 -. hue) /. 60.0
50 else
q1 in
let p2 =
if l <= 0.5 then l *. (1.0 +. s)
else l +. s -. (l *. s) in
55 let p1 = 2.0 *. l -. p2 in
if s = 0.0 then
l,l,l
else
rgb p1 p2 (h +. 100.0),
60 rgb p1 p2 h,
rgb p1 p2 (h -. 120.0)
;;
let hsv_to_rgb h s v =
65 if s = 0.0 then v,v,v
else
let h = h /. 60.0 in
let i = truncate h in
let f = h -. float i in
70 let p = v *. (1.0 -. s) in
let q = v *. (1.0 -. (s *. f)) in
let t = v *. (1.0 -. (s *. (1.0 -. f))) in
match i with
| 0 -> v,t,p
75 | 1 -> q,v,p
| 2 -> p,v,t
| 3 -> p,q,v
| 4 -> t,p,v
| 5 -> v,p,q
80 | _ -> Misc.fatal ("Bad HSV color specification")
;;
85 exception Failed
;;
let do_compute mdl value = match mdl with
| "gray" ->
90 let x = Colscan.one (Lexing.from_string value) in
let xx = to_hex x in
xx^xx^xx
| "rgb" ->
let r,g,b = Colscan.three(Lexing.from_string value) in
95 to_hex r^to_hex g^to_hex b
| "cmyk" ->
let c,m,y,k = Colscan.four (Lexing.from_string value) in
let r,g,b = cmyk_to_rgb c m y k in
to_hex r^to_hex g^to_hex b
100 | "hsv" ->
let h,s,v = Colscan.three (Lexing.from_string value) in
let r,g,b = hsv_to_rgb h s v in
to_hex r^to_hex g^to_hex b
| "hls" ->
105 let h,l,s = Colscan.three (Lexing.from_string value) in
let r,g,b = hls_to_rgb h l s in
to_hex r^to_hex g^to_hex b
| "named" -> begin
try Hashtbl.find table ("named@"^value) with
110 | Not_found -> begin
Misc.warning ("Unkown name in the named color model: "^value) ;
raise Failed
end
end
115 | _ ->
Misc.warning ("Color.compute, unknown color model: "^mdl);
raise Failed
120
let compute mdl value =
try do_compute mdl value with Failed -> ""
let define clr mdl value =
125 try
Hashtbl.add table clr (do_compute mdl value)
with Failed -> ()
;;
130 let retrieve clr =
try
Hashtbl.find table clr
with Not_found ->
Misc.warning ("Color.retrieve, unknown color: "^clr);
135 default_color
;;
let define_named name mdl value = define ("named@"^name) mdl value
140 ;;
let remove clr = Hashtbl.remove table clr
<6>70 colscan.ml
12 "colscan.mll"
open Lexing
5 exception Error of string
;;
let buf = Out.create_buff ()
;;
10 let lex_tables = {
Lexing.lex_base =
"\000\000\001\000\255\255\003\000\012\000\027\000\039\000\002\000\
";
Lexing.lex_backtrk =
"\000\000\001\000\255\255\255\255\000\000\000\000\000\000\000\000\
";
15 Lexing.lex_default =
"\255\255\255\255\000\000\255\255\255\255\255\255\255\255\255\255\
";
Lexing.lex_trans =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\004\000\003\000\007\000\003\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\004\000\002\000\005\000\002\000\
\006\000\006\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\007\000\006\000\006\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\000\000\007\000\
\000\000\000\000\000\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\000\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
";
Lexing.lex_check =
20 "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\001\000\007\000\003\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\004\000\001\000\000\000\003\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\004\000\005\000\004\000\004\000\004\000\004\000\
\004\000\004\000\004\000\004\000\004\000\004\000\255\255\006\000\
\255\255\255\255\255\255\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\006\000\255\255\006\000\
\006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
\006\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
"
}
let rec one lexbuf = __ocaml_lex_one_rec lexbuf 0
and __ocaml_lex_one_rec lexbuf state =
25 match Lexing.engine lex_tables state lexbuf with
0 -> (
23 "colscan.mll"
let lxm = lexeme lexbuf in
float_of_string lxm)
30 | 1 -> (
25 "colscan.mll"
raise (Error "Syntax error in color argument"))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_one_rec lexbuf n
35 and other lexbuf = __ocaml_lex_other_rec lexbuf 1
and __ocaml_lex_other_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
28 "colscan.mll"
40 one lexbuf)
| 1 -> (
29 "colscan.mll"
raise (Error "Syntax error in color argument"))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_other_rec lexbuf n
45
and three lexbuf = __ocaml_lex_three_rec lexbuf 2
and __ocaml_lex_three_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
50 33 "colscan.mll"
let fst = one lexbuf in
let snd = other lexbuf in
let thrd = other lexbuf in
fst,snd,thrd)
55 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_three_rec lexbuf n
and four lexbuf = __ocaml_lex_four_rec lexbuf 2
and __ocaml_lex_four_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
60 0 -> (
39 "colscan.mll"
let fst = one lexbuf in
let snd = other lexbuf in
let thrd = other lexbuf in
65 let fourth = other lexbuf in
fst,snd,thrd,fourth)
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_four_rec lexbuf n
;;
<6>71 counter.ml
(***********************************************************************)
(* *)
(* 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: counter.ml,v 1.10 2000/01/19 20:10:59 maranget Exp $"
type t_counter =
{mutable count : int ;
15 mutable within : t_counter option ;
mutable related : t_counter list}
let mk_bidon () = {count = 0 ; within = None ; related = []}
20 type t_checked =
{cname : string ;
cvalue : int ;
cwithin : int option ;
crelated : int list}
25
let cbidon = {cname = "" ; cvalue = (-1) ; cwithin = None ; crelated = []}
let ctable = (Hashtbl.create 19 : (string,t_counter) Hashtbl.t);;
30 type saved = t_checked array
let prerr_cc check_ctable cc =
prerr_endline ("counter: "^cc.cname) ;
35 prerr_endline ("\tvalue = "^string_of_int cc.cvalue) ;
prerr_endline
("\twithin = "^
begin match cc.cwithin with
| None -> "None"
40 | Some j -> (check_ctable).(j).cname
end) ;
prerr_string "\trelated =" ;
List.iter
(fun j ->
45 prerr_string " " ;
prerr_string (check_ctable).(j).cname)
cc.crelated ;
prerr_endline ""
50 let checkpoint () =
let module H = struct
type t = t_counter
let equal = (==)
let hash = Hashtbl.hash
55 end in
let module RevHash = Hashtbl.Make (H) in
let rev_table = RevHash.create 19
and count = ref 0 in
Hashtbl.iter
60 (fun key value ->
RevHash.add rev_table value (key, !count) ;
incr count)
ctable ;
let to_int c =
65 try
let _,j = RevHash.find rev_table c in
j
with
| Not_found -> Misc.fatal "Counter.checkpoint" in
70
let t = Array.create !count cbidon in
RevHash.iter
(fun {count = value ; within = within ; related = related} (name, i) ->
75 t.(i) <-
{cname = name ;
cvalue = value ;
cwithin =
begin match within with
80 | None -> None
| Some c -> Some (to_int c)
end ;
crelated = List.map to_int related})
rev_table ;
85 t
and hot_start check_ctable =
Hashtbl.clear ctable ;
90 let rec create_rec i =
let cc = (check_ctable).(i) in
try
Hashtbl.find ctable cc.cname
with
95 | Not_found ->
let c =
{count = cc.cvalue ; within = None ; related = []} in
Hashtbl.add ctable cc.cname c;
c.within <- begin match cc.cwithin with
100 | None -> None
| Some j -> Some (create_rec j) end ;
c.related <- List.map create_rec cc.crelated ;
if !Misc.verbose > 1 then begin
prerr_string "Restored " ;
105 prerr_cc check_ctable cc
end ;
c in
for i = 0 to Array.length check_ctable - 1 do
let _ = create_rec i in ()
110 done
;;
let unkown name where =
Misc.warning ("Unknown counter: "^name^" in "^where)
115
let find_counter name = Hashtbl.find ctable name
let value_counter name =
120 try
let {count=c} = find_counter name in
c
with Not_found -> begin
unkown name "\\value" ; 0
125 end
;;
let def_counter name within =
try
130 let _ = Hashtbl.find ctable name in
Misc.warning ("Counter "^name^" is already defined, not defining it") ;
raise Latexmacros.Failed
with
| Not_found -> begin
135 let within_c =
try match within with "" -> None | _ -> Some (find_counter within)
with Not_found -> begin
unkown within ("\\newcounter{"^name^"}["^within^"]") ;
None end in
140 let c = {count=0 ; within=within_c ; related = []} in
Hashtbl.add ctable name c ;
match within_c with
| Some d -> d.related <- c :: d.related
| _ -> ()
145 end
let number_within name within =
try
let c = find_counter name in
150 begin match c.within with
| Some d ->
d.related <-
List.fold_right (fun e r -> if e == c then r else e :: r)
d.related []
155 | _ -> ()
end ;
let d = find_counter within in
c.within <- Some d ;
d.related <- c :: d.related
160 with Not_found ->
unkown (name^" or "^within) ("\\numberwithin")
let add_counter name i =
try
165 let c = find_counter name in
c.count <- c.count + i
with Not_found -> unkown name "\\addtocounter"
let set_counter name x =
170 try
let c = find_counter name in
c.count <- x
with Not_found -> unkown name "\\setcounter"
;;
175
let step_counter name =
try
let c = find_counter name in
c.count <- c.count + 1;
180 List.iter (fun c -> c.count <- 0) c.related
with Not_found ->
unkown name ("\\stepcounter")
;;
<6>72 cross.ml
(***********************************************************************)
(* *)
(* 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: cross.ml,v 1.10 2000/03/28 13:52:53 maranget Exp $"
let verbose = ref 0
;;
15
let table = Hashtbl.create 37
;;
let add name file =
20 if !verbose > 0 then
prerr_endline ("Register "^name^" in "^file) ;
try
let _ = Hashtbl.find table name in
Location.print_pos () ;
25 prerr_endline ("Warning, multiple definitions for anchor: "^name) ;
with
| Not_found ->
Hashtbl.add table name (ref file)
;;
30
let fullname myfilename name =
try
let filename = !(Hashtbl.find table name) in
35 let newname =
if myfilename = filename then
"#"^name
else
filename^"#"^name in
40 if !verbose > 0 then
prerr_endline ("From "^name^" to "^newname) ;
newname
with Not_found -> begin
Location.print_pos () ;
45 prerr_endline ("Warning, cannot find anchor: "^name) ;
raise Not_found
end
;;
50 let change oldname name =
Hashtbl.iter
(fun k x -> if !x = oldname then x := name)
table
<6>73 cutmain.ml
(***********************************************************************)
(* *)
(* 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: cutmain.ml,v 1.15 2001/05/25 09:07:08 maranget Exp $"
exception Error of string
15 ;;
let filename = ref ""
;;
20 let outname = ref "index.html"
;;
let main () =
Arg.parse
25 [("-o", Arg.String (fun s -> outname := s),
"filename, make htmlcut output go into file ``filename'' (defaults to index.html)");
("-francais", Arg.Unit (fun () -> Cut.language := "fra"),
", French mode");
("-tocbis", Arg.Unit (fun () -> Cut.tocbis := true),
30 ", Add small table of contents at the begining of files");
("-v", Arg.Unit (fun () -> incr Cut.verbose),
", verbose flag") ]
(fun s -> filename := s) ("hacha "^Version.version);
let base = Filename.basename !filename in
35 Cut.name :=
(try Filename.chop_extension base with Invalid_argument _ -> base) ;
let chan = try open_in !filename with Sys_error s -> raise (Error ("File error: "^s)) in
let buf = Lexing.from_channel chan in
Location.set !filename buf ;
40 Cut.start_phase !outname ;
Cut.main buf ;
Location.restore () ;
let chan = try open_in !filename with Sys_error s -> raise (Error ("File error: "^s)) in
let buf = Lexing.from_channel chan in
45 Location.set !filename buf ;
Cut.start_phase !outname ;
Cut.main buf
;;
50
let copy_gifs () =
try
Mysys.copy_from_lib Mylib.libdir "previous_motif.gif" ;
Mysys.copy_from_lib Mylib.libdir "next_motif.gif" ;
55 Mysys.copy_from_lib Mylib.libdir "contents_motif.gif"
with
| Mysys.Error s ->
Location.print_pos () ;
prerr_endline s
60
let _ = try
main () ;
copy_gifs ()
with
65 | Error s ->
prerr_endline s ;
prerr_endline "Adios" ;
exit 2
| Cut.Error s ->
70 Location.print_pos () ;
prerr_endline ("Error while reading HTML: "^s) ;
prerr_endline "Adios" ;
exit 2
| Misc.Fatal s ->
75 Location.print_pos () ;
prerr_endline
("Fatal error: "^s^" (please report to Luc.Maranget@inria.fr") ;
prerr_endline "Adios" ;
exit 2
80 | x ->
Location.print_pos () ;
prerr_endline
("Fatal error: spurious exception "^Printexc.to_string x^
" (please report to Luc.Maranget@inria.fr") ;
85 prerr_endline "Adios" ;
exit 2
;;
exit 0;;
<6>74 cut.ml
12 "cut.mll"
open Lexing
open Stack
5 let header = "$Id: cut.mll,v 1.30 2001/05/25 09:07:07 maranget Exp $"
let verbose = ref 0
;;
10 let language = ref "eng"
;;
let tocbis = ref false
;;
15
exception Error of string
(* Accumulate all META, LINK and similar tags that appear in the preamble
20 in order to output them in the preamble of every generated page. *)
let header_buff = Out.create_buff ()
let common_headers = ref "";;
25 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 () =
30 common_headers := Out.to_string header_buff
let html_buff = Out.create_buff ()
let html_head = ref ""
and html_foot = ref ""
35
let phase = ref (-1)
;;
let name = ref "main"
40 and count = ref 0
;;
let body = ref "<BODY>"
and doctype = ref ""
45 and html = ref "<HTML>"
;;
let changed_t = Hashtbl.create 17
50 let rec check_changed name =
try
let r = Hashtbl.find changed_t name in
check_changed r
with
55 | Not_found -> name
let new_filename () =
incr count ;
let r1 = Printf.sprintf "%s%0.3d.html" !name !count in
60 let r2 = check_changed r1 in
r2
;;
let out = ref (Out.create_null ())
65 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)
70 and flow_stack = (Stack.create "flow" : Out.t Stack.t)
;;
let toc = ref !out
and tocname = ref !outname
75 and otherout = ref !out
;;
let change_name oldname name =
if !phase <= 0 then begin
80 Thread.change oldname name ;
Cross.change oldname name ;
outname := name ;
Hashtbl.add changed_t oldname name
end
85
let start_phase name =
incr phase ;
if !verbose > 0 then
90 prerr_endline ("Starting phase number: "^string_of_int !phase);
outname := name ;
tocname := name ;
otheroutname := "" ;
count := 0 ;
95 if !phase > 0 then begin
out := (Out.create_chan (open_out name))
end ;
toc := !out
;;
100
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>" ;
105 Out.put out "<A HREF=\"" ;
Out.put out filename ;
Out.put out "\">" ;
Out.put out s ;
Out.put out "</A>\n"
110
and itemanchor filename label s out =
Out.put out "<LI>" ;
Out.put out "<A HREF=\"" ;
Out.put out filename ;
115 Out.put_char out '#' ;
Out.put out label ;
Out.put out "\">" ;
Out.put out s ;
Out.put out "</A>\n"
120
and putanchor label out =
Out.put out "<A NAME=\"" ;
Out.put out label ;
Out.put out "\"></A>"
125
and itemlist s out =
Out.put out "<LI>" ;
Out.put out s
;;
130
let putlink out name img alt =
Out.put out "<A HREF=\"" ;
Out.put out name ;
Out.put out "\"><IMG SRC =\"" ;
135 Out.put out img ;
Out.put out "\" ALT=\"" ;
Out.put out alt ;
Out.put out "\"></A>\n"
;;
140
let link_buff = Out.create_buff ()
let putlinks name =
let links_there = ref false in
145 if !verbose > 0 then
prerr_endline ("putlinks: "^name) ;
begin try
putlink link_buff (Thread.prev name) "previous_motif.gif"
(if !language = "fra" then "Precedent"
150 else "Previous") ;
links_there := true
with Not_found -> () end ;
begin try
putlink link_buff (Thread.up name) "contents_motif.gif"
155 (if !language = "fra" then "Index"
else "Contents") ;
links_there := true
with Not_found -> () end ;
begin try
160 putlink link_buff (Thread.next name) "next_motif.gif"
(if !language = "fra" then "Suivant"
else "Next") ;
links_there := true
with Not_found -> () end ;
165 if !links_there then
Some (Out.to_string link_buff)
else
None
170 let putlinks_start out outname = match putlinks outname with
| Some s ->
Out.put out s ;
Out.put out "<HR>\n"
| None -> ()
175
let putlinks_end out outname = match putlinks outname with
| Some s ->
Out.put out "<HR>\n" ;
Out.put out s
180 | None -> ()
let openhtml withlinks title out outname =
Out.put out !doctype ; Out.put_char out '\n' ;
185 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
190 Out.put out title ;
Out.put out "\n</TITLE>\n" ;
Out.put out "</HEAD>\n" ;
Out.put out !body;
Out.put out "\n" ;
195 if withlinks then
putlinks_start out outname ;
Out.put out !html_head
200 and closehtml withlinks name out =
Out.put out !html_foot ;
if withlinks then begin
putlinks_end out name
end ;
205 Out.put out "</BODY>\n" ;
Out.put out "</HTML>\n" ;
Out.close out
;;
210 let put_sec hd title hde out =
Out.put out hd ;
Out.put_char out '\n' ;
Out.put out title ;
Out.put out hde ;
215 Out.put_char out '\n'
;;
let put s = Out.put !out s
220 and put_char c = Out.put_char !out c
;;
let cur_level = ref (Section.value "DOCUMENT")
and chapter = ref (Section.value "CHAPTER")
225 and depth = ref 2
;;
(* Open all lists in toc from chapter to sec, with sec > chapter *)
230 let rec do_open l1 l2 =
if l1 < l2 then begin
openlist !toc ;
if !tocbis then openlist !out_prefix ;
do_open (l1+1) l2
235 end
;;
(* close from l1 down to l2 *)
let rec do_close l1 l2 =
240 if l1 > l2 then begin
closelist !toc ;
if !tocbis then closelist !out_prefix ;
do_close (l1-1) l2
end else
245 cur_level := l1
;;
let anchor = ref 0
;;
250
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 ;
255 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 ;
260 cur_level := sec
end else
cur_level := sec
and close_section sec =
265 if !phase > 0 then do_close !cur_level sec
else
cur_level := sec
;;
270 let close_chapter () =
if !verbose > 0 then
prerr_endline ("Close chapter out="^ !outname^" toc="^ !tocname) ;
if !phase > 0 then begin
closehtml true !outname !out ;
275 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
280 end else
Out.close !out ;
out := !toc
end else begin
lastclosed := !outname ;
285 outname := !tocname
end
and open_chapter name =
outname := new_filename () ;
290 if !verbose > 0 then
prerr_endline
("Open chapter out="^ !outname^" toc="^ !tocname^
" cur_level="^string_of_int !cur_level) ;
if !phase > 0 then begin
295 if !tocbis then begin
out_prefix := Out.create_buff () ;
out := !out_prefix ;
openhtml true name !out_prefix !outname
end else begin
300 out := Out.create_chan (open_out !outname) ;
openhtml true name !out !outname
end ;
itemref !outname name !toc ;
cur_level := !chapter
305 end else begin
if !verbose > 0 then
prerr_endline ("link prev="^ !lastclosed^" next="^ !outname) ;
Thread.setup !outname !tocname ;
Thread.setprevnext !lastclosed !outname ;
310 cur_level := !chapter
end
;;
let setlink set target =
if !phase = 0 && target <> "" then
315 set !outname target
let open_notes sec_notes =
if sec_notes <> !chapter || !outname = !tocname then begin
otheroutname := !outname ;
320 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' ;
325 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 ;
330 Out.put !out "\n"
end
end else
otheroutname := ""
335 and close_notes () =
if !otheroutname <> "" then begin
Out.put !out "\n</BODY></HTML>\n" ;
Out.close !out ;
outname := !otheroutname ;
340 out := !otherout ;
otheroutname := ""
end
;;
345 let toc_buf = Out.create_buff ()
and arg_buf = Out.create_buff ()
;;
let stack = Stack.create "main"
350 ;;
let save_state newchapter newdepth =
if !verbose > 0 then
prerr_endline ("New state: "^string_of_int newchapter) ;
355 push stack
(!outname, Stack.save flowname_stack, Stack.save flow_stack,
!chapter,!depth,!toc,!tocname,!cur_level,!lastclosed,!out_prefix) ;
chapter := newchapter ;
depth := newdepth ;
360 tocname := !outname ;
lastclosed := "" ;
toc := !out
;;
365 let restore_state () =
if !verbose > 0 then prerr_endline ("Restore") ;
let
oldoutname, oldflowname, oldflow,
oldchapter,olddepth,oldtoc,oldtocname,
370 oldlevel,oldlastclosed,oldprefix = pop stack in
outname := oldoutname ;
Stack.restore flowname_stack oldflowname ;
Stack.restore flow_stack oldflow ;
chapter := oldchapter ;
375 depth := olddepth ;
toc := oldtoc ;
tocname := oldtocname ;
lastclosed := !lastclosed ;
cur_level := oldlevel ;
380 out_prefix := oldprefix
;;
let hevea_footer = ref false
385 let close_top lxm =
putlinks_end !toc !tocname ;
if !hevea_footer then begin
Out.put !out "<!--FOOTER-->\n" ;
begin try
390 Mysys.put_from_file
(Filename.concat Mylib.libdir ("cutfoot-"^ !language^".html"))
(Out.put !out)
with Mysys.Error s -> begin
Location.print_pos () ;
395 prerr_endline s
end
end
end ;
Out.put !toc lxm ;
400 if !tocname = "" then
Out.flush !toc
else
Out.close !toc
;;
405
let open_toc () = if !phase > 0 then openlist !toc
and close_toc () = if !phase > 0 then closelist !toc
;;
410 let close_all () =
if !cur_level > !chapter then begin
close_section !chapter ;
close_chapter () ;
close_toc ()
415 end else if !cur_level = !chapter then begin
close_chapter () ;
close_toc ()
end ;
cur_level := (Section.value "DOCUMENT")
420
let openflow title =
let new_outname = new_filename () in
push flowname_stack !outname ;
outname := new_outname ;
425 if !phase > 0 then begin
push flow_stack !out ;
out := Out.create_chan (open_out !outname) ;
openhtml false title !out !outname
end
430
and closeflow () =
if !phase > 0 then begin
closehtml false !outname !out;
Out.close !out ;
435 out := pop flow_stack
end ;
outname := pop flowname_stack
440 let lex_tables = {
Lexing.lex_base =
"\000\000\001\000\002\000\003\000\004\000\000\000\000\000\013\000\
\031\000\078\000\079\000\063\000\109\000\000\000\001\000\032\000\
\254\255\000\000\028\000\032\000\255\255\095\000\000\000\033\000\
\000\000\005\000\016\001\252\255\253\255\014\000\061\000\014\000\
\032\000\251\255\021\000\030\000\110\000\002\000\031\000\031\000\
\140\000\003\000\057\000\067\000\068\000\074\000\250\255\014\000\
\080\000\064\000\076\000\004\000\168\000\079\000\067\000\070\000\
\089\000\253\255\083\000\067\000\094\000\080\000\085\000\108\000\
\140\000\001\000\158\000\140\000\150\000\162\000\005\000\150\000\
\162\000\152\000\161\000\169\000\177\000\178\000\002\000\194\000\
\177\000\161\000\173\000\183\000\202\000\187\000\003\000\222\000\
\074\001\203\000\185\000\173\000\186\000\166\000\200\000\007\000\
\217\000\181\000\193\000\183\000\192\000\211\000\219\000\004\000\
\246\000\210\000\210\000\200\000\209\000\217\000\227\000\221\000\
\226\000\224\000\232\000\005\000\250\000\251\000\228\000\220\000\
\231\000\133\001\192\001\012\001\000\001\240\000\005\000\234\255\
\250\001\233\255\007\001\237\000\008\000\225\000\156\001\240\000\
\229\000\231\000\247\000\238\255\242\000\249\000\236\255\244\000\
\225\000\253\000\237\255\009\000\237\000\008\001\244\000\018\001\
\235\255\062\001\029\001\042\001\026\001\023\001\086\001\098\001\
\106\001\239\255\218\001\165\001\100\001\085\001\148\001\152\001\
\160\001\157\001\167\001\164\001\157\001\127\001\140\001\010\000\
\011\000\174\001\175\001\012\000\174\001\167\001\178\001\254\001\
\203\001\189\001\006\000\248\255\175\001\185\001\223\001\224\001\
\211\001\216\001\209\001\005\002\007\002\212\001\223\001\227\001\
\016\002\226\001\237\001\242\001\240\001\022\002\008\002\249\001\
\007\000\242\255\233\001\229\001\026\002\016\002\000\002\008\000\
\241\255\250\001\255\001\020\002\023\002\025\002\009\000\246\001\
\249\001\004\002\252\001\008\002\004\002\045\002\034\002\018\002\
\244\255\253\001\014\002\002\002\044\002\046\002\030\002\010\000\
\240\255\006\002\062\002\063\002\028\002\065\002\066\002\023\002\
\021\002\017\002\033\002\020\002\072\002\060\002\045\002\011\000\
\245\255\029\002\022\002\078\002\066\002\050\002\012\000\029\002\
\082\002\047\002\049\002\041\002\052\002\089\002\077\002\062\002\
\013\000\247\255\055\002\094\002\095\002\057\002\056\002\052\002\
\099\002\100\002\054\002\051\002\068\002\055\002\107\002\108\002\
\059\002";
Lexing.lex_backtrk =
"\255\255\255\255\255\255\255\255\255\255\001\000\001\000\255\255\
\255\255\255\255\255\255\255\255\002\000\000\000\001\000\255\255\
\255\255\001\000\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\001\000\255\255\255\255\003\000\003\000\003\000\
\003\000\255\255\255\255\255\255\255\255\000\000\255\255\255\255\
\255\255\001\000\255\255\255\255\255\255\255\255\255\255\005\000\
\005\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\003\000\003\000\003\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\001\000\001\000\
\255\255\255\255\255\255\255\255\001\000\255\255\000\000\000\000\
\000\000\001\000\255\255\255\255\255\255\255\255\255\255\000\000\
\001\000\255\255\255\255\255\255\255\255\255\255\255\255\000\000\
\002\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\001\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\
\021\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\012\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\005\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\007\000\255\255\255\255\255\255\255\255\004\000\
\255\255\255\255\255\255\255\255\002\000\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\013\000\255\255\255\255\255\255\255\255\255\255\255\255\014\000\
\255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\015\000\
\255\255\255\255\255\255\001\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\010\000\
\255\255\255\255\255\255\255\255\255\255\255\255\003\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\008\000\255\255\255\255\255\255\006\000\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\009\000\
\255\255";
445 Lexing.lex_default =
"\127\000\016\000\057\000\016\000\016\000\255\255\255\255\016\000\
\016\000\027\000\046\000\027\000\255\255\255\255\255\255\016\000\
\000\000\255\255\255\255\255\255\000\000\255\255\255\255\255\255\
\255\255\025\000\255\255\000\000\000\000\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\000\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\095\000\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\110\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\138\000\000\000\255\255\141\000\000\000\255\255\
\255\255\145\000\000\000\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\160\000\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\000\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\219\000\219\000\219\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255";
Lexing.lex_trans =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\020\000\027\000\016\000\020\000\020\000\020\000\
\187\000\209\000\216\000\020\000\240\000\000\001\027\000\017\001\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\013\000\021\000\037\000\041\000\052\000\071\000\116\000\020\000\
\147\000\147\000\176\000\176\000\180\000\023\000\022\000\018\000\
\087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\
\087\000\087\000\084\000\064\000\128\000\115\000\104\000\096\000\
\089\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\079\000\017\000\019\000\020\000\024\000\
\044\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\066\000\047\000\028\000\042\000\021\000\
\038\000\034\000\035\000\036\000\039\000\040\000\043\000\029\000\
\036\000\045\000\067\000\048\000\022\000\030\000\036\000\025\000\
\040\000\049\000\050\000\051\000\061\000\058\000\056\000\057\000\
\059\000\060\000\026\000\026\000\020\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\031\000\
\062\000\063\000\016\000\037\000\040\000\032\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\052\000\041\000\065\000\077\000\026\000\068\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\069\000\070\000\072\000\073\000\074\000\075\000\076\000\020\000\
\078\000\080\000\081\000\082\000\083\000\020\000\053\000\085\000\
\054\000\086\000\090\000\091\000\092\000\055\000\093\000\094\000\
\129\000\057\000\255\255\255\255\057\000\255\255\095\000\255\255\
\097\000\098\000\099\000\100\000\101\000\255\255\087\000\087\000\
\087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\
\102\000\103\000\111\000\107\000\108\000\109\000\110\000\057\000\
\255\255\016\000\112\000\113\000\114\000\105\000\020\000\117\000\
\118\000\119\000\120\000\121\000\123\000\125\000\126\000\148\000\
\143\000\140\000\137\000\138\000\153\000\139\000\141\000\142\000\
\144\000\124\000\145\000\146\000\149\000\026\000\026\000\033\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\106\000\154\000\150\000\151\000\057\000\033\000\
\152\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\162\000\155\000\156\000\157\000\026\000\
\158\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\121\000\159\000\160\000\
\161\000\021\001\007\001\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\163\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\123\000\135\000\244\000\255\255\223\000\197\000\192\000\224\000\
\188\000\178\000\225\000\032\001\177\000\124\000\174\000\175\000\
\136\000\175\000\179\000\181\000\198\000\182\000\183\000\255\255\
\185\000\255\255\163\000\186\000\189\000\255\255\190\000\191\000\
\191\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\130\000\164\000\165\000\183\000\166\000\
\167\000\193\000\168\000\194\000\195\000\196\000\169\000\196\000\
\170\000\131\000\217\000\184\000\199\000\171\000\172\000\200\000\
\200\000\210\000\203\000\204\000\205\000\207\000\205\000\208\000\
\211\000\212\000\212\000\132\000\133\000\214\000\215\000\218\000\
\219\000\220\000\134\000\206\000\221\000\241\000\221\000\213\000\
\233\000\226\000\227\000\228\000\229\000\229\000\173\000\231\000\
\232\000\234\000\255\255\235\000\236\000\255\255\201\000\222\000\
\202\000\237\000\230\000\238\000\239\000\242\000\243\000\243\000\
\245\000\246\000\246\000\001\001\249\000\250\000\251\000\252\000\
\252\000\254\000\255\255\255\000\002\001\003\001\003\001\005\001\
\006\001\008\001\009\001\010\001\011\001\253\000\018\001\012\001\
\013\001\013\001\015\001\004\001\016\001\019\001\020\001\020\001\
\022\001\023\001\024\001\025\001\025\001\027\001\014\001\028\001\
\247\000\029\001\030\001\031\001\031\001\225\000\000\000\000\000\
\248\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\026\001\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\255\255\000\000\000\000\255\255\
\000\000\255\255\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000";
Lexing.lex_check =
450 "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\024\000\065\000\078\000\086\000\103\000\126\000\
\186\000\208\000\215\000\222\000\239\000\255\000\006\001\016\001\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\013\000\014\000\037\000\041\000\051\000\070\000\115\000\025\000\
\132\000\147\000\175\000\176\000\179\000\022\000\014\000\017\000\
\006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\
\006\000\006\000\007\000\047\000\000\000\001\000\002\000\003\000\
\004\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\008\000\015\000\018\000\019\000\023\000\
\029\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\005\000\005\000\005\000\005\000\005\000\
\005\000\005\000\005\000\009\000\010\000\011\000\030\000\021\000\
\031\000\032\000\034\000\035\000\038\000\039\000\042\000\011\000\
\043\000\044\000\009\000\010\000\021\000\011\000\036\000\012\000\
\045\000\048\000\049\000\050\000\053\000\054\000\055\000\056\000\
\058\000\059\000\012\000\012\000\060\000\012\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\011\000\
\061\000\062\000\063\000\036\000\040\000\011\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\052\000\040\000\064\000\066\000\012\000\067\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\068\000\069\000\071\000\072\000\073\000\074\000\075\000\076\000\
\077\000\079\000\080\000\081\000\082\000\083\000\052\000\084\000\
\052\000\085\000\089\000\090\000\091\000\052\000\092\000\093\000\
\000\000\001\000\002\000\003\000\004\000\025\000\094\000\095\000\
\096\000\097\000\098\000\099\000\100\000\007\000\087\000\087\000\
\087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\
\101\000\102\000\105\000\106\000\107\000\108\000\109\000\008\000\
\015\000\110\000\111\000\112\000\113\000\104\000\114\000\116\000\
\117\000\118\000\119\000\120\000\123\000\124\000\125\000\131\000\
\133\000\135\000\136\000\137\000\130\000\138\000\140\000\141\000\
\143\000\123\000\144\000\145\000\148\000\026\000\026\000\011\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\104\000\130\000\149\000\150\000\009\000\010\000\
\151\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\153\000\154\000\155\000\156\000\026\000\
\157\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\026\000\026\000\026\000\026\000\026\000\
\026\000\026\000\026\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\121\000\158\000\159\000\
\160\000\164\000\165\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\
\088\000\088\000\088\000\088\000\088\000\163\000\121\000\121\000\
\121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\
\121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\
\121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\
\122\000\134\000\166\000\110\000\167\000\168\000\169\000\167\000\
\170\000\171\000\167\000\163\000\172\000\122\000\173\000\174\000\
\134\000\177\000\178\000\180\000\168\000\181\000\182\000\138\000\
\184\000\141\000\162\000\185\000\188\000\145\000\189\000\190\000\
\191\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\
\122\000\122\000\122\000\128\000\162\000\162\000\183\000\162\000\
\162\000\192\000\162\000\193\000\194\000\195\000\162\000\196\000\
\162\000\128\000\197\000\183\000\198\000\162\000\162\000\199\000\
\200\000\201\000\202\000\203\000\204\000\206\000\205\000\207\000\
\210\000\211\000\212\000\128\000\128\000\213\000\214\000\217\000\
\218\000\219\000\128\000\205\000\220\000\223\000\221\000\212\000\
\224\000\225\000\226\000\227\000\228\000\229\000\162\000\230\000\
\231\000\233\000\219\000\234\000\235\000\220\000\200\000\221\000\
\200\000\236\000\229\000\237\000\238\000\241\000\242\000\243\000\
\244\000\245\000\246\000\247\000\248\000\249\000\250\000\251\000\
\252\000\253\000\160\000\254\000\001\001\002\001\003\001\004\001\
\005\001\007\001\008\001\009\001\009\001\252\000\010\001\011\001\
\012\001\013\001\014\001\003\001\015\001\018\001\019\001\020\001\
\021\001\022\001\023\001\024\001\025\001\026\001\013\001\027\001\
\246\000\028\001\029\001\030\001\031\001\032\001\255\255\255\255\
\246\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\025\001\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\219\000\255\255\255\255\220\000\
\255\255\221\000\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255"
}
let rec main lexbuf = __ocaml_lex_main_rec lexbuf 0
and __ocaml_lex_main_rec lexbuf state =
455 match Lexing.engine lex_tables state lexbuf with
0 -> (
454 "cut.mll"
let lxm = lexeme lexbuf in
if !phase > 0 then begin
460 put lxm ;
put ("<!--HACHA command line is: ") ;
for i = 0 to Array.length Sys.argv - 1 do
put Sys.argv.(i) ;
put_char ' '
465 done ;
put "-->\n"
end ;
main lexbuf)
| 1 -> (
470 466 "cut.mll"
let title = flowline lexbuf in
openflow title ;
main lexbuf)
| 2 -> (
475 470 "cut.mll"
linkline lexbuf ;
main lexbuf)
| 3 -> (
473 "cut.mll"
480 closeflow () ;
main lexbuf)
| 4 -> (
476 "cut.mll"
let name = tocline lexbuf in
485 change_name !outname name ;
main lexbuf)
| 5 -> (
480 "cut.mll"
let arg = secname lexbuf in
490 let sn =
if String.uppercase arg = "NOW" then !chapter
else Section.value arg in
let name = tocline lexbuf in
if !verbose > 1 then begin
495 prerr_endline ("TOC "^arg^" "^name)
end;
if sn < !chapter then begin
if !cur_level >= !chapter then begin
close_section (!chapter) ;
500 close_chapter () ;
close_toc ()
end ;
cur_level := sn
end else if sn = !chapter then begin
505 if !cur_level < sn then begin
open_toc () ;
end else begin
close_section !chapter ;
close_chapter ()
510 end ;
open_chapter name
end else if sn <= !chapter + !depth then begin (* sn > !chapter *)
if !cur_level < !chapter then begin
open_toc () ;
515 open_chapter ""
end ;
close_section sn ;
open_section sn name
end ;
520 main lexbuf)
| 6 -> (
513 "cut.mll"
let chapter = Section.value (String.uppercase (secname lexbuf)) in
skip_blanks lexbuf;
525 let depth = intarg lexbuf in
skip_endcom lexbuf ;
save_state chapter depth ;
cur_level := Section.value "DOCUMENT" ;
main lexbuf)
530 | 7 -> (
521 "cut.mll"
if !phase > 0 then begin
if !tocbis && !out == !out_prefix then
out := Out.create_buff ()
535 end ;
main lexbuf)
| 8 -> (
527 "cut.mll"
close_all () ;
540 restore_state () ;
main lexbuf)
| 9 -> (
531 "cut.mll"
let sec_notes = secname lexbuf in
545 skip_endcom lexbuf ;
open_notes (Section.value sec_notes) ;
main lexbuf)
| 10 -> (
536 "cut.mll"
550 if !otheroutname <> "" then
close_notes ();
main lexbuf)
| 11 -> (
540 "cut.mll"
555 language := "fra" ;
main lexbuf)
| 12 -> (
543 "cut.mll"
if !phase > 0 then put (lexeme lexbuf) ;
560 aargs lexbuf)
| 13 -> (
546 "cut.mll"
let head = save_html lexbuf in
if !phase = 0 then
565 html_head := head
else
Out.put !out head;
main lexbuf)
| 14 -> (
570 553 "cut.mll"
let foot = save_html lexbuf in
if !phase = 0 then
html_foot := foot ;
main lexbuf)
575 | 15 -> (
558 "cut.mll"
close_all () ;
if !phase > 0 then begin
hevea_footer := true ;
580 Out.put !out !html_foot
end ;
footer lexbuf)
| 16 -> (
565 "cut.mll"
585 let lxm = lexeme lexbuf in
if !phase = 0 then
doctype := lxm
else
Out.put !out lxm;
590 main lexbuf)
| 17 -> (
572 "cut.mll"
let lxm = lexeme lexbuf in
if !phase = 0 then
595 html := lxm
else
Out.put !out lxm;
main lexbuf)
| 18 -> (
600 579 "cut.mll"
let lxm = lexeme lexbuf in
if !phase = 0 then
body := lxm
else begin
605 Out.put !out lxm ;
putlinks_start !out !outname
end ;
main lexbuf)
| 19 -> (
610 588 "cut.mll"
put (lexeme lexbuf);
if !phase = 0 then begin
if !verbose > 0 then prerr_endline "Collect header" ;
collect_header lexbuf
615 end else
main lexbuf)
| 20 -> (
595 "cut.mll"
let lxm = lexeme lexbuf in
620 close_all () ;
if !phase > 0 then begin
close_top lxm
end)
| 21 -> (
625 601 "cut.mll"
let lxm = lexeme_char lexbuf 0 in
if !phase > 0 then put_char lxm ;
main lexbuf)
| 22 -> (
630 605 "cut.mll"
raise (Error ("No </BODY> tag in input file")))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_main_rec lexbuf n
and save_html lexbuf = __ocaml_lex_save_html_rec lexbuf 1
635 and __ocaml_lex_save_html_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
609 "cut.mll"
let s = Out.to_string html_buff in
640 if !verbose > 0 then
prerr_endline ("save_html -> ``"^s^"''");
s)
| 1 -> (
614 "cut.mll"
645 let lxm = lexeme_char lexbuf 0 in
Out.put_char html_buff lxm ;
save_html lexbuf)
| 2 -> (
618 "cut.mll"
650 raise (Misc.Fatal ("End of file in save_html")))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_save_html_rec lexbuf n
and collect_header lexbuf = __ocaml_lex_collect_header_rec lexbuf 2
and __ocaml_lex_collect_header_rec lexbuf state =
655 match Lexing.engine lex_tables state lexbuf with
0 -> (
622 "cut.mll"
let lxm = lexeme lexbuf in
finalize_header () ;
660 if !verbose > 0 then begin
prerr_string "Header is: ``" ;
prerr_string !common_headers ;
prerr_endline "''"
end ;
665 main lexbuf)
| 1 -> (
632 "cut.mll"
skip_title lexbuf ;
collect_header lexbuf)
670 | 2 -> (
635 "cut.mll"
let lxm = lexeme_char lexbuf 0 in
adjoin_to_header_char lxm;
collect_header lexbuf)
675 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_collect_header_rec lexbuf n
and skip_title lexbuf = __ocaml_lex_skip_title_rec lexbuf 3
and __ocaml_lex_skip_title_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
680 0 -> (
640 "cut.mll"
())
| 1 -> (
641 "cut.mll"
685 skip_title lexbuf)
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_title_rec lexbuf n
and footer lexbuf = __ocaml_lex_footer_rec lexbuf 4
and __ocaml_lex_footer_rec lexbuf state =
690 match Lexing.engine lex_tables state lexbuf with
0 -> (
645 "cut.mll"
let lxm = lexeme lexbuf in
if !phase > 0 then begin
695 close_top lxm
end)
| 1 -> (
649 "cut.mll"
footer lexbuf)
700 | 2 -> (
650 "cut.mll"
raise (Misc.Fatal ("End of file in footer (no </BODY> tag)")))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_footer_rec lexbuf n
705 and secname lexbuf = __ocaml_lex_secname_rec lexbuf 5
and __ocaml_lex_secname_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
654 "cut.mll"
710 let r = lexeme lexbuf in r)
| 1 -> (
655 "cut.mll"
raise (Error "Bad section name syntax"))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_secname_rec lexbuf n
715
and intarg lexbuf = __ocaml_lex_intarg_rec lexbuf 6
and __ocaml_lex_intarg_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
720 658 "cut.mll"
int_of_string (lexeme lexbuf))
| 1 -> (
659 "cut.mll"
!depth)
725 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_intarg_rec lexbuf n
and tocline lexbuf = __ocaml_lex_tocline_rec lexbuf 7
and __ocaml_lex_tocline_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
730 0 -> (
662 "cut.mll"
Out.to_string toc_buf)
| 1 -> (
664 "cut.mll"
735 Out.put_char toc_buf (lexeme_char lexbuf 0) ;
tocline lexbuf)
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_tocline_rec lexbuf n
and arg lexbuf = __ocaml_lex_arg_rec lexbuf 8
740 and __ocaml_lex_arg_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
668 "cut.mll"
Out.to_string arg_buf)
745 | 1 -> (
669 "cut.mll"
Out.put_char arg_buf (Lexing.lexeme_char lexbuf 0) ; arg lexbuf)
| 2 -> (
670 "cut.mll"
750 raise (Misc.Fatal "Unclosed arg"))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_arg_rec lexbuf n
and flowline lexbuf = __ocaml_lex_flowline_rec lexbuf 9
and __ocaml_lex_flowline_rec lexbuf state =
755 match Lexing.engine lex_tables state lexbuf with
0 -> (
674 "cut.mll"
let title = arg lexbuf in
let _ = flowline lexbuf in
760 title)
| 1 -> (
678 "cut.mll"
"")
| 2 -> (
765 679 "cut.mll"
raise (Misc.Fatal "Unclosed comment"))
| 3 -> (
680 "cut.mll"
flowline lexbuf)
770 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_flowline_rec lexbuf n
and linkline lexbuf = __ocaml_lex_linkline_rec lexbuf 10
and __ocaml_lex_linkline_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
775 0 -> (
684 "cut.mll"
let link = arg lexbuf in
setlink Thread.setprev link ;
linkline lexbuf)
780 | 1 -> (
688 "cut.mll"
let link = arg lexbuf in
setlink Thread.setnext link ;
linkline lexbuf)
785 | 2 -> (
692 "cut.mll"
let link = arg lexbuf in
setlink Thread.setup link ;
linkline lexbuf)
790 | 3 -> (
696 "cut.mll"
())
| 4 -> (
697 "cut.mll"
795 raise (Misc.Fatal "Unclosed comment"))
| 5 -> (
698 "cut.mll"
linkline lexbuf)
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_linkline_rec lexbuf n
800
and aargs lexbuf = __ocaml_lex_aargs_rec lexbuf 11
and __ocaml_lex_aargs_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
805 702 "cut.mll"
if !phase = 0 then begin
let name = refname lexbuf in
Cross.add name !outname
end else
810 put (lexeme lexbuf) ;
aargs lexbuf)
| 1 -> (
709 "cut.mll"
if !phase > 0 then begin
815 let lxm = lexeme lexbuf in
let name = refname lexbuf in
try
let newname =
if String.length name > 0 && String.get name 0 = '#' then
820 Cross.fullname !outname (String.sub name 1 (String.length name-1))
else name in
put lxm ;
put "\"" ;
put newname ;
825 put "\""
with Not_found -> ()
end ;
aargs lexbuf)
| 2 -> (
830 725 "cut.mll"
if !phase > 0 then put_char '>' ;
main lexbuf)
| 3 -> (
728 "cut.mll"
835 if !phase > 0 then put_char (lexeme_char lexbuf 0) ;
aargs lexbuf)
| 4 -> (
731 "cut.mll"
raise (Error "Bad <A ...> tag"))
840 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_aargs_rec lexbuf n
and refname lexbuf = __ocaml_lex_refname_rec lexbuf 12
and __ocaml_lex_refname_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
845 0 -> (
735 "cut.mll"
let lxm = lexeme lexbuf in
String.sub lxm 1 (String.length lxm-2))
| 1 -> (
850 738 "cut.mll"
lexeme lexbuf)
| 2 -> (
739 "cut.mll"
raise (Error "Bad reference name syntax"))
855 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_refname_rec lexbuf n
and skip_blanks lexbuf = __ocaml_lex_skip_blanks_rec lexbuf 13
and __ocaml_lex_skip_blanks_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
860 0 -> (
742 "cut.mll"
())
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_blanks_rec lexbuf n
865 and skip_endcom lexbuf = __ocaml_lex_skip_endcom_rec lexbuf 14
and __ocaml_lex_skip_endcom_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
745 "cut.mll"
870 ())
| 1 -> (
746 "cut.mll"
raise (Error "Bad HTML comment syntax"))
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_endcom_rec lexbuf n
875
and skip_aref lexbuf = __ocaml_lex_skip_aref_rec lexbuf 15
and __ocaml_lex_skip_aref_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
0 -> (
880 748 "cut.mll"
())
| 1 -> (
749 "cut.mll"
skip_aref lexbuf)
885 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_aref_rec lexbuf n
;;
<6>75 element.ml
(***********************************************************************)
(* *)
(* 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: element.ml,v 1.1 2000/05/30 12:30:14 maranget Exp $"
(* For text-level elements *)
type text =
15 Style of string
| Font of int
| Color of string
let pretty_text = function
20 Style s -> "Style: "^s
| Font i -> "Font size: "^string_of_int i
| Color s -> "Font color: "^s
;;
<6>76 emisc.ml
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: emisc.ml,v 1.1 2001/05/29 09:23:30 maranget Exp $ *)
(***********************************************************************)
let basefont = ref 3
15 let reset () =
basefont := 3
<6>77 entry.ml
12 "entry.mll"
open Lexing
5 let header = "$Id: entry.mll,v 1.11 1999/12/07 16:12:15 maranget Exp $"
let buff = Out.create_buff ()
;;
10 let put s =
Out.put buff s
and put_char c =
Out.put_char buff c
;;
15
type res =
| Bang of string * string
| Bar of string * string
20 | Eof of string * string
;;
let extend r i = match r with
| Bang (p,_) -> Bang (i,p)
25 | Bar (p,_) -> Bar (i,p)
| Eof (p,_) -> Eof (i,p)
;;
type key = string list * string list
30
exception Fini
exception NoGood
;;
35 let lex_tables = {
Lexing.lex_base =
"\000\000\001\000\253\255\000\000\254\255\000\000\000\000\000\000\
\000\000\001\000\001\000\000\000\000\000\000\000\255\255\247\255\
\251\255\002\000\250\255\002\000\249\255\248\255\252\255";
Lexing.lex_backtrk =
"\255\255\255\255\255\255\002\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\008\000\255\255\008\000\255\255\255\255\255\255";
40 Lexing.lex_default =
"\015\000\002\000\000\000\255\255\000\000\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\000\000\000\000\
\000\000\255\255\000\000\255\255\000\000\000\000\000\000";
Lexing.lex_trans =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\016\000\017\000\004\000\014\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\018\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\019\000\003\000\000\000\000\000\
\000\000\000\000\000\000\000\000\007\000\008\000\010\000\000\000\
\000\000\005\000\000\000\000\000\000\000\000\000\006\000\011\000\
\000\000\000\000\013\000\000\000\012\000\000\000\000\000\000\000\
\009\000\014\000\000\000\000\000\020\000\000\000\022\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\021\000\004\000\000\000";
Lexing.lex_check =
45 "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\000\000\000\000\017\000\019\000\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\255\255\017\000\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\000\000\001\000\255\255\255\255\
\255\255\255\255\255\255\255\255\006\000\007\000\009\000\255\255\
\255\255\003\000\255\255\255\255\255\255\255\255\005\000\010\000\
\255\255\255\255\012\000\255\255\011\000\255\255\255\255\255\255\
\008\000\013\000\255\255\255\255\000\000\255\255\017\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\001\000\255\255"
}
let rec entry lexbuf = __ocaml_lex_entry_rec lexbuf 0
and __ocaml_lex_entry_rec lexbuf state =
50 match Lexing.engine lex_tables state lexbuf with
0 -> (
48 "entry.mll"
put "\\\"" ; entry lexbuf)
| 1 -> (
55 50 "entry.mll"
put_char '!' ; entry lexbuf)
| 2 -> (
52 "entry.mll"
put_char '@' ; entry lexbuf)
60 | 3 -> (
54 "entry.mll"
put_char '|' ; entry lexbuf)
| 4 -> (
55 "entry.mll"
65 Bang (Out.to_string buff,""))
| 5 -> (
56 "entry.mll"
let s = Out.to_string buff in
let r = entry lexbuf in
70 extend r s)
| 6 -> (
59 "entry.mll"
Bar (Out.to_string buff,""))
| 7 -> (
75 60 "entry.mll"
Eof (Out.to_string buff,""))
| 8 -> (
62 "entry.mll"
let lxm = lexeme_char lexbuf 0 in put_char lxm ; entry lexbuf)
80 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_entry_rec lexbuf n
and idx lexbuf = __ocaml_lex_idx_rec lexbuf 1
and __ocaml_lex_idx_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
85 0 -> (
66 "entry.mll"
let key = Save.arg lexbuf in
let value = Save.arg lexbuf in
key,value)
90 | 1 -> (
69 "entry.mll"
raise Fini)
| 2 -> (
70 "entry.mll"
95 idx lexbuf)
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_idx_rec lexbuf n
;;
100 73 "entry.mll"
let read_key lexbuf =
105 let bar () = match entry lexbuf with
| Eof (s,_) ->
begin match s with
| ""|"("|")" -> None
| s ->
110 if s.[0] = '(' then
Some (String.sub s 1 (String.length s - 1))
else
Some s
end
115 | _ -> raise NoGood in
let rec get_rec () = match entry lexbuf with
Bang (i,p) ->
let l,see = get_rec () in
120 (i,p)::l,see
| Bar (i,p) ->
let see = bar () in
[i,p],see
| Eof (i,p) -> [i,p],None in
125
let separe (l,see) =
let rec sep_rec = function
[] -> [],[]
| (x,y)::r ->
130 let xs,ys = sep_rec r in
x::xs,y::ys in
let xs,ys = sep_rec l in
((xs,ys),see) in
135 separe (get_rec ())
let read_indexentry lexbuf = idx lexbuf
<6>78 esponjamain.ml
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: esponjamain.ml,v 1.3 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
open Mysys
open Esponja
15
let arg = ref []
;;
Arg.parse
20 ["-u", Arg.Set pess, "pessimize" ;
"-v", Arg.Unit (fun () -> incr Ultra.verbose),"be verbose" ;
"-n", Arg.Unit (fun () -> move := false ; incr Ultra.verbose),
"do not change files"]
(fun s -> arg := s :: !arg)
25 ("Usage: esponja [option*] < infile > outfile,\n or esponja [option*] files+
options are:")
;;
let main () =
30 try
begin match !arg with
| [] ->
ignore (process "" stdin stdout)
| files ->
35 List.iter (fun f -> ignore (Esponja.file f)) (List.rev files)
end ;
exit 0
with
| e ->
40 Printf.fprintf stderr "Unexpected exception: %s\n"
(Printexc.to_string e) ;
exit 1
;;
45 main ()
;;
<6>79 esponja.ml
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: esponja.ml,v 1.8 2001/05/29 09:23:31 maranget Exp $ *)
(***********************************************************************)
open Mysys
15 let pess = ref false
and move = ref true
;;
20 let process in_name input output =
let rec do_rec lexbuf = match Htmlparse.main lexbuf with
| [] -> ()
| ts ->
if !pess then
25 Pp.trees output (Explode.trees ts)
else
Ultra.main output ts ;
do_rec lexbuf in
try
30 let lexbuf = Lexing.from_channel input in
Location.set in_name lexbuf ;
Emisc.reset () ;
do_rec lexbuf ;
Location.restore () ;
35 true
with
| Htmllex.Error s ->
if !Ultra.verbose > 0 then
output_char stderr '\n' ;
40 Location.print_fullpos () ;
Printf.fprintf stderr "Lexer error: %s\n" s ;
Location.restore () ;
false
| Htmlparse.Error s ->
45 if !Ultra.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Parser error: %s\n" s ;
Htmllex.ptop () ;
50 Htmllex.reset () ;
Location.restore () ;
false
| e ->
Location.restore () ;
55 raise e
let file in_name =
if !Ultra.verbose > 0 then begin
60 Printf.fprintf stderr "Optimizing file: %s... " in_name ;
flush stderr
end ;
let out_name =
Filename.concat
65 (Filename.dirname in_name)
(Filename.basename in_name ^ ".esp")
in
begin try
let input = open_in in_name in
70 let out =
try open_out out_name
with Sys_error _ as e ->
close_in input ; raise e in
let size_in = in_channel_length input in
75 let ok =
try process in_name input out with e ->
close_in input ; close_out out ; raise e in
close_in input ;
flush out ;
80 let size_out = out_channel_length out in
close_out out ;
if ok && size_in > size_out then
begin if !move then rename out_name in_name end
else
85 remove out_name ;
if !Ultra.verbose > 0 && ok then begin
Printf.fprintf stderr "saved %d -> %d, %0.2f%%"
size_in size_out
((float (size_in-size_out) *. 100.0) /.
90 float size_in) ;
prerr_endline ""
end ;
ok
with
95 | Sys_error msg ->
Printf.fprintf stderr "File error: %s\n" msg ;
false
| e ->
remove out_name ;
100 raise e
end
<6>80 explode.ml
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
5 (* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
10 (* $Id: explode.ml,v 1.6 2001/05/28 17:28:55 maranget Exp $ *)
(***********************************************************************)
open Lexeme
open Htmltext
15 open Tree
let of_styles env r = match env with
| [] -> r
| _ -> Node (env,[r])
20
let rec tree env t k = match t with
| Text s ->
of_styles env (Text s)::k
25 | Blanks s ->
of_styles
(List.filter (fun s -> not (Htmltext.blanksNeutral s)) env)
(Blanks s)::
k
30 | Node (s,ts) ->
begin try
let new_env = Htmltext.add_style s env in
List.fold_right (tree new_env) ts k
with
35 | Split (s,env) ->
let ts = List.fold_right (tree []) ts [] in
let now =
if Util.is_blanks ts then
(List.filter (fun s -> not (Htmltext.blanksNeutral s)) env)
40 else
env in
match ts with
| [] -> k
| _ ->
45 of_styles now (Node ([s],ts))::k
end
| ONode (so,sc,ts) ->
ONode
(so,sc, List.fold_right (tree env) ts [])::k
50
let trees ts = List.fold_right (tree []) ts []
<6>81 foot.ml
(***********************************************************************)
(* *)
(* 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: foot.ml,v 1.18 2001/02/20 14:10:08 maranget Exp $"
open Parse_opts
15 let some = ref false
;;
let anchor = ref 0
20 ;;
let mark_to_anchor = Hashtbl.create 17
and anchor_to_note = Hashtbl.create 17
;;
25
type saved =
(int, int) Hashtbl.t
* (int, int * string * string) Hashtbl.t * int * bool
30 let checkpoint () =
Misc.clone_int_hashtbl mark_to_anchor,
Misc.clone_int_hashtbl anchor_to_note,
!anchor, !some
35 and hot_start (t1,t2,i,b) =
Misc.copy_int_hashtbl t1 mark_to_anchor ;
Misc.copy_int_hashtbl t2 anchor_to_note ;
anchor := i ;
some := b
40
let step_anchor mark =
incr anchor ;
Hashtbl.remove mark_to_anchor mark ;
Hashtbl.add mark_to_anchor mark !anchor
45 ;;
let get_anchor mark =
let r =
try Hashtbl.find mark_to_anchor mark
50 with Not_found -> begin
step_anchor mark ;
!anchor
end in
r
55 ;;
let register mark themark text =
some := true ;
let anchor = get_anchor mark in
60 begin try
let _ = Hashtbl.find anchor_to_note anchor in
Misc.warning "erasing previous footnote" ;
Hashtbl.remove anchor_to_note anchor
with Not_found -> ()
65 end ;
Hashtbl.add anchor_to_note anchor (mark,themark,text)
;;
70 let flush lexer sec_notes sec_here =
if !some && Section.value sec_here <= Section.value sec_notes then begin
some := false ;
lexer ("\\begin{thefootnotes}{"^sec_notes^"}") ;
let all = ref [] in
75 Hashtbl.iter
(fun anchor (mark,themark,text) ->
all := ((mark,anchor),(themark,text)) :: !all)
anchor_to_note ;
all := Sort.list
80 (fun ((m1,a1),_) ((m2,a2),_) ->
(a1 < a2) ||
((a1 = a2) && (m1 <= m2))) !all ;
List.iter
(fun ((_,anchor),(themark,text)) ->
85 lexer
("\\item["^
"\\@noteref{text}{note}{"^
string_of_int anchor^
"}{\\@print{"^themark^"}}]") ;
90 lexer ("\\@print{"^text^"\n}"))
!all ;
lexer "\\end{thefootnotes}" ;
Hashtbl.clear mark_to_anchor ;
Hashtbl.clear anchor_to_note ;
95 end
;;
<6>82 get.ml
12 "get.mll"
open Misc
open Parse_opts
5 open Lexing
open Latexmacros
open Lexstate
open Stack
10 (* Compute functions *)
let header = "$Id: get.mll,v 1.24 2001/02/12 10:05:29 maranget Exp $"
exception Error of string
15 let sbool = function
| true -> "true"
| false -> "false"
let get_this = ref (fun s -> assert false)
20 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)
25 ;;
let bool_out = ref false
and int_out = ref false
30 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
35 type saved =
bool * bool Stack.saved *
bool * int Stack.saved *
(unit -> unit) Stack.saved * bool
40 let check () =
!bool_out, Stack.save bool_stack,
!int_out, Stack.save int_stack,
Stack.save group_stack,
!just_opened
45
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 ;
50 just_opened := j
let push_int x =
if !verbose > 2 then
prerr_endline ("PUSH INT: "^string_of_int x) ;
55 just_opened := false ;
push int_stack x
let open_ngroups n =
let rec open_ngroups_rec = function
60 | 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
65 just_opened := true ;
open_ngroups_rec n
end
let close_ngroups n =
70 let rec close_ngroups_rec = function
| 0 -> ()
| n ->
let f = pop group_stack in
f() ; close_ngroups_rec (n-1) in
75 if !verbose > 2 then
prerr_endline ("CLOSE NGROUPS: "^string_of_int n);
close_ngroups_rec n
let open_aftergroup f s =
80 if !verbose > 2 then
prerr_endline ("OPEN AFTER: "^s) ;
just_opened := true ;
push group_stack f
85 let lex_tables = {
Lexing.lex_base =
"\000\000\001\000\002\000\061\000\003\000\254\255\255\255\240\255\
\001\000\020\000\054\000\004\000\136\000\244\255\243\255\246\255\
\247\255\144\000\245\255\164\000\250\255\000\000\000\000\239\255\
\007\000\000\000\249\255\004\000\000\000\012\000\248\255\241\255\
\254\000\154\000\164\000\034\000\242\255\073\001\006\000";
Lexing.lex_backtrk =
"\255\255\002\000\255\255\255\255\255\255\255\255\255\255\255\255\
\001\000\015\000\015\000\015\000\015\000\255\255\255\255\255\255\
\255\255\002\000\255\255\015\000\255\255\015\000\015\000\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\014\000\002\000\003\000\255\255\255\255\004\000\001\000";
90 Lexing.lex_default =
"\007\000\002\000\255\255\004\000\255\255\000\000\000\000\000\000\
\255\255\255\255\255\255\035\000\255\255\000\000\000\000\000\000\
\000\000\255\255\000\000\031\000\000\000\255\255\255\255\000\000\
\255\255\255\255\000\000\255\255\255\255\255\255\000\000\000\000\
\255\255\255\255\255\255\035\000\000\000\255\255\255\255";
Lexing.lex_trans =
"\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\008\000\038\000\000\000\000\000\006\000\000\000\
\038\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\008\000\038\000\009\000\010\000\000\000\011\000\038\000\012\000\
\013\000\014\000\015\000\016\000\006\000\016\000\000\000\015\000\
\017\000\017\000\017\000\017\000\017\000\017\000\017\000\017\000\
\017\000\017\000\000\000\000\000\018\000\018\000\018\000\000\000\
\000\000\000\000\000\000\000\000\037\000\037\000\037\000\037\000\
\037\000\037\000\037\000\037\000\037\000\037\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\037\000\037\000\037\000\
\037\000\037\000\037\000\000\000\019\000\003\000\000\000\000\000\
\020\000\027\000\000\000\000\000\000\000\026\000\021\000\036\000\
\036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\
\028\000\030\000\024\000\029\000\022\000\037\000\037\000\037\000\
\037\000\037\000\037\000\013\000\025\000\014\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\000\000\000\000\000\000\000\000\000\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\034\000\034\000\034\000\034\000\034\000\034\000\034\000\034\000\
\033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
\033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\
\033\000\033\000\033\000\033\000\034\000\034\000\034\000\034\000\
\034\000\034\000\034\000\034\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\000\000\
\023\000\255\255\005\000\006\000\255\255\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\000\000\
\000\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\
\031\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\005\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\000\000\000\000\000\000\000\000\000\000\000\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
\037\000\037\000\037\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\037\000\037\000\037\000\037\000\037\000\037\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\255\255\000\000\000\000\000\000\
\000\000\000\000\037\000\037\000\037\000\037\000\037\000\037\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000";
Lexing.lex_check =
95 "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\000\000\008\000\255\255\255\255\011\000\255\255\
\038\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\000\000\008\000\000\000\000\000\255\255\000\000\038\000\000\000\
\000\000\000\000\000\000\000\000\035\000\000\000\255\255\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\255\255\255\255\000\000\000\000\000\000\255\255\
\255\255\255\255\255\255\255\255\009\000\009\000\009\000\009\000\
\009\000\009\000\009\000\009\000\009\000\009\000\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\009\000\009\000\009\000\
\009\000\009\000\009\000\255\255\000\000\001\000\255\255\255\255\
\000\000\021\000\255\255\255\255\255\255\025\000\000\000\010\000\
\010\000\010\000\010\000\010\000\010\000\010\000\010\000\010\000\
\027\000\029\000\022\000\028\000\000\000\009\000\009\000\009\000\
\009\000\009\000\009\000\000\000\024\000\000\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\255\255\255\255\255\255\255\255\255\255\255\255\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\
\012\000\012\000\012\000\012\000\012\000\012\000\012\000\012\000\
\017\000\017\000\017\000\017\000\017\000\017\000\017\000\017\000\
\017\000\017\000\033\000\033\000\033\000\033\000\033\000\033\000\
\033\000\033\000\033\000\033\000\034\000\034\000\034\000\034\000\
\034\000\034\000\034\000\034\000\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\019\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\255\255\
\000\000\001\000\002\000\004\000\011\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\019\000\
\019\000\019\000\019\000\019\000\019\000\019\000\019\000\255\255\
\255\255\255\255\035\000\255\255\255\255\255\255\255\255\255\255\
\032\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\003\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\255\255\255\255\255\255\255\255\255\255\255\255\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\032\000\032\000\032\000\032\000\032\000\032\000\032\000\
\032\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\
\037\000\037\000\037\000\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\037\000\037\000\037\000\037\000\037\000\037\000\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\019\000\255\255\255\255\255\255\
\255\255\255\255\037\000\037\000\037\000\037\000\037\000\037\000\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255"
}
let rec result lexbuf = __ocaml_lex_result_rec lexbuf 0
and __ocaml_lex_result_rec lexbuf state =
100 match Lexing.engine lex_tables state lexbuf with
0 -> (
101 "get.mll"
result lexbuf)
| 1 -> (
105 102 "get.mll"
result lexbuf)
| 2 -> (
105 "get.mll"
let lxm = Lexing.lexeme lexbuf in
110 push_int (int_of_string lxm) ;
result lexbuf)
| 3 -> (
109 "get.mll"
let lxm = lexeme lexbuf in
115 push_int
(int_of_string ("0o"^String.sub lxm 1 (String.length lxm-1))) ;
result lexbuf)
| 4 -> (
114 "get.mll"
120 let lxm = lexeme lexbuf in
push_int
(int_of_string ("0x"^String.sub lxm 1 (String.length lxm-1))) ;
result lexbuf)
| 5 -> (
125 119 "get.mll"
let token = !get_csname lexbuf in
after_quote (Lexing.from_string token) ;
result lexbuf)
| 6 -> (
130 123 "get.mll"
push bool_stack true ;
result lexbuf)
| 7 -> (
126 "get.mll"
135 push bool_stack false ;
result lexbuf)
| 8 -> (
130 "get.mll"
let lxm = lexeme_char lexbuf 0 in
140 let unary = !just_opened in
if unary then begin
let f = pop group_stack in
open_aftergroup
(fun () ->
145 if !verbose > 2 then begin
prerr_endline ("UNARY: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
end ;
let x1 = pop int_stack in
150 let r = match lxm with
| '+' -> x1
| '-' -> 0 - x1
| _ -> assert false in
push_int r ; f()) "UNARY"
155 end else begin
close_ngroups 2 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
160 prerr_endline ("OPPADD: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
end ;
let x2 = pop int_stack in
let x1 = pop int_stack in
165 let r = match lxm with
| '+' -> x1 + x2
| '-' -> x1 - x2
| _ -> assert false in
push_int r) "ADD";
170 open_ngroups 1 ;
end ;
result lexbuf)
| 9 -> (
165 "get.mll"
175 let lxm = lexeme_char lexbuf 0 in
close_ngroups 1 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
180 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
185 let r = match lxm with
| '*' -> x1 * x2
| '/' -> x1 / x2
| _ -> assert false in
push_int r) "MULT";
190 result lexbuf)
| 10 -> (
183 "get.mll"
let lxm = Lexing.lexeme_char lexbuf 0 in
close_ngroups 3 ;
195 open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline ("COMP: "^String.make 1 lxm) ;
Stack.pretty string_of_int int_stack
200 end ;
let x2 = pop int_stack in
let x1 = pop int_stack in
push bool_stack
(match lxm with
205 | '<' -> x1 < x2
| '>' -> x1 > x2
| '=' -> x1 = x2
| _ -> assert false) ;
if !verbose > 2 then
210 Stack.pretty sbool bool_stack) "COMP" ;
open_ngroups 2 ;
result lexbuf)
| 11 -> (
206 "get.mll"
215 open_ngroups 2 ;
result lexbuf)
| 12 -> (
209 "get.mll"
close_ngroups 2 ;
220 result lexbuf)
| 13 -> (
213 "get.mll"
let lxm = lexeme lexbuf in
let i = Char.code (lxm.[1]) - Char.code '1' in
225 scan_arg (scan_this_arg result) i ;
result lexbuf)
| 14 -> (
218 "get.mll"
let lxm = lexeme lexbuf in
230 let pat,body = Latexmacros.find lxm in
let args = make_stack lxm pat lexbuf in
scan_body
(function
| Subst body -> scan_this result body
235 | Toks l ->
List.iter
(scan_this result)
(List.rev l)
| CamlCode f ->
240 let rs = !get_fun f lexbuf in
scan_this result rs)
body args ;
result lexbuf)
| 15 -> (
245 233 "get.mll"
raise (Error ("Bad character in Get.result: ``"^lexeme lexbuf^"''")))
| 16 -> (
234 "get.mll"
())
250 | n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_result_rec lexbuf n
and after_quote lexbuf = __ocaml_lex_after_quote_rec lexbuf 1
and __ocaml_lex_after_quote_rec lexbuf state =
match Lexing.engine lex_tables state lexbuf with
255 0 -> (
238 "get.mll"
let lxm = lexeme lexbuf in
push_int (Char.code lxm.[1]);
result lexbuf)
260 | 1 -> (
242 "get.mll"
let lxm = lexeme lexbuf in
push_int (Char.code lxm.[0]);
result lexbuf)
265 | 2 -> (
246 "get.mll"
Misc.fatal "Cannot understand `-like numerical argument")
| n -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_after_quote_rec lexbuf n
270 ;;
247 "get.mll"
let init latexget latexgetfun latexopenenv latexcloseenv latexcsname
275 latexmain =
get_this := latexget ;
get_fun := latexgetfun ;
open_env := latexopenenv ;
close_env := latexcloseenv ;
280 get_csname := latexcsname ;
main := latexmain
;;
let def_loc name f =
285 Latexmacros.def name zero_pat (CamlCode f) ;
;;
let def_commands l =
List.map
290 (fun (name,f) ->
name,Latexmacros.replace name (Some (zero_pat,CamlCode f)))
l
let def_commands_int () =
295 def_commands
["\\value",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
push_int (Counter.value_counter name)) ;
300 "\\pushint",
(fun lexbuf ->
let s = !get_this (save_arg lexbuf) in
scan_this result s)]
305 let def_commands_bool () =
let old_ints = def_commands_int () in
let old_commands =
def_commands
["\\(", (fun _ -> open_ngroups 7) ;
310 "\\)", (fun _ -> close_ngroups 7) ;
"\\@fileexists",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
push bool_stack
315 (try
let _ = Myfiles.open_tex name in
true
with Myfiles.Except | Myfiles.Error _ -> false)) ;
"\\@commandexists",
320 (fun lexbuf ->
let name = !get_csname lexbuf in
push bool_stack (Latexmacros.exists name)) ;
"\\or",
(fun _ ->
325 close_ngroups 7 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
prerr_endline "OR" ;
330 Stack.pretty sbool bool_stack
end ;
let b1 = pop bool_stack in
let b2 = pop bool_stack in
push bool_stack (b1 || b2)) "OR";
335 open_ngroups 6) ;
"\\and",
(fun _ ->
close_ngroups 6 ;
open_aftergroup
340 (fun () ->
if !verbose > 2 then begin
prerr_endline "AND" ;
Stack.pretty sbool bool_stack
end ;
345 let b1 = pop bool_stack in
let b2 = pop bool_stack in
push bool_stack (b1 && b2)) "AND";
open_ngroups 5) ;
"\\not",
350 (fun _ ->
close_ngroups 4 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
355 prerr_endline "NOT" ;
Stack.pretty sbool bool_stack
end ;
let b1 = pop bool_stack in
push bool_stack (not b1)) "NOT";
360 open_ngroups 3) ;
"\\boolean",
(fun lexbuf ->
let name = !get_this (save_arg lexbuf) in
let b = try
365 let r = !get_this
(string_to_arg ("\\if"^name^" true\\else false\\fi")) in
match r with
| "true" -> true
| "false" -> false
370 | _ -> raise (Misc.Fatal ("boolean value: "^r))
with
Latexmacros.Failed -> true in
push bool_stack b) ;
"\\isodd",
375 (fun lexbuf ->
close_ngroups 3 ;
open_aftergroup
(fun () ->
if !verbose > 2 then begin
380 prerr_endline ("ISODD") ;
Stack.pretty string_of_int int_stack
end ;
let x = pop int_stack in
push bool_stack (x mod 2 = 1) ;
385 if !verbose > 2 then
Stack.pretty sbool bool_stack) "ISODD" ;
open_ngroups 2) ] in
let old_equal =
try Some (Latexmacros.find_fail "\\equal") with Failed -> None in
390
def_loc "\\equal"
(fun lexbuf ->
let arg1 = save_arg lexbuf in
let arg2 = save_arg lexbuf in
395 scan_this !main "\\begin{@norefs}" ;
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 _ =
400 List.map (fun (name,x) -> Latexmacros.replace name x) again in
scan_this !main "\\end{@norefs}")
405 let first_try s =
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
410 else match s.[i] with
| '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
415 ;;
let get_int {arg=expr ; subst=subst} =
if !verbose > 1 then
prerr_endline ("get_int : "^expr) ;
420 let r =
try first_try expr with Failure _ -> begin
let old_int = !int_out in
int_out := true ;
start_normal subst ;
425 !open_env "*int*" ;
<