git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3709 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Daniel de Rauglaudre
parent
342c9e02b1
commit
13b1f3f0ac
|
|
@ -2,3 +2,4 @@
|
|||
camlp4
|
||||
camlp4o
|
||||
camlp4r
|
||||
SAVED
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
structure System =
|
||||
struct
|
||||
structure Unsafe =
|
||||
struct
|
||||
structure Susp =
|
||||
struct
|
||||
type 'a susp = 'a Lazy.t
|
||||
fun delay f = (ref (Lazy.Delayed f) : 'a susp)
|
||||
fun force (f : 'a susp) = Lazy.force f
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
fun null x = x = []
|
||||
fun fold f = List.fold_right (fn x => fn y => f (x, y))
|
||||
fun foldl f = List.fold_left (fn x => fn y => f (y, x))
|
||||
fun foldr f = List.fold_left (fn x => fn y => f (y, x))
|
||||
|
||||
val rev = List.rev
|
||||
val length = List.length
|
||||
val map = List.map
|
||||
|
|
@ -0,0 +1,123 @@
|
|||
(* camlp4r q_MLast.cmo pa_extend.cmo *)
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
value not_impl name x =
|
||||
let desc =
|
||||
if Obj.is_block (Obj.repr x) then
|
||||
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
|
||||
else "int_val = " ^ string_of_int (Obj.magic x)
|
||||
in
|
||||
do {
|
||||
print_newline (); failwith ("pa_extfun: not impl " ^ name ^ " " ^ desc)
|
||||
}
|
||||
;
|
||||
|
||||
value rec mexpr p =
|
||||
let loc = MLast.loc_of_patt p in
|
||||
match p with
|
||||
[ <:patt< $p1$ $p2$ >> ->
|
||||
loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
|
||||
fun
|
||||
[ <:patt< $p1$ $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
|
||||
| p -> <:expr< Extfun.Eapp [$mexpr p$ :: $el$] >> ]
|
||||
| <:patt< $p1$ . $p2$ >> ->
|
||||
loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
|
||||
fun
|
||||
[ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
|
||||
| p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ]
|
||||
| <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list loc pl$ >>
|
||||
| <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >>
|
||||
| <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >>
|
||||
| <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >>
|
||||
| <:patt< $str:s$ >> -> <:expr< Extfun.Estr $str:s$ >>
|
||||
| <:patt< ($p1$ as $_$) >> -> mexpr p1
|
||||
| <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >>
|
||||
| <:patt< _ >> -> <:expr< Extfun.Evar () >>
|
||||
| <:patt< $p1$ | $p2$ >> ->
|
||||
Stdpp.raise_with_loc loc (Failure "or patterns not allowed in extfun")
|
||||
| p -> not_impl "mexpr" p ]
|
||||
and mexpr_list loc =
|
||||
fun
|
||||
[ [] -> <:expr< [] >>
|
||||
| [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list loc el$] >> ]
|
||||
;
|
||||
|
||||
value rec catch_any =
|
||||
fun
|
||||
[ <:patt< $uid:id$ >> -> False
|
||||
| <:patt< ` $_$ >> -> False
|
||||
| <:patt< $lid:_$ >> -> True
|
||||
| <:patt< _ >> -> True
|
||||
| <:patt< ($list:pl$) >> -> List.for_all catch_any pl
|
||||
| <:patt< $p1$ $p2$ >> -> False
|
||||
| <:patt< $p1$ | $p2$ >> -> False
|
||||
| <:patt< $int:_$ >> -> False
|
||||
| <:patt< $str:_$ >> -> False
|
||||
| <:patt< ($p1$ as $_$) >> -> catch_any p1
|
||||
| p -> not_impl "catch_any" p ]
|
||||
;
|
||||
|
||||
value conv (p, wo, e) =
|
||||
let tst = mexpr p in
|
||||
let loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in
|
||||
let e =
|
||||
if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >>
|
||||
else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >>
|
||||
in
|
||||
let has_when =
|
||||
match wo with
|
||||
[ Some _ -> <:expr< True >>
|
||||
| None -> <:expr< False >> ]
|
||||
in
|
||||
<:expr< ($tst$, $has_when$, $e$) >>
|
||||
;
|
||||
|
||||
value rec conv_list tl =
|
||||
fun
|
||||
[ [pe :: pel] ->
|
||||
let loc = MLast.loc_of_expr tl in
|
||||
<:expr< [$conv pe$ :: $conv_list tl pel$] >>
|
||||
| [] -> tl ]
|
||||
;
|
||||
|
||||
value rec split_or =
|
||||
fun
|
||||
[ [(<:patt< $p1$ | $p2$ >>, wo, e) :: pel] ->
|
||||
split_or [(p1, wo, e); (p2, wo, e) :: pel]
|
||||
| [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] ->
|
||||
let p1 =
|
||||
let loc = MLast.loc_of_patt p1 in
|
||||
<:patt< ($p1$ as $p$) >>
|
||||
in
|
||||
let p2 =
|
||||
let loc = MLast.loc_of_patt p2 in
|
||||
<:patt< ($p2$ as $p$) >>
|
||||
in
|
||||
split_or [(p1, wo, e); (p2, wo, e) :: pel]
|
||||
| [pe :: pel] -> [pe :: split_or pel]
|
||||
| [] -> [] ]
|
||||
;
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr;
|
||||
expr: LEVEL "top"
|
||||
[ [ "extfun"; e = SELF; "with"; "["; list = match_case_list; "]" ->
|
||||
<:expr< Extfun.extend $e$ $list$ >> ] ]
|
||||
;
|
||||
match_case_list:
|
||||
[ [ pel = LIST0 match_case SEP "|" ->
|
||||
conv_list <:expr< [] >> (split_or pel) ] ]
|
||||
;
|
||||
match_case:
|
||||
[ [ p = patt; aso = OPT [ "as"; p = patt -> p ];
|
||||
w = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
|
||||
let p =
|
||||
match aso with
|
||||
[ Some p2 -> <:patt< ($p$ as $p2$) >>
|
||||
| _ -> p ]
|
||||
in
|
||||
(p, w, e) ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr;
|
||||
expr: LEVEL "top"
|
||||
[ [ n = box_type; d = SELF; "begin";
|
||||
el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
|
||||
let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in
|
||||
let el = el @ [<:expr< Format.close_box () >>] in
|
||||
<:expr< do { $list:el$ } >>
|
||||
| "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
|
||||
let el = [<:expr< Format.open_hbox () >> :: el] in
|
||||
let el = el @ [<:expr< Format.close_box () >>] in
|
||||
<:expr< do { $list:el$ } >>
|
||||
| "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
|
||||
match el with
|
||||
[ [e] -> e
|
||||
| _ -> <:expr< do { $list:el$ } >> ] ] ]
|
||||
;
|
||||
box_type:
|
||||
[ [ n = "hovbox" -> n
|
||||
| n = "hvbox" -> n
|
||||
| n = "vbox" -> n
|
||||
| n = "box" -> n ] ]
|
||||
;
|
||||
box_expr:
|
||||
[ [ s = STRING -> <:expr< Format.print_string $str:s$ >>
|
||||
| UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >>
|
||||
| UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >>
|
||||
| "/-" -> <:expr< Format.print_space () >>
|
||||
| "//" -> <:expr< Format.print_cut () >>
|
||||
| "!/" -> <:expr< Format.force_newline () >>
|
||||
| "?/" -> <:expr< Format.print_if_newline () >>
|
||||
| e = expr -> e ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,163 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
type spat_comp =
|
||||
[ SpTrm of MLast.loc and MLast.patt and option MLast.expr
|
||||
| SpNtr of MLast.loc and MLast.patt and MLast.expr
|
||||
| SpStr of MLast.loc and MLast.patt ]
|
||||
;
|
||||
type sexp_comp =
|
||||
[ SeTrm of MLast.loc and MLast.expr
|
||||
| SeNtr of MLast.loc and MLast.expr ]
|
||||
;
|
||||
|
||||
(* parsers *)
|
||||
|
||||
value strm_n = "strm__";
|
||||
value next_fun loc = <:expr< Fstream.next >>;
|
||||
|
||||
value rec pattern_eq_expression p e =
|
||||
match (p, e) with
|
||||
[ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
|
||||
| (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
|
||||
| (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
|
||||
pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
|
||||
| (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) ->
|
||||
loop pl el where rec loop pl el =
|
||||
match (pl, el) with
|
||||
[ ([p :: pl], [e :: el]) ->
|
||||
pattern_eq_expression p e && loop pl el
|
||||
| ([], []) -> True
|
||||
| _ -> False ]
|
||||
| _ -> False ]
|
||||
;
|
||||
|
||||
value stream_pattern_component skont =
|
||||
fun
|
||||
[ SpTrm loc p wo ->
|
||||
let p = <:patt< Some ($p$, $lid:strm_n$) >> in
|
||||
if wo = None && pattern_eq_expression p skont then
|
||||
<:expr< $next_fun loc$ $lid:strm_n$ >>
|
||||
else
|
||||
<:expr< match $next_fun loc$ $lid:strm_n$ with
|
||||
[ $p$ $when:wo$ -> $skont$
|
||||
| _ -> None ] >>
|
||||
| SpNtr loc p e ->
|
||||
let p = <:patt< Some ($p$, $lid:strm_n$) >> in
|
||||
if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >>
|
||||
else
|
||||
<:expr< match $e$ $lid:strm_n$ with
|
||||
[ $p$ -> $skont$
|
||||
| _ -> None ] >>
|
||||
| SpStr loc p ->
|
||||
<:expr< let $p$ = $lid:strm_n$ in $skont$ >> ]
|
||||
;
|
||||
|
||||
value rec stream_pattern loc epo e =
|
||||
fun
|
||||
[ [] ->
|
||||
let e =
|
||||
match epo with
|
||||
[ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >>
|
||||
| None -> e ]
|
||||
in
|
||||
<:expr< Some ($e$, $lid:strm_n$) >>
|
||||
| [spc :: spcl] ->
|
||||
let skont = stream_pattern loc epo e spcl in
|
||||
stream_pattern_component skont spc ]
|
||||
;
|
||||
|
||||
value rec parser_cases loc =
|
||||
fun
|
||||
[ [] -> <:expr< None >>
|
||||
| [(spcl, epo, e) :: spel] ->
|
||||
match parser_cases loc spel with
|
||||
[ <:expr< None >> -> stream_pattern loc epo e spcl
|
||||
| pc ->
|
||||
<:expr< match $stream_pattern loc epo e spcl$ with
|
||||
[ Some _ as x -> x
|
||||
| None -> $pc$ ] >> ] ]
|
||||
;
|
||||
|
||||
value cparser_match loc me bpo pc =
|
||||
let pc = parser_cases loc pc in
|
||||
let e =
|
||||
match bpo with
|
||||
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
|
||||
| None -> pc ]
|
||||
in
|
||||
<:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>
|
||||
;
|
||||
|
||||
value cparser loc bpo pc =
|
||||
let e = parser_cases loc pc in
|
||||
let e =
|
||||
match bpo with
|
||||
[ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >>
|
||||
| None -> e ]
|
||||
in
|
||||
let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >>
|
||||
;
|
||||
|
||||
(* streams *)
|
||||
|
||||
value slazy loc x = <:expr< fun () -> $x$ >>;
|
||||
|
||||
value rec cstream loc =
|
||||
fun
|
||||
[ [] -> <:expr< Fstream.nil () >>
|
||||
| [SeTrm loc e :: sel] ->
|
||||
let e2 = cstream loc sel in
|
||||
let x = <:expr< Fstream.cons $e$ $e2$ >> in
|
||||
<:expr< Fstream.flazy $slazy loc x$ >>
|
||||
| [SeNtr loc e] ->
|
||||
e
|
||||
| [SeNtr loc e :: sel] ->
|
||||
let e2 = cstream loc sel in
|
||||
let x = <:expr< Fstream.app $e$ $e2$ >> in
|
||||
<:expr< Fstream.flazy $slazy loc x$ >> ]
|
||||
;
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr;
|
||||
expr: LEVEL "top"
|
||||
[ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" ->
|
||||
<:expr< $cparser loc po pcl$ >>
|
||||
| "fparser"; po = OPT ipatt; pc = parser_case ->
|
||||
<:expr< $cparser loc po [pc]$ >>
|
||||
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "[";
|
||||
pcl = LIST0 parser_case SEP "|"; "]" ->
|
||||
<:expr< $cparser_match loc e po pcl$ >>
|
||||
| "match"; e = SELF; "with"; "parser"; po = OPT ipatt;
|
||||
pc = parser_case ->
|
||||
<:expr< $cparser_match loc e po [pc]$ >> ] ]
|
||||
;
|
||||
parser_case:
|
||||
[ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr ->
|
||||
(sp, po, e) ] ]
|
||||
;
|
||||
stream_patt:
|
||||
[ [ spc = stream_patt_comp -> [spc]
|
||||
| spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" ->
|
||||
[spc :: sp]
|
||||
| -> [] ] ]
|
||||
;
|
||||
stream_patt_comp:
|
||||
[ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm loc p eo
|
||||
| p = patt; "="; e = expr -> SpNtr loc p e
|
||||
| p = patt -> SpStr loc p ] ]
|
||||
;
|
||||
ipatt:
|
||||
[ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
|
||||
;
|
||||
expr: LEVEL "simple"
|
||||
[ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" ->
|
||||
<:expr< $cstream loc se$ >> ] ]
|
||||
;
|
||||
stream_expr_comp:
|
||||
[ [ "`"; e = expr -> SeTrm loc e
|
||||
| e = expr -> SeNtr loc e ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,680 @@
|
|||
;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
|
||||
;; $Id$
|
||||
|
||||
(open Pcaml)
|
||||
(open Stdpp)
|
||||
|
||||
(type (choice 'a 'b) (sum (Left 'a) (Right 'b)))
|
||||
|
||||
;; Buffer
|
||||
|
||||
(module Buff
|
||||
(struct
|
||||
(value buff (ref (String.create 80)))
|
||||
(value store (lambda (len x)
|
||||
(if (>= len (String.length buff.val))
|
||||
(:= buff.val
|
||||
(^ buff.val
|
||||
(String.create (String.length buff.val)))))
|
||||
(:= ([] buff.val len) x)
|
||||
(succ len)))
|
||||
(value get (lambda len (String.sub buff.val 0 len)))))
|
||||
|
||||
;; Lexer
|
||||
|
||||
(value rec skip_to_eol
|
||||
(parser
|
||||
(((` (or '\n' '\r'))) ())
|
||||
(((` _) s) (skip_to_eol s))))
|
||||
|
||||
(value no_ident (list '(' ')' ' ' '\t' '\n' '\r' ';'))
|
||||
|
||||
(value rec ident
|
||||
(lambda len
|
||||
(parser
|
||||
(((` x (not (List.mem x no_ident))) s)
|
||||
(ident (Buff.store len x) s))
|
||||
(()
|
||||
(Buff.get len)))))
|
||||
|
||||
(value rec
|
||||
string (lambda len
|
||||
(parser
|
||||
(((` '"')) (Buff.get len))
|
||||
(((` '\\') (` c) s)
|
||||
(string (Buff.store (Buff.store len '\\') c) s))
|
||||
(((` x) s) (string (Buff.store len x) s)))))
|
||||
|
||||
(value rec
|
||||
number (lambda len
|
||||
(parser
|
||||
(((` (as (range '0' '9') c)) s)
|
||||
(number (Buff.store len c) s))
|
||||
(()
|
||||
(, "INT" (Buff.get len))))))
|
||||
|
||||
(value char_or_quote_id
|
||||
(lambda x
|
||||
(parser
|
||||
(((` ''')) (, "CHAR" (String.make 1 x)))
|
||||
((s)
|
||||
(let ((len (Buff.store (Buff.store 0 ''') x)))
|
||||
(, "LIDENT" (ident len s)))))))
|
||||
|
||||
(value rec char
|
||||
(lambda len
|
||||
(parser
|
||||
(((` ''')) len)
|
||||
(((` x) s) (char (Buff.store len x) s)))))
|
||||
|
||||
(value quote
|
||||
(parser
|
||||
(((` '\\') (len (char (Buff.store 0 '\\')))) (, "CHAR" (Buff.get len)))
|
||||
(((` x) s) (char_or_quote_id x s))))
|
||||
|
||||
(value rec
|
||||
lexer
|
||||
(lambda kwt
|
||||
(parser bp
|
||||
(((` (or ' ' '\t' '\n' '\r')) s) (lexer kwt s))
|
||||
(((` ';') (a (semi kwt bp))) a)
|
||||
(((` '(')) (, (, "" "(") (, bp (+ bp 1))))
|
||||
(((` ')')) (, (, "" ")") (, bp (+ bp 1))))
|
||||
(((` '"') (s (string 0))) ep (, (, "STRING" s) (, bp ep)))
|
||||
(((` ''') (tok quote)) ep (, tok (, bp ep)))
|
||||
(((` '<') (tok less)) ep (, tok (, bp ep)))
|
||||
(((` (as (range '0' '9') c)) (n (number (Buff.store 0 c)))) ep
|
||||
(, n (, bp ep)))
|
||||
(((` x) (s (ident (Buff.store 0 x)))) ep
|
||||
(let ((con (try (progn (: (Hashtbl.find kwt s) unit) "")
|
||||
(Not_found
|
||||
(match x
|
||||
((range 'A' 'Z') "UIDENT")
|
||||
((_) "LIDENT"))))))
|
||||
(, (, con s) (, bp ep))))
|
||||
(() (, (, "EOI" "") (, bp (+ bp 1))))))
|
||||
semi
|
||||
(lambda (kwt bp)
|
||||
(parser
|
||||
(((` ';') (_ skip_to_eol) s) (lexer kwt s))
|
||||
(() ep (, (, "" ";") (, bp ep)))))
|
||||
less
|
||||
(parser
|
||||
(((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0)))
|
||||
(, "QUOT" (^ lab (^ ":" q))))
|
||||
(() (, "LIDENT" "<")))
|
||||
label
|
||||
(lambda len
|
||||
(parser
|
||||
(((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s)
|
||||
(label (Buff.store len c) s))
|
||||
(() (Buff.get len))))
|
||||
quotation
|
||||
(lambda len
|
||||
(parser
|
||||
(((` '>') s) (quotation_greater len s))
|
||||
(((` x) s) (quotation (Buff.store len x) s))
|
||||
(() (failwith "quotation not terminated"))))
|
||||
quotation_greater
|
||||
(lambda len
|
||||
(parser
|
||||
(((` '>')) (Buff.get len))
|
||||
(((a (quotation (Buff.store len '>')))) a))))
|
||||
|
||||
(value lexer_using
|
||||
(lambda (kwt (, con prm))
|
||||
(match con
|
||||
((or "CHAR" "EOI" "INT" "LIDENT" "QUOT" "STRING" "UIDENT") ())
|
||||
(("ANTIQUOT") ())
|
||||
(("")
|
||||
(try (Hashtbl.find kwt prm)
|
||||
(Not_found (Hashtbl.add kwt prm ()))))
|
||||
(_ (raise
|
||||
(Token.Error
|
||||
(^ "the constructor \""
|
||||
(^ con "\" is not recognized by Plexer"))))))))
|
||||
|
||||
(value lexer_text
|
||||
(lambda (, con prm)
|
||||
(if (= con "") (^ "'" (^ prm "'"))
|
||||
(if (= prm "") con
|
||||
(^ con (^ " \"" (^ prm "\"")))))))
|
||||
|
||||
(value lexer_make
|
||||
(lambda ()
|
||||
(let ((kwt (Hashtbl.create 89)))
|
||||
({}
|
||||
(Token.func (Token.lexer_func_of_parser (lexer kwt)))
|
||||
(Token.using (lexer_using kwt))
|
||||
(Token.removing (lambda))
|
||||
(Token.tparse (lambda _ None))
|
||||
(Token.text lexer_text)))))
|
||||
|
||||
;; Building AST
|
||||
|
||||
(type sexpr (sum
|
||||
(Sexpr MLast.loc (list sexpr))
|
||||
(Satom MLast.loc atom string)
|
||||
(Squot MLast.loc string string))
|
||||
atom (sum (Alid) (Auid) (Aint) (Achar) (Astring)))
|
||||
|
||||
(value error_loc
|
||||
(lambda (loc err)
|
||||
(raise_with_loc loc (Stream.Error (^ err " expected")))))
|
||||
(value error
|
||||
(lambda (se err)
|
||||
(let ((loc (match se
|
||||
((or (Satom loc _ _) (Sexpr loc _) (Squot loc _ _))
|
||||
loc))))
|
||||
(error_loc loc err))))
|
||||
|
||||
(value expr_id
|
||||
(lambda (loc s)
|
||||
(match ([] s 0)
|
||||
((range 'A' 'Z') <:expr< $uid:s$ >>)
|
||||
(_ <:expr< $lid:s$ >>))))
|
||||
|
||||
(value patt_id
|
||||
(lambda (loc s)
|
||||
(match ([] s 0)
|
||||
((range 'A' 'Z') <:patt< $uid:s$ >>)
|
||||
(_ <:patt< $lid:s$ >>))))
|
||||
|
||||
(value ctyp_id
|
||||
(lambda (loc s)
|
||||
(match ([] s 0)
|
||||
(''' (let ((s (String.sub s 1 (- (String.length s) 1))))
|
||||
<:ctyp< '$s$ >>))
|
||||
((range 'A' 'Z') <:ctyp< $uid:s$ >>)
|
||||
(_ <:ctyp< $lid:s$ >>))))
|
||||
|
||||
(value strm_n "strm__")
|
||||
(value peek_fun (lambda loc <:expr< Stream.peek >>))
|
||||
(value junk_fun (lambda loc <:expr< Stream.junk >>))
|
||||
|
||||
(value rec
|
||||
module_expr_se
|
||||
(lambda_match
|
||||
((Sexpr loc (list (Satom _ Alid "struct") :: sl))
|
||||
(let ((mel (List.map str_item_se sl)))
|
||||
<:module_expr< struct $list:mel$ end >>))
|
||||
((Satom loc Auid s)
|
||||
<:module_expr< $uid:s$ >>)
|
||||
((se)
|
||||
(error se "module expr")))
|
||||
str_item_se
|
||||
(lambda se
|
||||
(match se
|
||||
((or (Satom loc _ _) (Squot loc _ _))
|
||||
(let ((e (expr_se se))) <:str_item< $exp:e$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid "module") (Satom _ Auid i) se))
|
||||
(let ((mb (module_binding_se se)))
|
||||
<:str_item< module $i$ = $mb$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid "open") (Satom _ Auid s)))
|
||||
(let ((s (list s)))
|
||||
<:str_item< open $s$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid "type") :: sel))
|
||||
(let ((tdl (type_declaration_list_se sel)))
|
||||
<:str_item< type $list:tdl$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid "value") :: sel))
|
||||
(let* (((, r sel)
|
||||
(match sel
|
||||
((list (Satom _ Alid "rec") :: sel) (, True sel))
|
||||
((_) (, False sel))))
|
||||
(lbs (value_binding_se sel)))
|
||||
<:str_item< value $rec:r$ $list:lbs$ >>))
|
||||
((Sexpr loc _)
|
||||
(let ((e (expr_se se)))
|
||||
<:str_item< $exp:e$ >>))))
|
||||
value_binding_se
|
||||
(lambda_match
|
||||
((list se1 se2 :: sel)
|
||||
(list (, (ipatt_se se1) (expr_se se2)) :: (value_binding_se sel)))
|
||||
((list) (list))
|
||||
((list se :: _) (error se "value_binding")))
|
||||
module_binding_se
|
||||
(lambda se (module_expr_se se))
|
||||
expr_se
|
||||
(lambda_match
|
||||
((Satom loc (or Alid Auid) s)
|
||||
(expr_ident_se loc s))
|
||||
((Satom loc Aint s)
|
||||
<:expr< $int:s$ >>)
|
||||
((Satom loc Achar s)
|
||||
(<:expr< $chr:s$ >>))
|
||||
((Satom loc Astring s)
|
||||
<:expr< $str:s$ >>)
|
||||
((Sexpr loc (list))
|
||||
<:expr< () >>)
|
||||
((Sexpr loc (list (Satom _ Alid "if") se se1))
|
||||
(let* ((e (expr_se se))
|
||||
(e1 (expr_se se1)))
|
||||
<:expr< if $e$ then $e1$ else () >>))
|
||||
((Sexpr loc (list (Satom _ Alid "if") se se1 se2))
|
||||
(let* ((e (expr_se se))
|
||||
(e1 (expr_se se1))
|
||||
(e2 (expr_se se2)))
|
||||
<:expr< if $e$ then $e1$ else $e2$ >>))
|
||||
((Sexpr loc (list (Satom loc1 Alid "lambda"))) <:expr< fun [] >>)
|
||||
((Sexpr loc (list (Satom loc1 Alid "lambda") sep :: sel))
|
||||
(let ((e (progn_se loc1 sel)))
|
||||
(match (ipatt_opt_se sep)
|
||||
((Left p) <:expr< fun $p$ -> $e$ >>)
|
||||
((Right (, se sel))
|
||||
(List.fold_right
|
||||
(lambda (se e)
|
||||
(let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>))
|
||||
(list se :: sel) e)))))
|
||||
((Sexpr loc (list (Satom _ Alid "lambda_match") :: sel))
|
||||
(let ((pel (List.map (match_case loc) sel)))
|
||||
<:expr< fun [ $list:pel$ ] >>))
|
||||
((Sexpr loc (list (Satom _ Alid "let") :: sel))
|
||||
(let (((, r sel)
|
||||
(match sel
|
||||
((list (Satom _ Alid "rec") :: sel) (, True sel))
|
||||
((_) (, False sel)))))
|
||||
(match sel
|
||||
((list (Sexpr _ sel1) :: sel2)
|
||||
(let* ((lbs (List.map let_binding_se sel1))
|
||||
(e (progn_se loc sel2)))
|
||||
<:expr< let $rec:r$ $list:lbs$ in $e$ >>))
|
||||
((list se :: _) (error se "let_binding"))
|
||||
((_) (error_loc loc "let_binding")))))
|
||||
((Sexpr loc (list (Satom _ Alid "let*") :: sel))
|
||||
(match sel
|
||||
((list (Sexpr _ sel1) :: sel2)
|
||||
(List.fold_right
|
||||
(lambda (se ek)
|
||||
(let (((, p e) (let_binding_se se)))
|
||||
<:expr< let $p$ = $e$ in $ek$ >>))
|
||||
sel1 (progn_se loc sel2)))
|
||||
((list se :: _) (error se "let_binding"))
|
||||
((_) (error_loc loc "let_binding"))))
|
||||
((Sexpr loc (list (Satom _ Alid "match") se :: sel))
|
||||
(let* ((e (expr_se se))
|
||||
(pel (List.map (match_case loc) sel)))
|
||||
<:expr< match $e$ with [ $list:pel$ ] >>))
|
||||
((Sexpr loc (list (Satom _ Alid "parser") :: sel))
|
||||
(let ((e (match sel
|
||||
((list (as (Satom _ _ _) se) :: sel)
|
||||
(let* ((p (patt_se se))
|
||||
(pc (parser_cases_se loc sel)))
|
||||
<:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>))
|
||||
(_ (parser_cases_se loc sel)))))
|
||||
<:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid "try") se :: sel))
|
||||
(let* ((e (expr_se se))
|
||||
(pel (List.map (match_case loc) sel)))
|
||||
<:expr< try $e$ with [ $list:pel$ ] >>))
|
||||
((Sexpr loc (list (Satom _ Alid "progn") :: sel))
|
||||
(let ((el (List.map expr_se sel)))
|
||||
<:expr< do { $list:el$ } >>))
|
||||
((Sexpr loc (list (Satom _ Alid "while") se :: sel))
|
||||
(let* ((e (expr_se se))
|
||||
(el (List.map expr_se sel)))
|
||||
<:expr< while $e$ do { $list:el$ } >>))
|
||||
((Sexpr loc (list (Satom _ Alid ":=") se1 se2))
|
||||
(let ((e2 (expr_se se2)))
|
||||
(match (expr_se se1)
|
||||
(<:expr< $uid:"()"$ $e1$ $i$ >> <:expr< $e1$.($i$) := $e2$ >>)
|
||||
(e1 <:expr< $e1$ := $e2$ >>))))
|
||||
((Sexpr loc (list (Satom _ Alid "[]") se1 se2))
|
||||
(let* ((e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< $e1$.[$e2$] >>))
|
||||
((Sexpr loc (list (Satom _ Alid ",") :: sel))
|
||||
(let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>))
|
||||
((Sexpr loc (list (Satom _ Alid "{}") :: sel))
|
||||
(let ((lel (List.map (label_expr_se loc) sel))) <:expr< { $list:lel$ } >>))
|
||||
((Sexpr loc (list (Satom _ Alid ":") se1 se2))
|
||||
(let* ((e (expr_se se1))
|
||||
(t (ctyp_se se2)))
|
||||
<:expr< ( $e$ : $t$ ) >>))
|
||||
((Sexpr loc (list (Satom _ Alid "list") :: sel))
|
||||
(let rec ((loop
|
||||
(lambda_match
|
||||
((list) <:expr< [] >>)
|
||||
((list se1 (Satom _ Alid "::") se2)
|
||||
(let* ((e (expr_se se1))
|
||||
(el (expr_se se2)))
|
||||
<:expr< [$e$ :: $el$] >>))
|
||||
((list se :: sel)
|
||||
(let* ((e (expr_se se))
|
||||
(el (loop sel)))
|
||||
<:expr< [$e$ :: $el$] >>)))))
|
||||
(loop sel)))
|
||||
((Sexpr loc (list se :: sel))
|
||||
(List.fold_left
|
||||
(lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>))
|
||||
(expr_se se) sel))
|
||||
((Squot loc typ txt)
|
||||
(Pcaml.handle_expr_quotation loc (, typ txt))))
|
||||
progn_se
|
||||
(lambda loc
|
||||
(lambda_match
|
||||
((list) <:expr< () >>)
|
||||
((list se) (expr_se se))
|
||||
((sel) (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>))))
|
||||
let_binding_se
|
||||
(lambda_match
|
||||
((Sexpr loc (list se1 se2)) (, (ipatt_se se1) (expr_se se2)))
|
||||
(se (error se "let_binding")))
|
||||
match_case
|
||||
(lambda loc
|
||||
(lambda_match
|
||||
((Sexpr _ (list se1 se2))
|
||||
(, (patt_se se1) None (expr_se se2)))
|
||||
((Sexpr _ (list se1 sew se2))
|
||||
(, (patt_se se1) (Some (expr_se sew)) (expr_se se2)))
|
||||
(se (error se "match_case"))))
|
||||
label_expr_se
|
||||
(lambda loc
|
||||
(lambda_match
|
||||
((Sexpr _ (list se1 se2)) (, (patt_se se1) (expr_se se2)))
|
||||
(se (error se ("label_expr")))))
|
||||
expr_ident_se
|
||||
(lambda (loc s)
|
||||
(if (= ([] s 0) '<')
|
||||
<:expr< $lid:s$ >>
|
||||
(let rec
|
||||
((loop
|
||||
(lambda (ibeg i)
|
||||
(if (= i (String.length s))
|
||||
(if (> i ibeg)
|
||||
(expr_id loc (String.sub s ibeg (- i ibeg)))
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (fst loc) i))
|
||||
(Stream.Error "expr expected")))
|
||||
(if (= ([] s i) '.')
|
||||
(if (> i ibeg)
|
||||
(let* ((e1 (expr_id
|
||||
loc
|
||||
(String.sub s ibeg (- i ibeg))))
|
||||
(e2 (loop (+ i 1) (+ i 1))))
|
||||
<:expr< $e1$ . $e2$ >>)
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (+ (fst loc) i) 1))
|
||||
(Stream.Error "expr expected")))
|
||||
(loop ibeg (+ i 1)))))))
|
||||
(loop 0 0))))
|
||||
parser_cases_se
|
||||
(lambda loc
|
||||
(lambda_match
|
||||
((list) <:expr< raise Stream.Failure >>)
|
||||
((list (Sexpr loc (list (Sexpr _ spsel) :: act)) :: sel)
|
||||
(let* ((ekont (lambda _ (parser_cases_se loc sel)))
|
||||
(act (match act
|
||||
((list se) (expr_se se))
|
||||
((list sep se)
|
||||
(let* ((p (patt_se sep))
|
||||
(e (expr_se se)))
|
||||
<:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>))
|
||||
(_ (error_loc loc "parser_case")))))
|
||||
(stream_pattern_se loc act ekont spsel)))
|
||||
((list se :: _)
|
||||
(error se "parser_case"))))
|
||||
stream_pattern_se
|
||||
(lambda (loc act ekont)
|
||||
(lambda_match
|
||||
((list) act)
|
||||
((list se :: sel)
|
||||
(let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>))
|
||||
(skont (stream_pattern_se loc act ckont sel)))
|
||||
(stream_pattern_component skont ekont <:expr< "" >> se)))))
|
||||
stream_pattern_component
|
||||
(lambda (skont ekont err)
|
||||
(lambda_match
|
||||
((Sexpr loc (list (Satom _ Alid "`") se :: wol))
|
||||
(let* ((wo (match wol
|
||||
((list se) (Some (expr_se se)))
|
||||
((list) None)
|
||||
(_ (error_loc loc "stream_pattern_component"))))
|
||||
(e (peek_fun loc))
|
||||
(p (patt_se se))
|
||||
(j (junk_fun loc))
|
||||
(k (ekont err)))
|
||||
<:expr< match $e$ $lid:strm_n$ with
|
||||
[ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
|
||||
| _ -> $k$ ] >>))
|
||||
((Sexpr loc (list se1 se2))
|
||||
(let* ((p (patt_se se1))
|
||||
(e (let ((e (expr_se se2)))
|
||||
<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>))
|
||||
(k (ekont err)))
|
||||
<:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>))
|
||||
((Sexpr loc (list (Satom _ Alid "?") se1 se2))
|
||||
(stream_pattern_component skont ekont (expr_se se2) se1))
|
||||
((Satom loc Alid s)
|
||||
<:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)
|
||||
(se
|
||||
(error se "stream_pattern_component"))))
|
||||
patt_se
|
||||
(lambda_match
|
||||
((Satom loc Alid "_") <:patt< _ >>)
|
||||
((Satom loc (or Alid Auid) s) (patt_ident_se loc s))
|
||||
((Satom loc Aint s)
|
||||
<:patt< $int:s$ >>)
|
||||
((Satom loc Achar s)
|
||||
(<:patt< $chr:s$ >>))
|
||||
((Satom loc Astring s)
|
||||
<:patt< $str:s$ >>)
|
||||
((Sexpr loc (list (Satom _ Alid "or") se :: sel))
|
||||
(List.fold_left
|
||||
(lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>))
|
||||
(patt_se se) sel))
|
||||
((Sexpr loc (list (Satom _ Alid "range") se1 se2))
|
||||
(let* ((p1 (patt_se se1))
|
||||
(p2 (patt_se se2)))
|
||||
<:patt< $p1$ .. $p2$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid ",") :: sel))
|
||||
(let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>))
|
||||
((Sexpr loc (list (Satom _ Alid "as") se1 se2))
|
||||
(let* ((p1 (patt_se se1))
|
||||
(p2 (patt_se se2)))
|
||||
<:patt< ($p1$ as $p2$) >>))
|
||||
((Sexpr loc (list (Satom _ Alid "list") :: sel))
|
||||
(let rec ((loop
|
||||
(lambda_match
|
||||
((list) <:patt< [] >>)
|
||||
((list se1 (Satom _ Alid "::") se2)
|
||||
(let* ((p (patt_se se1))
|
||||
(pl (patt_se se2)))
|
||||
<:patt< [$p$ :: $pl$] >>))
|
||||
((list se :: sel)
|
||||
(let* ((p (patt_se se))
|
||||
(pl (loop sel)))
|
||||
<:patt< [$p$ :: $pl$] >>)))))
|
||||
(loop sel)))
|
||||
((Sexpr loc (list se :: sel))
|
||||
(List.fold_left
|
||||
(lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>))
|
||||
(patt_se se) sel))
|
||||
((Sexpr loc (list)) <:patt< () >>)
|
||||
((Squot loc typ txt) (Pcaml.handle_patt_quotation loc (, typ txt))))
|
||||
patt_ident_se
|
||||
(lambda (loc s)
|
||||
(let rec
|
||||
((loop
|
||||
(lambda (ibeg i)
|
||||
(if (= i (String.length s))
|
||||
(if (> i ibeg)
|
||||
(patt_id loc (String.sub s ibeg (- i ibeg)))
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (fst loc) i))
|
||||
(Stream.Error "patt expected")))
|
||||
(if (= ([] s i) '.')
|
||||
(if (> i ibeg)
|
||||
(let* ((p1 (patt_id
|
||||
loc
|
||||
(String.sub s ibeg (- i ibeg))))
|
||||
(p2 (loop (+ i 1) (+ i 1))))
|
||||
<:patt< $p1$ . $p2$ >>)
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (+ (fst loc) i) 1))
|
||||
(Stream.Error "patt expected")))
|
||||
(loop ibeg (+ i 1)))))))
|
||||
(loop 0 0)))
|
||||
ipatt_se
|
||||
(lambda se
|
||||
(match (ipatt_opt_se se)
|
||||
((Left p) p)
|
||||
((Right (, se _))
|
||||
(error se "ipatt"))))
|
||||
ipatt_opt_se
|
||||
(lambda_match
|
||||
((Satom loc Alid "_") (Left <:patt< _ >>))
|
||||
((Satom loc Alid s) (Left <:patt< $lid:s$ >>))
|
||||
((Sexpr loc (list (Satom _ Alid ",") :: sel))
|
||||
(let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>)))
|
||||
((Sexpr loc (list)) (Left <:patt< () >>))
|
||||
((Sexpr loc (list se :: sel)) (Right (, se sel)))
|
||||
(se (error se "ipatt")))
|
||||
type_declaration_list_se
|
||||
(lambda_match
|
||||
((list se1 se2 :: sel)
|
||||
(let (((, n1 tpl)
|
||||
(match se1
|
||||
((Sexpr _ (list (Satom _ Alid n) :: sel))
|
||||
(, n (List.map type_parameter_se sel)))
|
||||
((Satom _ Alid n)
|
||||
(, n (list)))
|
||||
((se)
|
||||
(error se "type declaration")))))
|
||||
(list (, n1 tpl (ctyp_se se2) (list)) ::
|
||||
(type_declaration_list_se sel))))
|
||||
((list) (list))
|
||||
((list se :: _) (error se "type_declaration")))
|
||||
type_parameter_se
|
||||
(lambda_match
|
||||
((Satom _ Alid s) (&& (>= (String.length s) 2) (= ([] s 0) '''))
|
||||
(, (String.sub s 1 (- (String.length s) 1)) (, False False)))
|
||||
(se
|
||||
(error se "type_parameter")))
|
||||
ctyp_se
|
||||
(lambda_match
|
||||
((Sexpr loc (list (Satom _ Alid "sum") :: sel))
|
||||
(let ((cdl (List.map constructor_declaration_se sel)))
|
||||
<:ctyp< [ $list:cdl$ ] >>))
|
||||
((Sexpr loc (list se :: sel))
|
||||
(List.fold_left
|
||||
(lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>))
|
||||
(ctyp_se se) sel))
|
||||
((Satom loc (or Alid Auid) s)
|
||||
(ctyp_ident_se loc s))
|
||||
(se
|
||||
(error se "ctyp")))
|
||||
ctyp_ident_se
|
||||
(lambda (loc s)
|
||||
(let rec
|
||||
((loop (lambda (ibeg i)
|
||||
(if (= i (String.length s))
|
||||
(if (> i ibeg)
|
||||
(ctyp_id loc (String.sub s ibeg (- i ibeg)))
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (fst loc) i))
|
||||
(Stream.Error "ctyp expected")))
|
||||
(if (= ([] s i) '.')
|
||||
(if (> i ibeg)
|
||||
(let* ((t1 (ctyp_id
|
||||
loc (String.sub s ibeg (- i ibeg))))
|
||||
(t2 (loop (+ i 1) (+ i 1))))
|
||||
<:ctyp< $t1$ . $t2$ >>)
|
||||
(raise_with_loc (, (- (+ (fst loc) i) 1)
|
||||
(+ (+ (fst loc) i) 1))
|
||||
(Stream.Error "ctyp expected")))
|
||||
(loop ibeg (+ i 1)))))))
|
||||
(loop 0 0)))
|
||||
constructor_declaration_se
|
||||
(lambda_match
|
||||
((Sexpr loc (list (Satom _ Auid ci) :: sel))
|
||||
(, ci (List.map ctyp_se sel)))
|
||||
(se
|
||||
(error se "constructor_declaration"))))
|
||||
|
||||
(value top_phrase_se
|
||||
(lambda se
|
||||
(match se
|
||||
((or (Satom loc _ _) (Squot loc _ _)) (str_item_se se))
|
||||
((Sexpr loc (list (Satom _ Alid s) :: sl))
|
||||
(if (= ([] s 0) '#')
|
||||
(let ((n (String.sub s 1 (- (String.length s) 1))))
|
||||
(match sl
|
||||
((list (Satom _ Astring s))
|
||||
(MLast.StDir loc n (Some <:expr< $str:s$ >>)))
|
||||
(_ (match ()))))
|
||||
(str_item_se se)))
|
||||
((Sexpr loc _) (str_item_se se)))))
|
||||
|
||||
;; Parser
|
||||
|
||||
(value phony_quot (ref False))
|
||||
(Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations")
|
||||
|
||||
(:= Pcaml.no_constructors_arity.val False)
|
||||
|
||||
(progn
|
||||
(Grammar.Unsafe.reinit_gram gram (lexer_make ()))
|
||||
(Grammar.Unsafe.clear_entry interf)
|
||||
(Grammar.Unsafe.clear_entry implem)
|
||||
(Grammar.Unsafe.clear_entry top_phrase)
|
||||
(Grammar.Unsafe.clear_entry use_file)
|
||||
(Grammar.Unsafe.clear_entry module_type)
|
||||
(Grammar.Unsafe.clear_entry module_expr)
|
||||
(Grammar.Unsafe.clear_entry sig_item)
|
||||
(Grammar.Unsafe.clear_entry str_item)
|
||||
(Grammar.Unsafe.clear_entry expr)
|
||||
(Grammar.Unsafe.clear_entry patt)
|
||||
(Grammar.Unsafe.clear_entry ctyp)
|
||||
(Grammar.Unsafe.clear_entry let_binding)
|
||||
(Grammar.Unsafe.clear_entry class_type)
|
||||
(Grammar.Unsafe.clear_entry class_expr)
|
||||
(Grammar.Unsafe.clear_entry class_sig_item)
|
||||
(Grammar.Unsafe.clear_entry class_str_item))
|
||||
|
||||
(value sexpr (Grammar.Entry.create gram "sexpr"))
|
||||
(value atom (Grammar.Entry.create gram "atom"))
|
||||
|
||||
EXTEND
|
||||
implem :
|
||||
[ [ st = LIST0 [ s = str_item -> (, s loc) ]; EOI -> (, st False) ] ]
|
||||
;
|
||||
top_phrase :
|
||||
[ [ se = sexpr -> (Some (top_phrase_se se))
|
||||
| EOI -> None ] ]
|
||||
;
|
||||
use_file :
|
||||
[ [ l = LIST0 sexpr; EOI -> (, (List.map top_phrase_se l) False) ] ]
|
||||
;
|
||||
str_item :
|
||||
[ [ se = sexpr -> (str_item_se se)
|
||||
| e = expr -> <:str_item< $exp:e$ >> ] ]
|
||||
;
|
||||
expr :
|
||||
[ "top"
|
||||
[ se = sexpr -> (expr_se se) ] ]
|
||||
;
|
||||
patt :
|
||||
[ [ se = sexpr -> (patt_se se) ] ]
|
||||
;
|
||||
sexpr :
|
||||
[ [ "("; sl = LIST0 sexpr; ")" -> (Sexpr loc sl)
|
||||
| a = atom -> (Satom loc Alid a)
|
||||
| s = LIDENT -> (Satom loc Alid s)
|
||||
| s = UIDENT -> (Satom loc Auid s)
|
||||
| s = INT -> (Satom loc Aint s)
|
||||
| s = CHAR -> (Satom loc Achar s)
|
||||
| s = STRING -> (Satom loc Astring s)
|
||||
| s = QUOT ->
|
||||
(let* ((i (String.index s ':'))
|
||||
(typ (String.sub s 0 i))
|
||||
(txt (String.sub s (+ i 1) (- (- (String.length s) i) 1))))
|
||||
(if phony_quot.val
|
||||
(Satom loc Alid (^ "<:" (^ typ (^ "<" (^ txt ">>")))))
|
||||
(Squot loc typ txt))) ] ]
|
||||
;
|
||||
atom :
|
||||
[ [ "_" -> "_"
|
||||
| "," -> ","
|
||||
| "=" -> "="
|
||||
| ":" -> ":"
|
||||
| "." -> "." ] ]
|
||||
;
|
||||
END
|
||||
|
|
@ -0,0 +1,661 @@
|
|||
(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
|
||||
(* File generated by pretty print; do not edit! *)
|
||||
|
||||
open Pcaml;
|
||||
open Stdpp;
|
||||
|
||||
type choice 'a 'b =
|
||||
[ Left of 'a
|
||||
| Right of 'b ]
|
||||
;
|
||||
|
||||
(* Buffer *)
|
||||
|
||||
module Buff =
|
||||
struct
|
||||
value buff = ref (String.create 80);
|
||||
value store len x =
|
||||
do {
|
||||
if len >= String.length buff.val then
|
||||
buff.val := buff.val ^ String.create (String.length buff.val)
|
||||
else ();
|
||||
buff.val.[len] := x;
|
||||
succ len
|
||||
}
|
||||
;
|
||||
value get len = String.sub buff.val 0 len;
|
||||
end
|
||||
;
|
||||
|
||||
(* Lexer *)
|
||||
|
||||
value rec skip_to_eol =
|
||||
parser
|
||||
[ [: `'\n' | '\r' :] -> ()
|
||||
| [: `_; s :] -> skip_to_eol s ]
|
||||
;
|
||||
|
||||
value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';'];
|
||||
|
||||
value rec ident len =
|
||||
parser
|
||||
[ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
|
||||
| [: :] -> Buff.get len ]
|
||||
;
|
||||
|
||||
value rec string len =
|
||||
parser
|
||||
[ [: `'"' :] -> Buff.get len
|
||||
| [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
|
||||
| [: `x; s :] -> string (Buff.store len x) s ]
|
||||
;
|
||||
|
||||
value rec number len =
|
||||
parser
|
||||
[ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
|
||||
| [: :] -> ("INT", Buff.get len) ]
|
||||
;
|
||||
|
||||
value char_or_quote_id x =
|
||||
parser
|
||||
[ [: `''' :] -> ("CHAR", String.make 1 x)
|
||||
| [: s :] ->
|
||||
let len = Buff.store (Buff.store 0 ''') x in
|
||||
("LIDENT", ident len s) ]
|
||||
;
|
||||
|
||||
value rec char len =
|
||||
parser
|
||||
[ [: `''' :] -> len
|
||||
| [: `x; s :] -> char (Buff.store len x) s ]
|
||||
;
|
||||
|
||||
value quote =
|
||||
parser
|
||||
[ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
|
||||
| [: `x; s :] -> char_or_quote_id x s ]
|
||||
;
|
||||
|
||||
value rec lexer kwt =
|
||||
parser bp
|
||||
[ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt s
|
||||
| [: `';'; a = semi kwt bp :] -> a
|
||||
| [: `'(' :] -> (("", "("), (bp, bp + 1))
|
||||
| [: `')' :] -> (("", ")"), (bp, bp + 1))
|
||||
| [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
|
||||
| [: `'''; tok = quote :] ep -> (tok, (bp, ep))
|
||||
| [: `'<'; tok = less :] ep -> (tok, (bp, ep))
|
||||
| [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, (bp, ep))
|
||||
| [: `x; s = ident (Buff.store 0 x) :] ep ->
|
||||
let con =
|
||||
try do { (Hashtbl.find kwt s : unit); "" } with
|
||||
[ Not_found ->
|
||||
match x with
|
||||
[ 'A'..'Z' -> "UIDENT"
|
||||
| _ -> "LIDENT" ] ]
|
||||
in
|
||||
((con, s), (bp, ep))
|
||||
| [: :] -> (("EOI", ""), (bp, bp + 1)) ]
|
||||
and semi kwt bp =
|
||||
parser
|
||||
[ [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
|
||||
| [: :] ep -> (("", ";"), (bp, ep)) ]
|
||||
and less =
|
||||
parser
|
||||
[ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
|
||||
("QUOT", lab ^ ":" ^ q)
|
||||
| [: :] -> ("LIDENT", "<") ]
|
||||
and label len =
|
||||
parser
|
||||
[ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
|
||||
| [: :] -> Buff.get len ]
|
||||
and quotation len =
|
||||
parser
|
||||
[ [: `'>'; s :] -> quotation_greater len s
|
||||
| [: `x; s :] -> quotation (Buff.store len x) s
|
||||
| [: :] -> failwith "quotation not terminated" ]
|
||||
and quotation_greater len =
|
||||
parser
|
||||
[ [: `'>' :] -> Buff.get len
|
||||
| [: a = quotation (Buff.store len '>') :] -> a ]
|
||||
;
|
||||
|
||||
value lexer_using kwt (con, prm) =
|
||||
match con with
|
||||
[ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> ()
|
||||
| "ANTIQUOT" -> ()
|
||||
| "" ->
|
||||
try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
|
||||
| _ ->
|
||||
raise
|
||||
(Token.Error
|
||||
("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
|
||||
;
|
||||
|
||||
value lexer_text (con, prm) =
|
||||
if con = "" then "'" ^ prm ^ "'"
|
||||
else if prm = "" then con
|
||||
else con ^ " \"" ^ prm ^ "\""
|
||||
;
|
||||
|
||||
value lexer_make () =
|
||||
let kwt = Hashtbl.create 89 in
|
||||
{Token.func = Token.lexer_func_of_parser (lexer kwt);
|
||||
Token.using = lexer_using kwt; Token.removing = fun [];
|
||||
Token.tparse _ = None; Token.text = lexer_text}
|
||||
;
|
||||
|
||||
(* Building AST *)
|
||||
|
||||
type sexpr =
|
||||
[ Sexpr of MLast.loc and list sexpr
|
||||
| Satom of MLast.loc and atom and string
|
||||
| Squot of MLast.loc and string and string ]
|
||||
and atom =
|
||||
[ Alid
|
||||
| Auid
|
||||
| Aint
|
||||
| Achar
|
||||
| Astring ]
|
||||
;
|
||||
|
||||
value error_loc loc err =
|
||||
raise_with_loc loc (Stream.Error (err ^ " expected"))
|
||||
;
|
||||
value error se err =
|
||||
let loc =
|
||||
match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ]
|
||||
in
|
||||
error_loc loc err
|
||||
;
|
||||
|
||||
value expr_id loc s =
|
||||
match s.[0] with
|
||||
[ 'A'..'Z' -> <:expr< $uid:s$ >>
|
||||
| _ -> <:expr< $lid:s$ >> ]
|
||||
;
|
||||
|
||||
value patt_id loc s =
|
||||
match s.[0] with
|
||||
[ 'A'..'Z' -> <:patt< $uid:s$ >>
|
||||
| _ -> <:patt< $lid:s$ >> ]
|
||||
;
|
||||
|
||||
value ctyp_id loc s =
|
||||
match s.[0] with
|
||||
[ ''' ->
|
||||
let s = String.sub s 1 (String.length s - 1) in
|
||||
<:ctyp< '$s$ >>
|
||||
| 'A'..'Z' -> <:ctyp< $uid:s$ >>
|
||||
| _ -> <:ctyp< $lid:s$ >> ]
|
||||
;
|
||||
|
||||
value strm_n = "strm__";
|
||||
value peek_fun loc = <:expr< Stream.peek >>;
|
||||
value junk_fun loc = <:expr< Stream.junk >>;
|
||||
|
||||
value rec module_expr_se =
|
||||
fun
|
||||
[ Sexpr loc [Satom _ Alid "struct" :: sl] ->
|
||||
let mel = List.map str_item_se sl in
|
||||
<:module_expr< struct $list:mel$ end >>
|
||||
| Satom loc Auid s -> <:module_expr< $uid:s$ >>
|
||||
| se -> error se "module expr" ]
|
||||
and str_item_se se =
|
||||
match se with
|
||||
[ Satom loc _ _ | Squot loc _ _ ->
|
||||
let e = expr_se se in
|
||||
<:str_item< $exp:e$ >>
|
||||
| Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] ->
|
||||
let mb = module_binding_se se in
|
||||
<:str_item< module $i$ = $mb$ >>
|
||||
| Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] ->
|
||||
let s = [s] in
|
||||
<:str_item< open $s$ >>
|
||||
| Sexpr loc [Satom _ Alid "type" :: sel] ->
|
||||
let tdl = type_declaration_list_se sel in
|
||||
<:str_item< type $list:tdl$ >>
|
||||
| Sexpr loc [Satom _ Alid "value" :: sel] ->
|
||||
let (r, sel) =
|
||||
match sel with
|
||||
[ [Satom _ Alid "rec" :: sel] -> (True, sel)
|
||||
| _ -> (False, sel) ]
|
||||
in
|
||||
let lbs = value_binding_se sel in
|
||||
<:str_item< value $rec:r$ $list:lbs$ >>
|
||||
| Sexpr loc _ ->
|
||||
let e = expr_se se in
|
||||
<:str_item< $exp:e$ >> ]
|
||||
and value_binding_se =
|
||||
fun
|
||||
[ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel]
|
||||
| [] -> []
|
||||
| [se :: _] -> error se "value_binding" ]
|
||||
and module_binding_se se = module_expr_se se
|
||||
and expr_se =
|
||||
fun
|
||||
[ Satom loc (Alid | Auid) s -> expr_ident_se loc s
|
||||
| Satom loc Aint s -> <:expr< $int:s$ >>
|
||||
| Satom loc Achar s -> <:expr< $chr:s$ >>
|
||||
| Satom loc Astring s -> <:expr< $str:s$ >>
|
||||
| Sexpr loc [] -> <:expr< () >>
|
||||
| Sexpr loc [Satom _ Alid "if"; se; se1] ->
|
||||
let e = expr_se se in
|
||||
let e1 = expr_se se1 in
|
||||
<:expr< if $e$ then $e1$ else () >>
|
||||
| Sexpr loc [Satom _ Alid "if"; se; se1; se2] ->
|
||||
let e = expr_se se in
|
||||
let e1 = expr_se se1 in
|
||||
let e2 = expr_se se2 in
|
||||
<:expr< if $e$ then $e1$ else $e2$ >>
|
||||
| Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >>
|
||||
| Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] ->
|
||||
let e = progn_se loc1 sel in
|
||||
match ipatt_opt_se sep with
|
||||
[ Left p -> <:expr< fun $p$ -> $e$ >>
|
||||
| Right (se, sel) ->
|
||||
List.fold_right
|
||||
(fun se e ->
|
||||
let p = ipatt_se se in
|
||||
<:expr< fun $p$ -> $e$ >>)
|
||||
[se :: sel] e ]
|
||||
| Sexpr loc [Satom _ Alid "lambda_match" :: sel] ->
|
||||
let pel = List.map (match_case loc) sel in
|
||||
<:expr< fun [ $list:pel$ ] >>
|
||||
| Sexpr loc [Satom _ Alid "let" :: sel] ->
|
||||
let (r, sel) =
|
||||
match sel with
|
||||
[ [Satom _ Alid "rec" :: sel] -> (True, sel)
|
||||
| _ -> (False, sel) ]
|
||||
in
|
||||
match sel with
|
||||
[ [Sexpr _ sel1 :: sel2] ->
|
||||
let lbs = List.map let_binding_se sel1 in
|
||||
let e = progn_se loc sel2 in
|
||||
<:expr< let $rec:r$ $list:lbs$ in $e$ >>
|
||||
| [se :: _] -> error se "let_binding"
|
||||
| _ -> error_loc loc "let_binding" ]
|
||||
| Sexpr loc [Satom _ Alid "let*" :: sel] ->
|
||||
match sel with
|
||||
[ [Sexpr _ sel1 :: sel2] ->
|
||||
List.fold_right
|
||||
(fun se ek ->
|
||||
let (p, e) = let_binding_se se in
|
||||
<:expr< let $p$ = $e$ in $ek$ >>)
|
||||
sel1 (progn_se loc sel2)
|
||||
| [se :: _] -> error se "let_binding"
|
||||
| _ -> error_loc loc "let_binding" ]
|
||||
| Sexpr loc [Satom _ Alid "match"; se :: sel] ->
|
||||
let e = expr_se se in
|
||||
let pel = List.map (match_case loc) sel in
|
||||
<:expr< match $e$ with [ $list:pel$ ] >>
|
||||
| Sexpr loc [Satom _ Alid "parser" :: sel] ->
|
||||
let e =
|
||||
match sel with
|
||||
[ [(Satom _ _ _ as se) :: sel] ->
|
||||
let p = patt_se se in
|
||||
let pc = parser_cases_se loc sel in
|
||||
<:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
|
||||
| _ -> parser_cases_se loc sel ]
|
||||
in
|
||||
<:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
|
||||
| Sexpr loc [Satom _ Alid "try"; se :: sel] ->
|
||||
let e = expr_se se in
|
||||
let pel = List.map (match_case loc) sel in
|
||||
<:expr< try $e$ with [ $list:pel$ ] >>
|
||||
| Sexpr loc [Satom _ Alid "progn" :: sel] ->
|
||||
let el = List.map expr_se sel in
|
||||
<:expr< do { $list:el$ } >>
|
||||
| Sexpr loc [Satom _ Alid "while"; se :: sel] ->
|
||||
let e = expr_se se in
|
||||
let el = List.map expr_se sel in
|
||||
<:expr< while $e$ do { $list:el$ } >>
|
||||
| Sexpr loc [Satom _ Alid ":="; se1; se2] ->
|
||||
let e2 = expr_se se2 in
|
||||
match expr_se se1 with
|
||||
[ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >>
|
||||
| e1 -> <:expr< $e1$ := $e2$ >> ]
|
||||
| Sexpr loc [Satom _ Alid "[]"; se1; se2] ->
|
||||
let e1 = expr_se se1 in
|
||||
let e2 = expr_se se2 in
|
||||
<:expr< $e1$.[$e2$] >>
|
||||
| Sexpr loc [Satom _ Alid "," :: sel] ->
|
||||
let el = List.map expr_se sel in
|
||||
<:expr< ( $list:el$ ) >>
|
||||
| Sexpr loc [Satom _ Alid "{}" :: sel] ->
|
||||
let lel = List.map (label_expr_se loc) sel in
|
||||
<:expr< { $list:lel$ } >>
|
||||
| Sexpr loc [Satom _ Alid ":"; se1; se2] ->
|
||||
let e = expr_se se1 in
|
||||
let t = ctyp_se se2 in
|
||||
<:expr< ( $e$ : $t$ ) >>
|
||||
| Sexpr loc [Satom _ Alid "list" :: sel] ->
|
||||
let rec loop =
|
||||
fun
|
||||
[ [] -> <:expr< [] >>
|
||||
| [se1; Satom _ Alid "::"; se2] ->
|
||||
let e = expr_se se1 in
|
||||
let el = expr_se se2 in
|
||||
<:expr< [$e$ :: $el$] >>
|
||||
| [se :: sel] ->
|
||||
let e = expr_se se in
|
||||
let el = loop sel in
|
||||
<:expr< [$e$ :: $el$] >> ]
|
||||
in
|
||||
loop sel
|
||||
| Sexpr loc [se :: sel] ->
|
||||
List.fold_left
|
||||
(fun e se ->
|
||||
let e1 = expr_se se in
|
||||
<:expr< $e$ $e1$ >>)
|
||||
(expr_se se) sel
|
||||
| Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
|
||||
and progn_se loc =
|
||||
fun
|
||||
[ [] -> <:expr< () >>
|
||||
| [se] -> expr_se se
|
||||
| sel ->
|
||||
let el = List.map expr_se sel in
|
||||
<:expr< do { $list:el$ } >> ]
|
||||
and let_binding_se =
|
||||
fun
|
||||
[ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2)
|
||||
| se -> error se "let_binding" ]
|
||||
and match_case loc =
|
||||
fun
|
||||
[ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2)
|
||||
| Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2)
|
||||
| se -> error se "match_case" ]
|
||||
and label_expr_se loc =
|
||||
fun
|
||||
[ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
|
||||
| se -> error se "label_expr" ]
|
||||
and expr_ident_se loc s =
|
||||
if s.[0] = '<' then <:expr< $lid:s$ >>
|
||||
else
|
||||
let rec loop ibeg i =
|
||||
if i = String.length s then
|
||||
if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg))
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i)
|
||||
(Stream.Error "expr expected")
|
||||
else if s.[i] = '.' then
|
||||
if i > ibeg then
|
||||
let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in
|
||||
let e2 = loop (i + 1) (i + 1) in
|
||||
<:expr< $e1$ . $e2$ >>
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i + 1)
|
||||
(Stream.Error "expr expected")
|
||||
else loop ibeg (i + 1)
|
||||
in
|
||||
loop 0 0
|
||||
and parser_cases_se loc =
|
||||
fun
|
||||
[ [] -> <:expr< raise Stream.Failure >>
|
||||
| [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
|
||||
let ekont _ = parser_cases_se loc sel in
|
||||
let act =
|
||||
match act with
|
||||
[ [se] -> expr_se se
|
||||
| [sep; se] ->
|
||||
let p = patt_se sep in
|
||||
let e = expr_se se in
|
||||
<:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
|
||||
| _ -> error_loc loc "parser_case" ]
|
||||
in
|
||||
stream_pattern_se loc act ekont spsel
|
||||
| [se :: _] -> error se "parser_case" ]
|
||||
and stream_pattern_se loc act ekont =
|
||||
fun
|
||||
[ [] -> act
|
||||
| [se :: sel] ->
|
||||
let ckont err = <:expr< raise (Stream.Error $err$) >> in
|
||||
let skont = stream_pattern_se loc act ckont sel in
|
||||
stream_pattern_component skont ekont <:expr< "" >> se ]
|
||||
and stream_pattern_component skont ekont err =
|
||||
fun
|
||||
[ Sexpr loc [Satom _ Alid "`"; se :: wol] ->
|
||||
let wo =
|
||||
match wol with
|
||||
[ [se] -> Some (expr_se se)
|
||||
| [] -> None
|
||||
| _ -> error_loc loc "stream_pattern_component" ]
|
||||
in
|
||||
let e = peek_fun loc in
|
||||
let p = patt_se se in
|
||||
let j = junk_fun loc in
|
||||
let k = ekont err in
|
||||
<:expr< match $e$ $lid:strm_n$ with
|
||||
[ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
|
||||
| _ -> $k$ ] >>
|
||||
| Sexpr loc [se1; se2] ->
|
||||
let p = patt_se se1 in
|
||||
let e =
|
||||
let e = expr_se se2 in
|
||||
<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
|
||||
in
|
||||
let k = ekont err in
|
||||
<:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
|
||||
| Sexpr loc [Satom _ Alid "?"; se1; se2] ->
|
||||
stream_pattern_component skont ekont (expr_se se2) se1
|
||||
| Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
|
||||
| se -> error se "stream_pattern_component" ]
|
||||
and patt_se =
|
||||
fun
|
||||
[ Satom loc Alid "_" -> <:patt< _ >>
|
||||
| Satom loc (Alid | Auid) s -> patt_ident_se loc s
|
||||
| Satom loc Aint s -> <:patt< $int:s$ >>
|
||||
| Satom loc Achar s -> <:patt< $chr:s$ >>
|
||||
| Satom loc Astring s -> <:patt< $str:s$ >>
|
||||
| Sexpr loc [Satom _ Alid "or"; se :: sel] ->
|
||||
List.fold_left
|
||||
(fun p se ->
|
||||
let p1 = patt_se se in
|
||||
<:patt< $p$ | $p1$ >>)
|
||||
(patt_se se) sel
|
||||
| Sexpr loc [Satom _ Alid "range"; se1; se2] ->
|
||||
let p1 = patt_se se1 in
|
||||
let p2 = patt_se se2 in
|
||||
<:patt< $p1$ .. $p2$ >>
|
||||
| Sexpr loc [Satom _ Alid "," :: sel] ->
|
||||
let pl = List.map patt_se sel in
|
||||
<:patt< ( $list:pl$ ) >>
|
||||
| Sexpr loc [Satom _ Alid "as"; se1; se2] ->
|
||||
let p1 = patt_se se1 in
|
||||
let p2 = patt_se se2 in
|
||||
<:patt< ($p1$ as $p2$) >>
|
||||
| Sexpr loc [Satom _ Alid "list" :: sel] ->
|
||||
let rec loop =
|
||||
fun
|
||||
[ [] -> <:patt< [] >>
|
||||
| [se1; Satom _ Alid "::"; se2] ->
|
||||
let p = patt_se se1 in
|
||||
let pl = patt_se se2 in
|
||||
<:patt< [$p$ :: $pl$] >>
|
||||
| [se :: sel] ->
|
||||
let p = patt_se se in
|
||||
let pl = loop sel in
|
||||
<:patt< [$p$ :: $pl$] >> ]
|
||||
in
|
||||
loop sel
|
||||
| Sexpr loc [se :: sel] ->
|
||||
List.fold_left
|
||||
(fun p se ->
|
||||
let p1 = patt_se se in
|
||||
<:patt< $p$ $p1$ >>)
|
||||
(patt_se se) sel
|
||||
| Sexpr loc [] -> <:patt< () >>
|
||||
| Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
|
||||
and patt_ident_se loc s =
|
||||
loop 0 0 where rec loop ibeg i =
|
||||
if i = String.length s then
|
||||
if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg))
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i)
|
||||
(Stream.Error "patt expected")
|
||||
else if s.[i] = '.' then
|
||||
if i > ibeg then
|
||||
let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in
|
||||
let p2 = loop (i + 1) (i + 1) in
|
||||
<:patt< $p1$ . $p2$ >>
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i + 1)
|
||||
(Stream.Error "patt expected")
|
||||
else loop ibeg (i + 1)
|
||||
and ipatt_se se =
|
||||
match ipatt_opt_se se with
|
||||
[ Left p -> p
|
||||
| Right (se, _) -> error se "ipatt" ]
|
||||
and ipatt_opt_se =
|
||||
fun
|
||||
[ Satom loc Alid "_" -> Left <:patt< _ >>
|
||||
| Satom loc Alid s -> Left <:patt< $lid:s$ >>
|
||||
| Sexpr loc [Satom _ Alid "," :: sel] ->
|
||||
let pl = List.map ipatt_se sel in
|
||||
Left <:patt< ( $list:pl$ ) >>
|
||||
| Sexpr loc [] -> Left <:patt< () >>
|
||||
| Sexpr loc [se :: sel] -> Right (se, sel)
|
||||
| se -> error se "ipatt" ]
|
||||
and type_declaration_list_se =
|
||||
fun
|
||||
[ [se1; se2 :: sel] ->
|
||||
let (n1, tpl) =
|
||||
match se1 with
|
||||
[ Sexpr _ [Satom _ Alid n :: sel] ->
|
||||
(n, List.map type_parameter_se sel)
|
||||
| Satom _ Alid n -> (n, [])
|
||||
| se -> error se "type declaration" ]
|
||||
in
|
||||
[(n1, tpl, ctyp_se se2, []) :: type_declaration_list_se sel]
|
||||
| [] -> []
|
||||
| [se :: _] -> error se "type_declaration" ]
|
||||
and type_parameter_se =
|
||||
fun
|
||||
[ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' ->
|
||||
(String.sub s 1 (String.length s - 1), (False, False))
|
||||
| se -> error se "type_parameter" ]
|
||||
and ctyp_se =
|
||||
fun
|
||||
[ Sexpr loc [Satom _ Alid "sum" :: sel] ->
|
||||
let cdl = List.map constructor_declaration_se sel in
|
||||
<:ctyp< [ $list:cdl$ ] >>
|
||||
| Sexpr loc [se :: sel] ->
|
||||
List.fold_left
|
||||
(fun t se ->
|
||||
let t2 = ctyp_se se in
|
||||
<:ctyp< $t$ $t2$ >>)
|
||||
(ctyp_se se) sel
|
||||
| Satom loc (Alid | Auid) s -> ctyp_ident_se loc s
|
||||
| se -> error se "ctyp" ]
|
||||
and ctyp_ident_se loc s =
|
||||
loop 0 0 where rec loop ibeg i =
|
||||
if i = String.length s then
|
||||
if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg))
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i)
|
||||
(Stream.Error "ctyp expected")
|
||||
else if s.[i] = '.' then
|
||||
if i > ibeg then
|
||||
let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in
|
||||
let t2 = loop (i + 1) (i + 1) in
|
||||
<:ctyp< $t1$ . $t2$ >>
|
||||
else
|
||||
raise_with_loc (fst loc + i - 1, fst loc + i + 1)
|
||||
(Stream.Error "ctyp expected")
|
||||
else loop ibeg (i + 1)
|
||||
and constructor_declaration_se =
|
||||
fun
|
||||
[ Sexpr loc [Satom _ Auid ci :: sel] -> (ci, List.map ctyp_se sel)
|
||||
| se -> error se "constructor_declaration" ]
|
||||
;
|
||||
|
||||
value top_phrase_se se =
|
||||
match se with
|
||||
[ Satom loc _ _ | Squot loc _ _ -> str_item_se se
|
||||
| Sexpr loc [Satom _ Alid s :: sl] ->
|
||||
if s.[0] = '#' then
|
||||
let n = String.sub s 1 (String.length s - 1) in
|
||||
match sl with
|
||||
[ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>)
|
||||
| _ -> match () with [] ]
|
||||
else str_item_se se
|
||||
| Sexpr loc _ -> str_item_se se ]
|
||||
;
|
||||
|
||||
(* Parser *)
|
||||
|
||||
value phony_quot = ref False;
|
||||
Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations";
|
||||
|
||||
Pcaml.no_constructors_arity.val := False;
|
||||
|
||||
do {
|
||||
Grammar.Unsafe.reinit_gram gram (lexer_make ());
|
||||
Grammar.Unsafe.clear_entry interf;
|
||||
Grammar.Unsafe.clear_entry implem;
|
||||
Grammar.Unsafe.clear_entry top_phrase;
|
||||
Grammar.Unsafe.clear_entry use_file;
|
||||
Grammar.Unsafe.clear_entry module_type;
|
||||
Grammar.Unsafe.clear_entry module_expr;
|
||||
Grammar.Unsafe.clear_entry sig_item;
|
||||
Grammar.Unsafe.clear_entry str_item;
|
||||
Grammar.Unsafe.clear_entry expr;
|
||||
Grammar.Unsafe.clear_entry patt;
|
||||
Grammar.Unsafe.clear_entry ctyp;
|
||||
Grammar.Unsafe.clear_entry let_binding;
|
||||
Grammar.Unsafe.clear_entry class_type;
|
||||
Grammar.Unsafe.clear_entry class_expr;
|
||||
Grammar.Unsafe.clear_entry class_sig_item;
|
||||
Grammar.Unsafe.clear_entry class_str_item
|
||||
};
|
||||
|
||||
value sexpr = Grammar.Entry.create gram "sexpr";
|
||||
value atom = Grammar.Entry.create gram "atom";
|
||||
|
||||
EXTEND
|
||||
implem:
|
||||
[ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ]
|
||||
;
|
||||
top_phrase:
|
||||
[ [ se = sexpr -> Some (top_phrase_se se)
|
||||
| EOI -> None ] ]
|
||||
;
|
||||
use_file:
|
||||
[ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ]
|
||||
;
|
||||
str_item:
|
||||
[ [ se = sexpr -> str_item_se se
|
||||
| e = expr -> <:str_item< $exp:e$ >> ] ]
|
||||
;
|
||||
expr:
|
||||
[ "top"
|
||||
[ se = sexpr -> expr_se se ] ]
|
||||
;
|
||||
patt:
|
||||
[ [ se = sexpr -> patt_se se ] ]
|
||||
;
|
||||
sexpr:
|
||||
[ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
|
||||
| a = atom -> Satom loc Alid a
|
||||
| s = LIDENT -> Satom loc Alid s
|
||||
| s = UIDENT -> Satom loc Auid s
|
||||
| s = INT -> Satom loc Aint s
|
||||
| s = CHAR -> Satom loc Achar s
|
||||
| s = STRING -> Satom loc Astring s
|
||||
| s = QUOT ->
|
||||
let i = String.index s ':' in
|
||||
let typ = String.sub s 0 i in
|
||||
let txt = String.sub s (i + 1) (String.length s - i - 1) in
|
||||
if phony_quot.val then
|
||||
Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>")
|
||||
else Squot loc typ txt ] ]
|
||||
;
|
||||
atom:
|
||||
[ [ "_" -> "_"
|
||||
| "," -> ","
|
||||
| "=" -> "="
|
||||
| ":" -> ":"
|
||||
| "." -> "." ] ]
|
||||
;
|
||||
END;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,154 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
type spat_comp =
|
||||
[ SpTrm of MLast.loc and MLast.patt and option MLast.expr
|
||||
| SpNtr of MLast.loc and MLast.patt and MLast.expr
|
||||
| SpStr of MLast.loc and MLast.patt ]
|
||||
;
|
||||
type sexp_comp =
|
||||
[ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ]
|
||||
;
|
||||
|
||||
value strm_n = "strm__";
|
||||
value peek_fun loc = <:expr< Stream.peek >>;
|
||||
value junk_fun loc = <:expr< Stream.junk >>;
|
||||
|
||||
(* Parsers. *)
|
||||
|
||||
value stream_pattern_component skont =
|
||||
fun
|
||||
[ SpTrm loc p wo ->
|
||||
(<:expr< $peek_fun loc$ $lid:strm_n$ >>, p, wo,
|
||||
<:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >>)
|
||||
| SpNtr loc p e ->
|
||||
(<:expr< try Some ($e$ $lid:strm_n$) with
|
||||
[ Stream.Failure -> None ] >>,
|
||||
p, None, skont)
|
||||
| SpStr loc p ->
|
||||
(<:expr< Some $lid:strm_n$ >>, p, None, skont) ]
|
||||
;
|
||||
|
||||
value rec stream_pattern loc epo e ekont =
|
||||
fun
|
||||
[ [] ->
|
||||
match epo with
|
||||
[ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
|
||||
| _ -> e ]
|
||||
| [(spc, err) :: spcl] ->
|
||||
let skont =
|
||||
let ekont err =
|
||||
let str =
|
||||
match err with
|
||||
[ Some estr -> estr
|
||||
| _ -> <:expr< "" >> ]
|
||||
in
|
||||
<:expr< raise (Stream.Error $str$) >>
|
||||
in
|
||||
stream_pattern loc epo e ekont spcl
|
||||
in
|
||||
let (tst, p, wo, e) = stream_pattern_component skont spc in
|
||||
let ckont = ekont err in
|
||||
<:expr< match $tst$ with
|
||||
[ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ]
|
||||
;
|
||||
|
||||
value rec parser_cases loc =
|
||||
fun
|
||||
[ [] -> <:expr< raise Stream.Failure >>
|
||||
| [(spcl, epo, e) :: spel] ->
|
||||
stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl ]
|
||||
;
|
||||
|
||||
value cparser loc bpo pc =
|
||||
let e = parser_cases loc pc in
|
||||
let e =
|
||||
match bpo with
|
||||
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
|
||||
| None -> e ]
|
||||
in
|
||||
let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
|
||||
<:expr< fun $p$ -> $e$ >>
|
||||
;
|
||||
|
||||
value cparser_match loc me bpo pc =
|
||||
let pc = parser_cases loc pc in
|
||||
let e =
|
||||
match bpo with
|
||||
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
|
||||
| None -> pc ]
|
||||
in
|
||||
<:expr< let $lid:strm_n$ = $me$ in $e$ >>
|
||||
;
|
||||
|
||||
(* streams *)
|
||||
|
||||
value slazy loc e = <:expr< fun _ -> $e$ >>;
|
||||
|
||||
value rec cstream gloc =
|
||||
fun
|
||||
[ [] -> let loc = gloc in <:expr< Stream.sempty >>
|
||||
| [SeTrm loc e :: secl] ->
|
||||
<:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >>
|
||||
| [SeNtr loc e :: secl] ->
|
||||
<:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ]
|
||||
;
|
||||
|
||||
(* Syntax extensions in Ocaml grammar *)
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr;
|
||||
expr: LEVEL "expr1"
|
||||
[ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" ->
|
||||
<:expr< $cparser loc po pcl$ >>
|
||||
| "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|";
|
||||
pcl = LIST1 parser_case SEP "|" ->
|
||||
<:expr< $cparser_match loc e po pcl$ >> ] ]
|
||||
;
|
||||
parser_case:
|
||||
[ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr ->
|
||||
(sp, po, e) ] ]
|
||||
;
|
||||
stream_patt:
|
||||
[ [ spc = stream_patt_comp -> [(spc, None)]
|
||||
| spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" ->
|
||||
[(spc, None) :: sp]
|
||||
| (* empty *) -> [] ] ]
|
||||
;
|
||||
stream_patt_comp_err:
|
||||
[ [ spc = stream_patt_comp;
|
||||
eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] ->
|
||||
(spc, eo) ] ]
|
||||
;
|
||||
stream_patt_comp:
|
||||
[ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] ->
|
||||
SpTrm loc p eo
|
||||
| p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr loc p e
|
||||
| p = patt -> SpStr loc p ] ]
|
||||
;
|
||||
ipatt:
|
||||
[ [ i = LIDENT -> <:patt< $lid:i$ >> ] ]
|
||||
;
|
||||
|
||||
expr: LEVEL "simple"
|
||||
[ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" ->
|
||||
<:expr< $cstream loc se$ >> ] ]
|
||||
;
|
||||
stream_expr_comp:
|
||||
[ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e
|
||||
| e = expr LEVEL "expr1" -> SeNtr loc e ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
value o2b =
|
||||
fun
|
||||
[ Some _ -> True
|
||||
| None -> False ]
|
||||
;
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr;
|
||||
expr: LEVEL "top"
|
||||
[ [ "do"; "{"; seq = sequence; "}" ->
|
||||
match seq with
|
||||
[ [e] -> e
|
||||
| _ -> <:expr< do { $list:seq$ } >> ] ] ]
|
||||
;
|
||||
sequence:
|
||||
[ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in";
|
||||
el = SELF ->
|
||||
let e =
|
||||
match el with
|
||||
[ [e] -> e
|
||||
| _ -> <:expr< do { $list:el$ } >> ]
|
||||
in
|
||||
[<:expr< let $rec:o2b o$ $list:l$ in $e$ >>]
|
||||
| e = expr; ";"; el = SELF ->
|
||||
let e = let loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in
|
||||
[e :: el]
|
||||
| e = expr; ";" -> [e]
|
||||
| e = expr -> [e] ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,621 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Stdpp;
|
||||
open Pcaml;
|
||||
|
||||
Pcaml.no_constructors_arity.val := False;
|
||||
|
||||
do {
|
||||
Grammar.Unsafe.reinit_gram gram (Plexer.make ());
|
||||
Grammar.Unsafe.clear_entry interf;
|
||||
Grammar.Unsafe.clear_entry implem;
|
||||
Grammar.Unsafe.clear_entry top_phrase;
|
||||
Grammar.Unsafe.clear_entry use_file;
|
||||
Grammar.Unsafe.clear_entry module_type;
|
||||
Grammar.Unsafe.clear_entry module_expr;
|
||||
Grammar.Unsafe.clear_entry sig_item;
|
||||
Grammar.Unsafe.clear_entry str_item;
|
||||
Grammar.Unsafe.clear_entry expr;
|
||||
Grammar.Unsafe.clear_entry patt;
|
||||
Grammar.Unsafe.clear_entry ctyp;
|
||||
Grammar.Unsafe.clear_entry let_binding;
|
||||
};
|
||||
|
||||
value not_impl loc s =
|
||||
raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]"))
|
||||
;
|
||||
|
||||
value get_seq =
|
||||
fun
|
||||
[ <:expr< do { $list:el$ } >> -> el
|
||||
| e -> [e] ]
|
||||
;
|
||||
|
||||
value choose_tvar tpl =
|
||||
let rec find_alpha v =
|
||||
let s = String.make 1 v in
|
||||
if List.mem_assoc s tpl then
|
||||
if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
|
||||
else Some (String.make 1 v)
|
||||
in
|
||||
let rec make_n n =
|
||||
let v = "a" ^ string_of_int n in
|
||||
if List.mem_assoc v tpl then make_n (succ n) else v
|
||||
in
|
||||
match find_alpha 'a' with
|
||||
[ Some x -> x
|
||||
| None -> make_n 1 ]
|
||||
;
|
||||
|
||||
external loc_of_node : 'a -> (int * int) = "%field0";
|
||||
|
||||
value mklistexp loc last =
|
||||
loop True where rec loop top =
|
||||
fun
|
||||
[ [] ->
|
||||
match last with
|
||||
[ Some e -> e
|
||||
| None -> <:expr< [] >> ]
|
||||
| [e1 :: el] ->
|
||||
let loc = if top then loc else (fst (loc_of_node e1), snd loc) in
|
||||
<:expr< [$e1$ :: $loop False el$] >> ]
|
||||
;
|
||||
|
||||
value str_declare loc =
|
||||
fun
|
||||
[ [d] -> d
|
||||
| dl -> <:str_item< declare $list:dl$ end >> ]
|
||||
;
|
||||
|
||||
value sig_declare loc =
|
||||
fun
|
||||
[ [d] -> d
|
||||
| dl -> <:sig_item< declare $list:dl$ end >> ]
|
||||
;
|
||||
|
||||
value rec separate_fun_val =
|
||||
fun
|
||||
[ [((_, <:expr< fun [$list:_$] >>) as x) :: l] ->
|
||||
let (f, v) = separate_fun_val l in ([x :: f], v)
|
||||
| [x :: l] ->
|
||||
let (f, v) = separate_fun_val l in (f, [x :: v])
|
||||
| [] -> ([], []) ]
|
||||
;
|
||||
|
||||
value extract_label_types loc tn tal cdol =
|
||||
let (cdl, aux) =
|
||||
List.fold_right
|
||||
(fun (c, tl, aux_opt) (cdl, aux) ->
|
||||
match aux_opt with
|
||||
[ Some anon_record_type ->
|
||||
let new_tn = tn ^ "_" ^ c in
|
||||
let loc = loc_of_node anon_record_type in
|
||||
let aux_def = (new_tn, [], anon_record_type, []) in
|
||||
let tl = [<:ctyp< $lid:new_tn$ >>] in
|
||||
([(c, tl) :: cdl], [aux_def :: aux])
|
||||
| None -> ([(c, tl) :: cdl], aux) ])
|
||||
cdol ([], [])
|
||||
in
|
||||
[(tn, tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux]
|
||||
;
|
||||
|
||||
value special x =
|
||||
do {
|
||||
assert (String.length x > 0);
|
||||
match x.[0] with
|
||||
[ '+' | '<' -> True
|
||||
| _ -> False ]
|
||||
}
|
||||
;
|
||||
|
||||
value idd =
|
||||
let p =
|
||||
parser
|
||||
[ [: `("LIDENT", x) :] -> x
|
||||
| [: `("UIDENT", x) :] -> x
|
||||
| [: `("", x) when special x :] -> x ]
|
||||
in
|
||||
Grammar.Entry.of_parser Pcaml.gram "ID" p
|
||||
;
|
||||
|
||||
value uncap s = String.uncapitalize s;
|
||||
|
||||
value op = Grammar.Entry.of_parser gram "op" (parser [] : Stream.t 'a -> unit);
|
||||
|
||||
EXTEND
|
||||
GLOBAL: implem top_phrase use_file sig_item str_item ctyp patt expr
|
||||
module_type module_expr;
|
||||
|
||||
implem:
|
||||
[ [ x = interdec; EOI -> x ] ]
|
||||
;
|
||||
top_phrase:
|
||||
[ [ ph = phrase; ";" -> Some ph
|
||||
| EOI -> None ] ]
|
||||
;
|
||||
use_file:
|
||||
[ [ l = LIST0 phrase; EOI -> (l, False) ] ]
|
||||
;
|
||||
phrase:
|
||||
[ [ x = str_item -> x
|
||||
| x = expr -> <:str_item< $exp:x$ >>
|
||||
| "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
|
||||
;
|
||||
dir_param:
|
||||
[ [ -> None
|
||||
| e = expr -> Some e ] ]
|
||||
;
|
||||
|
||||
sdecs: [ [ -> not_impl loc "sdecs" ] ];
|
||||
fsigb: [ [ -> not_impl loc "fsigb" ] ];
|
||||
fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ];
|
||||
fct_exp: [ [ -> not_impl loc "fct_exp" ] ];
|
||||
exp_pa: [ [ -> not_impl loc "exp_pa" ] ];
|
||||
rvb: [ [ -> not_impl loc "rvb" ] ];
|
||||
tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ];
|
||||
tyvar_pc: [ [ -> not_impl loc "tyvar_pc" ] ];
|
||||
|
||||
lident_loc:
|
||||
[ [ x1 = LIDENT -> (x1, loc) ] ]
|
||||
;
|
||||
id:
|
||||
[ [ x1 = idd -> x1
|
||||
| "*" -> "*" ] ]
|
||||
;
|
||||
ident:
|
||||
[ [ x1 = idd -> x1
|
||||
| "*" -> "*"
|
||||
| "=" -> "=" ] ]
|
||||
;
|
||||
op_op:
|
||||
[ [ x1 = op -> not_impl loc "op_op 1"
|
||||
| -> () ] ]
|
||||
;
|
||||
qid:
|
||||
[ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >>
|
||||
| x1 = idd -> <:module_expr< $uid:x1$ >>
|
||||
| x1 = "*" -> <:module_expr< $uid:x1$ >>
|
||||
| x1 = "=" -> <:module_expr< $uid:x1$ >> ] ]
|
||||
;
|
||||
tqid:
|
||||
[ [ x1 = idd; "."; x2 = tqid -> <:module_type< $uid:x1$ . $x2$ >>
|
||||
| x1 = idd -> <:module_type< $uid:x1$ >>
|
||||
| x1 = "*" -> <:module_type< $uid:x1$ >>
|
||||
| x1 = "=" -> <:module_type< $uid:x1$ >> ] ]
|
||||
;
|
||||
eqid:
|
||||
[ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
|
||||
| x1 = UIDENT -> <:expr< $uid:x1$ >>
|
||||
| x1 = idd -> <:expr< $lid:x1$ >>
|
||||
| x1 = "*" -> <:expr< $lid:x1$ >>
|
||||
| x1 = "=" -> <:expr< $lid:x1$ >> ] ]
|
||||
;
|
||||
sqid:
|
||||
[ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2]
|
||||
| x1 = idd -> [x1]
|
||||
| x1 = "*" -> [x1]
|
||||
| x1 = "=" -> [x1] ] ]
|
||||
;
|
||||
tycon:
|
||||
[ [ LIDENT "real" -> <:ctyp< float >>
|
||||
| x1 = idd; "."; x2 = tycon -> <:ctyp< $uid:x1$ . $x2$ >>
|
||||
| x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ]
|
||||
;
|
||||
selector:
|
||||
[ [ x1 = id -> x1
|
||||
| x1 = INT -> not_impl loc "selector 1" ] ]
|
||||
;
|
||||
tlabel:
|
||||
[ [ x1 = selector; ":"; x2 = ctyp -> (x1, False, x2) ] ]
|
||||
;
|
||||
tuple_ty:
|
||||
[ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2]
|
||||
| x1 = ctyp LEVEL "ty'" -> [x1] ] ]
|
||||
;
|
||||
ctyp:
|
||||
[ RIGHTA
|
||||
[ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ]
|
||||
| [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ]
|
||||
| "ty'"
|
||||
[ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
|
||||
| "{"; x1 = LIST1 tlabel SEP ","; "}" -> <:ctyp< {$list:x1$} >>
|
||||
| "{"; "}" -> not_impl loc "ty' 3"
|
||||
| "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon ->
|
||||
not_impl loc "ty' 4"
|
||||
| "("; x1 = ctyp; ")" -> x1
|
||||
| x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >>
|
||||
| x1 = tycon -> x1 ] ]
|
||||
;
|
||||
rule:
|
||||
[ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ]
|
||||
;
|
||||
elabel:
|
||||
[ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ]
|
||||
;
|
||||
exp_ps:
|
||||
[ [ x1 = expr -> x1
|
||||
| x1 = expr; ";"; x2 = expr ->
|
||||
<:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ]
|
||||
;
|
||||
expr:
|
||||
[ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr ->
|
||||
<:expr< if $x1$ then $x2$ else $x3$ >>
|
||||
| "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >>
|
||||
| "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" ->
|
||||
<:expr< match $x1$ with [$list:x2$] >> ]
|
||||
| LEFTA
|
||||
[ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ]
|
||||
| LEFTA
|
||||
[ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ]
|
||||
| LEFTA
|
||||
[ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ]
|
||||
| "4" NONA
|
||||
[ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >>
|
||||
| x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >>
|
||||
| x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >>
|
||||
| x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >>
|
||||
| x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ]
|
||||
| "5" RIGHTA
|
||||
[ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ]
|
||||
| "6" LEFTA
|
||||
[ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >>
|
||||
| x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ]
|
||||
| "7" LEFTA
|
||||
[ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >>
|
||||
| x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >> ]
|
||||
| LEFTA
|
||||
[ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ]
|
||||
| [ "!"; x1 = expr -> <:expr< $x1$ . val >> ]
|
||||
| [ "~"; x1 = expr -> <:expr< - $x1$ >> ]
|
||||
| [ "#"; x1 = selector; x2 = expr -> <:expr< $x2$ . $lid:x1$ >> ]
|
||||
| [ x1 = LIDENT ->
|
||||
match x1 with
|
||||
[ "true" | "false" -> <:expr< $uid:x1$ >>
|
||||
| _ -> <:expr< $lid:x1$ >> ]
|
||||
| x1 = UIDENT -> <:expr< $uid:x1$ >>
|
||||
| x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
|
||||
| x1 = INT -> <:expr< $int:x1$ >>
|
||||
| x1 = FLOAT -> <:expr< $flo:x1$ >>
|
||||
| x1 = STRING -> <:expr< $str:x1$ >>
|
||||
| "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" ->
|
||||
let (let_fun, let_val) = separate_fun_val x1 in
|
||||
let x2 =
|
||||
List.fold_right (fun (p, e) x2 -> <:expr< let $p$ = $e$ in $x2$ >>)
|
||||
let_val x2
|
||||
in
|
||||
let x2 =
|
||||
match let_fun with
|
||||
[ [] -> x2
|
||||
| _ -> <:expr< let rec $list:let_fun$ in $x2$ >> ]
|
||||
in
|
||||
x2
|
||||
| "{"; x1 = LIST1 elabel SEP ","; "}" -> <:expr< {$list:x1$} >>
|
||||
| "["; "]" -> <:expr< [] >>
|
||||
| "["; x1 = expr; "]" -> <:expr< [$x1$] >>
|
||||
| "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" ->
|
||||
mklistexp loc None [x1 :: x2]
|
||||
| "("; ")" -> <:expr< () >>
|
||||
| "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" ->
|
||||
<:expr< ($list:[x1::x2]$) >>
|
||||
| "("; x1 = expr; ")" -> x1 ] ]
|
||||
;
|
||||
fixity:
|
||||
[ [ "infix" -> not_impl loc "fixity 1"
|
||||
| "infix"; x1 = INT -> not_impl loc "fixity 2"
|
||||
| "infixr" -> not_impl loc "fixity 3"
|
||||
| "infixr"; x1 = INT -> ("infixr", Some x1)
|
||||
| "nonfix" -> not_impl loc "fixity 5" ] ]
|
||||
;
|
||||
patt:
|
||||
[ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ]
|
||||
| LEFTA
|
||||
[ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ]
|
||||
| RIGHTA
|
||||
[ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ]
|
||||
| [ x1 = patt; x2 = patt -> <:patt< $x1$ $x2$ >> ]
|
||||
| "apat"
|
||||
[ x1 = INT -> <:patt< $int:x1$ >>
|
||||
| x1 = UIDENT -> <:patt< $uid:x1$ >>
|
||||
| x1 = id -> <:patt< $lid:x1$ >>
|
||||
| "_" -> <:patt< _ >>
|
||||
| "["; "]" -> <:patt< [] >>
|
||||
| "["; x1 = patt; "]" -> <:patt< [$x1$] >>
|
||||
| "("; ")" -> <:patt< () >>
|
||||
| "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" ->
|
||||
<:patt< ($list:[x1::x2]$) >>
|
||||
| "("; x1 = patt; ")" -> x1 ] ]
|
||||
;
|
||||
vb:
|
||||
[ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1"
|
||||
| x1 = patt; "="; x2 = expr -> (x1, x2) ] ]
|
||||
;
|
||||
constrain:
|
||||
[ [ -> None
|
||||
| ":"; x1 = ctyp -> Some x1 ] ]
|
||||
;
|
||||
fb:
|
||||
[ [ xl = LIST1 clause SEP "|" ->
|
||||
let (fname, l) =
|
||||
List.fold_left
|
||||
(fun (fname, l) ((x1, loc), x2, x3, x4) ->
|
||||
let fname =
|
||||
match fname with
|
||||
[ Some fname ->
|
||||
if x1 <> fname then
|
||||
raise_with_loc loc
|
||||
(Stream.Error ("'" ^ fname ^ "' expected"))
|
||||
else Some fname
|
||||
| _ -> Some x1 ]
|
||||
in
|
||||
let x4 =
|
||||
match x3 with
|
||||
[ Some t -> <:expr< ($x4$ : $t$) >>
|
||||
| _ -> x4 ]
|
||||
in
|
||||
let l = [(x2, None, x4) :: l] in
|
||||
(fname, l))
|
||||
(None, []) xl
|
||||
in
|
||||
match fname with
|
||||
[ Some fname ->
|
||||
(<:patt< $lid:fname$ >>, <:expr< fun [ $list:List.rev l$ ] >>)
|
||||
| None -> assert False ]
|
||||
| "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ]
|
||||
;
|
||||
clause:
|
||||
[ [ x1 = lident_loc; x2 = patt LEVEL "apat"; x3 = patt LEVEL "apat";
|
||||
x4 = constrain; "="; x5 = expr ->
|
||||
let x2 =
|
||||
match x2 with
|
||||
[ <:patt< $lid:s$ >> -> s
|
||||
| _ -> raise (Stream.Error "bad clause") ]
|
||||
in
|
||||
((x2, loc), <:patt< ($lid:fst x1$, $x3$) >>, x4, x5)
|
||||
| x1 = lident_loc; x2 = patt LEVEL "apat"; x3 = constrain; "=";
|
||||
x4 = expr ->
|
||||
(x1, x2, x3, x4)
|
||||
| x1 = patt LEVEL "apat"; x2 = idd_loc; x3 = patt LEVEL "apat";
|
||||
x4 = constrain; "="; x5 = expr ->
|
||||
(x2, <:patt< ($x1$, $x3$) >>, x4, x5) ] ]
|
||||
;
|
||||
idd_loc:
|
||||
[ [ x1 = idd -> (x1, loc) ] ]
|
||||
;
|
||||
tb:
|
||||
[ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> (uncap x2, x1, x3, []) ] ]
|
||||
;
|
||||
tyvars:
|
||||
[ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
|
||||
| "("; x1 = tyvar_pc; ")" -> x1
|
||||
| -> [] ] ]
|
||||
;
|
||||
db1:
|
||||
[ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
|
||||
let x2 = uncap x2 in
|
||||
extract_label_types loc x2 x1 x3
|
||||
| "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
|
||||
not_impl loc "db 2" ] ]
|
||||
;
|
||||
db:
|
||||
[ [ x1 = LIST1 db1 SEP "and" ->
|
||||
List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ]
|
||||
;
|
||||
dbrhs:
|
||||
[ [ x1 = LIST1 constr SEP "|" -> x1
|
||||
| "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ]
|
||||
;
|
||||
constr:
|
||||
[ [ x1 = op_op; x2 = ident -> (x2, [], None)
|
||||
| x1 = op_op; x2 = ident; "of"; x3 = ctyp ->
|
||||
match x3 with
|
||||
[ <:ctyp< {$list:_$} >> -> (x2, [], Some x3)
|
||||
| _ -> (x2, [x3], None) ] ] ]
|
||||
;
|
||||
eb:
|
||||
[ [ x1 = op_op; x2 = ident -> (x2, [])
|
||||
| x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3]) ] ]
|
||||
;
|
||||
ldec1:
|
||||
[ [ "val"; x1 = LIST1 vb SEP "and" -> x1
|
||||
| "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ]
|
||||
;
|
||||
ldecs:
|
||||
[ [ -> []
|
||||
| x1 = ldec1; x2 = ldecs -> x1 @ x2
|
||||
| ";"; x1 = ldecs -> x1
|
||||
| "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs ->
|
||||
not_impl loc "ldecs 4" ] ]
|
||||
;
|
||||
spec_s:
|
||||
[ [ -> []
|
||||
| x1 = sig_item; x2 = spec_s -> [x1 :: x2]
|
||||
| ";"; x1 = spec_s -> x1 ] ]
|
||||
;
|
||||
sig_item:
|
||||
[ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1
|
||||
| "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1
|
||||
| "datatype"; x1 = db -> <:sig_item< type $list:x1$ >>
|
||||
| "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
|
||||
| "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1
|
||||
| "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1
|
||||
| "sharing"; x1 = LIST1 sharespec SEP "and" -> not_impl loc "sig_item 5"
|
||||
| "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ]
|
||||
;
|
||||
strspec:
|
||||
[ [ x1 = ident; ":"; x2 = module_type ->
|
||||
<:sig_item< module $x1$ : $x2$ >> ] ]
|
||||
;
|
||||
fctspec:
|
||||
[ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ]
|
||||
;
|
||||
tyspec:
|
||||
[ [ x1 = tyvars; x2 = idd ->
|
||||
(uncap x2, x1, <:ctyp< '$choose_tvar x1$ >>, [])
|
||||
| x1 = tyvars; x2 = idd; "="; x3 = ctyp -> not_impl loc "tyspec 2" ] ]
|
||||
;
|
||||
valspec:
|
||||
[ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp ->
|
||||
<:sig_item< value $x2$ : $x3$ >> ] ]
|
||||
;
|
||||
exnspec:
|
||||
[ [ x1 = ident -> <:sig_item< exception $x1$ >>
|
||||
| x1 = ident; "of"; x2 = ctyp ->
|
||||
<:sig_item< exception $x1$ of $x2$ >> ] ]
|
||||
;
|
||||
sharespec:
|
||||
[ [ "type"; x1 = patheqn -> not_impl loc "sharespec 1"
|
||||
| x1 = patheqn -> not_impl loc "sharespec 2" ] ]
|
||||
;
|
||||
patheqn:
|
||||
[ [ x1 = qid; "="; x2 = qid -> [x1; x2]
|
||||
| x1 = qid; "="; x2 = patheqn -> [x1 :: x2] ] ]
|
||||
;
|
||||
whspec:
|
||||
[ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp ->
|
||||
MLast.WcTyp loc x2 x1 x3
|
||||
| x1 = sqid; "="; x2 = tqid -> MLast.WcMod loc x1 x2 ] ]
|
||||
;
|
||||
module_type:
|
||||
[ [ x1 = ident -> <:module_type< $uid:x1$ >>
|
||||
| "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >>
|
||||
| x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" ->
|
||||
<:module_type< $x1$ with $list:x2$ >> ] ]
|
||||
;
|
||||
sigconstraint_op:
|
||||
[ [ -> None
|
||||
| ":"; x1 = module_type -> Some x1
|
||||
| ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ]
|
||||
;
|
||||
sigb:
|
||||
[ [ x1 = ident; "="; x2 = module_type ->
|
||||
<:str_item< module type $x1$ = $x2$ >> ] ]
|
||||
;
|
||||
fsig:
|
||||
[ [ ":"; x1 = ident -> not_impl loc "fsig 1"
|
||||
| x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ]
|
||||
;
|
||||
module_expr:
|
||||
[ [ x1 = qid -> x1
|
||||
| "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >>
|
||||
| x1 = qid; x2 = arg_fct -> <:module_expr< $x1$ $x2$ >>
|
||||
| "let"; x1 = strdecs; "in"; x2 = module_expr; "end" ->
|
||||
not_impl loc "str 4"
|
||||
| x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5"
|
||||
| x1 = module_expr; x2 = ":>"; x3 = module_type ->
|
||||
not_impl loc "str 6" ] ]
|
||||
;
|
||||
arg_fct:
|
||||
[ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1"
|
||||
| "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2"
|
||||
| "("; x1 = module_expr; ")" -> x1
|
||||
| "("; x2 = strdecs; ")" -> not_impl loc "arg_fct 4" ] ]
|
||||
;
|
||||
strdecs:
|
||||
[ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2]
|
||||
| ";"; x1 = strdecs -> x1
|
||||
| -> [] ] ]
|
||||
;
|
||||
str_item:
|
||||
[ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1
|
||||
| "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ]
|
||||
| "strdec"
|
||||
[ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1
|
||||
| "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1
|
||||
| "local"; x1 = sdecs; "in"; x2 = sdecs; "end" ->
|
||||
not_impl loc "sdec 5" ]
|
||||
| [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >>
|
||||
| "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" ->
|
||||
not_impl loc "ldec 2"
|
||||
| "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3"
|
||||
| "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4"
|
||||
| "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >>
|
||||
| "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6"
|
||||
| "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >>
|
||||
| "datatype"; x1 = db -> <:str_item< type $list:x1$ >>
|
||||
| "datatype"; x1 = db; "withtype"; x2 = tb ->
|
||||
<:str_item< type $list:x1 @ [x2]$ >>
|
||||
| "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10"
|
||||
| "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" ->
|
||||
not_impl loc "ldec 11"
|
||||
| "exception"; x1 = LIST1 eb SEP "and" ->
|
||||
let dl =
|
||||
List.map
|
||||
(fun (s, tl) -> <:str_item< exception $s$ of $list:tl$ >>) x1
|
||||
in
|
||||
str_declare loc dl
|
||||
| "open"; x1 = LIST1 sqid ->
|
||||
let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in
|
||||
str_declare loc dl
|
||||
| x1 = fixity; x2 = idd ->
|
||||
match x1 with
|
||||
[ ("infixr", Some n) ->
|
||||
do {
|
||||
List.iter
|
||||
(fun s ->
|
||||
EXTEND
|
||||
expr: LEVEL $n$
|
||||
[ [ x1 = expr; $s$; x2 = expr ->
|
||||
<:expr< $lid:s$ ($x1$, $x2$) >> ] ]
|
||||
;
|
||||
END)
|
||||
[x2];
|
||||
str_declare loc []
|
||||
}
|
||||
| _ -> not_impl loc "ldec 14" ]
|
||||
| "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa ->
|
||||
not_impl loc "ldec 15" ] ]
|
||||
;
|
||||
strb:
|
||||
[ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr ->
|
||||
let x3 =
|
||||
match x2 with
|
||||
[ Some x2 -> <:module_expr< ($x3$ : $x2$) >>
|
||||
| None -> x3 ]
|
||||
in
|
||||
<:str_item< module $x1$ = $x3$ >> ] ]
|
||||
;
|
||||
fparam:
|
||||
[ [ x1 = idd; ":"; x2 = module_type -> (x1, x2)
|
||||
| x1 = spec_s ->
|
||||
match x1 with
|
||||
[ [<:sig_item< module $x1$ : $x2$ >>] -> (x1, x2)
|
||||
| _ -> not_impl loc "fparam 2" ] ] ]
|
||||
;
|
||||
fparamList:
|
||||
[ [ "("; x1 = fparam; ")" -> [x1]
|
||||
| "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ]
|
||||
;
|
||||
fctb:
|
||||
[ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "=";
|
||||
x4 = module_expr ->
|
||||
let x4 =
|
||||
match x3 with
|
||||
[ Some x3 -> <:module_expr< ($x4$ : $x3$) >>
|
||||
| None -> x4 ]
|
||||
in
|
||||
let x4 =
|
||||
List.fold_right
|
||||
(fun (i, s) x4 -> <:module_expr< functor ($i$ : $s$) -> $x4$ >>)
|
||||
x2 x4
|
||||
in
|
||||
<:str_item< module $x1$ = $x4$ >>
|
||||
| x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp ->
|
||||
not_impl loc "fctb 2" ] ]
|
||||
;
|
||||
interdec:
|
||||
[ [ x = LIST1 [ s = str_item -> (s, loc) ] -> (x, False)
|
||||
| x = expr -> not_impl loc "interdec 2" ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,318 @@
|
|||
(* camlp4r *)
|
||||
(* $Id$ *)
|
||||
|
||||
open MLast;
|
||||
|
||||
value not_impl name x =
|
||||
let desc =
|
||||
if Obj.is_block (Obj.repr x) then
|
||||
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
|
||||
else "int_val = " ^ string_of_int (Obj.magic x)
|
||||
in
|
||||
do {
|
||||
Printf.eprintf "pr_depend: not impl: %s; %s\n" name desc; flush stderr;
|
||||
}
|
||||
;
|
||||
|
||||
module StrSet =
|
||||
Set.Make (struct type t = string; value compare = compare; end)
|
||||
;
|
||||
|
||||
value fset = ref StrSet.empty;
|
||||
value addmodule s = fset.val := StrSet.add s fset.val;
|
||||
|
||||
value list = List.iter;
|
||||
|
||||
value option f =
|
||||
fun
|
||||
[ Some x -> f x
|
||||
| None -> () ]
|
||||
;
|
||||
|
||||
value longident =
|
||||
fun
|
||||
[ [s; _ :: _] -> addmodule s
|
||||
| _ -> () ]
|
||||
;
|
||||
|
||||
value rec ctyp =
|
||||
fun
|
||||
[ TyAcc _ t _ -> ctyp_module t
|
||||
| TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; }
|
||||
| TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; }
|
||||
| TyAny _ -> ()
|
||||
| TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; }
|
||||
| TyCls _ li -> longident li
|
||||
| TyLab _ _ t -> ctyp t
|
||||
| TyLid _ _ -> ()
|
||||
| TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; }
|
||||
| TyOlb _ _ t -> ctyp t
|
||||
| TyQuo _ _ -> ()
|
||||
| TyRec _ ldl -> list label_decl ldl
|
||||
| TySum _ cdl -> list constr_decl cdl
|
||||
| TyTup _ tl -> list ctyp tl
|
||||
| TyVrn _ sbtll _ -> list variant sbtll
|
||||
| TyXnd _ _ t -> ctyp t
|
||||
| x -> not_impl "ctyp" x ]
|
||||
and constr_decl (_, tl) = list ctyp tl
|
||||
and label_decl (_, _, t) = ctyp t
|
||||
and variant (_, _, tl) = list ctyp tl
|
||||
and ctyp_module =
|
||||
fun
|
||||
[ TyAcc _ t _ -> ctyp_module t
|
||||
| TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; }
|
||||
| TyUid _ m -> addmodule m
|
||||
| x -> not_impl "ctyp_module" x ]
|
||||
;
|
||||
|
||||
value rec patt =
|
||||
fun
|
||||
[ PaAcc _ p _ -> patt_module p
|
||||
| PaAli _ p1 p2 -> do { patt p1; patt p2; }
|
||||
| PaAny _ -> ()
|
||||
| PaApp _ p1 p2 -> do { patt p1; patt p2; }
|
||||
| PaArr _ pl -> list patt pl
|
||||
| PaChr _ _ -> ()
|
||||
| PaInt _ _ -> ()
|
||||
| PaLab _ _ p -> patt p
|
||||
| PaLid _ _ -> ()
|
||||
| PaOlb _ _ p eo -> patt p
|
||||
| PaOrp _ p1 p2 -> do { patt p1; patt p2; }
|
||||
| PaRec _ lpl -> list label_patt lpl
|
||||
| PaRng _ p1 p2 -> do { patt p1; patt p2; }
|
||||
| PaStr _ _ -> ()
|
||||
| PaTup _ pl -> list patt pl
|
||||
| PaTyc _ p t -> do { patt p; ctyp t; }
|
||||
| PaUid _ _ -> ()
|
||||
| PaVrn _ _ -> ()
|
||||
| PaXnd _ _ p -> patt p
|
||||
| x -> not_impl "patt" x ]
|
||||
and patt_module =
|
||||
fun
|
||||
[ PaUid _ m -> addmodule m
|
||||
| PaAcc _ p _ -> patt_module p
|
||||
| x -> not_impl "patt_module" x ]
|
||||
and label_patt (p1, p2) = do { patt p1; patt p2; };
|
||||
|
||||
value rec expr =
|
||||
fun
|
||||
[ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; }
|
||||
| ExApp _ e1 e2 -> do { expr e1; expr e2; }
|
||||
| ExAre _ e1 e2 -> do { expr e1; expr e2; }
|
||||
| ExArr _ el -> list expr el
|
||||
| ExAss _ e1 e2 -> do { expr e1; expr e2; }
|
||||
| ExChr _ _ -> ()
|
||||
| ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 }
|
||||
| ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; }
|
||||
| ExFun _ pwel -> list match_case pwel
|
||||
| ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; }
|
||||
| ExInt _ _ -> ()
|
||||
| ExFlo _ _ -> ()
|
||||
| ExLab _ _ e -> expr e
|
||||
| ExLet _ _ pel e -> do { list let_binding pel; expr e; }
|
||||
| ExLid _ _ -> ()
|
||||
| ExLmd _ _ me e -> do { module_expr me; expr e; }
|
||||
| ExMat _ e pwel -> do { expr e; list match_case pwel; }
|
||||
| ExNew _ li -> longident li
|
||||
| ExOlb _ _ e -> expr e
|
||||
| ExRec _ lel w -> do { list label_expr lel; option expr w; }
|
||||
| ExSeq _ el -> list expr el
|
||||
| ExSnd _ e _ -> expr e
|
||||
| ExSte _ e1 e2 -> do { expr e1; expr e2; }
|
||||
| ExStr _ _ -> ()
|
||||
| ExTry _ e pwel -> do { expr e; list match_case pwel; }
|
||||
| ExTup _ el -> list expr el
|
||||
| ExTyc _ e t -> do { expr e; ctyp t; }
|
||||
| ExUid _ _ -> ()
|
||||
| ExVrn _ _ -> ()
|
||||
| ExWhi _ e el -> do { expr e; list expr el; }
|
||||
| ExXnd _ _ e -> expr e
|
||||
| x -> not_impl "expr" x ]
|
||||
and expr_module =
|
||||
fun
|
||||
[ ExUid _ m -> addmodule m
|
||||
| e -> expr e ]
|
||||
and let_binding (p, e) = do { patt p; expr e }
|
||||
and label_expr (p, e) = do { patt p; expr e }
|
||||
and match_case (p, w, e) = do { patt p; option expr w; expr e; }
|
||||
and module_type =
|
||||
fun
|
||||
[ MtAcc _ (MtUid _ m) _ -> addmodule m
|
||||
| MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; }
|
||||
| MtSig _ sil -> list sig_item sil
|
||||
| MtUid _ _ -> ()
|
||||
| MtWit _ mt wc -> do { module_type mt; list with_constr wc; }
|
||||
| x -> not_impl "module_type" x ]
|
||||
and with_constr =
|
||||
fun
|
||||
[ WcTyp _ _ _ t -> ctyp t
|
||||
| x -> not_impl "with_constr" x ]
|
||||
and sig_item =
|
||||
fun
|
||||
[ SgDcl _ sil -> list sig_item sil
|
||||
| SgExc _ _ tl -> list ctyp tl
|
||||
| SgExt _ _ t _ -> ctyp t
|
||||
| SgMod _ _ mt -> module_type mt
|
||||
| SgMty _ _ mt -> module_type mt
|
||||
| SgOpn _ [s :: _] -> addmodule s
|
||||
| SgTyp _ tdl -> list type_decl tdl
|
||||
| SgVal _ _ t -> ctyp t
|
||||
| x -> not_impl "sig_item" x ]
|
||||
and module_expr =
|
||||
fun
|
||||
[ MeAcc _ (MeUid _ m) _ -> addmodule m
|
||||
| MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; }
|
||||
| MeFun _ _ mt me -> do { module_type mt; module_expr me; }
|
||||
| MeStr _ sil -> list str_item sil
|
||||
| MeTyc _ me mt -> do { module_expr me; module_type mt; }
|
||||
| MeUid _ _ -> ()
|
||||
| x -> not_impl "module_expr" x ]
|
||||
and str_item =
|
||||
fun
|
||||
[ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil
|
||||
| StDcl _ sil -> list str_item sil
|
||||
| StDir _ _ _ -> ()
|
||||
| StExc _ _ tl -> list ctyp tl
|
||||
| StExp _ e -> expr e
|
||||
| StExt _ _ t _ -> ctyp t
|
||||
| StMod _ _ me -> module_expr me
|
||||
| StMty _ _ mt -> module_type mt
|
||||
| StOpn _ [s :: _] -> addmodule s
|
||||
| StTyp _ tdl -> list type_decl tdl
|
||||
| StVal _ _ pel -> list let_binding pel
|
||||
| x -> not_impl "str_item" x ]
|
||||
and type_decl (_, _, t, _) = ctyp t
|
||||
and class_expr =
|
||||
fun
|
||||
[ CeApp _ ce el -> do { class_expr ce; list expr el; }
|
||||
| CeCon _ li tl -> do { longident li; list ctyp tl; }
|
||||
| CeFun _ p ce -> do { patt p; class_expr ce; }
|
||||
| CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; }
|
||||
| CeStr _ po csil -> do { option patt po; list class_str_item csil; }
|
||||
| x -> not_impl "class_expr" x ]
|
||||
and class_str_item =
|
||||
fun
|
||||
[ CrInh _ ce _ -> class_expr ce
|
||||
| CrIni _ e -> expr e
|
||||
| CrMth _ _ _ e -> expr e
|
||||
| CrVal _ _ _ e -> expr e
|
||||
| CrVir _ _ _ t -> ctyp t
|
||||
| x -> not_impl "class_str_item" x ]
|
||||
;
|
||||
|
||||
(* Print dependencies *)
|
||||
|
||||
value load_path = ref [""];
|
||||
|
||||
value find_in_path path name =
|
||||
if not (Filename.is_implicit name) then
|
||||
if Sys.file_exists name then name else raise Not_found
|
||||
else
|
||||
let rec try_dir =
|
||||
fun
|
||||
[ [] -> raise Not_found
|
||||
| [dir :: rem] ->
|
||||
let fullname = Filename.concat dir name in
|
||||
if Sys.file_exists fullname then fullname else try_dir rem ]
|
||||
in
|
||||
try_dir path
|
||||
;
|
||||
|
||||
value find_depend modname (byt_deps, opt_deps) =
|
||||
let name = String.uncapitalize modname in
|
||||
try
|
||||
let filename = find_in_path load_path.val (name ^ ".mli") in
|
||||
let basename = Filename.chop_suffix filename ".mli" in
|
||||
let byt_dep = basename ^ ".cmi" in
|
||||
let opt_dep =
|
||||
if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx"
|
||||
else basename ^ ".cmi"
|
||||
in
|
||||
([byt_dep :: byt_deps], [opt_dep :: opt_deps])
|
||||
with
|
||||
[ Not_found ->
|
||||
try
|
||||
let filename = find_in_path load_path.val (name ^ ".ml") in
|
||||
let basename = Filename.chop_suffix filename ".ml" in
|
||||
([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps])
|
||||
with
|
||||
[ Not_found -> (byt_deps, opt_deps) ] ]
|
||||
;
|
||||
|
||||
value (depends_on, escaped_eol) =
|
||||
match Sys.os_type with
|
||||
[ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ")
|
||||
| "MacOS" -> ("\196 ", "\182\n ")
|
||||
| _ -> assert False ]
|
||||
;
|
||||
|
||||
value print_depend target_file deps =
|
||||
match deps with
|
||||
[ [] -> ()
|
||||
| _ ->
|
||||
do {
|
||||
print_string target_file;
|
||||
print_string depends_on;
|
||||
let rec print_items pos =
|
||||
fun
|
||||
[ [] -> print_string "\n"
|
||||
| [dep :: rem] ->
|
||||
if pos + String.length dep <= 77 then do {
|
||||
print_string dep;
|
||||
print_string " ";
|
||||
print_items (pos + String.length dep + 1) rem
|
||||
}
|
||||
else do {
|
||||
print_string escaped_eol;
|
||||
print_string dep;
|
||||
print_string " ";
|
||||
print_items (String.length dep + 5) rem
|
||||
} ]
|
||||
in
|
||||
print_items (String.length target_file + 2) deps
|
||||
} ]
|
||||
;
|
||||
|
||||
(* Main *)
|
||||
|
||||
value depend_sig ast =
|
||||
do {
|
||||
fset.val := StrSet.empty;
|
||||
List.iter (fun (si, _) -> sig_item si) ast;
|
||||
let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in
|
||||
let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val ([], []) in
|
||||
print_depend (basename ^ ".cmi") byt_deps;
|
||||
}
|
||||
;
|
||||
|
||||
value depend_str ast =
|
||||
do {
|
||||
fset.val := StrSet.empty;
|
||||
List.iter (fun (si, _) -> str_item si) ast;
|
||||
let basename =
|
||||
if Filename.check_suffix Pcaml.input_file.val ".ml" then
|
||||
Filename.chop_suffix Pcaml.input_file.val ".ml"
|
||||
else
|
||||
try
|
||||
let len = String.rindex Pcaml.input_file.val '.' in
|
||||
String.sub Pcaml.input_file.val 0 len
|
||||
with
|
||||
[ Failure _ | Not_found -> Pcaml.input_file.val ]
|
||||
in
|
||||
let init_deps =
|
||||
if Sys.file_exists (basename ^ ".mli") then
|
||||
let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name])
|
||||
else ([], [])
|
||||
in
|
||||
let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in
|
||||
print_depend (basename ^ ".cmo") byt_deps;
|
||||
print_depend (basename ^ ".cmx") opt_deps;
|
||||
}
|
||||
;
|
||||
|
||||
Pcaml.print_interf.val := depend_sig;
|
||||
Pcaml.print_implem.val := depend_str;
|
||||
|
||||
Pcaml.add_option "-I"
|
||||
(Arg.String (fun dir -> load_path.val := load_path.val @ [dir]))
|
||||
"<dir> Add <dir> to the list of include directories.";
|
||||
|
|
@ -0,0 +1,435 @@
|
|||
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
open Spretty;
|
||||
|
||||
value expr e dg k = pr_expr.pr_fun "top" e dg k;
|
||||
value patt e dg k = pr_patt.pr_fun "top" e dg k;
|
||||
|
||||
(* Utilities *)
|
||||
|
||||
value rec list elem el k =
|
||||
match el with
|
||||
[ [] -> k
|
||||
| [x] -> [: `elem x k :]
|
||||
| [x :: l] -> [: `elem x [: :]; list elem l k :] ]
|
||||
;
|
||||
|
||||
value rec listws elem sep el k =
|
||||
match el with
|
||||
[ [] -> k
|
||||
| [x] -> [: `elem x k :]
|
||||
| [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ]
|
||||
;
|
||||
|
||||
value rec listwbws elem b sep el dg k =
|
||||
match el with
|
||||
[ [] -> [: b; k :]
|
||||
| [x] -> [: `elem b x dg k :]
|
||||
| [x :: l] ->
|
||||
let sdg =
|
||||
match sep with
|
||||
[ S _ x -> x
|
||||
| _ -> "" ]
|
||||
in
|
||||
[: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ]
|
||||
;
|
||||
|
||||
(* Extracting *)
|
||||
|
||||
value rec get_globals =
|
||||
fun
|
||||
[ [(<:patt< _ >>, <:expr< ($lid:s$ : Grammar.Entry.e '$_$) >>) :: pel] ->
|
||||
[s :: get_globals pel]
|
||||
| [] -> []
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value rec get_locals =
|
||||
fun
|
||||
[ [(<:patt< $_$ >>,
|
||||
<:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] ->
|
||||
get_locals pel
|
||||
| [] -> ()
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unposition =
|
||||
fun
|
||||
[ <:expr< None >> -> None
|
||||
| <:expr< Some Gramext.First >> -> Some Gramext.First
|
||||
| <:expr< Some Gramext.Last >> -> Some Gramext.Last
|
||||
| <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s)
|
||||
| <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s)
|
||||
| <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s)
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unlabel =
|
||||
fun
|
||||
[ <:expr< None >> -> None
|
||||
| <:expr< Some $str:s$ >> -> Some s
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unassoc =
|
||||
fun
|
||||
[ <:expr< None >> -> None
|
||||
| <:expr< Some Gramext.NonA >> -> Some Gramext.NonA
|
||||
| <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA
|
||||
| <:expr< Some Gramext.RightA >> -> Some Gramext.RightA
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value rec unaction =
|
||||
fun
|
||||
[ <:expr< fun ($lid:locp$ : (int * int)) -> ($a$ : $_$) >>
|
||||
when locp = Stdpp.loc_name.val ->
|
||||
let ao =
|
||||
match a with
|
||||
[ <:expr< () >> -> None
|
||||
| _ -> Some a ]
|
||||
in
|
||||
([], ao)
|
||||
| <:expr< fun ($p$ : $_$) -> $e$ >> ->
|
||||
let (pl, a) = unaction e in ([p :: pl], a)
|
||||
| <:expr< fun _ -> $e$ >> ->
|
||||
let (pl, a) = unaction e in
|
||||
(let loc = (0, 0) in [<:patt< _ >> :: pl], a)
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value untoken =
|
||||
fun
|
||||
[ <:expr< ($str:x$, $str:y$) >> -> (x, y)
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
type symbol =
|
||||
[ Snterm of MLast.expr
|
||||
| Snterml of MLast.expr and string
|
||||
| Slist0 of symbol
|
||||
| Slist0sep of symbol and symbol
|
||||
| Slist1 of symbol
|
||||
| Slist1sep of symbol and symbol
|
||||
| Sopt of symbol
|
||||
| Sself
|
||||
| Snext
|
||||
| Stoken of Token.pattern
|
||||
| Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ]
|
||||
;
|
||||
|
||||
value rec unsymbol =
|
||||
fun
|
||||
[ <:expr< Gramext.Snterm (Grammar.Entry.obj ($e$ : $_$)) >> -> Snterm e
|
||||
| <:expr< Gramext.Snterml (Grammar.Entry.obj ($e$ : $_$)) $str:s$ >> ->
|
||||
Snterml e s
|
||||
| <:expr< Gramext.Snterml (Grammar.Entry.obj ($e$ : $_$), $str:s$) >> ->
|
||||
Snterml e s
|
||||
| <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e)
|
||||
| <:expr< Gramext.Slist0sep $e1$ $e2$ >> ->
|
||||
Slist0sep (unsymbol e1) (unsymbol e2)
|
||||
| <:expr< Gramext.Slist0sep ($e1$, $e2$) >> ->
|
||||
Slist0sep (unsymbol e1) (unsymbol e2)
|
||||
| <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e)
|
||||
| <:expr< Gramext.Slist1sep $e1$ $e2$ >> ->
|
||||
Slist1sep (unsymbol e1) (unsymbol e2)
|
||||
| <:expr< Gramext.Slist1sep ($e1$, $e2$) >> ->
|
||||
Slist1sep (unsymbol e1) (unsymbol e2)
|
||||
| <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e)
|
||||
| <:expr< Gramext.Sself >> -> Sself
|
||||
| <:expr< Gramext.Snext >> -> Snext
|
||||
| <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e)
|
||||
| <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e)
|
||||
| _ -> raise Not_found ]
|
||||
and unpsymbol_list pl e =
|
||||
match (pl, e) with
|
||||
[ ([], <:expr< [] >>) -> []
|
||||
| ([p :: pl], <:expr< [$e$ :: $el$] >>) ->
|
||||
let op =
|
||||
match p with
|
||||
[ <:patt< _ >> -> None
|
||||
| _ -> Some p ]
|
||||
in
|
||||
[(op, unsymbol e) :: unpsymbol_list pl el]
|
||||
| _ -> raise Not_found ]
|
||||
and unrule =
|
||||
fun
|
||||
[ <:expr< ($e1$, Gramext.action $e2$) >> ->
|
||||
let (pl, a) =
|
||||
match unaction e2 with
|
||||
[ ([], None) -> let loc = (0, 0) in ([], Some <:expr< () >>)
|
||||
| x -> x ]
|
||||
in
|
||||
let sl = unpsymbol_list (List.rev pl) e1 in
|
||||
(sl, a)
|
||||
| _ -> raise Not_found ]
|
||||
and unrule_list rl =
|
||||
fun
|
||||
[ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el
|
||||
| <:expr< [] >> -> rl
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unlevel =
|
||||
fun
|
||||
[ <:expr< ($e1$, $e2$, $e3$) >> ->
|
||||
(unlabel e1, unassoc e2, unrule_list [] e3)
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value rec unlevel_list =
|
||||
fun
|
||||
[ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el]
|
||||
| <:expr< [] >> -> []
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unentry =
|
||||
fun
|
||||
[ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> ->
|
||||
(e, unposition pos, unlevel_list ll)
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value rec unentry_list =
|
||||
fun
|
||||
[ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el]
|
||||
| <:expr< [] >> -> []
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value unextend_body e =
|
||||
let (globals, e) =
|
||||
match e with
|
||||
[ <:expr< let $list:pel$ in $e1$ >> ->
|
||||
try (get_globals pel, e1) with
|
||||
[ Not_found -> ([], e) ]
|
||||
| _ -> ([], e) ]
|
||||
in
|
||||
let e =
|
||||
match e with
|
||||
[ <:expr<
|
||||
let grammar_entry_create s =
|
||||
Grammar.Entry.create (Grammar.of_entry $_$) s
|
||||
in
|
||||
$e$ >> ->
|
||||
let e =
|
||||
match e with
|
||||
[ <:expr< let $list:pel$ in $e1$ >> ->
|
||||
try let _ = get_locals pel in e1 with
|
||||
[ Not_found -> e ]
|
||||
| _ -> e ]
|
||||
in
|
||||
e
|
||||
| _ -> e ]
|
||||
in
|
||||
let el = unentry_list e in
|
||||
(globals, el)
|
||||
;
|
||||
|
||||
(* Printing *)
|
||||
|
||||
value ident s k = HVbox [: `S LR s; k :];
|
||||
value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :];
|
||||
|
||||
value position =
|
||||
fun
|
||||
[ None -> [: :]
|
||||
| Some Gramext.First -> [: `S LR "FIRST" :]
|
||||
| Some Gramext.Last -> [: `S LR "LAST" :]
|
||||
| Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :]
|
||||
| Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :]
|
||||
| Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ]
|
||||
;
|
||||
|
||||
value action expr a dg k =
|
||||
expr a dg k
|
||||
;
|
||||
|
||||
value token (con, prm) k =
|
||||
if con = "" then string prm k
|
||||
else if prm = "" then HVbox [: `S LR con; k :]
|
||||
else HVbox [: `S LR con; `string prm k :]
|
||||
;
|
||||
|
||||
value simplify_rules rl =
|
||||
try
|
||||
List.map
|
||||
(fun
|
||||
[ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) ->
|
||||
if x = y then ([(None, s)], None) else raise Exit
|
||||
| ([], _) as r -> r
|
||||
| _ -> raise Exit ])
|
||||
rl
|
||||
with
|
||||
[ Exit -> rl ]
|
||||
;
|
||||
|
||||
value rec symbol s k =
|
||||
match s with
|
||||
[ Snterm e -> expr e "" k
|
||||
| Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :]
|
||||
| Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :]
|
||||
| Slist0sep s sep ->
|
||||
HVbox
|
||||
[: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP";
|
||||
`symbol sep k :]
|
||||
| Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :]
|
||||
| Slist1sep s sep ->
|
||||
HVbox
|
||||
[: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP";
|
||||
`symbol sep k :]
|
||||
| Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :]
|
||||
| Sself -> HVbox [: `S LR "SELF"; k :]
|
||||
| Snext -> HVbox [: `S LR "NEXT"; k :]
|
||||
| Stoken tok -> token tok k
|
||||
(**)
|
||||
| Srules
|
||||
[([(Some <:patt< a >>, Snterm <:expr< anti_list >>)], Some <:expr< a >>);
|
||||
([(Some <:patt< l >>,
|
||||
((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))],
|
||||
Some <:expr< list l >>)]
|
||||
->
|
||||
match s with
|
||||
[ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :]
|
||||
| Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :]
|
||||
| Slist0sep s sep ->
|
||||
HVbox
|
||||
[: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP";
|
||||
`symbol sep k :]
|
||||
| Slist1sep s sep ->
|
||||
HVbox
|
||||
[: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP";
|
||||
`simple_symbol sep k :]
|
||||
| _ -> assert False ]
|
||||
(**)
|
||||
| Srules rl ->
|
||||
let rl = simplify_rules rl in
|
||||
HVbox [: `HVbox [: :]; rule_list rl k :] ]
|
||||
and simple_symbol s k =
|
||||
match s with
|
||||
[ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :]
|
||||
| s -> symbol s k ]
|
||||
and psymbol (p, s) k =
|
||||
match p with
|
||||
[ None -> symbol s k
|
||||
| Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ]
|
||||
and psymbol_list sl k =
|
||||
listws psymbol (S RO ";") sl k
|
||||
and rule b (sl, a) dg k =
|
||||
match a with
|
||||
[ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :]
|
||||
| Some a ->
|
||||
HVbox
|
||||
[: b;
|
||||
`HOVbox
|
||||
[: `HOVbox
|
||||
[: `HVbox [: :];
|
||||
psymbol_list sl [: `S LR "->" :] :];
|
||||
`action expr a dg k :] :] ]
|
||||
and rule_list ll k =
|
||||
listwbws rule [: `S LR "[" :] (S LR "|") ll ""
|
||||
[: `S LR "]"; k :]
|
||||
;
|
||||
|
||||
value label =
|
||||
fun
|
||||
[ Some s -> [: `S LR ("\"" ^ s ^ "\"") :]
|
||||
| None -> [: :] ]
|
||||
;
|
||||
|
||||
value assoc =
|
||||
fun
|
||||
[ Some Gramext.NonA -> [: `S LR "NONA" :]
|
||||
| Some Gramext.LeftA -> [: `S LR "LEFTA" :]
|
||||
| Some Gramext.RightA -> [: `S LR "RIGHTA" :]
|
||||
| None -> [: :] ]
|
||||
;
|
||||
|
||||
value level b (lab, ass, rl) dg k =
|
||||
let s =
|
||||
if rl = [] then [: `S LR "[ ]"; k :]
|
||||
else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :]
|
||||
in
|
||||
match (lab, ass) with
|
||||
[ (None, None) -> HVbox [: b; s :]
|
||||
| _ ->
|
||||
Vbox
|
||||
[: `HVbox [: b; label lab; assoc ass :];
|
||||
`HVbox [: `HVbox [: :]; s :] :] ]
|
||||
;
|
||||
|
||||
value level_list ll k =
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
listwbws level [: `S LR "[" :] (S LR "|") ll ""
|
||||
[: `S LR "]"; k :] :]
|
||||
;
|
||||
|
||||
value entry (e, pos, ll) k =
|
||||
BEbox
|
||||
[: `HVbox [: `expr e "" [: `S RO ":" :]; position pos :];
|
||||
`level_list ll [: :];
|
||||
`HVbox [: `S RO ";"; k :] :]
|
||||
;
|
||||
|
||||
value entry_list el k =
|
||||
Vbox [: `HVbox [: :]; list entry el k :]
|
||||
;
|
||||
|
||||
value extend_body (globals, e) k =
|
||||
let s = entry_list e k in
|
||||
match globals with
|
||||
[ [] -> s
|
||||
| sl ->
|
||||
HVbox
|
||||
[: `HVbox [: :];
|
||||
`HOVbox
|
||||
[: `S LR "GLOBAL"; `S RO ":"; list ident sl [: `S RO ";" :] :];
|
||||
`s :] ]
|
||||
;
|
||||
|
||||
value extend e dg k =
|
||||
match e with
|
||||
[ <:expr< Grammar.extend $e$ >> ->
|
||||
try
|
||||
let ex = unextend_body e in
|
||||
BEbox
|
||||
[: `S LR "EXTEND"; `extend_body ex [: :];
|
||||
`HVbox [: `S LR "END"; k :] :]
|
||||
with
|
||||
[ Not_found ->
|
||||
HVbox
|
||||
[: `S LR "Grammar.extend";
|
||||
`HOVbox
|
||||
[: `S LO "(";
|
||||
`expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ]
|
||||
| _ -> expr e "" k ]
|
||||
;
|
||||
|
||||
(* Printer extensions *)
|
||||
|
||||
let lev = find_pr_level "apply" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Grammar.extend $_$ >> as e ->
|
||||
fun curr next _ k -> [: `next e "" k :] ];
|
||||
|
||||
let lev = find_pr_level "simple" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Grammar.extend $_$ >> as e ->
|
||||
fun curr next _ k -> [: `extend e "" k :] ];
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
open Spretty;
|
||||
|
||||
value loc = (0, 0);
|
||||
|
||||
value expr e dg k = pr_expr.pr_fun "top" e dg k;
|
||||
value patt e dg k = pr_patt.pr_fun "top" e dg k;
|
||||
|
||||
value rec un_extfun rpel =
|
||||
fun
|
||||
[ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> ->
|
||||
let (p, wo, e) =
|
||||
match pel with
|
||||
[ [(p, wo, <:expr< Some $e$ >>);
|
||||
(<:patt< _ >>, None, <:expr< None >>)] ->
|
||||
(p, wo, e)
|
||||
| [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e)
|
||||
| _ -> raise Not_found ]
|
||||
in
|
||||
let rpel =
|
||||
match rpel with
|
||||
[ [(p1, wo1, e1) :: pel] ->
|
||||
if wo1 = wo && e1 = e then
|
||||
let p =
|
||||
match (p1, p) with
|
||||
[ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) ->
|
||||
if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >>
|
||||
else <:patt< $p1$ | $p$ >>
|
||||
| _ -> <:patt< $p1$ | $p$ >> ]
|
||||
in
|
||||
[(p, wo, e) :: pel]
|
||||
else [(p, wo, e) :: rpel]
|
||||
| [] -> [(p, wo, e)] ]
|
||||
in
|
||||
un_extfun rpel el
|
||||
| <:expr< [] >> -> List.rev rpel
|
||||
| _ -> raise Not_found ]
|
||||
;
|
||||
|
||||
value rec listwbws elem b sep el k =
|
||||
match el with
|
||||
[ [] -> [: b; k :]
|
||||
| [x] -> [: `elem b x k :]
|
||||
| [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ]
|
||||
;
|
||||
|
||||
value rec match_assoc_list pwel k =
|
||||
match pwel with
|
||||
[ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :]
|
||||
| pel ->
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
listwbws match_assoc [: `S LR "[" :] (S LR "|") pel
|
||||
[: `S LR "]"; k :] :] ]
|
||||
and match_assoc b (p, w, e) k =
|
||||
let s =
|
||||
let (p, k) =
|
||||
match p with
|
||||
[ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :])
|
||||
| _ -> (p, [: :]) ]
|
||||
in
|
||||
match w with
|
||||
[ Some e1 ->
|
||||
[: `HVbox
|
||||
[: `HVbox [: :]; `patt p "" k;
|
||||
`HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :]
|
||||
| _ -> [: `patt p "" [: k; `S LR "->" :] :] ]
|
||||
in
|
||||
HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :]
|
||||
;
|
||||
|
||||
let lev = find_pr_level "top" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Extfun.extend $e$ $list$ >> as ge ->
|
||||
fun curr next dg k ->
|
||||
try
|
||||
let pel = un_extfun [] list in
|
||||
[: `HVbox [: :];
|
||||
`BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :];
|
||||
`match_assoc_list pel k :]
|
||||
with
|
||||
[ Not_found -> [: `next ge dg k :] ] ];
|
||||
|
||||
let lev = find_pr_level "apply" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Extfun.extend $e$ $list$ >> as ge ->
|
||||
fun curr next dg k -> [: `next ge dg k :] ];
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
(* camlp4r *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
Pcaml.print_interf.val := fun _ -> ();
|
||||
Pcaml.print_implem.val := fun _ -> ();
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,513 @@
|
|||
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
open Spretty;
|
||||
|
||||
value loc = (0, 0);
|
||||
|
||||
value expr e dg k = pr_expr.pr_fun "top" e dg k;
|
||||
value patt e dg k = pr_patt.pr_fun "top" e dg k;
|
||||
|
||||
value spatt p dg k =
|
||||
match p with
|
||||
[ <:patt< $lid:s$ >> ->
|
||||
if String.length s >= 2 && s.[1] == ''' then
|
||||
HVbox [: `S LR (" " ^ s); k :]
|
||||
else patt p dg k
|
||||
| _ -> patt p dg k ]
|
||||
;
|
||||
|
||||
(* Streams *)
|
||||
|
||||
value stream e _ k =
|
||||
let rec get =
|
||||
fun
|
||||
[ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
|
||||
| <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
|
||||
| <:expr< Stream.ising $x$ >> -> [(True, x)]
|
||||
| <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
|
||||
| <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
|
||||
| <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
|
||||
| <:expr< Stream.sempty >> -> []
|
||||
| <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
|
||||
| <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
|
||||
| e -> [(False, e)] ]
|
||||
in
|
||||
let elem e dg k =
|
||||
match e with
|
||||
[ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :]
|
||||
| (False, e) -> [: `expr e dg k :] ]
|
||||
in
|
||||
let rec glop e k =
|
||||
match e with
|
||||
[ [] -> k
|
||||
| [e] -> [: elem e "" k :]
|
||||
| [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ]
|
||||
in
|
||||
HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :]
|
||||
;
|
||||
|
||||
(* Parsers *)
|
||||
|
||||
type spc =
|
||||
[ SPCterm of (MLast.patt * option MLast.expr)
|
||||
| SPCnterm of MLast.patt and MLast.expr
|
||||
| SPCsterm of MLast.patt ]
|
||||
;
|
||||
|
||||
exception NotImpl;
|
||||
|
||||
value rec subst v e =
|
||||
match e with
|
||||
[ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e
|
||||
| <:expr< $uid:_$ >> -> e
|
||||
| <:expr< $int:_$ >> -> e
|
||||
| <:expr< $chr:_$ >> -> e
|
||||
| <:expr< $str:_$ >> -> e
|
||||
| <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >>
|
||||
| <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >>
|
||||
| <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
|
||||
if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >>
|
||||
else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >>
|
||||
| <:expr< let _ = $e1$ in $e2$ >> ->
|
||||
<:expr< let _ = $subst v e1$ in $subst v e2$ >>
|
||||
| <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >>
|
||||
| _ -> raise NotImpl ]
|
||||
;
|
||||
|
||||
value rec is_free v =
|
||||
fun
|
||||
[ <:expr< $lid:x$ >> -> x <> v
|
||||
| <:expr< $uid:_$ >> -> True
|
||||
| <:expr< $int:_$ >> -> True
|
||||
| <:expr< $chr:_$ >> -> True
|
||||
| <:expr< $str:_$ >> -> True
|
||||
| <:expr< $e$ . $_$ >> -> is_free v e
|
||||
| <:expr< $x$ $y$ >> -> is_free v x && is_free v y
|
||||
| <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
|
||||
is_free v e1 && (s1 = v || is_free v e2)
|
||||
| <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2
|
||||
| <:expr< ($list:el$) >> -> List.for_all (is_free v) el
|
||||
| _ -> raise NotImpl ]
|
||||
;
|
||||
|
||||
value free_var_in_expr c e =
|
||||
let rec loop_alpha v =
|
||||
let x = String.make 1 v in
|
||||
if is_free x e then Some x
|
||||
else if v = 'z' then None
|
||||
else loop_alpha (Char.chr (Char.code v + 1))
|
||||
in
|
||||
let rec loop_count cnt =
|
||||
let x = String.make 1 c ^ string_of_int cnt in
|
||||
if is_free x e then x else loop_count (succ cnt)
|
||||
in
|
||||
try
|
||||
match loop_alpha c with
|
||||
[ Some v -> v
|
||||
| None -> loop_count 1 ]
|
||||
with
|
||||
[ NotImpl -> "\\%a" ]
|
||||
;
|
||||
|
||||
value parserify =
|
||||
fun
|
||||
[ <:expr< $e$ strm__ >> -> e
|
||||
| e -> <:expr< fun strm__ -> $e$ >> ]
|
||||
;
|
||||
|
||||
value is_raise_failure =
|
||||
fun
|
||||
[ <:expr< raise Stream.Failure >> -> True
|
||||
| _ -> False ]
|
||||
;
|
||||
|
||||
value is_raise_error =
|
||||
fun
|
||||
[ <:expr< raise (Stream.Error $_$) >> -> True
|
||||
| _ -> False ]
|
||||
;
|
||||
|
||||
value semantic e =
|
||||
try
|
||||
if is_free "strm__" e then e
|
||||
else
|
||||
let v = free_var_in_expr 's' e in
|
||||
<:expr< let $lid:v$ = strm__ in $subst v e$ >>
|
||||
with
|
||||
[ NotImpl -> e ]
|
||||
;
|
||||
|
||||
value rewrite_parser =
|
||||
rewrite True where rec rewrite top ge =
|
||||
match ge with
|
||||
[ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in
|
||||
$sp_kont$ >> ->
|
||||
let f = parserify e in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise $exc$ ]
|
||||
>>
|
||||
| <:expr< let $p$ = Stream.count strm__ in $f$ >> ->
|
||||
try
|
||||
if is_free "strm__" f then ge
|
||||
else
|
||||
let v = free_var_in_expr 's' f in
|
||||
<:expr<
|
||||
let $lid:v$ = strm__ in
|
||||
let $p$ = Stream.count strm__ in $subst v f$
|
||||
>>
|
||||
with
|
||||
[ NotImpl -> ge ]
|
||||
| <:expr< let $p$ = strm__ in $e$ >> ->
|
||||
<:expr< let $p$ = strm__ in $rewrite False e$ >>
|
||||
| <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top ->
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise Stream.Failure ]
|
||||
>>
|
||||
| <:expr< let $p$ = $e$ in $sp_kont$ >> ->
|
||||
if match e with
|
||||
[ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with
|
||||
[ $list:_$ ] >>
|
||||
| <:expr< match Stream.peek strm__ with [ $list:_$ ] >>
|
||||
| <:expr< try $_$ with [ Stream.Failure -> $_$ ] >>
|
||||
| <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True
|
||||
| _ -> False ]
|
||||
then
|
||||
let f = rewrite True <:expr< fun strm__ -> $e$ >> in
|
||||
let exc =
|
||||
if top then <:expr< Stream.Failure >>
|
||||
else <:expr< Stream.Error "" >>
|
||||
in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise $exc$ ]
|
||||
>>
|
||||
else semantic ge
|
||||
| <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
if not top && is_raise_failure p_kont then semantic ge
|
||||
else
|
||||
let (p, f, sp_kont, p_kont) =
|
||||
if top || is_raise_error p_kont then
|
||||
(p, f, rewrite False sp_kont, rewrite top p_kont)
|
||||
else
|
||||
let f =
|
||||
<:expr<
|
||||
fun strm__ ->
|
||||
match
|
||||
try Some ($f$ strm__) with [ Stream.Failure -> None ]
|
||||
with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
in
|
||||
(<:patt< a >>, f, <:expr< a >>,
|
||||
<:expr< raise (Stream.Error "") >>)
|
||||
in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
| <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ->
|
||||
let rec iter pel =
|
||||
match pel with
|
||||
[ [(<:patt< Some $p$ >>, eo,
|
||||
<:expr< do { Stream.junk strm__; $sp_kont$ } >>);
|
||||
(<:patt< _ >>, None, p_kont) :: _] ->
|
||||
<:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:eo$ ->
|
||||
do { Stream.junk strm__; $rewrite False sp_kont$ }
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
| [(<:patt< Some $p$ >>, eo,
|
||||
<:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] ->
|
||||
let p_kont = iter pel in
|
||||
<:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:eo$ ->
|
||||
do { Stream.junk strm__; $rewrite False sp_kont$ }
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
| _ ->
|
||||
<:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ]
|
||||
in
|
||||
iter pel
|
||||
| <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
let e =
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> Some a
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
in
|
||||
rewrite top e
|
||||
| <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
let e =
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> a
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
in
|
||||
rewrite top e
|
||||
| <:expr< $f$ strm__ >> ->
|
||||
if top then
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> a
|
||||
| _ -> raise Stream.Failure ]
|
||||
>>
|
||||
else
|
||||
let v = free_var_in_expr 's' f in
|
||||
<:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >>
|
||||
| e -> semantic e ]
|
||||
;
|
||||
|
||||
value parser_of_expr =
|
||||
let rec parser_cases e =
|
||||
match e with
|
||||
[ <:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ]
|
||||
>> ->
|
||||
let spc = (SPCnterm p f, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e) :: parser_cases p_kont]
|
||||
| <:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
|
||||
| _ -> $p_kont$ ]
|
||||
>> ->
|
||||
let spc = (SPCterm (p, wo), None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e) :: parser_cases p_kont]
|
||||
| <:expr< let $p$ = strm__ in $sp_kont$ >> ->
|
||||
let spc = (SPCsterm p, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e)]
|
||||
| <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)]
|
||||
| <:expr< raise Stream.Failure >> -> []
|
||||
| _ -> [([], None, e)] ]
|
||||
and kont e =
|
||||
match e with
|
||||
[ <:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> raise (Stream.Error $err$) ]
|
||||
>> ->
|
||||
let err =
|
||||
match err with
|
||||
[ <:expr< "" >> -> None
|
||||
| _ -> Some err ]
|
||||
in
|
||||
let spc = (SPCnterm p f, err) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
|
||||
| _ -> raise (Stream.Error $err$) ]
|
||||
>> ->
|
||||
let err =
|
||||
match err with
|
||||
[ <:expr< "" >> -> None
|
||||
| _ -> Some err ]
|
||||
in
|
||||
let spc = (SPCterm (p, wo), err) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr< let $p$ = strm__ in $sp_kont$ >> ->
|
||||
let spc = (SPCsterm p, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e)
|
||||
| _ -> ([], None, e) ]
|
||||
in
|
||||
parser_cases
|
||||
;
|
||||
|
||||
value parser_cases b spel dg k =
|
||||
let rec parser_cases b spel dg k =
|
||||
match spel with
|
||||
[ [] -> [: `HVbox [: b; k :] :]
|
||||
| [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :]
|
||||
| [(sp, epo, e) :: spel] ->
|
||||
[: `parser_case b sp epo e "|" [: :];
|
||||
parser_cases [: `S LR "|" :] spel dg k :] ]
|
||||
and parser_case b sp epo e dg k =
|
||||
let epo =
|
||||
match epo with
|
||||
[ Some p -> [: `patt p "" [: `S LR "->" :] :]
|
||||
| _ -> [: `S LR "->" :] ]
|
||||
in
|
||||
HVbox
|
||||
[: b;
|
||||
`HOVbox
|
||||
[: `HOVbox
|
||||
[: `S LR "[<";
|
||||
stream_patt [: :] sp [: `S LR ">]"; epo :] :];
|
||||
`expr e dg k :] :]
|
||||
and stream_patt b sp k =
|
||||
match sp with
|
||||
[ [] -> [: `HVbox [: b; k :] :]
|
||||
| [(spc, None)] -> [: `stream_patt_comp b spc "" k :]
|
||||
| [(spc, Some e)] ->
|
||||
[: `HVbox
|
||||
[: `stream_patt_comp b spc "" [: :];
|
||||
`HVbox [: `S LR "?"; `expr e "" k :] :] :]
|
||||
| [(spc, None) :: spcl] ->
|
||||
[: `stream_patt_comp b spc ";" [: `S RO ";" :];
|
||||
stream_patt [: :] spcl k :]
|
||||
| [(spc, Some e) :: spcl] ->
|
||||
[: `HVbox
|
||||
[: `stream_patt_comp b spc "" [: :];
|
||||
`HVbox [: `S LR "?"; `expr e ";" [: `S RO ";" :] :] :];
|
||||
stream_patt [: :] spcl k :] ]
|
||||
and stream_patt_comp b spc dg k =
|
||||
match spc with
|
||||
[ SPCterm (p, w) ->
|
||||
HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :]
|
||||
| SPCnterm p e ->
|
||||
HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :]
|
||||
| SPCsterm p -> HVbox [: b; `patt p "" k :] ]
|
||||
and when_opt wo k =
|
||||
match wo with
|
||||
[ Some e -> [: `S LR "when"; `expr e "" k :]
|
||||
| _ -> k ]
|
||||
in
|
||||
parser_cases b spel dg k
|
||||
;
|
||||
|
||||
value parser_body e dg k =
|
||||
let (bp, e) =
|
||||
match e with
|
||||
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
|
||||
| e -> (None, e) ]
|
||||
in
|
||||
let e = rewrite_parser e in
|
||||
match parser_of_expr e with
|
||||
[ [] ->
|
||||
let spe = ([], None, <:expr< raise Stream.Failure >>) in
|
||||
HVbox
|
||||
[: `HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
parser_cases [: :] [spe] dg k :]
|
||||
| [spe] ->
|
||||
HVbox
|
||||
[: `HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
parser_cases [: :] [spe] dg k :]
|
||||
| spel ->
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
`HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
`BEbox
|
||||
[: `HVbox [: :]; parser_cases [: :] spel dg k :] :] ]
|
||||
;
|
||||
|
||||
value pmatch e dg k =
|
||||
let (me, e) =
|
||||
match e with
|
||||
[ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
|
||||
| _ -> failwith "Pr_op.pmatch" ]
|
||||
in
|
||||
let (bp, e) =
|
||||
match e with
|
||||
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
|
||||
| e -> (None, e) ]
|
||||
in
|
||||
let e = rewrite_parser e in
|
||||
let spel = parser_of_expr e in
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
`HVbox
|
||||
[: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
`BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :]
|
||||
;
|
||||
|
||||
(* Printer extensions *)
|
||||
|
||||
pr_expr_fun_args.val :=
|
||||
extfun pr_expr_fun_args.val with
|
||||
[ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
|
||||
| <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
|
||||
|
||||
let lev = find_pr_level "expr1" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
|
||||
fun curr next dg k ->
|
||||
if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :]
|
||||
else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :]
|
||||
| <:expr< fun strm__ -> $x$ >> ->
|
||||
fun curr next dg k ->
|
||||
if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
|
||||
else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :]
|
||||
| <:expr< fun [ (strm__ : $_$) -> $x$ ] >> ->
|
||||
fun curr next dg k ->
|
||||
if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :]
|
||||
else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ];
|
||||
|
||||
let lev = find_pr_level "apply" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
|
||||
<:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
|
||||
<:expr< Stream.slazy $_$ >> as e ->
|
||||
fun curr next dg k -> [: `next e "" k :] ];
|
||||
|
||||
let lev = find_pr_level "dot" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.sempty >> as e ->
|
||||
fun curr next dg k -> [: `next e "" k :] ];
|
||||
|
||||
let lev = find_pr_level "simple" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
|
||||
<:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
|
||||
<:expr< Stream.slazy $_$ >> as e ->
|
||||
fun curr next dg k ->
|
||||
[: `stream e "" k :] ];
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,495 @@
|
|||
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1998 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
open Spretty;
|
||||
|
||||
value loc = (0, 0);
|
||||
|
||||
value expr e dg k = pr_expr.pr_fun "top" e dg k;
|
||||
value patt e dg k = pr_patt.pr_fun "top" e dg k;
|
||||
|
||||
(* Streams *)
|
||||
|
||||
value stream e dg k =
|
||||
let rec get =
|
||||
fun
|
||||
[ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y]
|
||||
| <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y]
|
||||
| <:expr< Stream.ising $x$ >> -> [(True, x)]
|
||||
| <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y]
|
||||
| <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y]
|
||||
| <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)]
|
||||
| <:expr< Stream.sempty >> -> []
|
||||
| <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)]
|
||||
| <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)]
|
||||
| e -> [(False, e)] ]
|
||||
in
|
||||
let elem e k =
|
||||
match e with
|
||||
[ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :]
|
||||
| (False, e) -> [: `expr e "" k :] ]
|
||||
in
|
||||
let rec glop e k =
|
||||
match e with
|
||||
[ [] -> k
|
||||
| [e] -> [: elem e k :]
|
||||
| [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ]
|
||||
in
|
||||
HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :]
|
||||
;
|
||||
|
||||
(* Parsers *)
|
||||
|
||||
type spc =
|
||||
[ SPCterm of (MLast.patt * option MLast.expr)
|
||||
| SPCnterm of MLast.patt and MLast.expr
|
||||
| SPCsterm of MLast.patt ]
|
||||
;
|
||||
|
||||
exception NotImpl;
|
||||
|
||||
value rec subst v e =
|
||||
match e with
|
||||
[ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e
|
||||
| <:expr< $uid:_$ >> -> e
|
||||
| <:expr< $int:_$ >> -> e
|
||||
| <:expr< $chr:_$ >> -> e
|
||||
| <:expr< $str:_$ >> -> e
|
||||
| <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >>
|
||||
| <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >>
|
||||
| <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
|
||||
if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >>
|
||||
else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >>
|
||||
| <:expr< let _ = $e1$ in $e2$ >> ->
|
||||
<:expr< let _ = $subst v e1$ in $subst v e2$ >>
|
||||
| <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >>
|
||||
| _ -> raise NotImpl ]
|
||||
;
|
||||
|
||||
value rec is_free v =
|
||||
fun
|
||||
[ <:expr< $lid:x$ >> -> x <> v
|
||||
| <:expr< $uid:_$ >> -> True
|
||||
| <:expr< $int:_$ >> -> True
|
||||
| <:expr< $chr:_$ >> -> True
|
||||
| <:expr< $str:_$ >> -> True
|
||||
| <:expr< $e$ . $_$ >> -> is_free v e
|
||||
| <:expr< $x$ $y$ >> -> is_free v x && is_free v y
|
||||
| <:expr< let $lid:s1$ = $e1$ in $e2$ >> ->
|
||||
is_free v e1 && (s1 = v || is_free v e2)
|
||||
| <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2
|
||||
| <:expr< ($list:el$) >> -> List.for_all (is_free v) el
|
||||
| _ -> raise NotImpl ]
|
||||
;
|
||||
|
||||
value free_var_in_expr c e =
|
||||
let rec loop_alpha v =
|
||||
let x = String.make 1 v in
|
||||
if is_free x e then Some x
|
||||
else if v = 'z' then None
|
||||
else loop_alpha (Char.chr (Char.code v + 1))
|
||||
in
|
||||
let rec loop_count cnt =
|
||||
let x = String.make 1 c ^ string_of_int cnt in
|
||||
if is_free x e then x else loop_count (succ cnt)
|
||||
in
|
||||
try
|
||||
match loop_alpha c with
|
||||
[ Some v -> v
|
||||
| None -> loop_count 1 ]
|
||||
with
|
||||
[ NotImpl -> "\\%a" ]
|
||||
;
|
||||
|
||||
value parserify =
|
||||
fun
|
||||
[ <:expr< $e$ strm__ >> -> e
|
||||
| e -> <:expr< fun strm__ -> $e$ >> ]
|
||||
;
|
||||
|
||||
value is_raise_failure =
|
||||
fun
|
||||
[ <:expr< raise Stream.Failure >> -> True
|
||||
| _ -> False ]
|
||||
;
|
||||
|
||||
value is_raise_error =
|
||||
fun
|
||||
[ <:expr< raise (Stream.Error $_$) >> -> True
|
||||
| _ -> False ]
|
||||
;
|
||||
|
||||
value semantic e =
|
||||
try
|
||||
if is_free "strm__" e then e
|
||||
else
|
||||
let v = free_var_in_expr 's' e in
|
||||
<:expr< let $lid:v$ = strm__ in $subst v e$ >>
|
||||
with
|
||||
[ NotImpl -> e ]
|
||||
;
|
||||
|
||||
value rewrite_parser =
|
||||
rewrite True where rec rewrite top ge =
|
||||
match ge with
|
||||
[ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in
|
||||
$sp_kont$ >> ->
|
||||
let f = parserify e in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise $exc$ ]
|
||||
>>
|
||||
| <:expr< let $p$ = Stream.count strm__ in $f$ >> ->
|
||||
try
|
||||
if is_free "strm__" f then ge
|
||||
else
|
||||
let v = free_var_in_expr 's' f in
|
||||
<:expr<
|
||||
let $lid:v$ = strm__ in
|
||||
let $p$ = Stream.count strm__ in $subst v f$
|
||||
>>
|
||||
with
|
||||
[ NotImpl -> ge ]
|
||||
| <:expr< let $p$ = strm__ in $e$ >> ->
|
||||
<:expr< let $p$ = strm__ in $rewrite False e$ >>
|
||||
| <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top ->
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise Stream.Failure ]
|
||||
>>
|
||||
| <:expr< let $p$ = $e$ in $sp_kont$ >> ->
|
||||
if match e with
|
||||
[ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with
|
||||
[ $list:_$ ] >>
|
||||
| <:expr< match Stream.peek strm__ with [ $list:_$ ] >>
|
||||
| <:expr< try $_$ with [ Stream.Failure -> $_$ ] >>
|
||||
| <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True
|
||||
| _ -> False ]
|
||||
then
|
||||
let f = rewrite True <:expr< fun strm__ -> $e$ >> in
|
||||
let exc =
|
||||
if top then <:expr< Stream.Failure >>
|
||||
else <:expr< Stream.Error "" >>
|
||||
in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> raise $exc$ ]
|
||||
>>
|
||||
else semantic ge
|
||||
| <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
if not top && is_raise_failure p_kont then semantic ge
|
||||
else
|
||||
let (p, f, sp_kont, p_kont) =
|
||||
if top || is_raise_error p_kont then
|
||||
(p, f, rewrite False sp_kont, rewrite top p_kont)
|
||||
else
|
||||
let f =
|
||||
<:expr<
|
||||
fun strm__ ->
|
||||
match
|
||||
try Some ($f$ strm__) with [ Stream.Failure -> None ]
|
||||
with
|
||||
[ Some $p$ -> $rewrite False sp_kont$
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
in
|
||||
(<:patt< a >>, f, <:expr< a >>,
|
||||
<:expr< raise (Stream.Error "") >>)
|
||||
in
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
| <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ->
|
||||
let rec iter pel =
|
||||
match pel with
|
||||
[ [(<:patt< Some $p$ >>, eo,
|
||||
<:expr< do { Stream.junk strm__; $sp_kont$ } >>);
|
||||
(<:patt< _ >>, None, p_kont) :: _] ->
|
||||
<:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:eo$ ->
|
||||
do { Stream.junk strm__; $rewrite False sp_kont$ }
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
| [(<:patt< Some $p$ >>, eo,
|
||||
<:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] ->
|
||||
let p_kont = iter pel in
|
||||
<:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:eo$ ->
|
||||
do { Stream.junk strm__; $rewrite False sp_kont$ }
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
| _ ->
|
||||
<:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ]
|
||||
in
|
||||
iter pel
|
||||
| <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
let e =
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> Some a
|
||||
| _ -> $p_kont$ ]
|
||||
>>
|
||||
in
|
||||
rewrite top e
|
||||
| <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> ->
|
||||
let f = parserify e in
|
||||
let e =
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> a
|
||||
| _ -> $rewrite top p_kont$ ]
|
||||
>>
|
||||
in
|
||||
rewrite top e
|
||||
| <:expr< $f$ strm__ >> ->
|
||||
if top then
|
||||
<:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some a -> a
|
||||
| _ -> raise Stream.Failure ]
|
||||
>>
|
||||
else
|
||||
let v = free_var_in_expr 's' f in
|
||||
<:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >>
|
||||
| e -> semantic e ]
|
||||
;
|
||||
|
||||
value parser_of_expr =
|
||||
let rec parser_cases e =
|
||||
match e with
|
||||
[ <:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> $p_kont$ ]
|
||||
>> ->
|
||||
let spc = (SPCnterm p f, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e) :: parser_cases p_kont]
|
||||
| <:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
|
||||
| _ -> $p_kont$ ]
|
||||
>> ->
|
||||
let spc = (SPCterm (p, wo), None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e) :: parser_cases p_kont]
|
||||
| <:expr< let $p$ = strm__ in $sp_kont$ >> ->
|
||||
let spc = (SPCsterm p, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
[([spc :: sp], epo, e)]
|
||||
| <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)]
|
||||
| <:expr< raise Stream.Failure >> -> []
|
||||
| _ -> [([], None, e)] ]
|
||||
and kont e =
|
||||
match e with
|
||||
[ <:expr<
|
||||
match try Some ($f$ strm__) with [ Stream.Failure -> None ] with
|
||||
[ Some $p$ -> $sp_kont$
|
||||
| _ -> raise (Stream.Error $err$) ]
|
||||
>> ->
|
||||
let err =
|
||||
match err with
|
||||
[ <:expr< "" >> -> None
|
||||
| _ -> Some err ]
|
||||
in
|
||||
let spc = (SPCnterm p f, err) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr<
|
||||
match Stream.peek strm__ with
|
||||
[ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ }
|
||||
| _ -> raise (Stream.Error $err$) ]
|
||||
>> ->
|
||||
let err =
|
||||
match err with
|
||||
[ <:expr< "" >> -> None
|
||||
| _ -> Some err ]
|
||||
in
|
||||
let spc = (SPCterm (p, wo), err) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr< let $p$ = strm__ in $sp_kont$ >> ->
|
||||
let spc = (SPCsterm p, None) in
|
||||
let (sp, epo, e) = kont sp_kont in
|
||||
([spc :: sp], epo, e)
|
||||
| <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e)
|
||||
| _ -> ([], None, e) ]
|
||||
in
|
||||
parser_cases
|
||||
;
|
||||
|
||||
value parser_cases b spel k =
|
||||
let rec parser_cases b spel k =
|
||||
match spel with
|
||||
[ [] -> [: `HVbox [: b; k :] :]
|
||||
| [(sp, epo, e)] -> [: `parser_case b sp epo e k :]
|
||||
| [(sp, epo, e) :: spel] ->
|
||||
[: `parser_case b sp epo e [: :];
|
||||
parser_cases [: `S LR "|" :] spel k :] ]
|
||||
and parser_case b sp epo e k =
|
||||
let epo =
|
||||
match epo with
|
||||
[ Some p -> [: `patt p "" [: `S LR "->" :] :]
|
||||
| _ -> [: `S LR "->" :] ]
|
||||
in
|
||||
HVbox
|
||||
[: b;
|
||||
`HOVbox
|
||||
[: `HOVbox
|
||||
[: `S LR "[:";
|
||||
stream_patt [: :] sp [: `S LR ":]"; epo :] :];
|
||||
`expr e "" k :] :]
|
||||
and stream_patt b sp k =
|
||||
match sp with
|
||||
[ [] -> [: `HVbox [: b; k :] :]
|
||||
| [(spc, None)] -> [: `stream_patt_comp b spc k :]
|
||||
| [(spc, Some e)] ->
|
||||
[: `HVbox
|
||||
[: `stream_patt_comp b spc [: :];
|
||||
`HVbox [: `S LR "?"; `expr e "" k :] :] :]
|
||||
| [(spc, None) :: spcl] ->
|
||||
[: `stream_patt_comp b spc [: `S RO ";" :];
|
||||
stream_patt [: :] spcl k :]
|
||||
| [(spc, Some e) :: spcl] ->
|
||||
[: `HVbox
|
||||
[: `stream_patt_comp b spc [: :];
|
||||
`HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :];
|
||||
stream_patt [: :] spcl k :] ]
|
||||
and stream_patt_comp b spc k =
|
||||
match spc with
|
||||
[ SPCterm (p, w) ->
|
||||
HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :]
|
||||
| SPCnterm p e ->
|
||||
HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :]
|
||||
| SPCsterm p -> HVbox [: b; `patt p "" k :] ]
|
||||
and when_opt wo k =
|
||||
match wo with
|
||||
[ Some e -> [: `S LR "when"; `expr e "" k :]
|
||||
| _ -> k ]
|
||||
in
|
||||
parser_cases b spel k
|
||||
;
|
||||
|
||||
value parser_body e dg k =
|
||||
let (bp, e) =
|
||||
match e with
|
||||
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
|
||||
| e -> (None, e) ]
|
||||
in
|
||||
let e = rewrite_parser e in
|
||||
match parser_of_expr e with
|
||||
[ [] ->
|
||||
HVbox
|
||||
[: `HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
`HVbox [: `S LR "[]"; k :] :]
|
||||
| [spe] ->
|
||||
HVbox
|
||||
[: `HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
parser_cases [: :] [spe] k :]
|
||||
| spel ->
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
`HVbox
|
||||
[: `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ]
|
||||
;
|
||||
|
||||
value pmatch e dg k =
|
||||
let (me, e) =
|
||||
match e with
|
||||
[ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
|
||||
| _ -> failwith "Pr_rp.pmatch" ]
|
||||
in
|
||||
let (bp, e) =
|
||||
match e with
|
||||
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
|
||||
| e -> (None, e) ]
|
||||
in
|
||||
let e = rewrite_parser e in
|
||||
let spel = parser_of_expr e in
|
||||
Vbox
|
||||
[: `HVbox [: :];
|
||||
`HVbox
|
||||
[: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser";
|
||||
match bp with
|
||||
[ Some p -> [: `patt p "" [: :] :]
|
||||
| _ -> [: :] ] :];
|
||||
parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :]
|
||||
;
|
||||
|
||||
(* Printer extensions *)
|
||||
|
||||
pr_expr_fun_args.val :=
|
||||
extfun pr_expr_fun_args.val with
|
||||
[ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge)
|
||||
| <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
|
||||
|
||||
let lev = find_pr_level "top" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
|
||||
fun curr next _ k -> [: `pmatch e "" k :]
|
||||
| <:expr< fun strm__ -> $x$ >> ->
|
||||
fun curr next _ k -> [: `parser_body x "" k :]
|
||||
| <:expr< fun (strm__ : $_$) -> $x$ >> ->
|
||||
fun curr next _ k -> [: `parser_body x "" k :] ];
|
||||
|
||||
let lev = find_pr_level "apply" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
|
||||
<:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
|
||||
<:expr< Stream.slazy $_$ >> as e ->
|
||||
fun curr next _ k -> [: `next e "" k :] ];
|
||||
|
||||
let lev = find_pr_level "dot" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.sempty >> as e ->
|
||||
fun curr next _ k -> [: `next e "" k :] ];
|
||||
|
||||
let lev = find_pr_level "simple" pr_expr.pr_levels in
|
||||
lev.pr_rules :=
|
||||
extfun lev.pr_rules with
|
||||
[ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> |
|
||||
<:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lcons (fun _ -> $_$) $_$ >> |
|
||||
<:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> |
|
||||
<:expr< Stream.slazy $_$ >> as e ->
|
||||
fun curr next _ k -> [: `stream e "" k :] ];
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pcaml;
|
||||
|
||||
value t = ref "";
|
||||
|
||||
Quotation.add ""
|
||||
(Quotation.ExAst
|
||||
(fun s ->
|
||||
let t =
|
||||
if t.val = "" then "<<" ^ s ^ ">>"
|
||||
else "<:" ^ t.val ^ "<" ^ s ^ ">>"
|
||||
in
|
||||
let loc = (0, 0) in
|
||||
<:expr< $uid:t$ >>,
|
||||
fun s ->
|
||||
let t =
|
||||
if t.val = "" then "<<" ^ s ^ ">>"
|
||||
else "<:" ^ t.val ^ "<" ^ s ^ ">>"
|
||||
in
|
||||
let loc = (0, 0) in
|
||||
<:patt< $uid:t$ >>))
|
||||
;
|
||||
|
||||
Quotation.default.val := "";
|
||||
Quotation.translate.val := fun s -> do { t.val := s; "" };
|
||||
|
||||
EXTEND
|
||||
expr: LEVEL "top"
|
||||
[ [ "ifdef"; c = UIDENT; "then"; e1 = expr; "else"; e2 = expr ->
|
||||
<:expr< if def $uid:c$ then $e1$ else $e2$ >>
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = expr; "else"; e2 = expr ->
|
||||
<:expr< if ndef $uid:c$ then $e1$ else $e2$ >> ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,529 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Stdpp;
|
||||
|
||||
value split_ext = ref False;
|
||||
|
||||
Pcaml.add_option "-split_ext" (Arg.Set split_ext)
|
||||
" Split EXTEND by functions to turn around a PowerPC problem.";
|
||||
|
||||
Pcaml.add_option "-split_gext" (Arg.Set split_ext)
|
||||
" Old name for the option -split_ext.";
|
||||
|
||||
type name = { expr : MLast.expr; tvar : string; loc : (int * int) };
|
||||
|
||||
type entry 'e 'p 't =
|
||||
{ name : name; pos : option 'e; levels : list (level 'e 'p 't) }
|
||||
and level 'e 'p 't =
|
||||
{ label : option string; assoc : option 'e; rules : list (rule 'e 'p 't) }
|
||||
and rule 'e 'p 't = { prod : list (psymbol 'e 'p 't); action : option 'e }
|
||||
and psymbol 'e 'p 't = { pattern : option 'p; symbol : symbol 'e 'p 't }
|
||||
and symbol 'e 'p 't =
|
||||
{ used : list name; text : string -> string -> 'e; styp : string -> 't }
|
||||
;
|
||||
|
||||
type used = [ Unused | UsedScanned | UsedNotScanned ];
|
||||
|
||||
value mark_used modif ht n =
|
||||
try
|
||||
let rll = Hashtbl.find_all ht n.tvar in
|
||||
List.iter
|
||||
(fun (r, _) ->
|
||||
if r.val == Unused then do {
|
||||
r.val := UsedNotScanned; modif.val := True;
|
||||
}
|
||||
else ())
|
||||
rll
|
||||
with
|
||||
[ Not_found -> () ]
|
||||
;
|
||||
|
||||
value rec mark_symbol modif ht symb =
|
||||
List.iter (fun e -> mark_used modif ht e) symb.used
|
||||
;
|
||||
|
||||
value check_use nl el =
|
||||
let ht = Hashtbl.create 301 in
|
||||
let modif = ref False in
|
||||
do {
|
||||
List.iter
|
||||
(fun e ->
|
||||
let u =
|
||||
match e.name.expr with
|
||||
[ <:expr< $lid:_$ >> -> Unused
|
||||
| _ -> UsedNotScanned ]
|
||||
in
|
||||
Hashtbl.add ht e.name.tvar (ref u, e))
|
||||
el;
|
||||
List.iter
|
||||
(fun n ->
|
||||
try
|
||||
let rll = Hashtbl.find_all ht n.tvar in
|
||||
List.iter (fun (r, _) -> r.val := UsedNotScanned) rll
|
||||
with _ ->
|
||||
())
|
||||
nl;
|
||||
modif.val := True;
|
||||
while modif.val do {
|
||||
modif.val := False;
|
||||
Hashtbl.iter
|
||||
(fun s (r, e) ->
|
||||
if r.val = UsedNotScanned then do {
|
||||
r.val := UsedScanned;
|
||||
List.iter
|
||||
(fun level ->
|
||||
let rules = level.rules in
|
||||
List.iter
|
||||
(fun rule ->
|
||||
List.iter (fun ps -> mark_symbol modif ht ps.symbol)
|
||||
rule.prod)
|
||||
rules)
|
||||
e.levels
|
||||
}
|
||||
else ())
|
||||
ht
|
||||
};
|
||||
Hashtbl.iter
|
||||
(fun s (r, e) ->
|
||||
if r.val = Unused then
|
||||
Pcaml.warning.val e.name.loc ("Unused local entry \"" ^ s ^ "\"")
|
||||
else ())
|
||||
ht;
|
||||
}
|
||||
;
|
||||
|
||||
value locate n = let loc = n.loc in <:expr< $n.expr$ >>;
|
||||
|
||||
value new_type_var =
|
||||
let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val }
|
||||
;
|
||||
|
||||
value used_of_rule_list rl =
|
||||
List.fold_left
|
||||
(fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) []
|
||||
rl
|
||||
;
|
||||
|
||||
value retype_rule_list_without_patterns loc rl =
|
||||
try
|
||||
List.map
|
||||
(fun
|
||||
[ {prod = [{pattern = None; symbol = s}]; action = None} ->
|
||||
{prod = [{pattern = Some <:patt< x >>; symbol = s}];
|
||||
action = Some <:expr< x >>}
|
||||
| {prod = []; action = Some _} as r -> r
|
||||
| _ -> raise Exit ])
|
||||
rl
|
||||
with
|
||||
[ Exit -> rl ]
|
||||
;
|
||||
|
||||
value text_of_psymbol_list loc gmod psl tvar =
|
||||
List.fold_right
|
||||
(fun ps txt ->
|
||||
let x = ps.symbol.text gmod tvar in <:expr< [$x$ :: $txt$] >>)
|
||||
psl <:expr< [] >>
|
||||
;
|
||||
|
||||
value text_of_action loc psl rtvar act tvar =
|
||||
let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in
|
||||
let act =
|
||||
match act with
|
||||
[ Some act -> act
|
||||
| None -> <:expr< () >> ]
|
||||
in
|
||||
let e = <:expr< fun [ ($locid$ : (int * int)) -> ($act$ : '$rtvar$) ] >> in
|
||||
let txt =
|
||||
List.fold_left
|
||||
(fun txt ps ->
|
||||
match ps.pattern with
|
||||
[ None -> <:expr< fun _ -> $txt$ >>
|
||||
| Some p ->
|
||||
let t = ps.symbol.styp tvar in
|
||||
<:expr< fun [ ($p$ : $t$) -> $txt$ ] >> ])
|
||||
e psl
|
||||
in
|
||||
<:expr< Gramext.action $txt$ >>
|
||||
;
|
||||
|
||||
value text_of_rule_list loc gmod rtvar rl tvar =
|
||||
List.fold_left
|
||||
(fun txt r ->
|
||||
let sl = text_of_psymbol_list loc gmod r.prod tvar in
|
||||
let ac = text_of_action loc r.prod rtvar r.action tvar in
|
||||
<:expr< [($sl$, $ac$) :: $txt$] >>)
|
||||
<:expr< [] >> rl
|
||||
;
|
||||
|
||||
value text_of_entry loc gmod e =
|
||||
let ent =
|
||||
let x = e.name in
|
||||
let loc = e.name.loc in
|
||||
<:expr< ($x.expr$ : $uid:gmod$.Entry.e '$x.tvar$) >>
|
||||
in
|
||||
let pos =
|
||||
match e.pos with
|
||||
[ Some pos -> <:expr< Some $pos$ >>
|
||||
| None -> <:expr< None >> ]
|
||||
in
|
||||
let txt =
|
||||
List.fold_right
|
||||
(fun level txt ->
|
||||
let lab =
|
||||
match level.label with
|
||||
[ Some lab -> <:expr< Some $str:lab$ >>
|
||||
| None -> <:expr< None >> ]
|
||||
in
|
||||
let ass =
|
||||
match level.assoc with
|
||||
[ Some ass -> <:expr< Some $ass$ >>
|
||||
| None -> <:expr< None >> ]
|
||||
in
|
||||
let txt =
|
||||
let rl =
|
||||
text_of_rule_list loc gmod e.name.tvar level.rules e.name.tvar
|
||||
in
|
||||
<:expr< [($lab$, $ass$, $rl$) :: $txt$] >>
|
||||
in
|
||||
txt)
|
||||
e.levels <:expr< [] >>
|
||||
in
|
||||
(ent, pos, txt)
|
||||
;
|
||||
|
||||
value let_in_of_extend loc gmod functor_version gl el args =
|
||||
match gl with
|
||||
[ Some ([n1 :: _] as nl) ->
|
||||
do {
|
||||
check_use nl el;
|
||||
let ll =
|
||||
List.fold_right
|
||||
(fun e ll ->
|
||||
match e.name.expr with
|
||||
[ <:expr< $lid:_$ >> ->
|
||||
if List.exists (fun n -> e.name.tvar = n.tvar) nl then ll
|
||||
else [e.name :: ll]
|
||||
| _ -> ll ])
|
||||
el []
|
||||
in
|
||||
let globals =
|
||||
List.map
|
||||
(fun {expr = e; tvar = x; loc = loc} ->
|
||||
(<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>))
|
||||
nl
|
||||
in
|
||||
let locals =
|
||||
List.map
|
||||
(fun {expr = e; tvar = x; loc = loc} ->
|
||||
let i =
|
||||
match e with
|
||||
[ <:expr< $lid:i$ >> -> i
|
||||
| _ -> failwith "internal error in pa_extend" ]
|
||||
in
|
||||
(<:patt< $lid:i$ >>, <:expr<
|
||||
(grammar_entry_create $str:i$ : $uid:gmod$.Entry.e '$x$) >>))
|
||||
ll
|
||||
in
|
||||
let e =
|
||||
if ll = [] then args
|
||||
else if functor_version then
|
||||
<:expr<
|
||||
let grammar_entry_create = $uid:gmod$.Entry.create in
|
||||
let $list:locals$ in $args$ >>
|
||||
else
|
||||
<:expr<
|
||||
let grammar_entry_create s =
|
||||
$uid:gmod$.Entry.create ($uid:gmod$.of_entry $locate n1$) s
|
||||
in
|
||||
let $list:locals$ in $args$ >>
|
||||
in
|
||||
<:expr< let $list:globals$ in $e$ >>
|
||||
}
|
||||
| _ -> args ]
|
||||
;
|
||||
|
||||
value text_of_extend loc gmod gl el f =
|
||||
if split_ext.val then
|
||||
let args =
|
||||
List.map
|
||||
(fun e ->
|
||||
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
||||
let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
|
||||
let e = <:expr< ($ent$, $pos$, $txt$) >> in
|
||||
<:expr< let aux () = $f$ [$e$] in aux () >>)
|
||||
el
|
||||
in
|
||||
let args = <:expr< do { $list:args$ } >> in
|
||||
let_in_of_extend loc gmod False gl el args
|
||||
else
|
||||
let args =
|
||||
List.fold_right
|
||||
(fun e el ->
|
||||
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
||||
let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in
|
||||
let e = <:expr< ($ent$, $pos$, $txt$) >> in
|
||||
<:expr< [$e$ :: $el$] >>)
|
||||
el <:expr< [] >>
|
||||
in
|
||||
let args = let_in_of_extend loc gmod False gl el args in
|
||||
<:expr< $f$ $args$ >>
|
||||
;
|
||||
|
||||
value text_of_functorial_extend loc gmod gl el =
|
||||
let args =
|
||||
let el =
|
||||
List.map
|
||||
(fun e ->
|
||||
let (ent, pos, txt) = text_of_entry e.name.loc gmod e in
|
||||
let e = <:expr< $uid:gmod$.extend $ent$ $pos$ $txt$ >> in
|
||||
if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e)
|
||||
el
|
||||
in
|
||||
<:expr< do { $list:el$ } >>
|
||||
in
|
||||
let_in_of_extend loc gmod True gl el args
|
||||
;
|
||||
|
||||
value expr_of_delete_rule loc gmod n sl =
|
||||
let sl =
|
||||
List.fold_right (fun s e -> <:expr< [$s.text gmod ""$ :: $e$] >>) sl
|
||||
<:expr< [] >>
|
||||
in
|
||||
(<:expr< $n.expr$ >>, sl)
|
||||
;
|
||||
|
||||
value sself loc gmod n = <:expr< Gramext.Sself >>;
|
||||
value snext loc gmod n = <:expr< Gramext.Snext >>;
|
||||
value snterm loc n lev gmod tvar =
|
||||
match lev with
|
||||
[ Some lab ->
|
||||
<:expr< Gramext.Snterml
|
||||
($uid:gmod$.Entry.obj
|
||||
($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$))
|
||||
$str:lab$ >>
|
||||
| None ->
|
||||
if n.tvar = tvar then sself loc gmod tvar
|
||||
else
|
||||
<:expr<
|
||||
Gramext.Snterm
|
||||
($uid:gmod$.Entry.obj
|
||||
($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ]
|
||||
;
|
||||
value slist loc min sep symb gmod n =
|
||||
let txt = symb.text gmod "" in
|
||||
match (min, sep) with
|
||||
[ (False, None) -> <:expr< Gramext.Slist0 $txt$ >>
|
||||
| (True, None) -> <:expr< Gramext.Slist1 $txt$ >>
|
||||
| (False, Some s) ->
|
||||
let x = s.text gmod n in <:expr< Gramext.Slist0sep $txt$ $x$ >>
|
||||
| (True, Some s) ->
|
||||
let x = s.text gmod n in <:expr< Gramext.Slist1sep $txt$ $x$ >> ]
|
||||
;
|
||||
value sopt loc symb gmod n =
|
||||
let txt = symb.text gmod "" in <:expr< Gramext.Sopt $txt$ >>
|
||||
;
|
||||
value srules loc t rl gmod tvar =
|
||||
let e = text_of_rule_list loc gmod t rl "" in
|
||||
<:expr< Gramext.srules $e$ >>
|
||||
;
|
||||
|
||||
value rec ident_of_expr =
|
||||
fun
|
||||
[ <:expr< $lid:s$ >> -> s
|
||||
| <:expr< $uid:s$ >> -> s
|
||||
| <:expr< $e1$ . $e2$ >> -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2
|
||||
| _ -> failwith "internal error in pa_extend" ]
|
||||
;
|
||||
|
||||
value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};
|
||||
|
||||
open Pcaml;
|
||||
value symbol = Grammar.Entry.create gram "symbol";
|
||||
|
||||
EXTEND
|
||||
GLOBAL: expr symbol;
|
||||
expr: AFTER "top"
|
||||
[ [ "EXTEND"; e = extend_body; "END" -> e
|
||||
| "GEXTEND"; e = gextend_body; "END" -> e
|
||||
| "DELETE_RULE"; e = delete_rule_body; "END" -> e
|
||||
| "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ]
|
||||
;
|
||||
extend_body:
|
||||
[ [ f = efunction; sl = OPT global; el = LIST1 [ e = entry; ";" -> e ] ->
|
||||
text_of_extend loc "Grammar" sl el f ] ]
|
||||
;
|
||||
gextend_body:
|
||||
[ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; ";" -> e ] ->
|
||||
text_of_functorial_extend loc g sl el ] ]
|
||||
;
|
||||
delete_rule_body:
|
||||
[ [ n = name; ":"; sl = LIST1 symbol SEP ";" ->
|
||||
let (e, b) = expr_of_delete_rule loc "Grammar" n sl in
|
||||
<:expr< Grammar.delete_rule $e$ $b$ >> ] ]
|
||||
;
|
||||
gdelete_rule_body:
|
||||
[ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP ";" ->
|
||||
let (e, b) = expr_of_delete_rule loc g n sl in
|
||||
<:expr< $uid:g$.delete_rule $e$ $b$ >> ] ]
|
||||
;
|
||||
efunction:
|
||||
[ [ UIDENT "FUNCTION"; ":"; f = qualid; ";" -> f
|
||||
| -> <:expr< Grammar.extend >> ] ]
|
||||
;
|
||||
global:
|
||||
[ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; ";" -> sl ] ]
|
||||
;
|
||||
entry:
|
||||
[ [ n = name; ":"; pos = OPT position; ll = level_list ->
|
||||
{name = n; pos = pos; levels = ll} ] ]
|
||||
;
|
||||
position:
|
||||
[ [ UIDENT "FIRST" -> <:expr< Gramext.First >>
|
||||
| UIDENT "LAST" -> <:expr< Gramext.Last >>
|
||||
| UIDENT "BEFORE"; n = string -> <:expr< Gramext.Before $n$ >>
|
||||
| UIDENT "AFTER"; n = string -> <:expr< Gramext.After $n$ >>
|
||||
| UIDENT "LEVEL"; n = string -> <:expr< Gramext.Level $n$ >> ] ]
|
||||
;
|
||||
level_list:
|
||||
[ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ]
|
||||
;
|
||||
level:
|
||||
[ [ lab = OPT STRING; ass = OPT assoc; rules = rule_list ->
|
||||
{label = lab; assoc = ass; rules = rules} ] ]
|
||||
;
|
||||
assoc:
|
||||
[ [ UIDENT "LEFTA" -> <:expr< Gramext.LeftA >>
|
||||
| UIDENT "RIGHTA" -> <:expr< Gramext.RightA >>
|
||||
| UIDENT "NONA" -> <:expr< Gramext.NonA >> ] ]
|
||||
;
|
||||
rule_list:
|
||||
[ [ "["; "]" -> []
|
||||
| "["; rules = LIST1 rule SEP "|"; "]" ->
|
||||
retype_rule_list_without_patterns loc rules ] ]
|
||||
;
|
||||
rule:
|
||||
[ [ psl = LIST0 psymbol SEP ";"; "->"; act = expr ->
|
||||
{prod = psl; action = Some act}
|
||||
| psl = LIST0 psymbol SEP ";" ->
|
||||
{prod = psl; action = None} ] ]
|
||||
;
|
||||
psymbol:
|
||||
[ [ p = LIDENT; "="; s = symbol ->
|
||||
{pattern = Some <:patt< $lid:p$ >>; symbol = s}
|
||||
| i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
|
||||
let name = mk_name loc <:expr< $lid:i$ >> in
|
||||
let text = snterm loc name lev in
|
||||
let styp _ = <:ctyp< '$i$ >> in
|
||||
let symb = {used = [name]; text = text; styp = styp} in
|
||||
{pattern = None; symbol = symb}
|
||||
| p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s}
|
||||
| s = symbol -> {pattern = None; symbol = s} ] ]
|
||||
;
|
||||
symbol:
|
||||
[ "top" NONA
|
||||
[ UIDENT "LIST0"; s = SELF;
|
||||
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
|
||||
let used =
|
||||
match sep with
|
||||
[ Some symb -> symb.used @ s.used
|
||||
| None -> s.used ]
|
||||
in
|
||||
let styp n = let t = s.styp n in <:ctyp< list $t$ >> in
|
||||
{used = used; text = slist loc False sep s; styp = styp}
|
||||
| UIDENT "LIST1"; s = SELF;
|
||||
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
|
||||
let used =
|
||||
match sep with
|
||||
[ Some symb -> symb.used @ s.used
|
||||
| None -> s.used ]
|
||||
in
|
||||
let styp n = let t = s.styp n in <:ctyp< list $t$ >> in
|
||||
{used = used; text = slist loc True sep s; styp = styp}
|
||||
| UIDENT "OPT"; s = SELF ->
|
||||
let styp n = let t = s.styp n in <:ctyp< option $t$ >> in
|
||||
{used = s.used; text = sopt loc s; styp = styp} ]
|
||||
| [ UIDENT "SELF" ->
|
||||
let styp n =
|
||||
if n = "" then
|
||||
Stdpp.raise_with_loc loc
|
||||
(Stream.Error "'SELF' illegal in anonymous entry level")
|
||||
else <:ctyp< '$n$ >>
|
||||
in
|
||||
{used = []; text = sself loc; styp = styp}
|
||||
| UIDENT "NEXT" ->
|
||||
let styp n =
|
||||
if n = "" then
|
||||
Stdpp.raise_with_loc loc
|
||||
(Stream.Error "'NEXT' illegal in anonymous entry level")
|
||||
else <:ctyp< '$n$ >>
|
||||
in
|
||||
{used = []; text = snext loc; styp = styp}
|
||||
| "["; rl = LIST0 rule SEP "|"; "]" ->
|
||||
let rl = retype_rule_list_without_patterns loc rl in
|
||||
let t = new_type_var () in
|
||||
{used = used_of_rule_list rl; text = srules loc t rl;
|
||||
styp = fun _ -> <:ctyp< '$t$ >>}
|
||||
| x = UIDENT ->
|
||||
{used = [];
|
||||
text = fun _ _ -> <:expr< Gramext.Stoken ($str:x$, "") >>;
|
||||
styp = fun _ -> <:ctyp< string >>}
|
||||
| x = UIDENT; e = string ->
|
||||
{used = [];
|
||||
text = fun _ _ -> <:expr< Gramext.Stoken ($str:x$, $e$) >>;
|
||||
styp = fun _ -> <:ctyp< string >>}
|
||||
| e = string ->
|
||||
{used = []; text = fun _ _ -> <:expr< Gramext.Stoken ("", $e$) >>;
|
||||
styp = fun _ -> <:ctyp< string >>}
|
||||
| i = UIDENT; "."; e = qualid;
|
||||
lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
|
||||
let n = mk_name loc <:expr< $uid:i$ . $e$ >> in
|
||||
{used = [n]; text = snterm loc n lev;
|
||||
styp = fun _ -> <:ctyp< '$n.tvar$ >>}
|
||||
| n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
|
||||
{used = [n]; text = snterm loc n lev;
|
||||
styp = fun _ -> <:ctyp< '$n.tvar$ >>}
|
||||
| "("; s_t = SELF; ")" -> s_t ] ]
|
||||
;
|
||||
pattern:
|
||||
[ [ i = LIDENT -> <:patt< $lid:i$ >>
|
||||
| "_" -> <:patt< _ >>
|
||||
| "("; p = SELF; ")" -> <:patt< $p$ >>
|
||||
| "("; p = SELF; ","; pl = patterns_comma; ")" ->
|
||||
<:patt< ( $list:[p :: pl]$ ) >> ] ]
|
||||
;
|
||||
patterns_comma:
|
||||
[ [ pl = SELF; ","; p = pattern -> pl @ [p] ]
|
||||
| [ p = pattern -> [p] ] ]
|
||||
;
|
||||
name:
|
||||
[ [ e = qualid -> mk_name loc e ] ]
|
||||
;
|
||||
qualid:
|
||||
[ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ]
|
||||
| [ i = UIDENT -> <:expr< $uid:i$ >>
|
||||
| i = LIDENT -> <:expr< $lid:i$ >> ] ]
|
||||
;
|
||||
string:
|
||||
[ [ s = STRING -> <:expr< $str:s$ >>
|
||||
| i = ANTIQUOT ->
|
||||
let shift = fst loc + String.length "$" in
|
||||
let e =
|
||||
try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with
|
||||
[ Exc_located (bp, ep) exc ->
|
||||
raise_with_loc (shift + bp, shift + ep) exc ]
|
||||
in
|
||||
Pcaml.expr_reloc (fun (bp, ep) -> (shift + bp, shift + ep)) 0 e ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Camlp4 *)
|
||||
(* *)
|
||||
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2001 Institut National de Recherche en Informatique et *)
|
||||
(* Automatique. Distributed only by permission. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
open Pa_extend;
|
||||
|
||||
value psymbol p s t =
|
||||
let symb = {used = []; text = s; styp = fun _ -> t} in
|
||||
{pattern = Some p; symbol = symb}
|
||||
;
|
||||
|
||||
EXTEND
|
||||
symbol: LEVEL "top"
|
||||
[ NONA
|
||||
[ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ];
|
||||
s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
|
||||
let used =
|
||||
match sep with
|
||||
[ Some symb -> [mk_name loc <:expr< anti >> :: symb.used @ s.used]
|
||||
| None -> s.used ]
|
||||
in
|
||||
let text n =
|
||||
let rl =
|
||||
let r1 =
|
||||
let prod =
|
||||
let n = mk_name loc <:expr< anti_list >> in
|
||||
[psymbol <:patt< a >> (snterm loc n None)
|
||||
<:ctyp< 'anti_list >>]
|
||||
in
|
||||
let act = <:expr< a >> in {prod = prod; action = Some act}
|
||||
in
|
||||
let r2 =
|
||||
let psymb =
|
||||
let symb =
|
||||
{used = []; text = slist loc min sep s;
|
||||
styp = fun n -> <:ctyp< list $s.styp n$ >>}
|
||||
in
|
||||
let patt = <:patt< l >> in
|
||||
{pattern = Some patt; symbol = symb}
|
||||
in
|
||||
let act = <:expr< list l >> in
|
||||
{prod = [psymb]; action = Some act}
|
||||
in
|
||||
[r1; r2]
|
||||
in
|
||||
srules loc "anti" rl n
|
||||
in
|
||||
{used = used; text = text; styp = fun _ -> <:ctyp< ast >>} ] ]
|
||||
;
|
||||
END;
|
||||
|
|
@ -0,0 +1,85 @@
|
|||
(* camlp4r pa_extend.cmo q_MLast.cmo *)
|
||||
(* $Id$ *)
|
||||
|
||||
type item_or_def 'a =
|
||||
[ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
|
||||
;
|
||||
|
||||
value list_remove x l =
|
||||
List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
|
||||
;
|
||||
|
||||
value defined = ref ["CAMLP4_300"; "NEWSEQ"];
|
||||
value define x = defined.val := [x :: defined.val];
|
||||
value undef x = defined.val := list_remove x defined.val;
|
||||
|
||||
EXTEND
|
||||
GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item;
|
||||
Pcaml.expr: LEVEL "top"
|
||||
[ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
|
||||
e2 = Pcaml.expr ->
|
||||
if List.mem c defined.val then e1 else e2
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
|
||||
e2 = Pcaml.expr ->
|
||||
if List.mem c defined.val then e2 else e1 ] ]
|
||||
;
|
||||
Pcaml.str_item: FIRST
|
||||
[ [ x = def_undef_str ->
|
||||
match x with
|
||||
[ SdStr si -> si
|
||||
| SdDef x -> do { define x; <:str_item< declare end >> }
|
||||
| SdUnd x -> do { undef x; <:str_item< declare end >> }
|
||||
| SdNop -> <:str_item< declare end >> ] ] ]
|
||||
;
|
||||
def_undef_str:
|
||||
[ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef;
|
||||
"else"; e2 = str_item_def_undef ->
|
||||
if List.mem c defined.val then e1 else e2
|
||||
| "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
|
||||
if List.mem c defined.val then e1 else SdNop
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef;
|
||||
"else"; e2 = str_item_def_undef ->
|
||||
if List.mem c defined.val then e2 else e1
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
|
||||
if List.mem c defined.val then SdNop else e1
|
||||
| "define"; c = UIDENT -> SdDef c
|
||||
| "undef"; c = UIDENT -> SdUnd c ] ]
|
||||
;
|
||||
str_item_def_undef:
|
||||
[ [ d = def_undef_str -> d
|
||||
| si = Pcaml.str_item -> SdStr si ] ]
|
||||
;
|
||||
Pcaml.sig_item: FIRST
|
||||
[ [ x = def_undef_sig ->
|
||||
match x with
|
||||
[ SdStr si -> si
|
||||
| SdDef x -> do { define x; <:sig_item< declare end >> }
|
||||
| SdUnd x -> do { undef x; <:sig_item< declare end >> }
|
||||
| SdNop -> <:sig_item< declare end >> ] ] ]
|
||||
;
|
||||
def_undef_sig:
|
||||
[ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
|
||||
"else"; e2 = sig_item_def_undef ->
|
||||
if List.mem c defined.val then e1 else e2
|
||||
| "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
|
||||
if List.mem c defined.val then e1 else SdNop
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
|
||||
"else"; e2 = sig_item_def_undef ->
|
||||
if List.mem c defined.val then e2 else e1
|
||||
| "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
|
||||
if List.mem c defined.val then SdNop else e1
|
||||
| "define"; c = UIDENT -> SdDef c
|
||||
| "undef"; c = UIDENT -> SdUnd c ] ]
|
||||
;
|
||||
sig_item_def_undef:
|
||||
[ [ d = def_undef_sig -> d
|
||||
| si = Pcaml.sig_item -> SdStr si ] ]
|
||||
;
|
||||
END;
|
||||
|
||||
Pcaml.add_option "-D" (Arg.String define)
|
||||
"<string> Define for ifdef instruction."
|
||||
;
|
||||
Pcaml.add_option "-U" (Arg.String undef)
|
||||
"<string> Undefine for ifdef instruction."
|
||||
;
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue