File: subst.mll

package info (click to toggle)
hevea 2.34-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye
  • size: 3,724 kB
  • sloc: ml: 19,172; sh: 495; makefile: 304; ansic: 132
file content (157 lines) | stat: -rw-r--r-- 4,975 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
(***********************************************************************)
(*                                                                     *)
(*                          HEVEA                                      *)
(*                                                                     *)
(*  Luc Maranget, projet Moscova, INRIA Rocquencourt                   *)
(*                                                                     *)
(*  Copyright 2001 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(*  $Id: subst.mll,v 1.20 2012-06-05 14:55:39 maranget Exp $           *)
(***********************************************************************)
{
open Printf
open Misc
open Lexstate

let subst_buff = Out.create_buff ()
;;
} 

let command_name =
 '\\' ((['@''A'-'Z' 'a'-'z']+ '*'?) | [^ 'A'-'Z' 'a'-'z'] | "\\*")


rule subst expn = parse
| '#' ['1'-'9'] as lxm
    {if is_plain '#' then begin
      let i = Char.code (lxm.[1]) - Char.code '1' in
      scan_arg
        (fun arg -> scan_this_arg_list (subst expn) arg) i
    end else
      Out.put subst_buff lxm ;
    subst expn lexbuf}
| '#' '#'
    {if is_plain '#' then
      Out.put_char subst_buff '#'
    else
      Out.put subst_buff "##" ;
    subst expn lexbuf}
|  "\\#" | '\\' | [^'\\' '#']+
    {Out.blit subst_buff lexbuf ; subst expn lexbuf}
| "\\@print" as lxm
    {Save.start_echo () ;
    let _ = Save.arg lexbuf in
    let real_arg = Save.get_echo () in
    Out.put subst_buff lxm ;
    Out.put subst_buff real_arg ;
    subst expn lexbuf}
|  command_name as cmd
    {
     if expn then begin
       try
         let pat,body = Latexmacros.find_fail cmd in
         begin match body with
         | Subst _ when not (Latexmacros.get_saved_macro cmd) ->
             if !verbose > 2 then eprintf "EXPAND: %s\n" cmd ;
             let args = make_stack cmd pat lexbuf in
             Out.put_char subst_buff '{' ;
             scan_body
               (function
                 | Subst body -> scan_this_list (subst expn) body
                 | _ -> assert false)
               body args ;
              Out.put_char subst_buff '}'
         | _ -> Out.put subst_buff cmd
         end
       with Latexmacros.Failed -> Out.put subst_buff cmd
     end else begin
       Out.put subst_buff cmd
     end ;
    subst expn lexbuf}
|  eof {()}
| "" {raise (Error "Empty lexeme in subst")}

and do_translate = parse
| "\\@print" as lxm
    {fun f ->
      Save.start_echo () ;
      let _ = Save.arg lexbuf in
      let real_arg = Save.get_echo () in
      Out.put subst_buff lxm ;
      Out.put subst_buff real_arg ;
      do_translate lexbuf f}
| command_name
    {fun f ->
      Out.blit subst_buff lexbuf ;
      do_translate lexbuf f}
| _ as lxm
    {fun f ->
      Out.put_char subst_buff (f lxm) ;
      do_translate lexbuf f}
| eof {fun _ -> Out.to_string subst_buff}

{

let sharp_inside s =
  try ignore (String.index s '#') ; true with Not_found -> false

let do_do_subst_this expn ({arg=arg ; subst=env} as x) =
  if not (is_top env) && sharp_inside arg then begin
    if !verbose > 1 then begin
      Printf.fprintf stderr "subst_this : [%s]\n" arg ;
      prerr_args ()
    end ;
    let _ = scan_this_arg (subst expn) x in
    let r = Out.to_string subst_buff in
    if !verbose > 1 then
      prerr_endline ("subst_this ["^arg^"] = "^r);
    r
  end else
    arg

let sharp_inside_list xs = List.exists sharp_inside xs

let do_do_subst_this_list expn ({arg=xs ; subst=env} as x) =
  if not (is_top env) && sharp_inside_list xs then begin
    if !verbose > 1 then begin
      fprintf stderr "subst_this_list : [%a]\n" Lexstate.pretty_body xs ;
      prerr_args ()
    end ;
    let _ = scan_this_arg_list (subst expn) x in
    let r = Out.to_list subst_buff in
    if !verbose > 1 then
      eprintf "subst_this_list [%a] = [%a]\n"
        Lexstate.pretty_body xs
        Lexstate.pretty_body r ;
    r
  end else
    xs

let do_subst_this_list x =
  String.concat "" (do_do_subst_this_list false x)
let do_subst_this x = do_do_subst_this false x

let subst_list {arg=args ; subst=env} =
  List.map
    (fun arg -> do_subst_this {arg=arg; subst=env})
    args

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_do_subst_this_list false  (save_opt def lexbuf)  

let subst_body lexbuf = do_do_subst_this_list false (save_body lexbuf)
let subst_arg_list lexbuf = do_do_subst_this_list false (save_body lexbuf)

let subst_expn_arg lexbuf = do_do_subst_this true (save_arg lexbuf)  
let subst_expn_body lexbuf = do_do_subst_this_list true (save_body lexbuf)

let translate f s =
  let lexbuf = MyLexing.from_string s in
  do_translate lexbuf f

let lowercase s = translate Char.lowercase s
and uppercase s = translate Char.uppercase s

}