diff options
Diffstat (limited to 'camlp4')
213 files changed, 0 insertions, 52581 deletions
diff --git a/camlp4/CHANGES b/camlp4/CHANGES deleted file mode 100644 index 0cba993c44..0000000000 --- a/camlp4/CHANGES +++ /dev/null @@ -1,851 +0,0 @@ -- [20 nov 03] Illegal escape sequences in strings now issue a warning. - -Camlp4 Version 3.07 -___________________ - -- [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6. -- [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in - both parsers (ocaml and revised). There was, afaik, no other way to fix - ambiguities (bugs) in parsing labels and type constraints. - -Camlp4 Version 3.07 beta1 -________________________ - -- [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4 - "parallel" CVS tree, which becomes obsolete from now on. - Added support for recursive modules, private data constructors, and - new syntaxes for integers (int32, nativeint, ...). - -Camlp4 Version 3.06++ ------------------------ - -- [02 Dec 02] In AST predefined quotation, changed antiquotations for - "rec", "mutable": now all are with coercion "opt": $opt:...$ (instead - of "rec" and "mut"). Added antiquotation for "private". Cleaned up - the entries for "methods" and for labelled and optional parameters. -- [29 Nov 02] Removed all "extract_crc" stuff no more necessary with - the new interface of Dynlink. -- [26 Nov 02] Added ability to use "#use" directives in compiled files. -- [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file" - is written: # (load "file"). Added directives in "implem", "interf" and - "use" directive. -- [20 Nov 02] Added Grammar.glexer returning the lexer used by a - grammar. Also added a field in Token.glexer type to ask lexers to - record the locations of the comments. -- [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo): - don't parse quotations (it allows to use e.g. <:> as a valid token). -- [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is - kept for compatibility, but deprecated). The extended statements - allow de definitions of macros and conditional compilation like - in C. -- [29 Oct 02] Changed pretty printers of the three main syntaxes: if - the locations of input are not correct, do no more raise End_of_file - when displaying the inter-phrases (return: the input found up to eof - if not empty, otherwise the value of the -sep parameter if not empty, - otherwise the string "\n"). -- [25 Oct 02] Added option -records in pa_sml.cmo: generates normal - OCaml records instead of objects (the user must be sure that there - are no names conflicts). -- [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the - next call to Plexer.gmake returns a lexer where the dot preceded by - spaces (space, tab, newline, etc.) return a different token than when - not preceded by spaces. -- [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the - extension pr_schemep.cmo which rebuilts parsers. -- [15 Oct 02] Now, in case of syntax error, the real input file name is - displayed (can be different from the input file, because of the possibility - of line directives, typically generated by /lib/cpp). - Changed interface of Stdpp.line_of_loc: now return also a string: the name - of the real input file name. -- [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors - with currification of parameters (C x y) were accepted. -- [14 Oct 02] Fixed many problems of make under Windows (in particular if - installations directories contain spaces). -- [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities - with the ocaml yacc version of the compiler): 1/ "ref new foo" was - interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary - minuses did not work correctly (nor in quotation of syntax trees), in - particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()". -- [Sep-Oct 02] Many changes and improvements in Scheme syntax. -- [07 Oct 02] Added definition of Pcaml.type_declaration which is - now visible in the interface, allowing to change the type declarations. -- [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test - it and take different decision. In revised syntax, its value is "Revised", - in normal syntax "OCaml" and in Scheme syntax "Scheme". -- [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number. -- [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing - comment: (* bleble'''*) -- [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string" - without location (syntaxes pa_o and pa_r). -- [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry - to iterate a grammar entry and transitively all the entries it calls. -- [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give - ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml) - when generating its identifiers. -- [09 Sep 02] Fixed bug under toplevel, the command: - !Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");; - failed "End_of_file". -- [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr, - Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string. - E.g. in the toplevel: - # #load "pr_o.cmo"; - # Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;; - - : string = "let x = 3 in x + 2" - -Camlp4 Version 3.06 --------------------- - -- [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel), - camlp4sch (command). - -Camlp4 Version 3.05 ------------------------ - -- [12 Jul 02] Better treatment of comments in option -cip (add comments - in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo - (revised syntax); added comments before let binding and class - structure items; treat comments inside sum and record type definitions; - the option -tc is now deprecated and equivalent to -cip. -- [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee - left evaluation of functions parameters, t-uples, and so on (instead of - the default non-specified-but-in-fact-right-to-left evaluation). -- [06 Jun 02] Changed revised syntax (pa_r) of variants types definition; - (Jacques Garrigue's idea): - old syntax new syntax - [| ... |] [ = ... ] - [| < ... |] [ < ... ] - [| > ... |] [ > ... ] - This applies also in predefined quotations of syntax tree for types - <:ctyp< ... >> -- [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons; - and the option -no_ss is now by default. -- [30 May 02] Improved SML syntax (pa_sml). -- [30 May 02] Changed the AST for the "with module" construct (was with - type "module_type"; changed into type "module_expr"). -- [26 May 02] Added missing abstract module types. -- [21 Apr 02] Added polymorphic types for polymorphic methods: - revised syntax (example): ! 'a 'b . type - ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >> -- [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on - the "dot" on (in interface file file): - class c : a * B.c -> object val x : int end -- [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated". -- [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be - displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo). -- [03 Apr 02] When there are several tokens parsed together (locally LL(n)), - the location error now highlights all tokens, resulting in a more clear - error message (e.g. "for i let" would display "illegal begin of expr" - and highlight the 3 tokens, not just "for"). -- [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar - symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial - parameters: a function of type 'a -> 'b -> 'b doing the fold and an - initial value of type 'b. Actually, LIST0 now is like - FOLD0 (fun x y -> x :: y) [] - with an reverse of the resulting list. -- [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4 - as a script, the camlp4 welcome message was displayed. -- [14 Mar 02] The configure shell and the program now test the consistency - of OCaml and Camlp4. Therefore 1/ if trying to compile this version with - an incompatible OCaml version or 2/ trying to run an installed Camlp4 with - a incompatible OCaml version: in both cases, camlp4 fails. -- [14 Mar 02] When make opt.opt is done, the very fast version is made for - the normal syntax ("compiled" version). The installed camlp4o.opt is that - version. -- [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >> - and <:expr< x.val := e >> which generates now the tree of !x and x := e, - no more x.contents and x.contents <- e. This change was necessary because - of a problem if a record has been defined with a field named "contents". - -- [16 Feb 02] Changed interface of grammars: the token type is now - customizable, using a new lexer type Token.glexer, parametrized by - the token type, and a new functor GMake. This was accompanied by - some cleanup. Become deprecated: the type Token.lexer (use Token.glexer), - Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use - Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake). - Deprecated means that they are kept during some versions and removed - afterwards. -- [06 Feb 02] Added missing infix "%" in pa_o (normal syntax). -- [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry - and having the Format.formatter as first parameter (Grammar.Entry.print - and its equivalent in functorial interface call it). -- [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the - quotations are no more lexed in all lexers built by Plexer.make () -- [05 Feb 02] Changed the printing of options so that the option -help - aligns correctly their documentation. One can use now Pcaml.add_option - without having to calculate that. -- [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is - by default, because its behaviour is not 100% sure. An option -cip has - been added to set it. -- [03 Feb 02] Added function Stdpp.line_of_loc returning the line and - columns positions from a character location and a file. -- [01 Feb 02] Fixed bug in token.ml: the location function provided by - lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location - could raise Invalid_argument "Array.make" for big files if the number - of read tokens overflows the maximum arrays size (Sys.max_array_length). - The bug is not really fixed: in case of this overflow, the returned - location is (0, 0) (but the program does not fail). -- [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack - had to be programmed to be able to treat them correctly. -- [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives - were not applied in the good order. -- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND - statements (before it tried only the EXTEND). -- [23 Jan 02] The empty functional stream "fstream [: :]" is now of type - 'a Fstream.t thanks to the new implementation of lazies allowing to - create polymorphic lazy values. -- [11 Jan 02] Added a test in grammars using Plexer that a keyword is not - used also as parameter of a LIDENT or a UIDENT. -- [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions - with several currified parameters did not work. It works now, but the - previous code was supposed to treat let ("fun" in SML syntax) definitions - of infix operators, what does not work any more now. -- [04 Jan 02] Alain Frisch's contribution: - Added pa_ocamllex.cma, syntax for ocamllex files. The command: - camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml - does the same thing as: - ocamllex foo.mll - Allow to compile directly mll files. Without option -ocamllex, allow - to insert lex rules in a ml file. -- [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option - string) to specify the string to print between phrases in pretty printers. - The default is None, meaning to copy the inter phrases from the source - file. - -Camlp4 Version 3.04 -------------------- - -- [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to - specify the parsers tof use, i.e. now can use other parsing technics - than the Camlp4 grammar system. -- [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which - returned bad values, resulting lexing of backslash sequences incompatible - with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns - the string of the two characters \ and 1). -- [15 Nov 01] In revised syntax, in let binding in sequences, the "in" - can be replaced by a semicolon; the revised syntax printer pr_r.cmo - now rather prints a semicolon there. -- [07 Nov 01] Added the ability to use $ as token: was impossible so far, - because of AST quotation uses it for its antiquotation. The fix is just - a little (invisible) change in Plexer. -- [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r - try to print comments inside sum and record types like they are in - the source (not by default, because may work incorrectly). -- [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r: - print ocamldoc comments after the declarations, when they are before. -- [04 Nov 01] Added locations for variants and labels declarations in AST - (file MLast.mli). -- [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line - when displaying the sources between phrase, to prevent e.g. the displaying - of the possible last comment of a sum type declaration (the other comment - being not displayed anyway). -- [24 Oct 01] Fixed incorrect locations in sequences. -- [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead - of the generated ocamlc. Fixed. -- [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc: - in parsers, in labels. -- [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard - syntax (pa_o). - -Camlp4 Version 3.03 -------------------- - -- [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed - some syntaxes of labels patterns. Added missing case in exception - declaration (exception rebinding). -- [05 Oct 01] Fixed bug in normal syntax: when defining a constructor - named "True" of "False" (capitalized, i.e. not like the booleans), it - did not work. -- [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes - and types (cleaner). Cleaned up also several parts of the parsers. -- [02 Oct 01] In revised syntax, the warning for using old syntax for - sequences is now by default. To remove it, the option -no-warn-seq - of camlp4r has been added. Option -warn-seq has been removed. -- [07 Sep 01] Included Camlp4 in OCaml distribution. -- [06 Sep 01] Added missing pattern construction #t -- [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused. -- [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0 - (minus float) as pattern. -- [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed - identically. -- [20 Aug 01] Fixed configure script for Windows configuration. -- [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing - problem. -- [10 Aug 01] Fixed bug in compilation process under Windows: the use of - the extension .exe was missing in several parts in Makefiles and shell - scripts. -- [09 Aug 01] Changed message error in grammar: in the case when the rule - is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other), - where the grammar is locally LL(n), it displays now: - tok1 tok2 .. tokn expected - instead of just - tok1 expected - because "tok1" can be correct in the input, and in this case, the message - underscored the tok1 and said "tok1 expected". -- [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are - now displayed in revised syntax. -- [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and - class_sig_item to be able to generate several items from one only item - (like in str_item and sig_item). - -Camlp4 Version 3.02 -------------------- - -- [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted - in a typing error. -- [13 Jul 01] Fixed bug: did not accept floats in patterns. -- [11 Jul 01] Added function Pcaml.top_printer to be able to use the - printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer - of OCaml toplevel. Ex: - let f = Pcaml.top_printer Pcaml.pr_expr;; - #install_printer f;; - #load "pr_o.cmo";; -- [24 Jun 01] In grammars, added symbol ANY, returning the current token, - whichever it is. -- [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ] - is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ] - instead of [ _ = s1 -> () | _ = s2 -> () .. ] -- [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and - [Plexer.string_of_string_token] into module [Token] with names - [Token.eval_char] and [Token.eval_string]. -- [22 Jun 01] Added warning when using old syntax for sequences, while - and do (do..return, do..done) in predefined quotation expr. -- [22 Jun 01] Changed message for unbound quotations (more clear). - -Camlp4 Version 3.01.6: ----------------------- - -- [22 Jun 01] Changed the module Pretty into Spretty. -- [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed: - in the directory "config", the file "configure_batch" is a possibility - to configure the compilation (alternative of "configure" of the top - directory) and has a parameter "-ocaml-top" to specify the OCaml top - directory (relative to the camlp4/config directory). -- [21 Jun 01] The interactive "configure" now tests if the native-code - compilers ocamlc.opt and ocamlopt.opt are accessible and tell the - Makefile to preferably use them if they are. -- [16 Jun 01] The syntax tree for strings and characters now represent their - exact input representation (the node for characters is now of type string, - no more char). For example, the string "a\098c" remains "a\098c" and is - *not* converted into (the equivalent) "abc" in the syntax tree. The - convertion takes place when converting into OCaml tree representation. - This has the advantage that the pretty print now display them as they - are in the input file. To convert from input to real representation - (if needed), two functions have been added: Plexer.string_of_string_token - and Plexer.char_of_char_token. -- [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short - form for {foo = fun x -> y}. -- [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants. -- [06 Jun 01] Completed missing cases in abstract syntax tree and in normal - syntax parser pa_o.ml (about classes). -- [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not - work, and actually all prefix operators between parentheses. - -Camlp4 Version 3.01.5: ----------------------- - -- [04 Jun 01] Fixed bug: when using "include" in a structure item the rest - of the structure was lost. -- [31 May 01] Added ability to user #load and #directory inside ml or mli - files to specify a cmo file to be loaded (for syntax extension) or the - directory path (like option -I). Same semantics than in toplevel. -- [29 May 01] The name of the location variable used in grammars (action - parts of the rules) and in the predefined quotations for OCaml syntax - trees is now configurable in Stdpp.loc_name (string reference). Added also - option -loc to set this variable. Default: loc. -- [26 May 01] Added functional streams: a library module Fstream and a syntax - kit: pa_fstream.cmo. Syntax: - streams: fstream [: ... :] - parsers: fparser [ [: ... :] -> ... | ... ] -- [25 May 01] Added function Token.lexer_func_of a little bit more general - than Token.lexer_func_of_parser. - -Camlp4 Version 3.01.4: ----------------------- - -- [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables - resulting incorrect program: - (e.g. fun s -> parser [: `_; x :] -> s x was printed: - fun s -> parser [: `_; s :] -> s s) -- [19 May 01] Small improvement in pretty.ml resulting a faster print (no - more stacked HOVboxes which printers pr_r and pr_o usually generate in - expr, patt, ctyp, etc.) -- [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex] - in module [Token] to create lexers functions from char stream parsers - or from [ocamllex] lexers. -- [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep - comments inside phrases. -- [15 May 01] Changed pretty printing system, using now new extensible - functions of Camlp4. -- [15 May 01] Added library module Extfun for extensible functions, - syntax pa_extfun, and a printer pr_extfun. -- [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of - "for", "while", and some other expressions, when between parentheses. - -Camlp4 Version 3.01.3: ----------------------- - -- [04 May 01] Put back the syntax "do ... return ..." in predefined - quotation "expr", to be able to compile previous programs. Work - only if the quotation is in position of expression, not in pattern. -- [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated). -- [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use, - the display was incorrect: it displayed the input, instead of the - file location. - -Camlp4 Version 3.01.2: ----------------------- - -- [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of - command camlp4 to display more information in case of parsing error. -- [27 Apr 01] Fixed bug: the locations in sequences was not what expected - by OCaml, resulting on bad locations displaying in case of typing error. -- [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed - of left associative instead of right associative, resulting bad pretty - printing. - -Camlp4 Version 3.01.1: ----------------------- - -- [19 Apr 01] Added missing new feature "include" (structure item). -- [17 Apr 01] Changed revised syntax of sequences. Now: - do { expr1; expr2 ..... ; exprn } - for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn } - while expr do { expr1; expr2 ..... ; exprn } - * If holding a "let ... in", the scope applies up to the end of the sequence. - * The old syntax "do .... return ..." is still accepted. - * In expr quotation, it is *not* accepted. To ensure backward - compatibility, use ifdef NEWSEQ, which answers True from this version. - * The printer pr_r.cmo by default prints with this new syntax. - * To print with old syntax, use option -old_seq. - * To get a warning when using old syntax, use option -warn_seq. - -Camlp4 Version 3.01: --------------------- - -- [5 Mar 01] In pa_o.ml fixed problem, did not parse: - class ['a, 'b] cl a b : ['a, 'b] classtype -- [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning - that the user probably forgot to initialize it). -- [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of - let (f : unit -> int) = fun () -> 1 -- [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in - toplevel. -- [24 May 00] Changed the "make opt", returning to what was done in the - previous releases, i.e. just the compilation of the library (6 files). - The native code compilation of "camlp4o" and "camlp4r" are not absolutely - necessary and can create problems in some systems because of too long code. - The drawbacks are more important than the advantages. -- [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into - -split_ext: it applies now also for non functorial grammars (extended by - EXTEND instead of GEXTEND). -- [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing - of the construction "match x with parser" did not work (because of the - type constraint "Stream.t _" added some versions ago). - -Camlp4 Version 3.00: --------------------- - -- [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax. -- [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt -- [Apr 17, 00] Added support for labels and variants. -- [Mar 28, 00] Improved the grammars: now the rules starting with n - terminals are locally LL(n), i.e. if any of the terminal fails, it is - not Error but just Failure. Allows to write the Ocaml syntax case: - ( operator ) - ( expr ) - with the problem of "( - )" as: - "("; "-"; ")" - "("; operator; ")" - "("; expr; ")" - after factorization of the "(", the rule "-"; ")" is locally LL(2): it - works for this reason. In the previous implementation, a hack had to be - added for this case. - - To allow this, the interface of "Token" changed. The field "tparse" is - now of type "pattern -> option (Stream.t t -> string)" instead of - "pattern -> Stream.t t -> string". Set it to "None" for standard pattern - parsing (or if you don't know). - -Camlp4 Version 2.04: --------------------- - -- [Nov 23, 99] Changed the module name Config into Oconfig, because of - conflict problem when applications want to link with the module Config of - Ocaml. - -Camlp4 Version 2.03: --------------------- - -* pr_depend: - - [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C. - - [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a - bad dependency with file "bar.ml" if existed. And changed "pa_r.ml" - (revised syntax parsing) to generate a more logical ast for case - "var.Mod.lab". - - [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo". - - [Mar 11, 99] Added missing cases in "pr_depend.cmo". - - [Mar 9, 99] Added missing case in pr_depend.ml. - -* Other: - - [Sep 10, 99] Updated from current Ocaml new interfaces. - - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same - change in Ocaml. - - [Jun 24, 99] Added missing "constraint" construction in types - - [Jun 15, 99] Added option -I for command "mkcamlp4". - - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp - - [May 10, 99] Added shell script "configure_batch" in directory "config". - - [May 10, 99] Changed LICENSE to BSD. - - [Apr 29, 99] Added "ifdef" for mli files. - - [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo. - - [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed. - - [Mar 24, 99] Added missing stream type constraint for parsers. - - [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt - by default, instead of ocamlc and ocamlopt. - - [Mar 9, 99] Added ifndef in pa_ifdef.ml. - - [Mar 7, 99] Completed and fixed some cases in pr_extend.ml. - -Camlp4 Version 2.02: --------------------- - -* Parsing: - - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect Ocaml parsing of the - program example: "type t = F(B).t" - - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()". - - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo". - - [Dec 22, 98] Fixed precedence of "!=" in Ocaml syntax - -* Printing: - - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. - - [Dec 28, 98] Fixed pretty printing of long strings starting with spaces; - used to display "\\n<spaces>..." instead of "<spaces>\\n...". - -* Camlp4: - - [Feb 19, 99] Sort command line argument list in reverse order to - avoid argument names conflicts when adding arguments. - -* Olabl: - - [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some - changes in MLast. Olabl programs can be preprocessed by: - camlp4 pa_labl.cma pr_ldump.cmo - -* Internal: - - Use of pr_depend.cmo instead of ocamldep for dependencies. - -Camlp4 Version 2.01: --------------------- - -Token interface -* Big change: the type for tokens and tokens patterns is now (string * string) - the first string being the constructor name and the second its possible - parameters. No change in EXTEND statements using Plexer. But lexers - have: - - a supplementary parameter "tparse" to specify how to parse token - from token patterns. - - fields "using" and "removing" replacing "add_keyword" and - "remove_keyword". - See the file README-2.01 for how to update your programs and the interface - of Token. - -Grammar interface -* The function "keywords" have been replaced by "tokens". The equivalent - of the old statement: - Grammar.keywords g - is now: - Grammar.tokens g "" - -Missing features added -* Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) -* Added print "assert" statement (pr_o.cmo, pr_r.cmo) -* Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo - -Compilation -* Added "make scratch" -* Changed Makefile. No more "make T=../", working bad in some systems. -* Some changes to make compilation in Windows 95/98 working better (thanks - to Patricia Peratto). - -Classes and objects -* Added quotations for classes and objects (q_MLast.ml) -* Added accessible entries in module Pcaml (class_type, class_expr, etc.) -* Changed classes and objects types in definition (module MLast) - -Miscelleneous -* Some adds in pa_sml.cmo. Thanks to Franklin Chen. -* Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do - not print comments between phrases. -* Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND - by functions to turn around a PowerPC problem. - -Bug fixes -* Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)" -* Fixed printing pr_o.cmo of "(a.b <- 1)::1" -* Extended options with parameters worked only when the parameter was sticked. - Ex: - camlp4o pr_o.cmo -l120 foo.ml - worked, but not: - camlp4o pr_o.cmo -l 120 foo.ml - -Camlp4 Version 2.00: --------------------- - -* Designation "righteous" has been renamed "revised". -* Added class and objects in Ocaml printing (pr_o.cmo), revised parsing - (pa_r.cmo) and printing (pr_r.cmo). -* Fixed bug in Ocaml syntax: let _, x = 1, 2;; was refused. - -Camlp4 Version 2.00--1: ------------------------ - -* Added classes and objects in Ocaml syntax (pa_o.cmo) -* Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o - -Camlp4 Version 2.00--: ----------------------- - -* Adapted for Ocaml 2.00. -* No objects and classes in this version. - -* Added "let module" parsing and printing. -* Added arrays patterns parsing and printing. -* Added records with "with" "{... with ...}" parsing and printing - -* Added # num "string" in plexer (was missing). -* Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;; -* Added "pa_sml.cmo", SML syntax + "lib.sml" -* Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding -* Changed Plexer: unknown keywords do not raise error but return Tterm -* q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work) -* Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded -* Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo -* Command ocpp works now without having to explicitely load - "/usr/local/lib/ocaml/stdlib.cma" and - "/usr/local/lib/camlp4/gramlib.cma" - -* Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes -* Added missing statement "include" in signature item in normal and righteous - syntaxes -* Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o): - now before "or", like in Ocaml compiler. -* Same change in righteous syntax, by symmetry. - -Camlp4 Version 1.07.2: ----------------------- - -Errors and missings in normal and righteous syntaxes. - -* Added forgotten syntax (righteous): type constraints in class type fields. -* Added missing syntax (normal): type foo = bar = {......} -* Added missing syntax (normal): did not accept separators before ending - constructions (many of them). -* Fixed bug: "assert false" is now of type 'a, like in Ocaml. -* Fixed to match Ocaml feature: "\^" is "\^" in Ocaml, but just "^" in Camlp4. -* Fixed bug in Windows NT/95: problem in backslash before newlines in strings - -Grammars, EXTEND, DELETE_RULE - -* Added functorial version for grammars (started in version 1.07.1, - completed in this version). -* Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial - version. -* EXTEND statement is added AFTER "top" instead of LEVEL "top" (because - of problems parsing "a; EXTEND...") -* Added ability to have expressions (in antiquotation form) of type string in - EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as - in others constructions inside EXTEND. -* A grammar rule hidden by another is not deleted but just masked. DELETE_RULE - will restore the old version. -* DELETE_RULE now raises Not_found if no rule matched. -* Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of - another rule. -* Some functions for "system use" in [Grammar] become "official": - [Entry.obj], [extend], [delete_rule]. - -Command line, man page - -* Added option -o: output on file instead of standard output, necessary - to allow compilation in Windows NT/95 (in fact, this option exists since - 1.07.1 but forgotten in its "changes" list). -* Command line option -help more complete. -* Updated man page: camlp4 options are better explained. -* Fixed bug: "camlp4 [other-options] foo.ml" worked but not - "camlp4 foo.ml [other-options]". -* Fixed bug: "camlp4 foo" did not display a understandable error message. - -Camlp4's compilation - -* Changes in compilation process in order to try to make it work better for - Windows NT under Cygnus. - -Miscellaneous - -* Added [Pcaml.add_option] for adding command line options. - -Camlp4 Version 1.07.1: ----------------------- - -* Added forgotten syntax in pr_o: type x = y = A | B -* Fixed bug negative floats parsing in pa_o => error while pretty printing -* Added assert statement and option -noassert. -* Environment variable CAMLP4LIB to change camlp4 library directory -* Grammar: empty rules have a correct location instead of (-1, -1) -* Compilation possible in Windows NT/95 -* String constants no more shared while parsing Ocaml -* Fixed bug in antiquotations in q_MLast.cmo (bad errors locations) -* Fixed bug in antiquotations in q_MLast.cmo (EOI not checked) -* Fixed bug in Plexer: could not create keywords with iso 8859 characters - -Camlp4 Version 1.07: --------------------- - -* Changed version number + configuration script -* Added iso 8859 uppercase characters for uidents in plexer.ml -* Fixed bug factorization IDENT in grammars -* Fixed bug pr_o.cmo was printing "declare" -* Fixed bug constructor arity in Ocaml syntax (pa_o.cmo). -* Changed "lazy" into "slazy". -* Completed pa_ifdef.cmo. - -Camlp4 Version 1.06: --------------------- - -* Adapted to Ocaml 1.06. -* Changed version number to match Ocaml's => 1.06 too. -* Deleted module Gstream, using Ocaml's Stream. -* Generate different AST for C(x,y) and C x y (change done in Ocaml's compiler) -* No more message "Interrupted" in toplevel in case of syntax error. -* Added flag to suppress warnings while extending grammars. -* Completed some missing statements and declarations (objects) -* Modified odyl implementation; works better -* Added ability to extend command line specification -* Added "let_binding" as predefined (accessible) entry in Pcaml. -* Added construction FUNCTION in EXTEND statement to call another function. -* Added some ISO-8859-1 characters in lexer identifiers. -* Fixed bug "value x = {val = 1};" (righteous syntax) -* Fixed bug "open A.B.C" was interpreted as "open B.A.C" -* Modified behavior of "DELETE_RULE": the complete rule must be provided -* Completed quotations MLast ("expr", "patt", etc) to accept whole language -* Renamed "LIKE" into "LEVEL" in grammar EXTEND -* Added "NEXT" as grammar symbol in grammar EXTEND -* Added command "mkcamlp4" to make camlp4 executables linked with C code -* Added "pr_extend.cmo" to reconstitute EXTEND instructions - -Camlp4 Version 0.6: -------------------- - ---- Installing - -* To compile camlp4, it is no more necessary to have the sources of the - Objective Caml compiler available. It can be compiled like any other - Objective Caml program. - ---- Options of "camlp4" - -* Added option -where: "camlp4 -where" prints the name of the standard - library directory of Camlp4 and exit. So, the ocaml toplevel and the - compiler can use the option: - -I `camlp4 -where` - -* Added option -nolib to not search for objects files in the installed - library directory of Camlp4. - ---- Interface of grammar library modules - -* The function Grammar.keywords returns now a list of pairs. The pair is - composed of a keyword and the number of times it is used in entries. - -* Changed interface of Token and Grammar for lexers, so user lexers have - to be changed. - ---- New features in grammars - -* New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules. - Ex: - DELETE_RULE Pcaml.expr: "if" END; - deletes the "if" instruction of the language. - -* Added the ability to parse some specific integer in grammars: a possible - parameter to INT, like the ones for LIDENT and UIDENT. - -* In instruction EXTEND, ability to omit "-> action", default is "-> ()" - -* Ability to add antiquotation (between $'s) as symbol rule, of type string, - interpreted as a keyword, in instruction EXTEND. - -* Ability to put entries with qualified names (Foo.bar) in instruction EXTEND. - ---- Quotations - -* The module Ast has been renamed MLast. The quotation expander "q_ast.cmo" - has been renamed "q_MLast.cmo". - -* Quotation expanders are now of two kinds: - - The "classical" type for expanders returning a string. These expanders - have now a supplementary parameter: a boolean value set to "True" - when the quotation is in a context of an expression an to "False" - when the quotation is in a context of a pattern. These expanders, - returning strings which are parsed afterwards, may work for some - language syntax and/or language extensions used (e.g. may work for - Righteous syntax and not for Ocaml syntax). - - A new type of expander returning directly syntax trees. A pair - of functions, for expressions and for patterns must be provided. - These expanders are independant from the language syntax and/or - extensions used. - -* The predefined quotation expanders "ctyp_", "patt_" and "expr_" has - been deleted; one can use "ctyp", "patt", and "expr" in position of - pattern or expression. - ---- Ocaml and Righteous syntaxes - -* Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo" - -* Corrected behavior different from Ocaml's: "^" and "@" were at the same - level than "=": now, like Ocaml, they have a separated right associative - level. - ---- Grammars behavior - -* While extending entries: default position is now "extension of the - first level", instead of "adding a new level at the end". - -* Another Change: in each precedence level, terminals are inserted before - other symbols (non terminals, lists, options, etc), LIDENT "foo" before - LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not - factorizable are now inserted before the other rules. - -* Changed algorithm of entries parsing: each precedence level is tested - against the stream *before* its next precedences levels (instead of - *after*): - EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END; - Now, parsing the entry e with the string "a" returns "xxx" instead of "a" - -* Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be - used now as normal identifiers. - -* When inserting a new rule, a warning appears if a rule with the - same production already existed (it is deleted). - -* Parse error messages (Gstream.Error) are formatted => spaces trigger - Format.print_space and newlines trigger Format.force_newline. - - -Camlp4 Version 0.5: -------------------- - -* Possible creation of native code library (make opt) - -* Ocaml and Righteous Syntax more complete - -* Added pa_ru.cmo for compiling sequences of type unit (Righteous) - -* Quotations AST - - No more quotation long_id - - Antiquotations for identifiers more simple - -* Lot of small changes - - -Camlp4 Version 0.4: -------------------- - -* First distributed version diff --git a/camlp4/ICHANGES b/camlp4/ICHANGES deleted file mode 100644 index 5b17aaf71d..0000000000 --- a/camlp4/ICHANGES +++ /dev/null @@ -1,20 +0,0 @@ -Internal, very small, undocumented, or invisible changes -******************************************************** - -- [20 nov 03], token.mli: eval_string takes a location as a extra - argument (needed to issue a warning). - -Camlp4s Version 3.06+19 ------------------------ - -- [28 Oct 02] Changed and simplified local entry of pa_o.ml from "cvalue" - to "cvalue_binding". -- [18 Oct 02] The standard syntax for antiquotations in object class_types - and object class_expr are now: <:class_type< $opt:x$ $list:y$ >> and - <:class_expr< $opt:x$ $list:y$ >>: the syntax without the "opt" is - accepted but deprecated (a warning is displayed). -- [15 Oct 02] Changed Plexer which now manages better the line directives - (applied only on begin of lines, no error if parsing error in the - directive). -- [14 Sep 02] Grammar.print_entry does not end any more with - Format.print_flush. The "flush" is done by Grammar.Entry.print. diff --git a/camlp4/Makefile b/camlp4/Makefile deleted file mode 100644 index f80090a0b4..0000000000 --- a/camlp4/Makefile +++ /dev/null @@ -1,190 +0,0 @@ -# $Id$ - -include config/Makefile - -DIRS=odyl camlp4 meta etc top ocpp lib man -FDIRS=odyl camlp4 meta lib -OPTDIRS= lib odyl camlp4 meta etc compile -SHELL=/bin/sh -COLD_FILES=ocaml_src/camlp4/argl.ml ocaml_src/camlp4/ast2pt.ml ocaml_src/camlp4/ast2pt.mli ocaml_src/camlp4/mLast.mli ocaml_src/camlp4/pcaml.ml ocaml_src/camlp4/pcaml.mli ocaml_src/camlp4/quotation.ml ocaml_src/camlp4/quotation.mli ocaml_src/camlp4/reloc.ml ocaml_src/camlp4/reloc.mli ocaml_src/camlp4/spretty.ml ocaml_src/camlp4/spretty.mli ocaml_src/lib/extfun.ml ocaml_src/lib/extfun.mli ocaml_src/lib/fstream.ml ocaml_src/lib/fstream.mli ocaml_src/lib/gramext.ml ocaml_src/lib/gramext.mli ocaml_src/lib/grammar.ml ocaml_src/lib/grammar.mli ocaml_src/lib/plexer.ml ocaml_src/lib/plexer.mli ocaml_src/lib/stdpp.ml ocaml_src/lib/stdpp.mli ocaml_src/lib/token.ml ocaml_src/lib/token.mli ocaml_src/meta/pa_extend.ml ocaml_src/meta/pa_extend_m.ml ocaml_src/meta/pa_macro.ml ocaml_src/meta/pa_r.ml ocaml_src/meta/pa_rp.ml ocaml_src/meta/pr_dump.ml ocaml_src/meta/q_MLast.ml ocaml_src/odyl/odyl_main.ml ocaml_src/odyl/odyl_main.mli ocaml_src/odyl/odyl.ml - -all: boot/camlp4$(EXE) - set -e; for i in $(DIRS); do cd $$i; $(MAKE) all; cd ..; done - -opt: - cd lib; $(MAKE) opt - -opt.opt: - set -e; for i in $(OPTDIRS); do cd $$i; $(MAKE) opt; cd ..; done - -boot/camlp4$(EXE): $(COLD_FILES) - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library - -clean_hot: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) clean); done - -depend: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend); done - -install: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) install BINDIR="$(BINDIR)" LIBDIR="$(LIBDIR)" MANDIR="$(MANDIR)"); done - -uninstall: - rm -rf "$(LIBDIR)/camlp4" - cd "$(BINDIR)"; rm -f *camlp4* odyl ocpp - -clean:: - $(MAKE) clean_hot clean_cold - rm -f boot/*.cm[oi] boot/camlp4* - rm -rf boot/SAVED - -scratch: clean - -always: - -# Normal bootstrap - -bootstrap: backup promote clean_hot all compare - -backup: - mkdir boot.new - make mv_cvs FROM=boot TO=boot.new - mv boot boot.new/SAVED - mv boot.new boot - -restore: - mv boot/SAVED boot.new - make mv_cvs FROM=boot TO=boot.new - rm -rf boot - mv boot.new boot - -promote: - for i in $(FDIRS); do (cd $$i; $(MAKE) promote); done - -compare: - @if (for i in $(FDIRS); do \ - if (cd $$i; $(MAKE) compare 2>/dev/null); then :; \ - else exit 1; fi; \ - done); \ - then echo "Fixpoint reached, bootstrap succeeded."; \ - else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ - fi - -cleanboot: - rm -rf boot/SAVED/SAVED - - -# Core and core bootstrap - -bootstrap_core: backup promote clean_hot core compare - -core: boot/camlp4$(EXE) - set -e; for i in $(FDIRS); do cd $$i; $(MAKE) all; cd ..; done - -clean_core: - for i in $(FDIRS); do (cd $$i; $(MAKE) clean); done - - -# The very beginning - -world: - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library all - -library: - cd lib; $(MAKE) all promote - -# Cold start using pure Objective Caml sources - -library_cold: - cd ocaml_src/lib; $(MAKE) all promote OTOP=../$(OTOP) - -compile_cold: - cd ocaml_src; set -e; \ - for i in $(FDIRS); do \ - cd $$i; $(MAKE) all OTOP=../$(OTOP); cd ..; \ - done - -promote_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) promote); \ - done - -clean_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) clean); \ - done - -# Configuring for native win32 - -configure_nt: - echo pouet - echo BINDIR = $(BINDIR) - -# Bootstrap the sources - -TXTGEN=This file has been generated by program: do not edit! - -bootstrap_sources: - cd etc; make pr_o.cmo - mkdir ocaml_src.new - @-for i in $(FDIRS); do \ - (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \ - sed 's-include ../config-include ../../config-g' | \ - sed 's-../boot-../../boot-g' > Makefile; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile.Mac | \ - sed 's-:boot-::boot-g' > Makefile.Mac; \ - cp ../../$$i/.depend . ; \ - cp ../../$$i/Makefile.Mac.depend .); \ - done - @-for i in $(FDIRS); do \ - (cd $$i; \ - for j in *.ml*; do \ - echo ============================================; \ - echo ocaml_src.new/$$i/$$j; \ - OTOP=../.. ../tools/conv.sh $$j | \ - sed 's/$$Id.*\$$/$(TXTGEN)/' > \ - ../ocaml_src.new/$$i/$$j; \ - done); \ - done - -untouch_sources: - @-cd ocaml_src; \ - for i in $(FDIRS); do \ - for j in $$i/*.ml* $$i/Makefile*; do \ - if cmp -s $$j ../ocaml_src.new/$$j 2>/dev/null; then \ - cp -p $$j ../ocaml_src.new/$$j; \ - fi; \ - done; \ - done - -promote_sources: - make mv_cvs FROM=ocaml_src TO=ocaml_src.new - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \ - done - mv ocaml_src/tools ocaml_src.new/. - mv ocaml_src ocaml_src.new/SAVED - mv ocaml_src.new ocaml_src - -unpromote_sources: - mv ocaml_src ocaml_src.new - mv ocaml_src.new/SAVED ocaml_src - mv ocaml_src.new/tools ocaml_src/. - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \ - done - make mv_cvs FROM=ocaml_src.new TO=ocaml_src - -clean_sources: - rm -rf ocaml_src/SAVED/SAVED - -# Utility - -mv_cvs: - test ! -d $(FROM)/CVS || mv $(FROM)/CVS $(TO)/. - test ! -f $(FROM)/.cvsignore || mv $(FROM)/.cvsignore $(TO)/. diff --git a/camlp4/Makefile.Mac b/camlp4/Makefile.Mac deleted file mode 100644 index 7b96430a1e..0000000000 --- a/camlp4/Makefile.Mac +++ /dev/null @@ -1,204 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -DIRS = odyl camlp4 meta etc top ocpp lib man -FDIRS = odyl camlp4 meta lib - -all Ä :boot:camlp4 - for i in {DIRS} - directory {i} - domake all - directory :: - end - -:boot:camlp4 Ä - domake clean_cold library_cold compile_cold - domake promote_cold - domake clean_cold clean_hot library - -clean_hot Ä - for i in {DIRS} - directory {i} - domake clean - directory :: - end - -depend Ä - for i in {DIRS} - directory {i} - domake depend - directory :: - end - -install Ä - for i in {DIRS} - directory {i} - domake install - directory :: - end - -scratch Ä clean - delete -i :boot:Å.cm[oi] || set status 0 - delete -i :boot:camlp4Å || set status 0 - delete -y -i :boot:SAVED - -clean Ä clean_hot clean_cold - -# Normal bootstrap - -bootstrap Ä backup promote clean_hot all compare - -backup Ä - newfolder :boot.new - domake mv_cvs -d FROM=:boot: -d TO=:boot.new: - move :boot :boot.new:SAVED - move :boot.new :boot - -restore Ä - move :boot:SAVED :boot.new - domake mv_cvs -d FROM=:boot: -d TO=:boot.new: - delete -y -i :boot - rename :boot.new :boot - -promote Ä - for i in {FDIRS} - directory {i} - domake promote - directory :: - end - -compare Ä - set failures 0 - set exit 0 - for i in {FDIRS} - directory {i} - domake compare ³ dev:null - evaluate failures += {status} - directory :: - end - if {failures} - echo "Fixpoint not reached, try one more bootstrapping cycle." - else - echo "Fixpoint reached, bootstrap succeeded." - end - -cleanboot Ä - delete -i -y :boot:SAVED:SAVED - - -# Fast bootstrap - -bootstrap_fast Ä backup promote clean_hot fast compare - -fast Ä :boot:camlp4 - for i in {FDIRS} - directory {i} - domake all - directory :: - end - -clean_fast Ä - for i in {FDIRS} - directory {i} - domake clean - directory :: - end - - -# The very beginning - -world Ä - domake clean_cold library_cold compile_cold - domake promote_cold - domake clean_cold clean_hot library all - -library Ä - directory lib - domake all promote - directory :: - -# Cold start using pure Objective Caml sources - -library_cold Ä - directory :ocaml_src:lib - domake all promote - directory ::: - -compile_cold Ä - directory ocaml_src - for i in {FDIRS} - directory {i} - domake all - directory :: - end - directory :: - -promote_cold Ä - for i in {FDIRS} - directory :ocaml_src:{i} - domake promote - directory ::: - end - -clean_cold Ä - for i in {FDIRS} - directory :ocaml_src:{i} - domake clean - directory ::: - end - -# Bootstrap the sources - -#bootstrap_sources Ä -# cd etc; make pr_o.cmo -# mkdir ocaml_src.new -# @-for i in $(FDIRS); do \ -# (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ -# sed 's/# $$Id.*\$$/# Id/' ../../$$i/Makefile | \ -# sed 's-include ../config-include ../../config-g' | \ -# sed 's-../boot-../../boot-g' > Makefile; \ -# cp ../../$$i/.depend .) \ -# done -# @-for i in $(FDIRS); do \ -# for j in $$i/*.ml*; do \ -# echo ============================================; \ -# echo ocaml_src.new/$$j; \ -# ./tools/conv.sh $$j | \ -# sed 's/$$Id.*\$$/Id/' > ocaml_src.new/$$j; \ -# done; \ -# done - -#promote_sources: -# make mv_cvs FROM=ocaml_src TO=ocaml_src.new -# for i in $(FDIRS); do \ -# make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \ -# done -# mv ocaml_src/tools ocaml_src.new/. -# mv ocaml_src ocaml_src.new/SAVED -# mv ocaml_src.new ocaml_src - -#unpromote_sources: -# mv ocaml_src ocaml_src.new -# mv ocaml_src.new/SAVED ocaml_src -# mv ocaml_src.new/tools ocaml_src/. -# for i in $(FDIRS); do \ -# make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \ -# done -# make mv_cvs FROM=ocaml_src.new TO=ocaml_src - -#clean_sources: -# rm -rf ocaml_src/SAVED/SAVED - -mv_cvs Ä - if "`exists "{FROM}CVS"`"; move "{FROM}CVS" "{TO}"; end - if "`exists "{FROM}.cvsignore"`"; move "{FROM}.cvsignore" "{TO}"; end diff --git a/camlp4/boot/.cvsignore b/camlp4/boot/.cvsignore deleted file mode 100644 index 85599a4b58..0000000000 --- a/camlp4/boot/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -*.cm[oia] -camlp4 -camlp4o -camlp4r -SAVED diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore deleted file mode 100644 index 38b5e0906f..0000000000 --- a/camlp4/camlp4/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.cm[oia] -camlp4 -*.lib -crc.ml -extract_crc -phony diff --git a/camlp4/camlp4/.depend b/camlp4/camlp4/.depend deleted file mode 100644 index bf82065403..0000000000 --- a/camlp4/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi -pcaml.cmi: mLast.cmi spretty.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi -argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx -ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile deleted file mode 100644 index 31ffc05057..0000000000 --- a/camlp4/camlp4/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." - cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi - -include .depend diff --git a/camlp4/camlp4/Makefile.Mac b/camlp4/camlp4/Makefile.Mac deleted file mode 100644 index 63a0e6bed3..0000000000 --- a/camlp4/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::odyl: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶ - -I ::boot: Extfold Extfun Fstream ¶ - Gramext Grammar Plexer ¶ - Stdpp Token -I "{OTOP}utils:" Config Warnings ¶ - -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶ - -I : Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶ - "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶ - "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶ - ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶ - quotation.cmi -CAMLP4_OBJS = ::boot:stdpp.cmo ::boot:token.cmo ::boot:plexer.cmo ¶ - ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶ - ::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶ - quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶ - argl.cmo crc.cmo -OBJS = ::odyl:odyl.cma camlp4.cma -XOBJS = camlp4.cmxa -CAMLP4M = - -CAMLP4 = camlp4 - -all Ä {CAMLP4} - -{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo - {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4} - -camlp4.cma Ä {CAMLP4_OBJS} - {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma - -clean ÄÄ - delete -i {CAMLP4} - -{dependrule} - -promote Ä - duplicate -y {CAMLP4} ::boot: - -compare Ä - for i in {CAMLP4} - equal -s {i} ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {CAMLP4} "{BINDIR}" - duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}" - duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶ - "{P4LIBDIR}" - duplicate -y camlp4.cma "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/camlp4/Makefile.Mac.depend b/camlp4/camlp4/Makefile.Mac.depend deleted file mode 100644 index 3665195f77..0000000000 --- a/camlp4/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml deleted file mode 100644 index 8880f07fd1..0000000000 --- a/camlp4/camlp4/argl.ml +++ /dev/null @@ -1,424 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id$ *) - -open Printf; - -value rec action_arg s sl = - fun - [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None - | Arg.Bool f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | [] -> None ] - else - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> None ] - | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None - | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None - | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] } - | Arg.String f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f s; Some sl } - | [] -> None ] - else do { f s; Some sl } - | Arg.Set_string r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := s; Some sl } - | [] -> None ] - else do { r.val := s; Some sl } - | Arg.Int f -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Set_int r -> - if s = "" then - match sl with - [ [s :: sl] -> - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | [] -> None ] - else - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> None ] - | Arg.Float f -> - if s = "" then - match sl with - [ [s :: sl] -> do { f (float_of_string s); Some sl } - | [] -> None ] - else do { f (float_of_string s); Some sl } - | Arg.Set_float r -> - if s = "" then - match sl with - [ [s :: sl] -> do { r.val := (float_of_string s); Some sl } - | [] -> None ] - else do { r.val := (float_of_string s); Some sl } - | Arg.Tuple specs -> - let rec action_args s sl = - fun - [ [] -> Some sl - | [spec :: spec_list] -> - match action_arg s sl spec with - [ None -> action_args "" [] spec_list - | Some [s :: sl] -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list - ] - ] in - action_args s sl specs - | Arg.Symbol syms f -> - match (if s = "" then sl else [s :: sl]) with - [ [s :: sl] when List.mem s syms -> do { f s; Some sl } - | _ -> None ] - ] -; - -value common_start s1 s2 = - loop 0 where rec loop i = - if i == String.length s1 || i == String.length s2 then i - else if s1.[i] == s2.[i] then loop (i + 1) - else i -; - -value rec parse_arg s sl = - fun - [ [(name, action, _) :: spec_list] -> - let i = common_start s name in - if i == String.length name then - try action_arg (String.sub s i (String.length s - i)) sl action with - [ Arg.Bad _ -> parse_arg s sl spec_list ] - else parse_arg s sl spec_list - | [] -> None ] -; - -value rec parse_aux spec_list anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - [ Some sl -> parse_aux spec_list anon_fun sl - | None -> [s :: parse_aux spec_list anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux spec_list anon_fun sl } ] -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc = - if Pcaml.input_file.val <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in - eprintf loc_fmt Pcaml.input_file.val line bp ep - else eprintf "At location %d-%d\n" (fst loc) (snd loc) -; - -value print_warning loc s = - do { print_location loc; eprintf "%s\n" s } -; - -value rec parse_file pa getdir useast = - let name = Pcaml.input_file.val in - do { - Pcaml.warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - loop () where rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - [ Some x -> - match x with - [ (loc, "load", Some <:expr< $str:s$ >>) -> - do { Odyl_main.loadfile s; pl } - | (loc, "directory", Some <:expr< $str:s$ >>) -> - do { Odyl_main.directory s; pl } - | (loc, "use", Some <:expr< $str:s$ >>) -> - List.rev_append rpl - [(useast loc s (use_file pa getdir useast s), loc)] - | (loc, _, _) -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") ] - | None -> pl ] - in - pl @ loop () - else pl - with x -> - do { clear (); raise x } - in - clear (); - phr - } -and use_file pa getdir useast s = - let clear = - let v_input_file = Pcaml.input_file.val in - fun () -> Pcaml.input_file.val := v_input_file - in - do { - Pcaml.input_file.val := s; - try - let r = parse_file pa getdir useast in - do { clear (); r } - with e -> - do { clear (); raise e } - } -; - -value process pa pr getdir useast = - pr (parse_file pa getdir useast); - - -value gind = - fun - [ [(MLast.SgDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value gimd = - fun - [ [(MLast.StDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value usesig loc fname ast = MLast.SgUse loc fname ast; -value usestr loc fname ast = MLast.StUse loc fname ast; - -value process_intf () = - process Pcaml.parse_interf.val Pcaml.print_interf.val gind usesig; -value process_impl () = - process Pcaml.parse_implem.val Pcaml.print_implem.val gimd usestr; - -type file_kind = - [ Intf - | Impl ] -; -value file_kind = ref Intf; -value file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -; - -value print_version () = - do { - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 - } -; - -value align_doc key s = - let s = - loop 0 where rec loop i = - if i = String.length s then "" - else if s.[i] = ' ' then loop (i + 1) - else String.sub s i (String.length s - i) - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - loop 0 where rec loop i = - if i = String.length s then ("", s) - else if s.[i] <> '>' then loop (i + 1) - else - let p = String.sub s 0 (i + 1) in - loop (i + 1) where rec loop i = - if i >= String.length s then (p, "") - else if s.[i] = ' ' then loop (i + 1) - else (p, String.sub s i (String.length s - i)) - else ("", s) - else ("", "") - in - let tab = - String.make (max 1 (13 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s -; - -value make_symlist l = - match l with - [ [] -> "<none>" - | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ] -; - -value print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - [ Arg.Symbol symbs _ -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) - l -; - -value make_symlist l = - match l with - [ [] -> "<none>" - | [h :: t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ] -; - -value print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - [ Arg.Symbol symbs _ -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) - l -; - -value usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - <object-file> Load this file in Camlp4 core. -Other options: - <file> Parse this file.\n"; - print_usage_list ini_sl; - loop (ini_sl @ ext_sl) where rec loop = - fun - [ [(y, _, _) :: _] when y = "-help" -> () - | [_ :: sl] -> loop sl - | [] -> eprintf " -help Display this list of options.\n" ]; - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl; - } - else (); - } -; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -"; - } -; - -value initial_spec_list = - [("-intf", - Arg.String - (fun x -> do { file_kind.val := Intf; Pcaml.input_file.val := x }), - "<file> Parse <file> as an interface, whatever its extension."); - ("-impl", - Arg.String - (fun x -> do { file_kind.val := Impl; Pcaml.input_file.val := x }), - "<file> Parse <file> as an implementation, whatever its extension."); - ("-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."); - ("-loc", Arg.String (fun x -> Stdpp.loc_name.val := x), - "<name> Name of the location variable (default: " ^ Stdpp.loc_name.val ^ - ")"); - ("-QD", Arg.String (fun x -> Pcaml.quotation_dump_file.val := Some x), - "<file> Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> Pcaml.output_file.val := Some x), - "<file> Output on <file> instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit.")] -; - -value anon_fun x = - do { Pcaml.input_file.val := x; file_kind.val := file_kind_of_name x } -; - -value parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - [ Arg.Bad s -> - do { - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 - } ] -; - -value remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop [Sys.argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)) -; - -value report_error = - fun - [ Odyl_main.Error fname msg -> - do { - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - } - | exc -> Pcaml.report_error exc ] -; - -value go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - do { - match parse arg_spec_list anon_fun remaining_args with - [ [] -> () - | ["-help" :: sl] -> do { usage initial_spec_list ext_spec_list; exit 0 } - | [s :: sl] -> - do { - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - } ]; - try - if Pcaml.input_file.val <> "" then - match file_kind.val with - [ Intf -> process_intf () - | Impl -> process_impl () ] - else () - with exc -> - do { - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - [ Stdpp.Exc_located (bp, ep) exc -> - do { print_location (bp, ep); exc } - | _ -> exc ] - in - report_error exc; - Format.close_box (); - Format.print_newline (); - exit 2 - } - } -; - -Odyl_main.name.val := "camlp4"; -Odyl_main.go.val := go; diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml deleted file mode 100644 index 09b2e037b3..0000000000 --- a/camlp4/camlp4/ast2pt.ml +++ /dev/null @@ -1,867 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open MLast; -open Parsetree; -open Longident; -open Asttypes; - -value fast = ref False; -value no_constructors_arity = ref False; - -value get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -; - -value error loc str = raise_with_loc loc (Failure str); - -value char_of_char_token loc s = - try Token.eval_char s with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value string_of_string_token loc s = - try Token.eval_string loc s - with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value glob_fname = ref ""; - -value mkloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = glob_fname.val; - Lexing.pos_lnum = 1; (* ddr met -1 ici ??? *) - Lexing.pos_bol = 0; - Lexing.pos_cnum = n - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = False} (* ddr met: bp = 0 && ep = 0 *) -; - -value mkghloc (bp, ep) = - let loc_at n = { - Lexing.pos_fname = ""; - Lexing.pos_lnum = 1; - Lexing.pos_bol = 0; - Lexing.pos_cnum = n - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = True} -; - -value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; -value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; -value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; -value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; -value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; -value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; -value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; -value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; -value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; -value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; -value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; -value mkpolytype t = - match t with - [ TyPol _ _ _ -> t - | _ -> TyPol (MLast.loc_of_ctyp t) [] t ] -; - -value lident s = Lident s; -value ldot l s = Ldot l s; - -value conv_con = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') - [("True", "true"); ("False", "false"); (" True", "True"); - (" False", "False")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } -; - -value conv_lab = - let t = Hashtbl.create 73 in - do { - List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; - fun s -> try Hashtbl.find t s with [ Not_found -> s ] - } -; - -value array_function str name = - ldot (lident str) (if fast.val then "unsafe_" ^ name else name) -; - -value mkrf = - fun - [ True -> Recursive - | False -> Nonrecursive ] -; - -value mkli s = - loop (fun s -> lident s) where rec loop f = - fun - [ [i :: il] -> loop (fun s -> ldot (f i) s) il - | [] -> f s ] -; - -value long_id_of_string_list loc sl = - match List.rev sl with - [ [] -> error loc "bad ast" - | [s :: sl] -> mkli s (List.rev sl) ] -; - -value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] -; - -value rec ctyp_long_id = - fun - [ TyAcc _ m (TyLid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) - | TyAcc _ m (TyUid _ s) -> - let (is_cls, li) = ctyp_long_id m in - (is_cls, ldot li s) - | TyApp _ m1 m2 -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in - (is_cls, Lapply li1 li2) - | TyUid _ s -> (False, lident s) - | TyLid _ s -> (False, lident s) - | TyCls loc sl -> (True, long_id_of_string_list loc sl) - | t -> error (loc_of_ctyp t) "incorrect type" ] -; - -value rec ctyp = - fun - [ TyAcc loc _ _ as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li [] []) - else mktyp loc (Ptyp_constr li []) - | TyAli loc t1 t2 -> - let (t, i) = - match (t1, t2) with - [ (t, TyQuo _ s) -> (t, s) - | (TyQuo _ s, t) -> (t, s) - | _ -> error loc "incorrect alias type" ] - in - mktyp loc (Ptyp_alias (ctyp t) i) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp loc _ _ as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al) []) - else mktyp loc (Ptyp_constr li (List.map ctyp al)) - | TyArr loc (TyLab loc1 lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (TyLid loc1 "option") t1 in - mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) - | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | TyObj loc fl v -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls loc id -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id) [] []) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc lab _ -> error loc "labelled type not allowed here" - | TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t)) - | TyQuo loc s -> mktyp loc (Ptyp_var s) - | TyRec loc _ _ -> error loc "record type not allowed here" - | TySum loc _ _ -> error loc "sum type not allowed here" - | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyVrn loc catl ool -> - let catl = - List.map - (fun - [ RfTag c a t -> Rtag c a (List.map ctyp t) - | RfInh t -> Rinherit (ctyp t) ]) - catl - in - let (clos, sl) = - match ool with - [ None -> (True, None) - | Some None -> (False, None) - | Some (Some sl) -> (True, Some sl) ] - in - mktyp loc (Ptyp_variant catl clos sl) ] -and meth_list loc fl v = - match fl with - [ [] -> if v then [mkfield loc Pfield_var] else [] - | [(lab, t) :: fl] -> - [mkfield loc (Pfield lab (ctyp (mkpolytype t))) :: meth_list loc fl v] ] -; - -value mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -; -value mkmutable m = if m then Mutable else Immutable; -value mkprivate m = if m then Private else Public; -value mktrecord (_, n, m, t) = (n, mkmutable m, ctyp (mkpolytype t)); -value mkvariant (_, c, tl) = (c, List.map ctyp tl); -value type_decl tl cl = - fun - [ TyMan loc t (TyRec _ pflag ltl) -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) - (Some (ctyp t)) - | TyMan loc t (TySum _ pflag ctl) -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) - (Some (ctyp t)) - | TyRec loc pflag ltl -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) None - | TySum loc pflag ctl -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) None - | t -> - let m = - match t with - [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) ] - in - mktype (loc_of_ctyp t) tl cl Ptype_abstract m ] -; - -value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; - -value option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value expr_of_lab loc lab = - fun - [ Some e -> e - | None -> ExLid loc lab ] -; - -value patt_of_lab loc lab = - fun - [ Some p -> p - | None -> PaLid loc lab ] -; - -value paolab loc lab peoo = - let lab = - match (lab, peoo) with - [ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i - | ("", _) -> error loc "bad ast" - | _ -> lab ] - in - let (p, eo) = - match peoo with - [ Some peo -> peo - | None -> (PaLid loc lab, None) ] - in - (lab, p, eo) -; - -value rec same_type_expr ct ce = - match (ct, ce) with - [ (TyLid _ s1, ExLid _ s2) -> s1 = s2 - | (TyUid _ s1, ExUid _ s2) -> s1 = s2 - | (TyAcc _ t1 t2, ExAcc _ e1 e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> False ] -; - -value rec common_id loc t e = - match (t, e) with - [ (TyLid _ s1, ExLid _ s2) when s1 = s2 -> lident s1 - | (TyUid _ s1, ExUid _ s2) when s1 = s2 -> lident s1 - | (TyAcc _ t1 (TyLid _ s1), ExAcc _ e1 (ExLid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | (TyAcc _ t1 (TyUid _ s1), ExAcc _ e1 (ExUid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" ] -; - -value rec type_id loc t = - match t with - [ TyLid _ s1 -> lident s1 - | TyUid _ s1 -> lident s1 - | TyAcc _ t1 (TyLid _ s1) -> ldot (type_id loc t1) s1 - | TyAcc _ t1 (TyUid _ s1) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" ] -; - -value rec module_type_long_id = - fun - [ MtAcc _ m (MtUid _ s) -> ldot (module_type_long_id m) s - | MtAcc _ m (MtLid _ s) -> ldot (module_type_long_id m) s - | MtApp _ m1 m2 -> Lapply (module_type_long_id m1) (module_type_long_id m2) - | MtLid _ s -> lident s - | MtUid _ s -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" ] -; - -value rec module_expr_long_id = - fun - [ MeAcc _ m (MeUid _ s) -> ldot (module_expr_long_id m) s - | MeUid _ s -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" ] -; - -value mkwithc = - fun - [ WcTyp loc id tpl ct -> - let (params, variance) = List.split tpl in - (long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = Ptype_abstract; ptype_manifest = Some (ctyp ct); - ptype_loc = mkloc loc; ptype_variance = variance}) - | WcMod loc id m -> - (long_id_of_string_list loc id, Pwith_module (module_expr_long_id m)) ] -; - -value rec patt_fa al = - fun - [ PaApp _ f a -> patt_fa [a :: al] f - | f -> (f, al) ] -; - -value rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -; - -value rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -; - -value rec patt_long_id il = - fun - [ PaAcc _ p (PaUid _ i) -> patt_long_id [i :: il] p - | p -> (p, il) ] -; - -value rec patt_label_long_id = - fun - [ PaAcc _ m (PaLid _ s) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc _ m (PaUid _ s) -> ldot (patt_label_long_id m) s - | PaUid _ s -> lident s - | PaLid _ s -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" ] -; - -value rec patt = - fun - [ PaAcc loc p1 p2 -> - let p = - match patt_long_id [] p1 with - [ (PaUid _ i, il) -> - match p2 with - [ PaUid _ s -> - Ppat_construct (mkli (conv_con s) [i :: il]) None - (not no_constructors_arity.val) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" ] - | _ -> error (loc_of_patt p2) "bad pattern" ] - in - mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, PaLid _ s) -> (p, s) - | (PaLid _ s, p) -> (p, s) - | _ -> error loc "incorrect alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt _ p -> patt p - | PaAny loc -> mkpat loc Ppat_any - | PaApp loc _ _ as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - match (patt f).ppat_desc with - [ Ppat_construct li None _ -> - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct li (Some a) True) - | Ppat_variant s None -> - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_variant s (Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" ] - | PaArr loc pl -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> mkpat loc (Ppat_constant (Const_int (int_of_string s))) - | PaInt32 loc s -> mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s))) - | PaInt64 loc s -> mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s))) - | PaNativeInt loc s -> mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s))) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaLid loc s -> mkpat loc (Ppat_var s) - | PaOlb loc _ _ -> error loc "labeled pattern not allowed here" - | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) - | PaRng loc p1 p2 -> - match (p1, p2) with - [ (PaChr loc1 c1, PaChr loc2 c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in - mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" ] - | PaRec loc lpl -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup loc pl -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc sl -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid loc s -> - let ca = not no_constructors_arity.val in - mkpat loc (Ppat_construct (lident (conv_con s)) None ca) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) ] -and mklabpat (lab, p) = (patt_label_long_id lab, patt p); - -value rec expr_fa al = - fun - [ ExApp _ f a -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -value rec class_expr_fa al = - fun - [ CeApp _ ce a -> class_expr_fa [a :: al] ce - | ce -> (ce, al) ] -; - -value rec sep_expr_acc l = - fun - [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 - | ExUid ((bp, _) as loc) s as e -> - match l with - [ [] -> [(loc, [], e)] - | [((_, ep), sl, e) :: l] -> [((bp, ep), [s :: sl], e) :: l] ] - | e -> [(loc_of_expr e, [], e) :: l] ] -; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -value class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = (params, mkloc (fst ci.ciPrm)); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -value rec expr = - fun - [ ExAcc loc x (ExLid _ "val") -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)]) - | ExAcc loc _ _ as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, ExUid _ s) :: l] -> - let ca = not no_constructors_arity.val in - (mkexp loc (Pexp_construct (mkli s ml) None ca), l) - | [(loc, ml, ExLid _ s) :: l] -> - (mkexp loc (Pexp_ident (mkli s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast" ] - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - [ ExLid _ s -> - let loc = (bp, ep) in - (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt _ e -> expr e - | ExApp loc _ _ as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - match (expr f).pexp_desc with - [ Pexp_construct li None _ -> - let al = List.map snd al in - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct li (Some a) True) - | Pexp_variant s None -> - let al = List.map snd al in - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_variant s (Some a)) - | _ -> mkexp loc (Pexp_apply (expr f) al) ] - | ExAre loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc el -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ ExAcc loc x (ExLid _ "val") -> - Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre _ e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | ExLid _ lab -> Pexp_setinstvar lab (expr v) - | ExSte _ e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | _ -> error loc "bad left part of assignment" ] - in - mkexp loc e - | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) - | ExChr loc s -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - mkexp loc (Pexp_constraint (expr e) (option ctyp t1) (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3)) - | ExFun loc [(PaLab _ lab po, w, e)] -> - mkexp loc - (Pexp_function lab None - [(patt (patt_of_lab loc lab po), when_expr e w)]) - | ExFun loc [(PaOlb _ lab peoo, w, e)] -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function ("?" ^ lab) (option expr eo) [(patt p, when_expr e w)]) - | ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel)) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> mkexp loc (Pexp_constant (Const_int (int_of_string s))) - | ExInt32 loc s -> mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s))) - | ExInt64 loc s -> mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s))) - | ExNativeInt loc s -> mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s))) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf pel e -> - mkexp loc (Pexp_let (mkrf rf) (List.map mkpe pel) (expr e)) - | ExLid loc s -> mkexp loc (Pexp_ident (lident s)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) - | ExMat loc e pel -> mkexp loc (Pexp_match (expr e) (List.map mkpwe pel)) - | ExNew loc id -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec loc lel eo -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - [ Some e -> Some (expr e) - | None -> None ] - in - mkexp loc (Pexp_record (List.map mklabexp lel) eo) - | ExSeq loc el -> - let rec loop = - fun - [ [] -> expr (ExUid loc "()") - | [e] -> expr e - | [e :: el] -> - let loc = (fst (loc_of_expr e), snd loc) in - mkexp loc (Pexp_sequence (expr e) (loop el)) ] - in - loop el - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e pel -> mkexp loc (Pexp_try (expr e) (List.map mkpwe pel)) - | ExTup loc el -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | ExUid loc s -> - let ca = not no_constructors_arity.val in - mkexp loc (Pexp_construct (lident (conv_con s)) None ca) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) ] -and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr (expr_of_lab loc lab eo)) - | ExOlb loc lab eo -> ("?" ^ lab, expr (expr_of_lab loc lab eo)) - | e -> ("", expr e) ] -and mkpe (p, e) = (patt p, expr e) -and mkpwe (p, w, e) = (patt p, when_expr e w) -and when_expr e = - fun - [ Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w) (expr e)) - | None -> expr e ] -and mklabexp (lab, e) = (patt_label_long_id lab, expr e) -and mkideexp (ide, e) = (ide, expr e) -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = (fst (loc_of_ctyp t1), snd (loc_of_ctyp t2)) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - (c, type_decl tl cl td) -and module_type = - fun - [ MtAcc loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun loc n nt mt -> - mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) - | MtLid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtQuo loc _ -> error loc "abstract module type not allowed here" - | MtSig loc sl -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtWit loc mt wcl -> - mkmty loc (Pmty_with (module_type mt) (List.map mkwithc wcl)) ] -and sig_item s l = - match s with - [ SgCls loc cd -> - [mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: - l] - | SgDcl loc sl -> List.fold_right sig_item sl l - | SgDir loc _ _ -> l - | SgExc loc n tl -> [mksig loc (Psig_exception n (List.map ctyp tl)) :: l] - | SgExt loc n t p -> [mksig loc (Psig_value n (mkvalue_desc t p)) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] - | SgRecMod loc nmts -> - [mksig loc (Psig_recmodule (List.map (fun (n,mt) -> (n, module_type mt)) nmts)) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype n si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open (long_id_of_string_list loc id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (List.map mktype_decl tdl)) :: l] - | SgUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] ] -and module_expr = - fun - [ MeAcc loc _ _ as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp loc me1 me2 -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | MeFun loc n mt me -> - mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) - | MeStr loc sl -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc loc me mt -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | MeUid loc s -> mkmod loc (Pmod_ident (lident s)) ] -and str_item s l = - match s with - [ StCls loc cd -> - [mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: - l] - | StDcl loc sl -> List.fold_right str_item sl l - | StDir loc _ _ -> l - | StExc loc n tl sl -> - let si = - match (tl, sl) with - [ (tl, []) -> Pstr_exception n (List.map ctyp tl) - | ([], sl) -> Pstr_exn_rebind n (long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" ] - in - [mkstr loc si :: l] - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t p -> [mkstr loc (Pstr_primitive n (mkvalue_desc t p)) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] - | StRecMod loc nmes -> - [mkstr loc - (Pstr_recmodule - (List.map - (fun (n,mt,me) -> (n, module_type mt, module_expr me)) - nmes)) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l] - | StUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal loc rf pel -> - [mkstr loc (Pstr_value (mkrf rf) (List.map mkpe pel)) :: l] ] -and class_type = - fun - [ CtCon loc id tl -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (TyLid loc1 "option") t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ Some t -> t - | None -> TyAny loc ] - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) ] -and class_sig_item c l = - match c with - [ CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CgDcl loc cl -> List.fold_right class_sig_item cl l - | CgInh loc ct -> [Pctf_inher (class_type ct) :: l] - | CgMth loc s pf t -> - [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l] - | CgVal loc s b t -> - [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l] - | CgVir loc s b t -> - [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc id tl -> - mkpcl loc - (Pcl_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CeFun loc (PaLab _ lab po) ce -> - mkpcl loc - (Pcl_fun lab None (patt (patt_of_lab loc lab po)) (class_expr ce)) - | CeFun loc (PaOlb _ lab peoo) ce -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc - (Pcl_fun ("?" ^ lab) (option expr eo) (patt p) (class_expr ce)) - | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf pel ce -> - mkpcl loc (Pcl_let (mkrf rf) (List.map mkpe pel) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ Some p -> p - | None -> PaAny loc ] - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc loc ce ct -> - mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) ] -and class_str_item c l = - match c with - [ CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CrDcl loc cl -> List.fold_right class_str_item cl l - | CrInh loc ce pb -> [Pcf_inher (class_expr ce) pb :: l] - | CrIni loc e -> [Pcf_init (expr e) :: l] - | CrMth loc s b e t -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e) t) in - [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] - | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] - | CrVir loc s b t -> - [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -; - -value interf ast = List.fold_right sig_item ast []; -value implem ast = List.fold_right str_item ast []; - -value directive loc = - fun - [ None -> Pdir_none - | Some (ExStr _ s) -> Pdir_string s - | Some (ExInt _ i) -> Pdir_int (int_of_string i) - | Some (ExUid _ "True") -> Pdir_bool True - | Some (ExUid _ "False") -> Pdir_bool False - | Some e -> - let sl = - loop e where rec loop = - fun - [ ExLid _ i | ExUid _ i -> [i] - | ExAcc _ e (ExLid _ i) | ExAcc _ e (ExUid _ i) -> loop e @ [i] - | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") ] - in - Pdir_ident (long_id_of_string_list loc sl) ] -; - -value phrase = - fun - [ StDir loc d dp -> Ptop_dir d (directive loc dp) - | si -> Ptop_def (str_item si []) ] -; diff --git a/camlp4/camlp4/ast2pt.mli b/camlp4/camlp4/ast2pt.mli deleted file mode 100644 index 3e7da854f6..0000000000 --- a/camlp4/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value fast : ref bool; -value no_constructors_arity : ref bool; -value mkloc : (int * int) -> Location.t; -value long_id_of_string_list : (int * int) -> list string -> Longident.t; - -value str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure; -value interf : list MLast.sig_item -> Parsetree.signature; -value implem : list MLast.str_item -> Parsetree.structure; -value phrase : MLast.str_item -> Parsetree.toplevel_phrase; diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli deleted file mode 100644 index 2d77944318..0000000000 --- a/camlp4/camlp4/mLast.mli +++ /dev/null @@ -1,211 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = (int * int); - -type ctyp = - [ TyAcc of loc and ctyp and ctyp - | TyAli of loc and ctyp and ctyp - | TyAny of loc - | TyApp of loc and ctyp and ctyp - | TyArr of loc and ctyp and ctyp - | TyCls of loc and list string - | TyLab of loc and string and ctyp - | TyLid of loc and string - | TyMan of loc and ctyp and ctyp - | TyObj of loc and list (string * ctyp) and bool - | TyOlb of loc and string and ctyp - | TyPol of loc and list string and ctyp - | TyQuo of loc and string - | TyRec of loc and bool and list (loc * string * bool * ctyp) - | TySum of loc and bool and list (loc * string * list ctyp) - | TyTup of loc and list ctyp - | TyUid of loc and string - | TyVrn of loc and list row_field and option (option (list string)) ] -and row_field = - [ RfTag of string and bool and list ctyp - | RfInh of ctyp ] -; - -type class_infos 'a = - { ciLoc : loc; - ciVir : bool; - ciPrm : (loc * list (string * (bool * bool))); - ciNam : string; - ciExp : 'a } -; - -type patt = - [ PaAcc of loc and patt and patt - | PaAli of loc and patt and patt - | PaAnt of loc and patt - | PaAny of loc - | PaApp of loc and patt and patt - | PaArr of loc and list patt - | PaChr of loc and string - | PaInt of loc and string - | PaInt32 of loc and string - | PaInt64 of loc and string - | PaNativeInt of loc and string - | PaFlo of loc and string - | PaLab of loc and string and option patt - | PaLid of loc and string - | PaOlb of loc and string and option (patt * option expr) - | PaOrp of loc and patt and patt - | PaRng of loc and patt and patt - | PaRec of loc and list (patt * patt) - | PaStr of loc and string - | PaTup of loc and list patt - | PaTyc of loc and patt and ctyp - | PaTyp of loc and list string - | PaUid of loc and string - | PaVrn of loc and string ] -and expr = - [ ExAcc of loc and expr and expr - | ExAnt of loc and expr - | ExApp of loc and expr and expr - | ExAre of loc and expr and expr - | ExArr of loc and list expr - | ExAsf of loc (* assert False *) - | ExAsr of loc and expr (* assert *) - | ExAss of loc and expr and expr (* assignment *) - | ExChr of loc and string - | ExCoe of loc and expr and option ctyp and ctyp - | ExFlo of loc and string - | ExFor of loc and string and expr and expr and bool and list expr - | ExFun of loc and list (patt * option expr * expr) - | ExIfe of loc and expr and expr and expr - | ExInt of loc and string - | ExInt32 of loc and string - | ExInt64 of loc and string - | ExNativeInt of loc and string - | ExLab of loc and string and option expr - | ExLaz of loc and expr - | ExLet of loc and bool and list (patt * expr) and expr - | ExLid of loc and string - | ExLmd of loc and string and module_expr and expr - | ExMat of loc and expr and list (patt * option expr * expr) - | ExNew of loc and list string - | ExOlb of loc and string and option expr - | ExOvr of loc and list (string * expr) - | ExRec of loc and list (patt * expr) and option expr - | ExSeq of loc and list expr - | ExSnd of loc and expr and string - | ExSte of loc and expr and expr - | ExStr of loc and string - | ExTry of loc and expr and list (patt * option expr * expr) - | ExTup of loc and list expr - | ExTyc of loc and expr and ctyp - | ExUid of loc and string - | ExVrn of loc and string - | ExWhi of loc and expr and list expr ] -and module_type = - [ MtAcc of loc and module_type and module_type - | MtApp of loc and module_type and module_type - | MtFun of loc and string and module_type and module_type - | MtLid of loc and string - | MtQuo of loc and string - | MtSig of loc and list sig_item - | MtUid of loc and string - | MtWit of loc and module_type and list with_constr ] -and sig_item = - [ SgCls of loc and list (class_infos class_type) - | SgClt of loc and list (class_infos class_type) - | SgDcl of loc and list sig_item - | SgDir of loc and string and option expr - | SgExc of loc and string and list ctyp - | SgExt of loc and string and ctyp and list string - | SgInc of loc and module_type - | SgMod of loc and string and module_type - | SgRecMod of loc and list (string * module_type) - | SgMty of loc and string and module_type - | SgOpn of loc and list string - | SgTyp of loc and list type_decl - | SgUse of loc and string and list (sig_item * loc) - | SgVal of loc and string and ctyp ] -and with_constr = - [ WcTyp of loc and list string and list (string * (bool * bool)) and ctyp - | WcMod of loc and list string and module_expr ] -and module_expr = - [ MeAcc of loc and module_expr and module_expr - | MeApp of loc and module_expr and module_expr - | MeFun of loc and string and module_type and module_expr - | MeStr of loc and list str_item - | MeTyc of loc and module_expr and module_type - | MeUid of loc and string ] -and str_item = - [ StCls of loc and list (class_infos class_expr) - | StClt of loc and list (class_infos class_type) - | StDcl of loc and list str_item - | StDir of loc and string and option expr - | StExc of loc and string and list ctyp and list string - | StExp of loc and expr - | StExt of loc and string and ctyp and list string - | StInc of loc and module_expr - | StMod of loc and string and module_expr - | StRecMod of loc and list (string * module_type * module_expr) - | StMty of loc and string and module_type - | StOpn of loc and list string - | StTyp of loc and list type_decl - | StUse of loc and string and list (str_item * loc) - | StVal of loc and bool and list (patt * expr) ] -and type_decl = - ((loc * string) * list (string * (bool * bool)) * ctyp * list (ctyp * ctyp)) -and class_type = - [ CtCon of loc and list string and list ctyp - | CtFun of loc and ctyp and class_type - | CtSig of loc and option ctyp and list class_sig_item ] -and class_sig_item = - [ CgCtr of loc and ctyp and ctyp - | CgDcl of loc and list class_sig_item - | CgInh of loc and class_type - | CgMth of loc and string and bool and ctyp - | CgVal of loc and string and bool and ctyp - | CgVir of loc and string and bool and ctyp ] -and class_expr = - [ CeApp of loc and class_expr and expr - | CeCon of loc and list string and list ctyp - | CeFun of loc and patt and class_expr - | CeLet of loc and bool and list (patt * expr) and class_expr - | CeStr of loc and option patt and list class_str_item - | CeTyc of loc and class_expr and class_type ] -and class_str_item = - [ CrCtr of loc and ctyp and ctyp - | CrDcl of loc and list class_str_item - | CrInh of loc and class_expr and option string - | CrIni of loc and expr - | CrMth of loc and string and bool and expr and option ctyp - | CrVal of loc and string and bool and expr - | CrVir of loc and string and bool and ctyp ] -; - -external loc_of_ctyp : ctyp -> loc = "%field0"; -external loc_of_patt : patt -> loc = "%field0"; -external loc_of_expr : expr -> loc = "%field0"; -external loc_of_module_type : module_type -> loc = "%field0"; -external loc_of_module_expr : module_expr -> loc = "%field0"; -external loc_of_sig_item : sig_item -> loc = "%field0"; -external loc_of_str_item : str_item -> loc = "%field0"; - -external loc_of_class_type : class_type -> loc = "%field0"; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0"; -external loc_of_class_expr : class_expr -> loc = "%field0"; -external loc_of_class_str_item : class_str_item -> loc = "%field0"; diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml deleted file mode 100644 index 63c083ceba..0000000000 --- a/camlp4/camlp4/pcaml.ml +++ /dev/null @@ -1,457 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value version = Sys.ocaml_version; - -value syntax_name = ref ""; - -value gram = - Grammar.gcreate - {Token.tok_func _ = failwith "no loaded parsing module"; - Token.tok_using _ = (); Token.tok_removing _ = (); - Token.tok_match = fun []; Token.tok_text _ = ""; - Token.tok_comm = None} -; - -value interf = Grammar.Entry.create gram "interf"; -value implem = Grammar.Entry.create gram "implem"; -value top_phrase = Grammar.Entry.create gram "top_phrase"; -value use_file = Grammar.Entry.create gram "use_file"; -value sig_item = Grammar.Entry.create gram "sig_item"; -value str_item = Grammar.Entry.create gram "str_item"; -value module_type = Grammar.Entry.create gram "module_type"; -value module_expr = Grammar.Entry.create gram "module_expr"; -value expr = Grammar.Entry.create gram "expr"; -value patt = Grammar.Entry.create gram "patt"; -value ctyp = Grammar.Entry.create gram "type"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; - -value class_sig_item = Grammar.Entry.create gram "class_sig_item"; -value class_str_item = Grammar.Entry.create gram "class_str_item"; -value class_type = Grammar.Entry.create gram "class_type"; -value class_expr = Grammar.Entry.create gram "class_expr"; - -value parse_interf = ref (Grammar.Entry.parse interf); -value parse_implem = ref (Grammar.Entry.parse implem); - -value rec skip_to_eol cs = - match Stream.peek cs with - [ Some '\n' -> () - | Some c -> do { Stream.junk cs; skip_to_eol cs } - | _ -> () ] -; -value sync = ref skip_to_eol; - -value input_file = ref ""; -value output_file = ref None; - -value warning_default_function (bp, ep) txt = - do { Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr } -; - -value warning = ref warning_default_function; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -List.iter (fun (n, f) -> Quotation.add n f) - [("id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$")); - ("string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\""))]; - -value quotation_dump_file = ref (None : option string); - -type err_ctx = - [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -value expand_quotation loc expander shift name str = - let new_warning = - let warn = warning.val in - fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - [ Stdpp.Exc_located (p1, p2) exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) - | exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located loc exc1) ]) -; - -value parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located iloc (Qerror _ Locating _ as exc) -> - raise (Stdpp.Exc_located (shift + fst iloc, shift + snd iloc) exc) - | Stdpp.Exc_located iloc (Qerror _ Expanding exc) -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) - | Stdpp.Exc_located _ (Qerror _ _ _ as exc) -> - raise (Stdpp.Exc_located loc exc) - | Stdpp.Exc_located iloc exc -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) ] -; - -value handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - [ "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" ] - in - let shift = fst loc + shift in - let expander = - try Quotation.find name with exc -> - let exc1 = Qerror name Finding exc in - let loc = (fst loc, shift) in - raise (Stdpp.Exc_located loc exc1) - in - let ast = - match expander with - [ Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str ] - in - reloc (fun _ -> loc) shift ast -; - -value parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located (p1, p2) exc -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry) ctx exc in - raise (Stdpp.Exc_located (shift + p1, shift + p2) exc1) ] -; - -value handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = (pos, pos + String.length s) in - let x = parse_locate entry (fst loc) s in - ast_f loc x -; - -value expr_anti loc e = MLast.ExAnt loc e; -value patt_anti loc p = MLast.PaAnt loc p; -value expr_eoi = Grammar.Entry.create gram "expression"; -value patt_eoi = Grammar.Entry.create gram "pattern"; -EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; -END; - -value handle_expr_quotation loc x = - handle_quotation loc fst True expr_eoi Reloc.expr x -; - -value handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x; - -value handle_patt_quotation loc x = - handle_quotation loc snd False patt_eoi Reloc.patt x -; - -value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x; - -value expr_reloc = Reloc.expr; -value patt_reloc = Reloc.patt; - -value rename_id = ref (fun x -> x); - -value find_line (bp, ep) str = - find 0 1 0 where rec find i line col = - if i == String.length str then (line, 0, col) - else if i == bp then (line, col, col + ep - bp) - else if str.[i] == '\n' then find (succ i) (succ line) 0 - else find (succ i) line (succ col) -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value report_quotation_error name ctx = - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - [ Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult _ _ -> "parsing result of quotation" - | Locating -> "parsing" ]) - name; - match ctx with - [ ParsingResult (bp, ep) str -> - match quotation_dump_file.val with - [ Some dump_file -> - do { - Printf.eprintf " dumping result...\n"; - flush stderr; - try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - do { - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - } - with _ -> - do { - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - } - } - | None -> - do { - if input_file.val = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - } ] - | _ -> do { Printf.eprintf "\n"; flush stderr } ] - } -; - -value print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - else () - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - [ '\n' -> - do { - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - } - | ' ' -> - do { - flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - } - | _ -> loop ini (cnt + 1) ] - in - do { Format.open_box 2; loop 0 0; Format.close_box () } -; - -value print_file_failed file line char = - do { - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char - } -; - -value print_exn = - fun - [ Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - do { - Format.print_string "Assertion failed"; - print_file_failed file line char; - } - | Match_failure (file, line, char) -> - do { - Format.print_string "Pattern matching failed"; - print_file_failed file line char; - } - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - do { Format.print_string "Lexing error: "; Format.print_string str } - | Failure str -> - do { Format.print_string "Failure: "; Format.print_string str } - | Invalid_argument str -> - do { Format.print_string "Invalid argument: "; Format.print_string str } - | Sys_error msg -> - do { Format.print_string "I/O error: "; Format.print_string msg } - | x -> - do { - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then do { - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do { - if i > 1 then Format.print_string ", " else (); - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then do { - Format.print_char '"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '"' - } - else Format.print_char '_' - }; - Format.print_char ')' - } - else () - } ] -; - -value report_error exn = - match exn with - [ Qerror name Finding Not_found -> - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - } - | Qerror name ctx exn -> - do { report_quotation_error name ctx; print_exn exn } - | e -> print_exn exn ] -; - -value no_constructors_arity = Ast2pt.no_constructors_arity; -(*value no_assert = ref False;*) - -value arg_spec_list_ref = ref []; -value arg_spec_list () = arg_spec_list_ref.val; -value add_option name spec descr = - arg_spec_list_ref.val := arg_spec_list_ref.val @ [(name, spec, descr)] -; - -(* Printers *) - -open Spretty; - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr = {pr_fun = fun []; pr_levels = []}; -value pr_patt = {pr_fun = fun []; pr_levels = []}; -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -value pr_class_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_type = {pr_fun = fun []; pr_levels = []}; -value pr_class_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr_fun_args = ref Extfun.empty; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun x dg k -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl ] -; - -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -pr_class_sig_item.pr_fun := pr_fun "class_sig_item" pr_class_sig_item; -pr_class_str_item.pr_fun := pr_fun "class_str_item" pr_class_str_item; -pr_class_type.pr_fun := pr_fun "class_type" pr_class_type; -pr_class_expr.pr_fun := pr_fun "class_expr" pr_class_expr; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value undef x = ref (fun _ -> failwith x); -value print_interf = undef "no printer"; -value print_implem = undef "no printer"; - -value top_printer pr x = - do { - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Format.print_string " >>"; - } -; - -value buff = Buffer.create 73; -value buffer_char = Buffer.add_char buff; -value buffer_string = Buffer.add_string buff; -value buffer_newline () = Buffer.add_char buff '\n'; - -value string_of pr x = - do { - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Buffer.contents buff - } -; - -value inter_phrases = ref None; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli deleted file mode 100644 index c87ebe39ae..0000000000 --- a/camlp4/camlp4/pcaml.mli +++ /dev/null @@ -1,157 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -value syntax_name : ref string; - -(** {6 Parsers} *) - -value parse_interf : - ref (Stream.t char -> (list (MLast.sig_item * MLast.loc) * bool)); -value parse_implem : - ref (Stream.t char -> (list (MLast.str_item * MLast.loc) * bool)); - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -value gram : Grammar.g; - (** Grammar variable of the OCaml language *) - -value interf : Grammar.Entry.e (list (MLast.sig_item * MLast.loc) * bool); -value implem : Grammar.Entry.e (list (MLast.str_item * MLast.loc) * bool); -value top_phrase : Grammar.Entry.e (option MLast.str_item); -value use_file : Grammar.Entry.e (list MLast.str_item * bool); -value module_type : Grammar.Entry.e MLast.module_type; -value module_expr : Grammar.Entry.e MLast.module_expr; -value sig_item : Grammar.Entry.e MLast.sig_item; -value str_item : Grammar.Entry.e MLast.str_item; -value expr : Grammar.Entry.e MLast.expr; -value patt : Grammar.Entry.e MLast.patt; -value ctyp : Grammar.Entry.e MLast.ctyp; -value let_binding : Grammar.Entry.e (MLast.patt * MLast.expr); -value type_declaration : Grammar.Entry.e MLast.type_decl; -value class_sig_item : Grammar.Entry.e MLast.class_sig_item; -value class_str_item : Grammar.Entry.e MLast.class_str_item; -value class_expr : Grammar.Entry.e MLast.class_expr; -value class_type : Grammar.Entry.e MLast.class_type; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -value input_file : ref string; - (** The file currently being parsed. *) -value output_file : ref (option string); - (** The output file, stdout if None (default) *) -value report_error : exn -> unit; - (** Prints an error message, using the module [Format]. *) -value quotation_dump_file : ref (option string); - (** [quotation_dump_file] optionally tells the compiler to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) -value version : string; - (** The current version of Camlp4. *) -value add_option : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value no_constructors_arity : ref bool; - (** [True]: dont generate constructor arity. *) -(*value no_assert : ref bool; - (** [True]: dont generate assertion checks. *) -*) - -value sync : ref (Stream.t char -> unit); - -value handle_expr_quotation : MLast.loc -> (string * string) -> MLast.expr; -value handle_expr_locate : MLast.loc -> (int * string) -> MLast.expr; - -value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt; -value handle_patt_locate : MLast.loc -> (int * string) -> MLast.patt; - -value expr_reloc : - (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr; -value patt_reloc : - (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -value rename_id : ref (string -> string); - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - [ Finding | Expanding | ParsingResult of (int * int) and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -(** {6 Printers} *) - -open Spretty; - -value print_interf : ref (list (MLast.sig_item * MLast.loc) -> unit); -value print_implem : ref (list (MLast.str_item * MLast.loc) -> unit); - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_sig_item : printer_t MLast.sig_item; -value pr_str_item : printer_t MLast.str_item; -value pr_module_type : printer_t MLast.module_type; -value pr_module_expr : printer_t MLast.module_expr; -value pr_expr : printer_t MLast.expr; -value pr_patt : printer_t MLast.patt; -value pr_ctyp : printer_t MLast.ctyp; -value pr_class_sig_item : printer_t MLast.class_sig_item; -value pr_class_str_item : printer_t MLast.class_str_item; -value pr_class_type : printer_t MLast.class_type; -value pr_class_expr : printer_t MLast.class_expr; - -value pr_expr_fun_args : - ref (Extfun.t MLast.expr (list MLast.patt * MLast.expr)); - -value find_pr_level : string -> list (pr_level 'a) -> pr_level 'a; - -value top_printer : printer_t 'a -> 'a -> unit; -value string_of : printer_t 'a -> 'a -> string; - -value inter_phrases : ref (option string); - -(**/**) - -(* for system use *) - -value warning : ref ((int * int) -> string -> unit); -value expr_eoi : Grammar.Entry.e MLast.expr; -value patt_eoi : Grammar.Entry.e MLast.patt; -value arg_spec_list : unit -> list (string * Arg.spec * string); diff --git a/camlp4/camlp4/quotation.ml b/camlp4/camlp4/quotation.ml deleted file mode 100644 index 431a75768d..0000000000 --- a/camlp4/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -value expanders_table = ref []; - -value default = ref ""; -value translate = ref (fun x -> x); - -value expander_name name = - match translate.val name with - [ "" -> default.val - | name -> name ] -; - -value find name = List.assoc (expander_name name) expanders_table.val; - -value add name f = expanders_table.val := [(name, f) :: expanders_table.val]; diff --git a/camlp4/camlp4/quotation.mli b/camlp4/camlp4/quotation.mli deleted file mode 100644 index 3c0f5f6c4f..0000000000 --- a/camlp4/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Quotation operations. *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -value add : string -> expander -> unit; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -value find : string -> expander; - (** [find name] returns the expander of the given quotation name. *) - -value default : ref string; - (** [default] holds the default quotation name. *) - -value translate : ref (string -> string); - (** function translating quotation names; default = identity *) diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml deleted file mode 100644 index 73f81b9b7b..0000000000 --- a/camlp4/camlp4/reloc.ml +++ /dev/null @@ -1,289 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open MLast; - -value option_map f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value rec ctyp floc sh = - self where rec self = - fun - [ TyAcc loc x1 x2 -> TyAcc (floc loc) (self x1) (self x2) - | TyAli loc x1 x2 -> TyAli (floc loc) (self x1) (self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp loc x1 x2 -> TyApp (floc loc) (self x1) (self x2) - | TyArr loc x1 x2 -> TyArr (floc loc) (self x1) (self x2) - | TyCls loc x1 -> TyCls (floc loc) x1 - | TyLab loc x1 x2 -> TyLab (floc loc) x1 (self x2) - | TyLid loc x1 -> TyLid (floc loc) x1 - | TyMan loc x1 x2 -> TyMan (floc loc) (self x1) (self x2) - | TyObj loc x1 x2 -> - TyObj (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) x2 - | TyOlb loc x1 x2 -> TyOlb (floc loc) x1 (self x2) - | TyPol loc x1 x2 -> TyPol (floc loc) x1 (self x2) - | TyQuo loc x1 -> TyQuo (floc loc) x1 - | TyRec loc pflag x1 -> - TyRec (floc loc) pflag - (List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)) x1) - | TySum loc pflag x1 -> - TySum (floc loc) pflag - (List.map (fun (loc, x1, x2) -> (floc loc, x1, List.map self x2)) x1) - | TyTup loc x1 -> TyTup (floc loc) (List.map self x1) - | TyUid loc x1 -> TyUid (floc loc) x1 - | TyVrn loc x1 x2 -> - TyVrn (floc loc) (List.map (row_field floc sh) x1) x2 ] -and row_field floc sh = - fun - [ RfTag x1 x2 x3 -> RfTag x1 x2 (List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) ] -; - -value class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = - let (x1, x2) = x.ciPrm in - (floc x1, x2); - ciNam = x.ciNam; ciExp = a floc sh x.ciExp} -; - -value rec patt floc sh = - self where rec self = - fun - [ PaAcc loc x1 x2 -> PaAcc (floc loc) (self x1) (self x2) - | PaAli loc x1 x2 -> PaAli (floc loc) (self x1) (self x2) - | PaAnt loc x1 -> - patt (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1 - | PaAny loc -> PaAny (floc loc) - | PaApp loc x1 x2 -> PaApp (floc loc) (self x1) (self x2) - | PaArr loc x1 -> PaArr (floc loc) (List.map self x1) - | PaChr loc x1 -> PaChr (floc loc) x1 - | PaInt loc x1 -> PaInt (floc loc) x1 - | PaInt32 loc x1 -> PaInt32 (floc loc) x1 - | PaInt64 loc x1 -> PaInt64 (floc loc) x1 - | PaNativeInt loc x1 -> PaNativeInt (floc loc) x1 - | PaFlo loc x1 -> PaFlo (floc loc) x1 - | PaLab loc x1 x2 -> PaLab (floc loc) x1 (option_map self x2) - | PaLid loc x1 -> PaLid (floc loc) x1 - | PaOlb loc x1 x2 -> - PaOlb (floc loc) x1 - (option_map - (fun (x1, x2) -> (self x1, option_map (expr floc sh) x2)) x2) - | PaOrp loc x1 x2 -> PaOrp (floc loc) (self x1) (self x2) - | PaRng loc x1 x2 -> PaRng (floc loc) (self x1) (self x2) - | PaRec loc x1 -> - PaRec (floc loc) (List.map (fun (x1, x2) -> (self x1, self x2)) x1) - | PaStr loc x1 -> PaStr (floc loc) x1 - | PaTup loc x1 -> PaTup (floc loc) (List.map self x1) - | PaTyc loc x1 x2 -> PaTyc (floc loc) (self x1) (ctyp floc sh x2) - | PaTyp loc x1 -> PaTyp (floc loc) x1 - | PaUid loc x1 -> PaUid (floc loc) x1 - | PaVrn loc x1 -> PaVrn (floc loc) x1 ] -and expr floc sh = - self where rec self = - fun - [ ExAcc loc x1 x2 -> ExAcc (floc loc) (self x1) (self x2) - | ExAnt loc x1 -> - expr (fun (p1, p2) -> (sh + fst loc + p1, sh + fst loc + p2)) 0 x1 - | ExApp loc x1 x2 -> ExApp (floc loc) (self x1) (self x2) - | ExAre loc x1 x2 -> ExAre (floc loc) (self x1) (self x2) - | ExArr loc x1 -> ExArr (floc loc) (List.map self x1) - | ExAsf loc -> ExAsf (floc loc) - | ExAsr loc x1 -> ExAsr (floc loc) (self x1) - | ExAss loc x1 x2 -> ExAss (floc loc) (self x1) (self x2) - | ExChr loc x1 -> ExChr (floc loc) x1 - | ExCoe loc x1 x2 x3 -> - ExCoe (floc loc) (self x1) (option_map (ctyp floc sh) x2) - (ctyp floc sh x3) - | ExFlo loc x1 -> ExFlo (floc loc) x1 - | ExFor loc x1 x2 x3 x4 x5 -> - ExFor (floc loc) x1 (self x2) (self x3) x4 (List.map self x5) - | ExFun loc x1 -> - ExFun (floc loc) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x1) - | ExIfe loc x1 x2 x3 -> ExIfe (floc loc) (self x1) (self x2) (self x3) - | ExInt loc x1 -> ExInt (floc loc) x1 - | ExInt32 loc x1 -> ExInt32 (floc loc) x1 - | ExInt64 loc x1 -> ExInt64 (floc loc) x1 - | ExNativeInt loc x1 -> ExNativeInt (floc loc) x1 - | ExLab loc x1 x2 -> ExLab (floc loc) x1 (option_map self x2) - | ExLaz loc x1 -> ExLaz (floc loc) (self x1) - | ExLet loc x1 x2 x3 -> - ExLet (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3) - | ExLid loc x1 -> ExLid (floc loc) x1 - | ExLmd loc x1 x2 x3 -> - ExLmd (floc loc) x1 (module_expr floc sh x2) (self x3) - | ExMat loc x1 x2 -> - ExMat (floc loc) (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExNew loc x1 -> ExNew (floc loc) x1 - | ExOlb loc x1 x2 -> ExOlb (floc loc) x1 (option_map self x2) - | ExOvr loc x1 -> - ExOvr (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) - | ExRec loc x1 x2 -> - ExRec (floc loc) - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x1) - (option_map self x2) - | ExSeq loc x1 -> ExSeq (floc loc) (List.map self x1) - | ExSnd loc x1 x2 -> ExSnd (floc loc) (self x1) x2 - | ExSte loc x1 x2 -> ExSte (floc loc) (self x1) (self x2) - | ExStr loc x1 -> ExStr (floc loc) x1 - | ExTry loc x1 x2 -> - ExTry (floc loc) (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExTup loc x1 -> ExTup (floc loc) (List.map self x1) - | ExTyc loc x1 x2 -> ExTyc (floc loc) (self x1) (ctyp floc sh x2) - | ExUid loc x1 -> ExUid (floc loc) x1 - | ExVrn loc x1 -> ExVrn (floc loc) x1 - | ExWhi loc x1 x2 -> ExWhi (floc loc) (self x1) (List.map self x2) ] -and module_type floc sh = - self where rec self = - fun - [ MtAcc loc x1 x2 -> MtAcc (floc loc) (self x1) (self x2) - | MtApp loc x1 x2 -> MtApp (floc loc) (self x1) (self x2) - | MtFun loc x1 x2 x3 -> MtFun (floc loc) x1 (self x2) (self x3) - | MtLid loc x1 -> MtLid (floc loc) x1 - | MtQuo loc x1 -> MtQuo (floc loc) x1 - | MtSig loc x1 -> MtSig (floc loc) (List.map (sig_item floc sh) x1) - | MtUid loc x1 -> MtUid (floc loc) x1 - | MtWit loc x1 x2 -> - MtWit (floc loc) (self x1) (List.map (with_constr floc sh) x2) ] -and sig_item floc sh = - self where rec self = - fun - [ SgCls loc x1 -> - SgCls (floc loc) (List.map (class_infos class_type floc sh) x1) - | SgClt loc x1 -> - SgClt (floc loc) (List.map (class_infos class_type floc sh) x1) - | SgDcl loc x1 -> SgDcl (floc loc) (List.map self x1) - | SgDir loc x1 x2 -> SgDir (floc loc) x1 x2 - | SgExc loc x1 x2 -> SgExc (floc loc) x1 (List.map (ctyp floc sh) x2) - | SgExt loc x1 x2 x3 -> SgExt (floc loc) x1 (ctyp floc sh x2) x3 - | SgInc loc x1 -> SgInc (floc loc) (module_type floc sh x1) - | SgMod loc x1 x2 -> SgMod (floc loc) x1 (module_type floc sh x2) - | SgRecMod loc xxs - -> SgRecMod (floc loc) (List.map (fun (x1,x2) -> (x1, (module_type floc sh x2))) xxs) - | SgMty loc x1 x2 -> SgMty (floc loc) x1 (module_type floc sh x2) - | SgOpn loc x1 -> SgOpn (floc loc) x1 - | SgTyp loc x1 -> - SgTyp (floc loc) - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | SgUse loc x1 x2 -> SgUse loc x1 x2 - | SgVal loc x1 x2 -> SgVal (floc loc) x1 (ctyp floc sh x2) ] -and with_constr floc sh = - self where rec self = - fun - [ WcTyp loc x1 x2 x3 -> WcTyp (floc loc) x1 x2 (ctyp floc sh x3) - | WcMod loc x1 x2 -> WcMod (floc loc) x1 (module_expr floc sh x2) ] -and module_expr floc sh = - self where rec self = - fun - [ MeAcc loc x1 x2 -> MeAcc (floc loc) (self x1) (self x2) - | MeApp loc x1 x2 -> MeApp (floc loc) (self x1) (self x2) - | MeFun loc x1 x2 x3 -> - MeFun (floc loc) x1 (module_type floc sh x2) (self x3) - | MeStr loc x1 -> MeStr (floc loc) (List.map (str_item floc sh) x1) - | MeTyc loc x1 x2 -> MeTyc (floc loc) (self x1) (module_type floc sh x2) - | MeUid loc x1 -> MeUid (floc loc) x1 ] -and str_item floc sh = - self where rec self = - fun - [ StCls loc x1 -> - StCls (floc loc) (List.map (class_infos class_expr floc sh) x1) - | StClt loc x1 -> - StClt (floc loc) (List.map (class_infos class_type floc sh) x1) - | StDcl loc x1 -> StDcl (floc loc) (List.map self x1) - | StDir loc x1 x2 -> StDir (floc loc) x1 x2 - | StExc loc x1 x2 x3 -> StExc (floc loc) x1 (List.map (ctyp floc sh) x2) x3 - | StExp loc x1 -> StExp (floc loc) (expr floc sh x1) - | StExt loc x1 x2 x3 -> StExt (floc loc) x1 (ctyp floc sh x2) x3 - | StInc loc x1 -> StInc (floc loc) (module_expr floc sh x1) - | StMod loc x1 x2 -> StMod (floc loc) x1 (module_expr floc sh x2) - | StRecMod loc nmtmes -> - StRecMod (floc loc) (List.map (fun (n, mt, me) -> (n, module_type floc sh mt, module_expr floc sh me)) nmtmes) - | StMty loc x1 x2 -> StMty (floc loc) x1 (module_type floc sh x2) - | StOpn loc x1 -> StOpn (floc loc) x1 - | StTyp loc x1 -> - StTyp (floc loc) - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | StUse loc x1 x2 -> StUse loc x1 x2 - | StVal loc x1 x2 -> - StVal (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) ] -and class_type floc sh = - self where rec self = - fun - [ CtCon loc x1 x2 -> CtCon (floc loc) x1 (List.map (ctyp floc sh) x2) - | CtFun loc x1 x2 -> CtFun (floc loc) (ctyp floc sh x1) (self x2) - | CtSig loc x1 x2 -> - CtSig (floc loc) (option_map (ctyp floc sh) x1) - (List.map (class_sig_item floc sh) x2) ] -and class_sig_item floc sh = - self where rec self = - fun - [ CgCtr loc x1 x2 -> CgCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2) - | CgDcl loc x1 -> CgDcl (floc loc) (List.map (class_sig_item floc sh) x1) - | CgInh loc x1 -> CgInh (floc loc) (class_type floc sh x1) - | CgMth loc x1 x2 x3 -> CgMth (floc loc) x1 x2 (ctyp floc sh x3) - | CgVal loc x1 x2 x3 -> CgVal (floc loc) x1 x2 (ctyp floc sh x3) - | CgVir loc x1 x2 x3 -> CgVir (floc loc) x1 x2 (ctyp floc sh x3) ] -and class_expr floc sh = - self where rec self = - fun - [ CeApp loc x1 x2 -> CeApp (floc loc) (self x1) (expr floc sh x2) - | CeCon loc x1 x2 -> CeCon (floc loc) x1 (List.map (ctyp floc sh) x2) - | CeFun loc x1 x2 -> CeFun (floc loc) (patt floc sh x1) (self x2) - | CeLet loc x1 x2 x3 -> - CeLet (floc loc) x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) - (self x3) - | CeStr loc x1 x2 -> - CeStr (floc loc) (option_map (patt floc sh) x1) - (List.map (class_str_item floc sh) x2) - | CeTyc loc x1 x2 -> CeTyc (floc loc) (self x1) (class_type floc sh x2) ] -and class_str_item floc sh = - self where rec self = - fun - [ CrCtr loc x1 x2 -> CrCtr (floc loc) (ctyp floc sh x1) (ctyp floc sh x2) - | CrDcl loc x1 -> CrDcl (floc loc) (List.map (class_str_item floc sh) x1) - | CrInh loc x1 x2 -> CrInh (floc loc) (class_expr floc sh x1) x2 - | CrIni loc x1 -> CrIni (floc loc) (expr floc sh x1) - | CrMth loc x1 x2 x3 x4 -> - CrMth (floc loc) x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) - | CrVal loc x1 x2 x3 -> CrVal (floc loc) x1 x2 (expr floc sh x3) - | CrVir loc x1 x2 x3 -> CrVir (floc loc) x1 x2 (ctyp floc sh x3) ] -; diff --git a/camlp4/camlp4/reloc.mli b/camlp4/camlp4/reloc.mli deleted file mode 100644 index d1a09a4e1f..0000000000 --- a/camlp4/camlp4/reloc.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt; -value expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr; diff --git a/camlp4/camlp4/spretty.ml b/camlp4/camlp4/spretty.ml deleted file mode 100644 index 2484cb47be..0000000000 --- a/camlp4/camlp4/spretty.ml +++ /dev/null @@ -1,481 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type prettyL = - [ SL of int and glue and string - | HL of list prettyL - | BL of list prettyL - | PL of list prettyL - | QL of list prettyL - | VL of list prettyL - | BE of list prettyL - | BV of list prettyL - | LI of (string * int * int) and prettyL ] -; -type getcomm = int -> int -> (string * int * int * int); - -value quiet = ref True; -value maxl = ref 20; -value dt = ref 2; -value tol = ref 1; -value sp = ref ' '; -value last_ep = ref 0; -value getcomm = ref (fun _ _ -> ("", 0, 0, 0)); -value prompt = ref ""; -value print_char_fun = ref (output_char stdout); -value print_string_fun = ref (output_string stdout); -value print_newline_fun = ref (fun () -> output_char stdout '\n'); -value lazy_tab = ref (-1); - -value flush_tab () = - if lazy_tab.val >= 0 then do { - print_newline_fun.val (); - print_string_fun.val prompt.val; - for i = 1 to lazy_tab.val do { print_char_fun.val sp.val }; - lazy_tab.val := -1 - } - else () -; -value print_newline_and_tab tab = lazy_tab.val := tab; -value print_char c = do { flush_tab (); print_char_fun.val c }; -value print_string s = do { flush_tab (); print_string_fun.val s }; - -value rec print_spaces nsp = - for i = 1 to nsp do { print_char sp.val } -; - -value end_with_tab s = - loop (String.length s - 1) where rec loop i = - if i >= 0 then - if s.[i] = ' ' then loop (i - 1) - else s.[i] = '\n' - else False -; - -value print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else do { - let (tab_aft, i_bef_tab) = - loop 0 (String.length s - 1) where rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else (tab_aft, i) - ; - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - loop 0 where rec loop i = - if i = len then () - else do { - print_char_fun.val s.[i]; - let i = - if s.[i] = '\n' && (i+1 = len || s.[i+1] <> '\n') - then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then do { - for i = 1 to delta_ind do { print_char_fun.val ' ' }; - i + 1 - } - else - loop delta_ind (i + 1) where rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - else i + 1 - in - loop i - } - } -; - -value string_np pos np = pos + np; - -value trace_ov pos = - if not quiet.val && pos > maxl.val then do { - prerr_string "<W> prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - } - else () -; - -value tolerate tab pos spc = pos + spc <= tab + dt.val + tol.val; - -value h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - do { print_spaces spc; print_string x; npos } -; - -value n_print_string pos spc np x = - do { print_spaces spc; print_string x; string_np (pos + spc) np } -; - -value rec hnps ((pos, spc) as ps) = - fun - [ SL np RO _ -> (string_np pos np, 1) - | SL np LO _ -> (string_np (pos + spc) np, 0) - | SL np NO _ -> (string_np pos np, 0) - | SL np LR _ -> (string_np (pos + spc) np, 1) - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> (maxl.val + 1, 0) - | BE x -> hnps_list ps x - | BV x -> (maxl.val + 1, 0) - | LI _ x -> hnps ps x ] -and hnps_list ((pos, _) as ps) pl = - if pos > maxl.val then (maxl.val + 1, 0) - else - match pl with - [ [p :: pl] -> hnps_list (hnps ps p) pl - | [] -> ps ] -; - -value rec first = - fun - [ SL _ _ s -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI _ x -> first x ] -and first_in_list = - fun - [ [p :: pl] -> - match first p with - [ Some p -> Some p - | None -> first_in_list pl ] - | [] -> None ] -; - -value first_is_too_big tab p = - match first p with - [ Some s -> tab + String.length s >= maxl.val - | None -> False ] -; - -value too_long tab x p = - if first_is_too_big tab p then False - else - let (pos, spc) = hnps x p in - pos > maxl.val -; - -value rec has_comment = - fun - [ [LI (comm, nl_bef, tab_bef) x :: pl] -> - comm <> "" || has_comment [x :: pl] - | [HL x | BL x | PL x | QL x | VL x | BE x | BV x :: pl] -> - has_comment x || has_comment pl - | [SL _ _ _ :: pl] -> has_comment pl - | [] -> False ] -; - -value rec hprint_pretty tab pos spc = - fun - [ SL np RO x -> (h_print_string pos 0 np x, 1) - | SL np LO x -> (h_print_string pos spc np x, 0) - | SL np NO x -> (h_print_string pos 0 np x, 0) - | SL np LR x -> (h_print_string pos spc np x, 1) - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> (pos, spc) - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> - (* This should not occur: should be - invalid_arg "hprint_pretty" instead *) - hprint_box tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef False; - hprint_pretty tab pos spc x - } ] -and hprint_box tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> (pos, spc) ] -; - -value rec print_pretty tab pos spc = - fun - [ SL np RO x -> (n_print_string pos 0 np x, 1) - | SL np LO x -> (n_print_string pos spc np x, 0) - | SL np NO x -> (n_print_string pos 0 np x, 0) - | SL np LR x -> (n_print_string pos spc np x, 1) - | HL x as p -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do { print_char_fun.val ' ' } - else if comm = "" && x = BL [] then lazy_tab.val := -1 - else flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab.val := -1 else flush_tab () - else (); - print_pretty tab pos spc x - } ] -and print_horiz tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_horiz tab npos nspc pl - | [] -> (pos, spc) ] -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_vertic_rest (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_vertic_rest (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_vertic_rest tab = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_vertic_rest tab pl - } - | [] -> (tab, 0) ] -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then do { - print_newline_and_tab (tab + dt.val); - print_parag_rest (tab + dt.val) (tab + dt.val) 0 pl - } - else if tolerate tab npos nspc then do { - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_parag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_parag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; - (tab, 0) - } - else (npos, nspc) - in - print_parag_rest tab pos spc pl - | [] -> (pos, spc) ] -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_sparag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_sparag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_sparag_rest tab npos nspc pl - | [] -> (pos, spc) ] -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - let nspc = if npos == tab then nspc + dt.val else nspc in - print_spaces nspc; - print_beg_end_rest tab (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_beg_end_rest tab (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_beg_end_rest tab pos = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty (tab + dt.val) pos 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_beg_end_rest tab tab pl - } - | [] -> (pos, 0) ] -; - -value string_npos s = String.length s; - -value rec conv = - fun - [ S g s -> SL (string_npos s) g s - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - match conv_stream x with - [ [(PL _ as x)] -> x - | x -> PL x ] - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo (bp, ep) x -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - last_ep.val in - if len > 0 then getcomm.val last_ep.val len - else ("", 0, 0, 0) - in - do { - last_ep.val := last_ep.val + cnt; - let v = conv x in - last_ep.val := max ep last_ep.val; - LI (comm, nl_bef, tab_bef) v - } ] -and conv_stream = - parser - [ [: `p; s :] -> let x = conv p in [x :: conv_stream s] - | [: :] -> [] ] -; - -value print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - do { - maxl.val := m; - print_char_fun.val := pr_ch; - print_string_fun.val := pr_str; - print_newline_fun.val := pr_nl; - prompt.val := pr2; - getcomm.val := lf; - last_ep.val := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in - () - } -; diff --git a/camlp4/camlp4/spretty.mli b/camlp4/camlp4/spretty.mli deleted file mode 100644 index 6ce1fd8fc0..0000000000 --- a/camlp4/camlp4/spretty.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type getcomm = int -> int -> (string * int * int * int); - -value print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> - string -> string -> int -> getcomm -> int -> pretty -> unit; -value quiet : ref bool; - -value dt : ref int; - -(*--*) - -value tol : ref int; -value sp : ref char; diff --git a/camlp4/compile/.cvsignore b/camlp4/compile/.cvsignore deleted file mode 100644 index 47817ccef6..0000000000 --- a/camlp4/compile/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fast -*.fast.opt -o_fast.ml -pa_o_fast.ml diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend deleted file mode 100644 index 5031b171af..0000000000 --- a/camlp4/compile/.depend +++ /dev/null @@ -1,4 +0,0 @@ -compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -comp_trail.cmo: ../camlp4/pcaml.cmi -comp_trail.cmx: ../camlp4/pcaml.cmx diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile deleted file mode 100644 index 277652b1c9..0000000000 --- a/camlp4/compile/Makefile +++ /dev/null @@ -1,45 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -OCAMLCFLAGS=-warn-error A $(INCLUDES) -SRC=../etc/pa_o.ml ../etc/pa_op.ml -D=o -COMP_OPT=-strict_parsing -COMP_OPT=-e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file" - -all: out - -out: camlp4$D.fast -opt: camlp4$D.fast.opt - -camlp4$D.fast: pa_$D_fast.cmo - rm -f camlp4$D.fast - cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo" - -camlp4$D.fast.opt: pa_$D_fast.cmx - rm -f camlp4$D.fast.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx" - -pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml - cat $(SRC) | sed -e "s/Plexer.gmake ()/P.lexer/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml - -$D_fast.ml: compile.cmo $(SRC) - OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) > $D_fast.ml - -install: - if test -f camlp4o.fast.opt; then cp camlp4o.fast.opt $(BINDIR)/camlp4o.opt$(EXE); fi - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f *.fast tmp.* pa_*_fast.ml *_fast.ml - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend || : ; \ - done - -include .depend diff --git a/camlp4/compile/comp_head.ml b/camlp4/compile/comp_head.ml deleted file mode 100644 index 5efa064073..0000000000 --- a/camlp4/compile/comp_head.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* camlp4r q_MLast.cmo pa_extend.cmo *) -(* $Id$ *) - -module P = - struct - value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm); - value list0 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> List.rev a - ; - value list0sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = symb; s :] -> List.rev (kont [a] s) - | [: :] -> [] ] - ; - value list1 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (loop [a] s) - ; - value list1sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (kont [a] s) - ; - value option f = - parser - [ [: x = f :] -> Some x - | [: :] -> None ] - ; - value token (p_con, p_prm) = - if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm - else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm - ; - value orzero f f0 = - parser bp - [ [: x = f :] -> x - | [: x = f0 :] ep -> -(* -let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in -let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in -*) - x ] - ; - value error entry prev_symb symb = - symb ^ " expected" ^ - (if prev_symb = "" then "" else " after " ^ prev_symb) ^ - " (in [" ^ entry ^ "])" - ; - value lexer = Plexer.gmake (); - end -; - -(****************************************) - diff --git a/camlp4/compile/comp_trail.ml b/camlp4/compile/comp_trail.ml deleted file mode 100644 index 75f40abbf4..0000000000 --- a/camlp4/compile/comp_trail.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(****************************************) - -value interf_p = - Grammar.Entry.of_parser Pcaml.gram "interf" interf_0 -; - -value implem_p = - Grammar.Entry.of_parser Pcaml.gram "implem" implem_0 -; - -value top_phrase_p = - Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0 -; - -value use_file_p = - Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0 -; - -EXTEND - interf: - [ [ x = interf_p -> x ] ] - ; - implem: - [ [ x = implem_p -> x ] ] - ; - top_phrase: - [ [ x = top_phrase_p -> x ] ] - ; - use_file: - [ [ x = use_file_p -> x ] ] - ; -END; diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml deleted file mode 100644 index 5fff04b27d..0000000000 --- a/camlp4/compile/compile.ml +++ /dev/null @@ -1,571 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -#load "q_MLast.cmo"; - -open Gramext; - -value strict_parsing = ref False; -value keywords = ref []; - -value loc = (0, 0); - -(* Watch the segmentation faults here! the compiled file must have been - loaded in camlp4 with the option pa_extend.cmo -meta_action. *) -value magic_act (act : Obj.t) : MLast.expr = Obj.magic act; - -(* Names of symbols for error messages; code borrowed to grammar.ml *) - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s ] -and name_of_tree_failed entry = - fun - [ Node {node = s; brother = bro; son = son} -> - let txt = name_of_symbol_failed entry s in - let txt = - match (s, son) with - [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt ] - in - let txt = - match bro with - [ DeadEnd | LocAct _ _ -> txt - | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | DeadEnd | LocAct _ _ -> "???" ] -; - -value tree_failed entry prev_symb tree = - let (s2, s3) = - let txt = name_of_tree_failed entry tree in - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist0sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Sopt _ | Stree _ -> ("", txt) - | _ -> (name_of_symbol entry prev_symb, txt) ] - in - <:expr< - P.error $str:entry.ename$ $str:String.escaped s2$ $str:String.escaped s3$ - >> -; - -(* Compilation *) - -value rec find_act = - fun - [ DeadEnd -> failwith "find_act" - | LocAct act _ -> (magic_act act, 0) - | Node {son = son; brother = bro} -> - let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in - (act, n + 1) ] -; - -value level_number e l = - match e.edesc with - [ Dlevels elevs -> - loop 0 elevs where rec loop n = - fun - [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs - | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ] - | Dparser _ -> 0 ] -; - -value nth_patt_of_act (e, n) = - let patt_list = - loop e where rec loop = - fun - [ <:expr< fun (loc : (int * int)) -> $_$ >> -> [] - | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] - | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] - | _ -> failwith "nth_patt_of_act" ] - in - List.nth patt_list n -; - -value rec last_patt_of_act = - fun - [ <:expr< fun ($p$ : $_$) (loc : (int * int)) -> $_$ >> -> p - | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e - | _ -> failwith "last_patt_of_act" ] -; - -value rec final_action = - fun - [ <:expr< fun (loc : (int * int)) -> ($e$ : $_$) >> -> e - | <:expr< fun $_$ -> $e$ >> -> final_action e - | _ -> failwith "final_action" ] -; - -value parse_standard_symbol e rkont fkont ending_act = - <:expr< - match try Some ($e$ strm__) with [ Stream.Failure -> None ] with - [ Some $nth_patt_of_act ending_act$ -> $rkont$ - | _ -> $fkont$ ] - >> -; - -value parse_symbol_no_failure e rkont fkont ending_act = - <:expr< - let $nth_patt_of_act ending_act$ = - try $e$ strm__ with [ Stream.Failure -> raise (Stream.Error "") ] - in - $rkont$ - >> -; - -value rec contain_loc = - fun - [ <:expr< $lid:s$ >> -> s = "loc" - | <:expr< $uid:_$ >> -> False - | <:expr< $str:_$ >> -> False - | <:expr< ($list:el$) >> -> List.exists contain_loc el - | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2 - | _ -> True ] -; - -value gen_let_loc loc e = - if contain_loc e then <:expr< let loc = P.gloc bp strm__ in $e$ >> else e -; - -value phony_entry = Grammar.Entry.obj Pcaml.implem; - -value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont = - match tree with - [ DeadEnd -> kont - | LocAct act _ -> - let act = magic_act act in - act_kont False act - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let n = entry.ename ^ "_" ^ string_of_int alevn in - let e = - if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >> - else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >> - in - let p2 = - match bro with - [ DeadEnd -> kont - | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ] - in - let p1 = act_kont True act in - parse_standard_symbol e p1 p2 (act, 0) - | Node {node = s; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = act_kont False act in - parse_symbol entry nlevn s p1 p2 (act, 0) - | Node {node = s; son = son; brother = bro} -> - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = - let err = - let txt = tree_failed entry s son in - <:expr< raise (Stream.Error $txt$) >> - in - match son with - [ Node {brother = DeadEnd} -> - parse_tree entry nlevn alevn (son, False) act_kont err - | _ -> - let p1 = - parse_tree entry nlevn alevn (son, True) act_kont - <:expr< raise Stream.Failure >> - in - <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ] - in - parse_symbol entry nlevn s p1 p2 (find_act son) ] -and parse_symbol entry nlevn s rkont fkont ending_act = - match s with - [ Slist0 s -> - let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1 s -> - let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in - parse_standard_symbol e rkont fkont ending_act - | Slist0sep s sep -> - let e = - <:expr< - P.list0sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1sep s sep -> - let e = - <:expr< - P.list1sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_standard_symbol e rkont fkont ending_act - | Sopt s -> - let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = gen_let_loc loc (final_action act) in - let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in - parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act - | Snterm e -> - let n = - match e.edesc with - [ Dparser _ -> e.ename - | Dlevels _ -> e.ename ^ "_0" ] - in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Sself -> - let n = entry.ename ^ "_0" in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p = - let patt = nth_patt_of_act ending_act in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - if snd tok = "" then - if fst tok = "ANY" then <:patt< (_, $patt$) >> - else <:patt< ($str:p_con$, $patt$) >> - else - let p = <:patt< ($str:p_con$, $str:p_prm$) >> in - match patt with - [ <:patt< _ >> -> <:patt< ($str:p_con$, $str:p_prm$) >> - | _ -> <:patt< ($str:p_con$, ($str:p_prm$ as $patt$)) >> ] - in - <:expr< - match Stream.peek strm__ with - [ Some $p$ -> do { Stream.junk strm__; $rkont$ } - | _ -> $fkont$ ] - >> - | _ -> - parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ] -and symbol_parser entry nlevn = - fun - [ Snterm e -> - let n = e.ename ^ "_0" in - <:expr< $lid:n$ >> - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - <:expr< $lid:n$ >> - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - if strict_parsing.val then <:expr< $lid:n$ >> - else - let n0 = entry.ename ^ "_0" in - <:expr< P.orzero $lid:n$ $lid:n0$ >> - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - <:expr< P.token ($str:p_con$, $str:p_prm$) >> - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = final_action act in - <:expr< - fun strm__ -> - $parse_tree phony_entry 0 0 (tree, True) act_kont kont$ - >> - | _ -> - <:expr< aaa >> ] -; - -value rec start_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn in - let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [Some (p, <:expr< fun strm__ -> raise Stream.Failure >>)] - | [lev :: levs] -> - let pel = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> - let ncont = - if not strict_parsing.val && clevn = 0 then - entry.ename ^ "_gen_cont" - else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - let curr = - <:expr< let a = $lid:next$ strm__ in $lid:ncont$ bp a strm__ >> - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - let pel = if levs = [] then [] else pel in - [Some (p, e) :: pel] - | tree -> - let alevn = clevn in - let (kont, pel) = - match levs with - [ [] -> (<:expr< raise Stream.Failure >>, []) - | _ -> - let e = - match (lev.assoc, lev.lsuffix) with - [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ strm__ >> - | _ -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - <:expr< - let a = $lid:next$ strm__ in - $lid:ncont$ bp a strm__ - >> ] - in - (e, pel) ] - in - let act_kont end_with_self act = - if lev.lsuffix = DeadEnd then gen_let_loc loc (final_action act) - else - let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - gen_let_loc loc - <:expr< $lid:ncont$ bp $final_action act$ strm__ >> - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value rec continue_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [None] - | [lev :: levs] -> - let pel = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> - [None :: pel] - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let (kont, pel) = - match levs with - [ [] -> (<:expr< a__ >>, []) - | _ -> (<:expr< a__ >>, pel) ] - in - let act_kont end_with_self act = - let p = last_patt_of_act act in - match lev.assoc with - [ RightA | NonA -> - <:expr< - let $p$ = a__ in - $gen_let_loc loc (final_action act)$ - >> - | LeftA -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - gen_let_loc loc - <:expr< - let $p$ = a__ in - $lid:ncont$ bp $final_action act$ strm__ - >> ] - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let e = <:expr< fun bp a__ strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value continue_parser_of_levels_again entry levs = - let n = entry.ename ^ "_gen_cont" in - let e = - loop <:expr< a__ >> 0 levs where rec loop var levn = - fun - [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x strm__ >> - | [lev :: levs] -> - match lev.lsuffix with - [ DeadEnd -> loop var (levn + 1) levs - | _ -> - let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in - let rest = loop <:expr< x >> (levn + 1) levs in - <:expr< let x = $lid:n$ bp $var$ strm__ in $rest$ >> ] ] - in - (<:patt< $lid:n$ >>, <:expr< fun bp a__ strm__ -> $e$ >>) -; - -value empty_entry ename = - let p = <:patt< $lid:ename$ >> in - let e = - <:expr< - fun strm__ -> - raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >> - in - [Some (p, e)] -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry entry = - match entry.edesc with - [ Dlevels elev -> continue_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry_again entry = - if strict_parsing.val then [] - else - match entry.edesc with - [ Dlevels ([_; _ :: _] as levs) -> - [continue_parser_of_levels_again entry levs] - | _ -> [] ] -; - -value rec list_alternate l1 l2 = - match (l1, l2) with - [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2] - | ([], l2) -> l2 - | (l1, []) -> l1 ] -; - -value compile_entry entry = - let pel1 = start_parser_of_entry entry in - let pel2 = continue_parser_of_entry entry in - let pel = list_alternate pel1 pel2 in - List.fold_right - (fun pe list -> - match pe with - [ Some pe -> [pe :: list] - | None -> list ]) - pel (continue_parser_of_entry_again entry) -; - -(* get all entries connected together *) - -value rec scan_tree list = - fun - [ Node {node = n; son = son; brother = bro} -> - let list = scan_symbol list n in - let list = scan_tree list son in - let list = scan_tree list bro in - list - | LocAct _ _ | DeadEnd -> list ] -and scan_symbol list = - fun - [ Snterm e -> scan_entry list e - | Snterml e l -> scan_entry list e - | Slist0 s -> scan_symbol list s - | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep - | Slist1 s -> scan_symbol list s - | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep - | Sopt s -> scan_symbol list s - | Stree t -> scan_tree list t - | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ] -and scan_level list lev = - let list = scan_tree list lev.lsuffix in - let list = scan_tree list lev.lprefix in - list -and scan_levels list levs = List.fold_left scan_level list levs -and scan_entry list entry = - if List.memq entry list then list - else - match entry.edesc with - [ Dlevels levs -> scan_levels [entry :: list] levs - | Dparser _ -> list ] -; - -value all_entries_in_graph list entry = - List.rev (scan_entry list entry) -; - -(* main *) - -value entries = ref []; - -value rec list_mem_right_assoc x = - fun - [ [] -> False - | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ] -; - -value rec expr_list = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [$str:String.escaped x$ :: $expr_list l$] >> ] -; - -value compile () = - let _ = do { keywords.val := []; } in - let list = List.fold_left all_entries_in_graph [] entries.val in - let list = - List.filter (fun e -> List.memq e list) entries.val @ - List.filter (fun e -> not (List.memq e entries.val)) list - in - let list = - let set = ref [] in - List.fold_right - (fun entry list -> - if List.mem entry.ename set.val then - list - else do { set.val := [entry.ename :: set.val]; [entry :: list] }) - list [] - in - let pell = List.map compile_entry list in - let pel = List.flatten pell in - let si1 = <:str_item< value rec $list:pel$ >> in - let si2 = - let list = List.sort compare keywords.val in - <:str_item< - List.iter (fun kw -> P.lexer.Token.tok_using ("", kw)) - $expr_list list$ - >> - in - let loc = (1, 1) in - ([(si1, loc); (si2, loc)], False) -; - -Pcaml.parse_implem.val := fun _ -> compile (); - -Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing) - "Don't generate error recovering by trying continuations or first levels" -; diff --git a/camlp4/compile/compile.sh b/camlp4/compile/compile.sh deleted file mode 100755 index 1e86d6f7eb..0000000000 --- a/camlp4/compile/compile.sh +++ /dev/null @@ -1,27 +0,0 @@ -#!/bin/sh -e - -ARGS= -FILES= -ENTRIES= -while test "" != "$1"; do - case $1 in - -e) - shift; - if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi - ENTRIES="$ENTRIES$1";; - *.ml*) FILES="$FILES $1";; - *) ARGS="$ARGS $1";; - esac - shift -done - -cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml -echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml -> tmp.mli -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli -$OTOP/boot/ocamlrun$EXE ../meta/camlp4r$EXE -I ../meta pa_extend.cmo q_MLast.cmo -meta_action tmp.ml -o tmp.ppo -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo -rm tmp.ppo -> tmp.null -$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null -rm tmp.* diff --git a/camlp4/config/.cvsignore b/camlp4/config/.cvsignore deleted file mode 100644 index f9761cda36..0000000000 --- a/camlp4/config/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -Makefile.cnf -Makefile diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf deleted file mode 100644 index 379f338507..0000000000 --- a/camlp4/config/Makefile-nt.cnf +++ /dev/null @@ -1,7 +0,0 @@ -EXE=.exe -OPT= -OTOP=../.. -OLIBDIR=$(OTOP)/boot -BINDIR=C:/ocaml/bin -LIBDIR=C:/ocaml/lib -MANDIR=C:/ocaml/man diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl deleted file mode 100644 index 0602525a62..0000000000 --- a/camlp4/config/Makefile.tpl +++ /dev/null @@ -1,28 +0,0 @@ -# $Id$ - -CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh -OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh -OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh -OCAMLCFLAGS= -MKDIR=mkdir -p - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppi - $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi - rm -f $*.ppi - -.ml.cmo: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - -.ml.cmx: - @if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - diff --git a/camlp4/config/config.mpw b/camlp4/config/config.mpw deleted file mode 100644 index 08fe278d4c..0000000000 --- a/camlp4/config/config.mpw +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set -e P4LIBDIR "{LIBDIR}camlp4:" -set -e MANDIR "{mpw}" -set -e OTOP "`directory `:" -set -e OLIBDIR "{OTOP}boot:" - -set -e CAMLP4_COMM ::tools:camlp4_comm.mpw -set -e OCAMLC ::tools:ocamlc.mpw - -set -e defrules "¶n¶ -.cmi Ä .mli ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.mli -o ¶{depdir¶}¶{default¶}.ppi ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -intf ¶{depdir¶}¶{default¶}.ppi ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppi ¶n¶ -¶n¶ -.cmo Ä .ml ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.ml -o ¶{depdir¶}¶{default¶}.ppo ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -impl ¶{depdir¶}¶{default¶}.ppo ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppo ¶n¶ -¶n¶ -.cmi Ä .cmo ¶n¶ - set status 0 ¶n¶ -¶n¶ -clean ÄÄ ¶n¶ - begin ¶n¶ - delete -i Å.cm[ioa] || set status 0 ¶n¶ - delete -i Å.pp[io] || set status 0 ¶n¶ - delete -i Å.bak || set status 0 ¶n¶ - end ³ dev:null ¶n¶ -" - -set -e dependrule "¶n¶ -depend Ķn¶ - duplicate -y Makefile.Mac.depend Makefile.Mac.depend.bak || set status 0¶n¶ - for i in Å.mliÇ0,1ȶn¶ - ::tools:apply.mpw pr_depend.cmo -- ¶{INCLUDES¶} ¶{i¶}¶n¶ - end > Makefile.Mac.depend¶n¶ -" diff --git a/camlp4/config/configure_batch b/camlp4/config/configure_batch deleted file mode 100755 index 49b3dafca5..0000000000 --- a/camlp4/config/configure_batch +++ /dev/null @@ -1,113 +0,0 @@ -#! /bin/sh -# $Id$ - -prefix=/usr/local -bindir='' -libdir='' -mandir='' -ocaml_top=../ocaml_stuff - -# Parse command-line arguments - -while : ; do - case "$1" in - "") break;; - -prefix|--prefix) - prefix=$2; shift;; - -bindir|--bindir) - bindir=$2; shift;; - -libdir|--libdir) - libdir=$2; shift;; - -mandir|--mandir) - mandir=$2; shift;; - -ocaml-top) - ocaml_top=$2; shift;; - *) echo "Unknown option \"$1\"." 1>&2; exit 2;; - esac - shift -done - -# Sanity checks - -case "$prefix" in - /*) ;; - *) echo "The -prefix directory must be absolute." 1>&2; exit 2;; -esac -case "$bindir" in - /*) ;; - "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; -esac -case "$libdir" in - /*) ;; - "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; -esac -case "$mandir" in - /*) ;; - "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; -esac - -# Generate the files - -rm -f Makefile.cnf -touch Makefile.cnf - -# Check Ocaml - -for i in utils parsing otherlibs/dynlink; do - if test ! -d "$ocaml_top/$i"; then - echo "Bad value $ocaml_top for option -ocaml-top" - echo "There is no directory $ocaml_top/$i" - echo "Configuration script failed" - exit 1 - fi -done - -echo "EXE=$EXE" >> Makefile.cnf -echo "O=o" >> Makefile.cnf -echo "A=a" >> Makefile.cnf -echo "OPT=" >> Makefile.cnf -echo "OTOP=$ocaml_top" >> Makefile.cnf - -if test "$ocaml_top" = "../ocaml_stuff"; then - if ocamlc -v >/dev/null 2>&1; then - : - else - echo "You need the command ocamlc accessible in the path!" - echo "Configuration script failed!" - exit 1 - fi - OLIBDIR=`ocamlc -where` - echo "OLIBDIR=$OLIBDIR" >> Makefile.cnf -else - echo "OLIBDIR=\$(OTOP)/boot" >> Makefile.cnf -fi - -# Where to install - -echo "PREFIX=$prefix" >> Makefile.cnf -case "$bindir" in - "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile.cnf - bindir="$prefix/bin";; - *) echo "BINDIR=$bindir" >> Makefile.cnf;; -esac -case "$libdir" in - "") echo 'LIBDIR=$(PREFIX)/lib/camlp4' >> Makefile.cnf - libdir="$prefix/lib/camlp4";; - *) echo "LIBDIR=$libdir" >> Makefile.cnf;; -esac -case "$mandir" in - "") echo 'MANDIR=$(PREFIX)/man/man1' >> Makefile.cnf - mandir="$prefix/man/man1";; - *) echo "MANDIR=$mandir" >> Makefile.cnf;; -esac - -rm -f Makefile -cat Makefile.tpl > Makefile -cat Makefile.cnf >> Makefile - -echo "Resulting configuration file (Makefile.cnf):" -echo -cat Makefile.cnf diff --git a/camlp4/etc/.cvsignore b/camlp4/etc/.cvsignore deleted file mode 100644 index 92c764cac9..0000000000 --- a/camlp4/etc/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.cm[oia] -camlp4o -camlp4sch -camlp4o.opt -mkcamlp4.sh -mkcamlp4.mpw diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend deleted file mode 100644 index 8191673978..0000000000 --- a/camlp4/etc/.depend +++ /dev/null @@ -1,73 +0,0 @@ -parserify.cmi: ../camlp4/mLast.cmi -pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_format.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_format.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_fstream.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_fstream.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lefteval.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lefteval.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lisp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lisp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \ - $(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/lex/syntax.cmi -pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \ - $(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \ - $(OTOP)/lex/syntax.cmx -pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -parserify.cmo: ../camlp4/mLast.cmi parserify.cmi -parserify.cmx: ../camlp4/mLast.cmi parserify.cmi -pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_schemer.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_schemer.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_sml.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_sml.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pr_depend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_null.cmo: ../camlp4/pcaml.cmi -pr_null.cmx: ../camlp4/pcaml.cmx -pr_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_op_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - ../camlp4/spretty.cmi -pr_op_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - ../camlp4/spretty.cmx -pr_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - ../camlp4/spretty.cmi -pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - ../camlp4/spretty.cmx -pr_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/spretty.cmi -pr_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/spretty.cmx -pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \ - pr_scheme.cmo -pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \ - pr_scheme.cmx -q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile deleted file mode 100644 index 070fa00b47..0000000000 --- a/camlp4/etc/Makefile +++ /dev/null @@ -1,107 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_scheme.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo -OBJSX=$(OBJS:.cmo=.cmx) -INTF=pa_o.cmi -CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo -CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx) -CAMLP4SCHM=pa_scheme.cmo ../meta/pr_dump.cmo -SHELL=/bin/sh -COUT=$(OBJS) camlp4o$(EXE) camlp4sch$(EXE) -COPT=$(OBJSX) camlp4o.opt - -all: $(COUT) mkcamlp4.sh -opt: $(COPT) - -pr_rp.cmo: parserify.cmo pr_rp_main.cmo - $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ - -pr_op.cmo: parserify.cmo pr_op_main.cmo - $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ - -pr_schemep.cmo: parserify.cmo pr_schp_main.cmo - $(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@ - -pr_rp.cmx: parserify.cmx pr_rp_main.cmx - $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o $@ - -pr_op.cmx: parserify.cmx pr_op_main.cmx - $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o $@ - -pr_schemep.cmx: parserify.cmx pr_schp_main.cmx - $(OCAMLOPT) parserify.cmx pr_schp_main.cmx -a -o $@ - -camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) - rm -f camlp4o$(EXE) - cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" - -camlp4sch$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4SCHM) - rm -f camlp4sch$(EXE) - cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4sch$(EXE) CAMLP4M="-I ../etc $(CAMLP4SCHM)" - -camlp4o.opt: $(CAMLP4OMX) - rm -f camlp4o.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" - -mkcamlp4.sh: mkcamlp4.sh.tpl - sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh - -pa_ocamllex.cma: pa_ocamllex.cmo - $(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma - -bootstrap_scheme: - @$(MAKE) bootstrap_l L=scheme | grep -v directory -compare_scheme: - @$(MAKE) compare_l L=scheme | grep -v directory -bootstrap_lisp: - @$(MAKE) bootstrap_l L=lisp | grep -v directory -compare_lisp: - @$(MAKE) compare_l L=lisp | grep -v directory - -bootstrap_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp - mv pa_$Lr.ml pa_$Lr.ml.old - sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' tmp > pa_$Lr.ml - rm -f tmp - -compare_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml - - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp $(INTF) "$(LIBDIR)/camlp4/." - cp lib.sml "$(LIBDIR)/camlp4/." - cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/." - if test -f camlp4o.opt; then cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; cp $(OBJSX) $(OBJSX:.cmx=.o) "$(LIBDIR)/camlp4/."; fi - cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" - chmod a+x "$(BINDIR)/mkcamlp4" - -pa_lisp.cmo: pa_lispr.cmo -pa_scheme.cmo: pa_schemer.cmo -pa_ocamllex.cmo: pa_o.cmo -pr_extend.cmo: pa_extfun.cmo -pr_o.cmo: pa_extfun.cmo -pr_op.cmo: pa_extfun.cmo -pr_r.cmo: pa_extfun.cmo -pr_rp.cmo: pa_extfun.cmo - -include .depend diff --git a/camlp4/etc/Makefile.Mac b/camlp4/etc/Makefile.Mac deleted file mode 100644 index 27c793fe39..0000000000 --- a/camlp4/etc/Makefile.Mac +++ /dev/null @@ -1,71 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -OCAMLCFLAGS = {INCLUDES} -OBJS = q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo ¶ - pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo spa_lefteval.cmo ¶ - pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo ¶ - pr_extfun.cmo pr_null.cmo pr_depend.cmo -INTF = pa_o.cmi -CAMLP4OM = pa_o.cmo pa_op.cmo ::meta:pr_dump.cmo -OUT = {OBJS} camlp4o - -all Ä {OUT} mkcamlp4.mpw - -camlp4o Ä ::camlp4:camlp4 {CAMLP4OM} - delete -i camlp4o - directory ::camlp4: - domake -d CAMLP4=::etc:camlp4o -d CAMLP4M="-I ::etc: {CAMLP4OM}" - directory ::etc: - -mkcamlp4.mpw Ä mkcamlp4.mpw.tpl - streamedit -e "1,$ replace -c ° /OLIBDIR/ ¶"`quote "{OLIBDIR}"`¶"" ¶ - -e "1,$ replace -c ° /LIBDIR/ ¶"`quote "{P4LIBDIR}"`¶"" ¶ - mkcamlp4.mpw.tpl > mkcamlp4.mpw - -bootstrap_lisp Ä $OutOfDate - ::boot:camlp4 :pa_lispr.cmo -I ::boot: pa_extend.cmo q_MLast.cmo ¶ - :pr_r.cmo :pr_extend.cmo :pr_rp.cmo -phony_quot pa_lisp.ml ¶ - | streamedit -e '1,$ replace /¥;; (Å)¨0°/ "(* " ¨0 " *)"' ¶ - -e "1,$ replace /'./pa_lispr.cmo'/ 'pa_r.cmo pa_rp.cmo'" >tmp - rename -y pa_lispr.ml pa_lispr.ml.old - rename -y tmp pa_lispr.ml - -compare_lisp Ä $OutOfDate - set status 0 - -clean ÄÄ - delete -i mkcamlp4.mpw camlp4o - -{dependrule} - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y {INTF} "{P4LIBDIR}" - duplicate -y lib.sml "{P4LIBDIR}" - duplicate -y camlp4o "{BINDIR}" - duplicate -y mkcamlp4.mpw "{BINDIR}mkcamlp4" - -{defrules} - -pa_lisp.cmoÄ pa_lispr.cmo -pr_extend.cmoÄ pa_extfun.cmo -pr_o.cmoÄ pa_extfun.cmo -pr_op.cmoÄ pa_extfun.cmo -pr_r.cmoÄ pa_extfun.cmo -pr_rp.cmoÄ pa_extfun.cmo diff --git a/camlp4/etc/Makefile.Mac.depend b/camlp4/etc/Makefile.Mac.depend deleted file mode 100644 index c8007dcb7f..0000000000 --- a/camlp4/etc/Makefile.Mac.depend +++ /dev/null @@ -1,40 +0,0 @@ -pa_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_format.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_format.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_fstream.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_fstream.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lisp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lisp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_lispr.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_lispr.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_olabl.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_olabl.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_oop.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_oop.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_ru.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_ru.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_sml.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_sml.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_depend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pr_depend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pr_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_extfun.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_extfun.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_null.cmoÄ ::camlp4:pcaml.cmi -pr_null.cmxÄ ::camlp4:pcaml.cmx -pr_o.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_o.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_op.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_op.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -pr_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:spretty.cmi -pr_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:spretty.cmx -q_phony.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_phony.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/etc/lib.sml b/camlp4/etc/lib.sml deleted file mode 100644 index a9d05fe04b..0000000000 --- a/camlp4/etc/lib.sml +++ /dev/null @@ -1,384 +0,0 @@ -(* $Id$ *) - -datatype 'a option = SOME of 'a | NONE -exception Fail of string -exception Domain -exception Subscript -type 'a vector = 'a array - -structure OCaml = - struct - structure List = List - structure String = String - end - -structure Time = - struct - datatype time = TIME of { sec : int, usec : int } - fun toString _ = failwith "not implemented Time.toString" - fun now _ = failwith "not implemented Time.now" - end - -datatype cpu_timer = - CPUT of { gc : Time.time, sys : Time.time, usr : Time.time } - -datatype real_timer = - RealT of Time.time - -structure Char = - struct - val ord = Char.code - end - -structure General = - struct - datatype order = LESS | EQUAL | GREATER - end -type order = General.order == LESS | EQUAL | GREATER - -structure OS = - struct - exception SysErr - structure Path = - struct - fun dir s = - let val r = Filename.dirname s in - if r = "." then "" else r - end - val file = Filename.basename - fun ext s = - let fun loop i = - if i < 0 then NONE - else if String.get s i = #"." then - let val len = String.length s - i - 1 in - if len = 0 then NONE else SOME (String.sub s (i + 1) len) - end - else loop (i - 1) - in - loop (String.length s - 1) - end - fun splitDirFile s = - {dir = Filename.dirname s, - file = Filename.basename s} - fun joinDirFile x = - let val {dir,file} = x in Filename.concat dir file end - end - structure FileSys = - struct - datatype access_mode = A_READ | A_WRITE | A_EXEC - val chDir = Sys.chdir - fun isDir s = - (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR - handle Unix.Unix_error _ => raise SysErr - fun access (s, accs) = - let val st = Unix.stat s - val prm = st ocaml_record_access Unix.st_perm - val prm = - if st ocaml_record_access Unix.st_uid = Unix.getuid () then - lsr prm 6 - else if st ocaml_record_access Unix.st_uid = Unix.getgid () - then - lsr prm 3 - else prm - val rf = - if List.mem A_READ accs then land prm 4 <> 0 else true - val wf = - if List.mem A_WRITE accs then land prm 2 <> 0 else true - val xf = - if List.mem A_EXEC accs then land prm 1 <> 0 else true - in - rf andalso wf andalso xf - end - handle Unix.Unix_error (_, f, _) => - if f = "stat" then false else raise SysErr - end - structure Process = - struct - fun system s = (flush stdout; flush stderr; Sys.command s) - fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE - val success = 0 - end - end - -exception SysErr = OS.SysErr - -structure IO = - struct - exception Io of {cause:exn, function:string, name:string} - end - -structure TextIO = - struct - type instream = in_channel * char option option ref - type outstream = out_channel - type elem = char - type vector = string - fun openIn fname = - (open_in fname, ref NONE) handle exn => - raise IO.Io {cause = exn, function = "openIn", name = fname} - val openOut = open_out - fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) - val closeOut = close_out - val stdIn = (stdin, ref NONE) - fun endOfStream (ic, _) = pos_in ic = in_channel_length ic - fun inputLine (ic, ahc) = - case !ahc of - NONE => - (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) - | SOME NONE => "" - | SOME (SOME c) => - (ahc := NONE; - if c = #"\n" then "\n" - else - String.make 1 c ^ input_line ic ^ "\n" handle - End_of_file => (ahc := SOME NONE; "")) - fun input1 (ic, ahc) = - case !ahc of - NONE => - (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE)) - | SOME NONE => NONE - | SOME x => (ahc := NONE; x) - fun inputN (ins, n) = - let fun loop n = - if n <= 0 then "" - else - case input1 ins of - SOME c => String.make 1 c ^ loop (n - 1) - | NONE => "" - in - loop n - end - fun output (oc, v) = output_string oc v - fun inputAll ic = failwith "not implemented TextIO.inputAll" - fun lookahead (ic, ahc) = - case !ahc of - NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end - | SOME x => x - fun print s = (print_string s; flush stdout) - end - -structure Timer = - struct - fun startRealTimer () = failwith "not implemented Timer.startRealTimer" - fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer" - fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer" - fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer" - end - -structure Date = - struct - datatype month = - Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec - datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat - datatype date = - DATE of - {day : int, hour : int, isDst : bool option, minute : int, - month : month, offset : int option, second : int, wday : wday, - yday : int, year : int} - fun fmt _ _ = failwith "not implemented Date.fmt" - fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal" - end - -structure Posix = - struct - structure ProcEnv = - struct - fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE - end - end - -structure SMLofNJ = - struct - fun exportML s = failwith ("not implemented exportML " ^ s) - end - -fun null x = x = [] -fun explode s = - let fun loop i = - if i = String.length s then [] - else String.get s i :: loop (i + 1) - in - loop 0 - end - -val app = List.iter -fun implode [] = "" - | implode (c :: l) = String.make 1 c ^ implode l - -fun ooo f g x = f (g x) - -structure Array = - struct - fun array (len, v) = Array.create len v - fun sub _ = failwith "not implemented Array.sub" - fun update _ = failwith "not implemented Array.update" - (* for make the profiler work *) - val set = Array.set - val get = Array.get - end - -structure Vector = - struct - fun tabulate _ = failwith "not implemented Vector.tabulate" - fun sub _ = failwith "not implemented Vector.sub" - end - -structure Bool = - struct - val toString = string_of_bool - end - -structure String = - struct - val size = String.length - fun substring (s, beg, len) = - String.sub s beg len handle Invalid_argument _ => raise Subscript - val concat = String.concat "" - fun sub (s, i) = String.get s i - val str = String.make 1 - fun compare (s1, s2) = - if s1 < s2 then LESS - else if s1 > s2 then GREATER - else EQUAL - fun isPrefix s1 s2 = - let fun loop i1 i2 = - if i1 >= String.length s1 then true - else if i2 >= String.length s2 then false - else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1) - else false - in - loop 0 0 - end - fun tokens p s = - let fun loop tok i = - if i >= String.length s then - if tok = "" then [] else [tok] - else if p (String.get s i) then - if tok <> "" then tok :: loop "" (i + 1) - else loop "" (i + 1) - else loop (tok ^ String.make 1 (String.get s i)) (i + 1) - in - loop "" 0 - end - fun extract _ = failwith "not implemented String.extract" - end - -structure Substring = - struct - type substring = string * int * int - fun string (s : substring) = String.substring s - fun all s : substring = (s, 0, String.size s) - fun splitl f ((s, beg, len) : substring) : substring * substring = - let fun loop di = - if di = len then ((s, beg, len), (s, 0, 0)) - else if f (String.sub (s, beg + di)) then loop (di + 1) - else ((s, beg, di), (s, beg + di, len - di)) - in - loop 0 - end - fun getc (s, i, len) = - if len > 0 andalso i < String.size s then - SOME (String.sub (s, i), (s, i+1, len-1)) - else NONE - fun slice _ = failwith "not implemented: Substring.slice" - fun isEmpty (s, beg, len) = len = 0 - fun concat sl = String.concat (List.map string sl) - end -type substring = Substring.substring - -structure StringCvt = - struct - datatype radix = BIN | OCT | DEC | HEX - type ('a, 'b) reader = 'b -> ('a * 'b) option - end - -structure ListPair = - struct - fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2) - | zip _ = [] - val unzip = List.split - fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2) - | all _ _ = true - fun map f (a1::l1, a2::l2) = - let val r = f (a1, a2) in r :: map f (l1, l2) end - | map _ _ = [] - end - -structure ListMergeSort = - struct - fun uniqueSort cmp l = - List.sort - (fn x => fn y => - case cmp (x, y) of - LESS => ~1 - | EQUAL => 0 - | GREATER => 1) - l - end - -structure List = - struct - exception Empty - fun hd [] = raise Empty - | hd (x :: l) = x - fun tl [] = raise Empty - | tl (x :: l) = l - fun foldr f a l = - let fun loop a [] = a - | loop a (x :: l) = loop (f (x, a)) l - in - loop a (List.rev l) - end - fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l - val concat = List.flatten - val exists = List.exists - val filter = List.filter - val length = List.length - val map = List.map - val rev = List.rev - val all = List.for_all - fun find f [] = NONE - | find f (x :: l) = if f x then SOME x else find f l - fun last s = - case List.rev s of - [] => raise Empty - | x :: _ => x - fun take _ = failwith "not implemented: List.take" - fun partition _ = failwith "not implemented: List.partition" - fun mapPartial f [] = [] - | mapPartial f (x :: l) = - case f x of - NONE => mapPartial f l - | SOME y => y :: mapPartial f l - fun op @ l1 l2 = List.rev_append (List.rev l1) l2 - end - -structure Int = - struct - type int1 = int - type int = int1 - val toString = string_of_int - fun fromString s = SOME (int_of_string s) handle Failure _ => NONE - fun min (x, y) = if x < y then x else y - fun max (x, y) = if x > y then x else y - fun scan radix getc src = failwith "not impl: Int.scan" - end - -val foldr = List.foldr -val exists = List.exists -val size = String.size -val substring = String.substring -val concat = String.concat -val length = List.length -val op @ = List.op @ -val hd = List.hd -val tl = List.tl -val map = List.map -val rev = List.rev -val use_hook = ref (fn (s : string) => failwith "no defined directive use") -fun use s = !use_hook s -fun isSome (SOME _) = true - | isSome NONE = false -fun valOf (SOME x) = x - | valOf NONE = failwith "valOf" -val print = TextIO.print diff --git a/camlp4/etc/mkcamlp4.mpw.tpl b/camlp4/etc/mkcamlp4.mpw.tpl deleted file mode 100644 index 6b174bf6a9..0000000000 --- a/camlp4/etc/mkcamlp4.mpw.tpl +++ /dev/null @@ -1,33 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set OLIB OLIBDIR -set LIB LIBDIR - -set INTERFACES "" -set OPTS "" -set INCL "-I :" - -loop - exit if "{1}" == "" - if "{1}" == "-I" - set INCL "{INCL} -I `quote "{2}"`" - shift - else if "{1}" =~ /([Â:])¨0([Â:]*)¨1.cmi/ - set first `echo {¨0} | translate a-z A-Z` - set INTERFACES "{INTERFACES} {first}{¨1}" - else - set OPTS "{OPTS} `quote "{1}"`" - end - shift -end diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl deleted file mode 100755 index 50c3ea61a7..0000000000 --- a/camlp4/etc/mkcamlp4.sh.tpl +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/sh -# $Id$ - -OLIB="`ocamlc -where`" -LIB="LIBDIR/camlp4" - -INTERFACES= -OPTS= -INCL="-I ." -while test "" != "$1"; do - case "$1" in - -I) INCL="$INCL -I $2"; shift;; - *) - j=`basename "$1" .cmi` - if test "$j.cmi" = "$1"; then - first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`" - rest="`expr "$j" : '.\(.*\)'`" - INTERFACES="$INTERFACES $first$rest" - else - OPTS="$OPTS $1" - fi;; - esac - shift -done - -CRC=crc_$$ -set -e -trap 'rm -f $CRC.ml $CRC.cmi $CRC.cmo' 0 2 -$OLIB/extract_crc -I $OLIB $INCL $INTERFACES > $CRC.ml -echo "let _ = Dynlink.add_available_units crc_unit_list" >> $CRC.ml -ocamlc -I $LIB odyl.cma camlp4.cma $CRC.ml $INCL $OPTS odyl.cmo -linkall -rm -f $CRC.ml $CRC.cmi $CRC.cmo - diff --git a/camlp4/etc/pa_extfold.ml b/camlp4/etc/pa_extfold.ml deleted file mode 100644 index 0c272c4d0c..0000000000 --- a/camlp4/etc/pa_extfold.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -open Pcaml; -open Pa_extend; - -value sfold loc n foldfun f e s = - let styp = STquo loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = STapp loc (STapp loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in - {used = s.used; text = TXmeta loc n [s.text] e t; styp = styp} -; - -value sfoldsep loc n foldfun f e s sep = - let styp = STquo loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = - STapp loc (STapp loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp - in - {used = s.used @ sep.used; text = TXmeta loc n [s.text; sep.text] e t; - styp = styp} -; - -EXTEND - GLOBAL: symbol; - symbol: LEVEL "top" - [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> - sfold loc "FOLD0" "sfold0" f e s - | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> - sfold loc "FOLD1" "sfold1" f e s - | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; - UIDENT "SEP"; sep = symbol -> - sfoldsep loc "FOLD0 SEP" "sfold0sep" f e s sep - | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; - UIDENT "SEP"; sep = symbol -> - sfoldsep loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] - ; - simple_expr: - [ [ i = LIDENT -> <:expr< $lid:i$ >> - | "("; e = expr; ")" -> e ] ] - ; -END; diff --git a/camlp4/etc/pa_extfun.ml b/camlp4/etc/pa_extfun.ml deleted file mode 100644 index 5cab09a2bb..0000000000 --- a/camlp4/etc/pa_extfun.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* 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; diff --git a/camlp4/etc/pa_format.ml b/camlp4/etc/pa_format.ml deleted file mode 100644 index 3c8deea472..0000000000 --- a/camlp4/etc/pa_format.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* 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; diff --git a/camlp4/etc/pa_fstream.ml b/camlp4/etc/pa_fstream.ml deleted file mode 100644 index 9a2faebc80..0000000000 --- a/camlp4/etc/pa_fstream.ml +++ /dev/null @@ -1,163 +0,0 @@ -(* 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; diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml deleted file mode 100644 index bc80a7d557..0000000000 --- a/camlp4/etc/pa_ifdef.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id$ *) - -(* This module is deprecated since version 3.07; use pa_macro.ml instead *) - -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 ["OCAML_307"; "OCAML_305"; "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." -; diff --git a/camlp4/etc/pa_lefteval.ml b/camlp4/etc/pa_lefteval.ml deleted file mode 100644 index e96e8d34f5..0000000000 --- a/camlp4/etc/pa_lefteval.ml +++ /dev/null @@ -1,239 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -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 - failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">") -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -(* generating let..in before functions calls which evaluates - several (more than one) of their arguments *) - -value no_side_effects_ht = - let ht = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add ht s True) - ["<"; "="; "@"; "^"; "+"; "-"; "ref"]; - ht - } -; - -value no_side_effects = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$ . $uid:_$ >> -> True - | <:expr< $lid:s$ >> -> - try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ] - | _ -> False ] -; - -value rec may_side_effect = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | - <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> -> - False - | <:expr< ($list:el$) >> -> List.exists may_side_effect el - | <:expr< $_$ $_$ >> as e -> - let (f, el) = expr_fa [] e in - not (no_side_effects f) || List.exists may_side_effect el - | _ -> True ] -; - -value rec may_be_side_effect_victim = - fun - [ <:expr< $lid:_$ . $_$ >> -> True - | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e - | _ -> False ] -; - -value rec may_depend_on_order el = - loop False False el where rec loop - side_effect_found side_effect_victim_found = - fun - [ [e :: el] -> - if may_side_effect e then - if side_effect_found || side_effect_victim_found then True - else loop True True el - else if may_be_side_effect_victim e then - if side_effect_found then True else loop False True el - else loop side_effect_found side_effect_victim_found el - | [] -> False ] -; - -value gen_let_in loc expr el = - let (pel, el) = - loop 0 (List.rev el) where rec loop n = - fun - [ [e :: el] -> - if may_side_effect e || may_be_side_effect_victim e then - if n = 0 then - let (pel, el) = loop 1 el in - (pel, [expr e :: el]) - else - let id = "xxx" ^ string_of_int n in - let (pel, el) = loop (n + 1) el in - ([(<:patt< $lid:id$ >>, expr e) :: pel], - [<:expr< $lid:id$ >> :: el]) - else - let (pel, el) = loop n el in - (pel, [expr e :: el]) - | [] -> ([], []) ] - in - match List.rev el with - [ [e :: el] -> (pel, e, el) - | _ -> assert False ] -; - -value left_eval_apply loc expr e1 e2 = - let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in - if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >> - else - let (pel, e, el) = gen_let_in loc expr [f :: el] in - let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_tuple loc expr el = - if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >> - else - let (pel, e, el) = gen_let_in loc expr el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) - <:expr< ($list:[e :: el]$) >> pel -; - -value left_eval_record loc expr lel = - let el = List.map snd lel in - if not (may_depend_on_order el) then - let lel = List.map (fun (p, e) -> (p, expr e)) lel in - <:expr< { $list:lel$ } >> - else - let (pel, e, el) = gen_let_in loc expr el in - let e = - let lel = List.combine (List.map fst lel) [e :: el] in - <:expr< { $list:lel$ } >> - in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; - -(* scanning the input tree, calling "left_eval_*" functions if necessary *) - -value map_option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value class_infos f ci = - {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir; - MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam; - MLast.ciExp = f ci.MLast.ciExp} -; - -value rec expr x = - let loc = MLast.loc_of_expr x in - match x with - [ <:expr< fun [ $list:pwel$ ] >> -> - <:expr< fun [ $list:List.map match_assoc pwel$ ] >> - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> - | <:expr< let module $s$ = $me$ in $e$ >> -> - <:expr< let module $s$ = $module_expr me$ in $expr e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >> - | <:expr< while $e$ do { $list:el$ } >> -> - <:expr< while $expr e$ do { $list:List.map expr el$ } >> - | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >> - | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >> - | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >> - | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >> - | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> - | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 - | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el - | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel - | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 - | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | - <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< new $list:_$ >> -> - x - | x -> not_impl "expr" x ] -and let_binding (p, e) = (p, expr e) -and match_assoc (p, eo, e) = (p, map_option expr eo, expr e) -and module_expr x = - let loc = MLast.loc_of_module_expr x in - match x with - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >> - | <:module_expr< ($me$ : $mt$) >> -> - <:module_expr< ($module_expr me$ : $mt$) >> - | <:module_expr< struct $list:sil$ end >> -> - <:module_expr< struct $list:List.map str_item sil$ end >> - | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> | - <:module_expr< $uid:_$ >> -> - x ] -and str_item x = - let loc = MLast.loc_of_str_item x in - match x with - [ <:str_item< module $s$ = $me$ >> -> - <:str_item< module $s$ = $module_expr me$ >> - | <:str_item< value $opt:rf$ $list:pel$ >> -> - <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> - | <:str_item< declare $list:sil$ end >> -> - <:str_item< declare $list:List.map str_item sil$ end >> - | <:str_item< class $list:ce$ >> -> - <:str_item< class $list:List.map (class_infos class_expr) ce$ >> - | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >> - | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> | - <:str_item< exception $_$ of $list:_$ = $_$ >> | - <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> -> - x - | x -> not_impl "str_item" x ] -and class_expr x = - let loc = MLast.loc_of_class_expr x in - match x with - [ <:class_expr< object $opt:p$ $list:csil$ end >> -> - <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >> - | x -> not_impl "class_expr" x ] -and class_str_item x = - let loc = MLast.loc_of_class_str_item x in - match x with - [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> - <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> - | <:class_str_item< method $s$ = $e$ >> -> - <:class_str_item< method $s$ = $expr e$ >> - | x -> not_impl "class_str_item" x ] -; - -value parse_implem = Pcaml.parse_implem.val; -value parse_implem_with_left_eval strm = - let (r, b) = parse_implem strm in - (List.map (fun (si, loc) -> (str_item si, loc)) r, b) -; -Pcaml.parse_implem.val := parse_implem_with_left_eval; diff --git a/camlp4/etc/pa_lisp.ml b/camlp4/etc/pa_lisp.ml deleted file mode 100644 index 653baf1ed6..0000000000 --- a/camlp4/etc/pa_lisp.ml +++ /dev/null @@ -1,684 +0,0 @@ -;; 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_gmake - (lambda () - (let ((kwt (Hashtbl.create 89))) - ({} - (Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) - (Token.tok_using (lexer_using kwt)) - (Token.tok_removing (lambda)) - (Token.tok_match Token.default_match) - (Token.tok_text lexer_text) - (Token.tok_comm None))))) - -;; 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 $opt: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 $opt: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 loc1 tpl) - (match se1 - ((Sexpr _ (list (Satom loc Alid n) :: sel)) - (, n loc (List.map type_parameter_se sel))) - ((Satom loc Alid n) - (, n loc (list))) - ((se) - (error se "type declaration"))))) - (list (, (, loc1 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)) - (, loc 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.gram_reinit gram (lexer_gmake ())) - (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)) - -(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) -(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) - -(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 diff --git a/camlp4/etc/pa_lispr.ml b/camlp4/etc/pa_lispr.ml deleted file mode 100644 index fb150e2096..0000000000 --- a/camlp4/etc/pa_lispr.ml +++ /dev/null @@ -1,665 +0,0 @@ -(* 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_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* 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 $opt: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 $opt: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, loc1, tpl) = - match se1 with - [ Sexpr _ [Satom loc Alid n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Satom loc Alid n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, 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] -> (loc, 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.gram_reinit gram (lexer_gmake ()); - 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 -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -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; diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml deleted file mode 100644 index 4f27f5ecc6..0000000000 --- a/camlp4/etc/pa_o.ml +++ /dev/null @@ -1,1293 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -Pcaml.syntax_name.val := "OCaml"; -Pcaml.no_constructors_arity.val := True; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Plexer.dollar_for_antiquotation.val := odfa; - 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 type_declaration; - 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 -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkumin loc f arg = - match (f, arg) with - [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l -> - MLast.ExInt32 loc ("-" ^ n) - | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L -> - MLast.ExInt64 loc ("-" ^ n) - | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n -> - MLast.ExNativeInt loc ("-" ^ n) - | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -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 (MLast.loc_of_expr e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.'; '$']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -value operator_rparen = - Grammar.Entry.of_parser gram "operator_rparen" - (fun strm -> - match Stream.npeek 2 strm with - [ [("", s); ("", ")")] when is_operator s -> - do { Stream.junk strm; Stream.junk strm; s } - | _ -> raise Stream.Failure ]) -; - -value lident_colon = - Grammar.Entry.of_parser gram "lident_colon" - (fun strm -> - match Stream.npeek 2 strm with - [ [("LIDENT", i); ("", ":")] -> - do { Stream.junk strm; Stream.junk strm; i } - | _ -> raise Stream.Failure ]) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="; "??"] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -(* horrible hack to be able to parse class_types *) - -value test_ctyp_minusgreater = - Grammar.Entry.of_parser gram "test_ctyp_minusgreater" - (fun strm -> - let rec skip_simple_ctyp n = - match stream_peek_nth n strm with - [ Some ("", "->") -> n - | Some ("", "[" | "[<") -> - skip_simple_ctyp (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1) - | Some - ("", - "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" | - "_") -> - skip_simple_ctyp (n + 1) - | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) -> - skip_simple_ctyp (n + 1) - | Some _ | None -> raise Stream.Failure ] - and ignore_upto end_kwd n = - match stream_peek_nth n strm with - [ Some ("", prm) when prm = end_kwd -> n - | Some ("", "[" | "[<") -> - ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) - | Some _ -> ignore_upto end_kwd (n + 1) - | None -> raise Stream.Failure ] - in - match Stream.peek strm with - [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1 - | Some ("", "object") -> raise Stream.Failure - | _ -> 1 ]) -; - -value test_label_eq = - Grammar.Entry.of_parser gram "test_label_eq" - (test 1 where rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> - test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ]) -; - -value test_typevar_list_dot = - Grammar.Entry.of_parser gram "test_typevar_list_dot" - (let rec test lev strm = - match stream_peek_nth lev strm with - [ Some ("", "'") -> test2 (lev + 1) strm - | Some ("", ".") -> () - | _ -> raise Stream.Failure ] - and test2 lev strm = - match stream_peek_nth lev strm with - [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm - | _ -> raise Stream.Failure ] - in - test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec is_expr_constr_call = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e - | <:expr< $e$ $_$ >> -> is_expr_constr_call e - | _ -> False ] -; - -value rec constr_expr_arity loc = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity loc e - | <:expr< $e$ $_$ >> -> - if is_expr_constr_call e then - Stdpp.raise_with_loc loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -value rec is_patt_constr_call = - fun - [ <:patt< $uid:_$ >> -> True - | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p - | <:patt< $p$ $_$ >> -> is_patt_constr_call p - | _ -> False ] -; - -value rec constr_patt_arity loc = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity loc p - | <:patt< $p$ $_$ >> -> - if is_patt_constr_call p then - Stdpp.raise_with_loc loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -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 ] -; - -value rec patt_lid = - fun - [ <:patt< $p1$ $p2$ >> -> - match p1 with - [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2]) - | _ -> - match patt_lid p1 with - [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl]) - | None -> None ] ] - | _ -> None ] -; - -value bigarray_get loc arr arg = - let coords = - match arg with - [ <:expr< ($list:el$) >> -> el - | _ -> [arg] ] - in - match coords with - [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >> - | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> - | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> - | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] -; - -value bigarray_set loc var newval = - match var with - [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> -> - Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >> - | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> -> - Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >> - | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> -> - Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >> - | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> -> - Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >> - | _ -> None ] -; - -(* ...works bad... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match cs with parser - [ [: `';' :] -> sync_semisemi cs - | [: :] -> sync cs ] -and sync_semisemi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync_semi cs ] -; -Pcaml.sync.val := sync; -*) - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - mod_expr_ident: - [ LEFTA - [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ] - | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ] - ; - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "module"; "type"; i = UIDENT -> - <:sig_item< module type $i$ = 'abstract >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator_rparen; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp loc i tpl t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - "else"; e3 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else () >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> - match bigarray_set loc e1 e2 with - [ Some e -> e - | None -> <:expr< $e1$ := $e2$ >> ] ] - | "||" RIGHTA - [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >> - | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >> - | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> - | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >> - | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> - | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> - | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> - | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> <:expr< $mkumin loc "-" e$ >> - | "-."; e = SELF -> <:expr< $mkumin loc "-." e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity loc e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = SELF -> - match e with - [ <:expr< False >> -> <:expr< assert False >> - | _ -> <:expr< assert ($e$) >> ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get loc e1 e2 - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "!"; e = SELF -> <:expr< $e$ . val>> - | "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> - | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ] - | "simple" LEFTA - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 loc s - | s = INT64 -> MLast.ExInt64 loc s - | s = NATIVEINT -> MLast.ExNativeInt loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | UIDENT "True" -> <:expr< $uid:" True"$ >> - | UIDENT "False" -> <:expr< $uid:" False"$ >> - | i = expr_ident -> i - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; op = operator_rparen -> <:expr< $lid:op$ >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | "begin"; "end" -> <:expr< () >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (loc, i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | i = UIDENT; "."; j = SELF -> - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:i$ >> j - | i = UIDENT; "."; "("; j = operator_rparen -> - <:expr< $uid:i$ . $lid:j$ >> ] ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity loc p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 loc s - | s = INT64 -> MLast.PaInt64 loc s - | s = NATIVEINT -> MLast.PaNativeInt loc s - | "-"; s = INT -> <:patt< $int:"-" ^ s$ >> - | "-"; s = INT32 -> MLast.PaInt32 loc ("-" ^ s) - | "-"; s = INT64 -> MLast.PaInt64 loc ("-" ^ s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt loc ("-" ^ s) - | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >> - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | UIDENT "True" -> <:patt< $uid:" True"$ >> - | UIDENT "False" -> <:patt< $uid:" False"$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; op = operator_rparen -> <:patt< $lid:op$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "_" -> <:patt< _ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ "private"; "{"; ldl = label_declarations; "}" -> - <:ctyp< private { $list:ldl$ } >> - | "private"; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< private [ $list:cdl$ ] >> - | test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "private"; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == private { $list:ldl$ } >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; "private"; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == private [ $list:cdl$ ] >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> - <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = poly_type -> (loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = poly_type -> (loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "star" - [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = labeled_patt; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> - | p = labeled_patt; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" LEFTA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth loc l True e (Some t) - | "method"; "private"; l = label; sb = fun_binding -> - MLast.CrMth loc l True sb None - | "method"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth loc l False e (Some t) - | "method"; l = label; sb = fun_binding -> - MLast.CrMth loc l False sb None - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> - <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = poly_type -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "simple" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ] - ; - (* Polymorphic types *) - typevar: - [ [ "'"; i = ident -> i ] ] - ; - poly_type: - [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp -> - <:ctyp< ! $list:tpl$ . $t2$ >> - | t = ctyp -> t ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - (* Labels *) - ctyp: LEVEL "arrow" - [ RIGHTA - [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >> - | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i True [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | t = ctyp -> MLast.RfInh t ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | "~"; i = LIDENT -> <:expr< ~ $i$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> - | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> - | "#"; t = mod_ident -> <:patt< # $list:t$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> - <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> - <:patt< ~ $i$ >> - | "~"; i=LIDENT -> <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ")" -> - <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ~ $i$ : ($lid:i$ : $t$) >> - | i = OPTLABEL; j = LIDENT -> - <:patt< ? $i$ : ($lid:j$) >> - | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $p$ = $e$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "="; - e = expr; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> - | i = QUESTIONIDENT -> <:patt< ? $i$ >> - | "?"; i = LIDENT -> <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ = $e$ ) >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ : $t$ = $e$ ) >> - | "?"; "("; i = LIDENT; ")" -> - <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ? ( $lid:i$ : $t$ ) >> ] ] - ; - class_type: - [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; -END; - -(* Main entry points *) - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; OPT ";;" -> (si, loc) ] ] - ; - implem: - [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; OPT ";;" -> (si, loc) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF -> - ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ] - ; -END; - -Pcaml.add_option "-no_quot" (Arg.Set Plexer.no_quotations) - "Don't parse quotations, allowing to use, e.g. \"<:>\" as token"; diff --git a/camlp4/etc/pa_ocamllex.ml b/camlp4/etc/pa_ocamllex.ml deleted file mode 100644 index 76c8c6aea9..0000000000 --- a/camlp4/etc/pa_ocamllex.ml +++ /dev/null @@ -1,344 +0,0 @@ -(* camlp4 ./pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) -(* $Id$ *) -(* Alain Frisch's contribution *) - -open Syntax -open Lexgen -open Compact - -(* Adapted from output.ml *) -(**************************) - -(* Output the DFA tables and its entry points *) - -(* To output an array of short ints, encoded as a string *) - -let output_byte buf b = - Buffer.add_char buf '\\'; - Buffer.add_char buf (Char.chr(48 + b / 100)); - Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10)); - Buffer.add_char buf (Char.chr(48 + b mod 10)) - -let loc = (-1,-1) - -let output_array v = - let b = Buffer.create (Array.length v * 3) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - output_byte b ((v.(i) asr 8) land 0xFF); - if i land 7 = 7 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - -let output_byte_array v = - let b = Buffer.create (Array.length v * 2) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - if i land 15 = 15 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - - - -(* Output the tables *) - -let output_tables tbl = - <:str_item< value lex_tables = { - Lexing.lex_base = $output_array tbl.tbl_base$; - Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$; - Lexing.lex_default = $output_array tbl.tbl_default$; - Lexing.lex_trans = $output_array tbl.tbl_trans$; - Lexing.lex_check = $output_array tbl.tbl_check$; - Lexing.lex_base_code = $output_array tbl.tbl_base_code$; - Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$; - Lexing.lex_default_code = $output_array tbl.tbl_default_code$; - Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$; - Lexing.lex_check_code = $output_array tbl.tbl_check_code$; - Lexing.lex_code = $output_byte_array tbl.tbl_code$ - } >> - -(* Output the entries *) - -let rec make_alias n = function - | [] -> [] - | h::t -> - (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) - -let abstraction = - List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>) - - -let application = - List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>) - -let int i = <:expr< $int:string_of_int i$ >> - -let output_memory_actions acts = - let aux = function - | Copy (tgt, src) -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_mem.($int src$) >> - | Set tgt -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_curr_pos >> - in - <:expr< do { $list:List.map aux acts$ } >> - -let output_base_mem = function - | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >> - | Start -> <:expr< lexbuf.Lexing.lex_start_pos >> - | End -> <:expr< lexbuf.Lexing.lex_curr_pos >> - -let output_tag_access = function - | Sum (a,0) -> output_base_mem a - | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >> - -let rec output_env e = function - | [] -> e - | (x, Ident_string (o,nstart,nend)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ - lexbuf $output_tag_access nstart$ $output_tag_access nend$ - in $output_env e rem$ - >> - | (x, Ident_char (o,nstart)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ - lexbuf $output_tag_access nstart$ - in $output_env e rem$ - >> - -let output_entry e = - let init_num, init_moves = e.auto_initial_state in - let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in - let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in - let call_f = application <:expr< $lid:f$ >> args in - let body_wrapper = - <:expr< - do { - lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; - $output_memory_actions init_moves$; - $call_f$ $int init_num$ - } >> in - let cases = - List.map - (fun (num, env, (loc,e)) -> - <:patt< $int:string_of_int num$ >>, - None, - output_env <:expr< $e$ >> env - (* Note: the <:expr<...>> above is there to set the location *) - ) e.auto_actions @ - [ <:patt< __ocaml_lex_n >>, - None, - <:expr< do - { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] - in - let engine = - if e.auto_mem_size = 0 - then <:expr< Lexing.engine >> - else <:expr< Lexing.new_engine >> in - let body = - <:expr< fun state -> - match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in - [ - <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); - <:patt< $lid:f$ >>, (abstraction args body) - ] - -(* Main output function *) - -exception Table_overflow - -let output_lexdef tables entry_points = - Printf.eprintf - "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" - (Array.length tables.tbl_base) - (Array.length tables.tbl_trans) - (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + - Array.length tables.tbl_default + Array.length tables.tbl_trans + - Array.length tables.tbl_check)); - let size_groups = - (2 * (Array.length tables.tbl_base_code + - Array.length tables.tbl_backtrk_code + - Array.length tables.tbl_default_code + - Array.length tables.tbl_trans_code + - Array.length tables.tbl_check_code) + - Array.length tables.tbl_code) in - if size_groups > 0 then - Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" - size_groups ; - flush stderr; - if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - - let entries = List.map output_entry entry_points in - [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ] - - -(* Adapted from parser.mly and main.ml *) -(***************************************) - -(* Auxiliaries for the parser. *) - -let char s = Char.code (Token.eval_char s) - -let named_regexps = - (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) - -let regexp_for_string s = - let rec re_string n = - if n >= String.length s then Epsilon - else if succ n = String.length s then - Characters (Cset.singleton (Char.code s.[n])) - else - Sequence - (Characters(Cset.singleton (Char.code s.[n])), - re_string (succ n)) - in re_string 0 - -let char_class c1 c2 = Cset.interval c1 c2 - -let all_chars = Cset.all_chars - -let rec remove_as = function - | Bind (e,_) -> remove_as e - | Epsilon|Eof|Characters _ as e -> e - | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) - | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) - | Repetition e -> Repetition (remove_as e) - -let () = - Hashtbl.add named_regexps "eof" (Characters Cset.eof) - -(* The parser *) - -let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let" -let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header" -let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef" - -EXTEND - GLOBAL: Pcaml.str_item let_regexp header lexer_def; - - let_regexp: [ - [ x = LIDENT; "="; r = regexp -> - if Hashtbl.mem named_regexps x then - Printf.eprintf - "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" - x; - Hashtbl.add named_regexps x r; - ] - ]; - - lexer_def: [ - [ def = LIST0 definition SEP "and" -> - (try - let (entries, transitions) = make_dfa def in - let tables = compact_tables transitions in - let output = output_lexdef tables entries in - <:str_item< declare $list: output$ end >> - with - |Table_overflow -> - failwith "Transition table overflow in lexer, automaton is too big" - | Lexgen.Memory_overflow -> - failwith "Position memory overflow in lexer, too many as variables") - ] - ]; - - - Pcaml.str_item: [ - [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d - | "pa_ocamllex"; "let"; let_regexp -> - <:str_item< declare $list: []$ end >> - ] - ]; - - definition: [ - [ x=LIDENT; pl = LIST0 Pcaml.patt; "="; - short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; - OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> - { name=x ; shortest=short ; args=pl ; clauses = l } ] - ]; - - action: [ - [ "{"; e = OPT Pcaml.expr; "}" -> - let e = match e with - | Some e -> e - | None -> <:expr< () >> - in - (loc,e) - ] - ]; - - header: [ - [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> - [<:str_item< declare $list:e$ end>>, loc] ] - | [ -> [] ] - ]; - - regexp: [ - [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ] - | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ] - | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ] - | [ r = regexp; "*" -> Repetition r - | r = regexp; "+" -> Sequence(Repetition (remove_as r), r) - | r = regexp; "?" -> Alternative(Epsilon, r) - | "("; r = regexp; ")" -> r - | "_" -> Characters all_chars - | c = CHAR -> Characters (Cset.singleton (char c)) - | s = STRING -> regexp_for_string (Token.eval_string s) - | "["; cc = ch_class; "]" -> Characters cc - | x = LIDENT -> - try Hashtbl.find named_regexps x - with Not_found -> - failwith - ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") - ] - ]; - - ch_class: [ - [ "^"; cc = ch_class -> Cset.complement cc] - | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2) - | c = CHAR -> Cset.singleton (char c) - | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2 - ] - ]; -END - -(* We have to be careful about "rule"; in standalone mode, - it is used as a keyword (otherwise, there is a conflict - with named regexp); in normal mode, it is used as LIDENT - (we do not want to reserve such an useful identifier). - - Plexer does not like identifiers used as keyword _and_ - as LIDENT ... -*) - -let standalone = - let already = ref false in - fun () -> - if not (!already) then - begin - already := true; - Printf.eprintf "pa_ocamllex: stand-alone mode\n"; - - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END; - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END; - let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in - EXTEND GLOBAL: ocamllex let_regexp header lexer_def; - ocamllex: [ - [ h = header; - l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)]; - t = header; EOI -> h @ (l :: t) ,false - ] - ]; - END; - Pcaml.parse_implem := Grammar.Entry.parse ocamllex - end - -let () = - Pcaml.add_option "-ocamllex" (Arg.Unit standalone) - "Activate (standalone) ocamllex emulation mode." - diff --git a/camlp4/etc/pa_olabl.ml b/camlp4/etc/pa_olabl.ml deleted file mode 100644 index d43b499dfd..0000000000 --- a/camlp4/etc/pa_olabl.ml +++ /dev/null @@ -1,2005 +0,0 @@ -(* 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$ *) - -module Plexer = - struct - open Stdpp; - open Token; - 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 mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get_buff len = String.sub buff.val 0 len; - value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] - and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] - and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | - '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | - '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | - '|' | '~' | ''' | '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] - and ident4 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | '<' | '>' | '|' as - c) - ; - s :] -> - ident4 (store len c) s - | [: :] -> len ] - and base_number len = - parser - [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s - | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s - | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s - | [: a = number len :] -> a ] - and octal_digits len = - parser - [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and hexa_digits len = - parser - [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] -> - hexa_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and binary_digits len = - parser - [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("INT", get_buff len) ] - and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] - and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] - and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s - | [: :] -> ("FLOAT", get_buff len) ] - ; - value valch x = Char.code x - Char.code '0'; - value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | _ -> raise Not_found ] - and backslash1 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> (Char.chr cod, i) ] - and backslash2 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> (Char.chr cod, i) ] - ; - value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] - ; - value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i - ; - value char_of_char_token s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" - ; - value string_of_string_token s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> (store (store len '\\') c, i + 1) ] ] - else (store len s.[i], i + 1) - in - loop len i - ; - value rec skip_spaces = - parser - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s - | [: :] -> () ] - ; - value error_on_unknown_keywords = ref False; - value next_token_fun find_id_kwd find_spe_kwd = - let err bp ep msg = raise_with_loc (bp, ep) (Token.Error msg) in - let keyword_or_error (bp, ep) s = - try ("", find_spe_kwd s) with - [ Not_found -> - if error_on_unknown_keywords.val then - err bp ep ("illegal token: " ^ s) - else ("", s) ] - in - let rec next_token = - parser bp - [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ] - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let is_label = - match Stream.peek s with - [ Some ':' -> - match Stream.npeek 2 s with - [ [_; ':' | '=' | '>'] -> False - | _ -> True ] - | _ -> False ] - in - if is_label then do { Stream.junk s; ("LABEL", id) } - else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ] - | [: `('1'..'9' as c); s :] -> number (store 0 c) s - | [: `'0'; s :] -> base_number (store 0 '0') s - | [: `'''; s :] ep -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s) - | _ -> keyword_or_error (bp, ep) "'" ] - | [: `'"'; s :] -> ("STRING", string bp 0 s) - | [: `'$'; s :] -> locate_or_antiquot bp 0 s - | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' as - c) - ; - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('?' as c); s :] -> - let id = get_buff (ident4 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - (is_label, len) = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> - (False, store (store 0 c1) c2) - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - (True, ident (store 0 c) s) - | [: :] -> (False, store 0 c1) ] :] ep -> - let id = get_buff len in - if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ] - and less bp = - parser - [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; s :] -> - ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s)) - | [: s :] ep -> - let id = get_buff (ident2 (store 0 '<') s) in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> get_buff len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err bp ep "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> - if len = 0 then char bp (store len ''') s else get_buff len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err bp ep "char not terminated" ] - and locate_or_antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err bp ep "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') strm__) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err bp ep "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - in - let rec next_token_loc = - parser bp - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> - next_token_loc s - | [: `'('; s :] -> maybe_comment bp s - | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a - | [: tok = next_token :] ep -> (tok, (bp, ep)) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and maybe_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; next_token_loc s } - | [: :] ep -> - let tok = keyword_or_error (bp, ep) "(" in - (tok, (bp, ep)) ] - and comment bp = - parser - [ [: `'('; s :] -> maybe_nested_comment bp s - | [: `'*'; s :] -> maybe_end_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err bp ep "comment not terminated" ] - and maybe_nested_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and maybe_end_comment bp = - parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] - and linenum bp = - parser - [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; - s :] -> - next_token_loc s - | [: :] -> (keyword_or_error (bp, bp + 1) "#", (bp, bp + 1)) ] - and spaces_tabs = - parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] - and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] - and any_to_nl = - parser - [ [: `'\r' | '\n' :] -> () - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try next_token_loc cstrm with - [ Stream.Error str -> - err (Stream.count cstrm) (Stream.count cstrm + 1) str ] - ; - value locerr () = invalid_arg "Lexer: location function"; - value loct_create () = ref (Array.create 1024 None); - value loct_func loct i = - match - if i < 0 || i >= Array.length loct.val then None - else Array.unsafe_get loct.val i - with - [ Some loc -> loc - | _ -> locerr () ] - ; - value loct_add loct i loc = - do { - if i >= Array.length loct.val then do { - let new_tmax = Array.length loct.val * 2 in - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct - } - else (); - loct.val.(i) := Some loc - } - ; - value func kwd_table = - let find = Hashtbl.find kwd_table in - let lex cstrm = - let next_token_loc = next_token_fun find find in - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc cstrm in - do { loct_add loct i loc; Some tok }) - in - let locf = loct_func loct in - (ts, locf) - in - lex - ; - value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True - and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] ep -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: :] -> - match Stream.peek strm__ with - [ Some ('|' | '<' | ':') -> Stream.junk strm__ - | _ -> () ] ] ] - | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> () - | [: `_ :] -> () ] - and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' | - '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] - and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] - ; - value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False - ; - value using_token kwd_table (p_con, p_prm) = - match p_con with - [ "" -> - try - let _ = Hashtbl.find kwd_table p_prm in - () - with - [ Not_found -> - if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm - else - raise - (Token.Error - ("the token \"" ^ p_prm ^ - "\" does not respect Plexer rules")) ] - | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | - "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Llexer")) ] - ; - value removing_token kwd_table (p_con, p_prm) = - if p_con = "" then Hashtbl.remove kwd_table p_prm else () - ; - value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT", s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("LABEL", "") -> "label" - | ("ELABEL", "") -> "elabel" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] - ; - value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False - ; - value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] - ; - value gmake () = - let kwd_table = Hashtbl.create 301 in - {tok_func = func kwd_table; tok_using = using_token kwd_table; - tok_removing = removing_token kwd_table; - tok_match = Token.default_match; tok_text = text; tok_comm = None} - ; - end -; - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := True; - -do { - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - 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 -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkumin loc f arg = - match arg with - [ <:expr< $int:n$ >> when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -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 mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (loc_of_node p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value neg s = string_of_int (- int_of_string s); - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -(* -value p_operator strm = - match Stream.peek strm with - [ Some (Token.Tterm "(") -> - match Stream.npeek 3 strm with - [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x -> - do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x } - | _ -> raise Stream.Failure ] - | _ -> raise Stream.Failure ] -; - -value operator = Grammar.Entry.of_parser gram "operator" p_operator; -*) - -value operator = - Grammar.Entry.of_parser gram "operator" - (parser [: `("", x) when is_operator x :] -> x) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value test_label_eq = - let rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ] - in - Grammar.Entry.of_parser gram "test_label_eq" (test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec constr_expr_arity = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e - | _ -> 1 ] -; - -value rec constr_patt_arity = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p - | _ -> 1 ] -; - -value rec 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 ] -; - -value rec patt_lid = - fun - [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) - | <:patt< $p1$ $p2$ >> -> - match patt_lid p1 with - [ Some (i, pl) -> Some (i, [p2 :: pl]) - | None -> None ] - | _ -> None ] -; - -value type_parameter = Grammar.Entry.create gram "type_parameter"; -value fun_def = Grammar.Entry.create gram "fun_def"; -value fun_binding = Grammar.Entry.create gram "fun_binding"; - -EXTEND - GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr let_binding type_parameter fun_def fun_binding; - (* Main entry points *) - interf: - [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - implem: - [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] - ; - dir_param: - [ [ -> None - | e = expr -> Some e ] ] - ; - (* Module expressions *) - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - mod_expr_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ] - | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ] - ; - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:str_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator; ")"; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp loc i tp t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" LEFTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $x$ with [ $list:l$ ] >> - | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $x$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; - f = - [ op = "<" -> op - | op = ">" -> op - | op = "<=" -> op - | op = ">=" -> op - | op = "=" -> op - | op = "<>" -> op - | op = "==" -> op - | op = "!=" -> op - | op = infixop0 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; - f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; - f = - [ op = "+" -> op - | op = "-" -> op - | op = "+." -> op - | op = "-." -> op - | op = infixop2 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; - f = - [ op = "*" -> op - | op = "/" -> op - | op = "*." -> op - | op = "/." -> op - | op = "land" -> op - | op = "lor" -> op - | op = "lxor" -> op - | op = "mod" -> op - | op = infixop3 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; - f = - [ op = "**" -> op - | op = "asr" -> op - | op = "lsl" -> op - | op = "lsr" -> op - | op = infixop4 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF -> - <:expr< $mkumin loc f e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = expr LEVEL "simple" -> - match e with - [ <:expr< False >> -> MLast.ExAsf loc - | _ -> MLast.ExAsr loc e ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "simple" LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> - | "!"; e = SELF -> <:expr< $e$ . val>> - | f = - [ op = "~-" -> op - | op = "~-." -> op - | op = "~" -> op - | op = prefixop -> op ]; - e = SELF -> - <:expr< $lid:f$ $e$ >> - | s = INT -> <:expr< $int:s$ >> - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | i = expr_ident -> i - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "("; "-"; ")" -> <:expr< $lid:"-"$ >> - | "("; "-."; ")" -> <:expr< $lid:"-."$ >> - | "("; op = operator; ")" -> <:expr< $lid:op$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | m = UIDENT; "."; i = SELF -> - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:m$ >> i - | m = UIDENT; "."; "("; i = operator; ")" -> - <:expr< $uid:m$ . $lid:i$ >> ] ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | "-"; s = INT -> <:patt< $int:neg s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; "-"; ")" -> <:patt< $lid:"-"$ >> - | "("; op = operator; ")" -> <:patt< $lid:op$ >> - | "_" -> <:patt< _ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> - | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t) - | i = LABEL; t = ctyp -> (loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t) - | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | m = UIDENT; "."; i = SELF -> [m :: i] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; -END; - -(* Objects and Classes *) - -value rec class_type_of_ctyp loc t = - match t with - [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >> - | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >> - | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ] -and type_id_list = - fun - [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t] - | <:ctyp< $lid:i$ >> -> [i] - | t -> - raise_with_loc (loc_of_node t) - (Stream.Error "lowercase identifier expected") ] -; - -value class_fun_binding = Grammar.Entry.create gram "class_fun_binding"; - -EXTEND - GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type - class_expr class_fun_binding; - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; (lab, mf, e) = cvalue -> - <:class_str_item< value $opt:mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; fb = fun_binding -> - <:class_str_item< method private $l$ = $fb$ >> - | "method"; l = label; fb = fun_binding -> - <:class_str_item< method $l$ = $fb$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue: - [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) - | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ : $t$) >>) - | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>) - | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t - | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*"; - "->"; ct = SELF -> - <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} - | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t1$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) - | lab = LABEL; t = ctyp -> (lab, t) ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; -END; - -(* Labels *) - -EXTEND - GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding; - ctyp: AFTER "arrow" - [ NONA - [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i False [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l - | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = ELABEL -> <:expr< ~ $i$ >> - | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> - | i = ELABEL -> <:patt< ~ $i$ >> - | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:j$ = $e$ ) >> - | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >> - | "?"; "("; i = ELABEL; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ] - ; - class_type: - [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; -END; - -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. *) -(* In syntax generated, many cases are optimisations. *) - -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 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> - e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $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 ckont = ekont err in - stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -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 rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> - let loc = gloc in - <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <: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 = SELF; "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; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | -> (* empty *) [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ] - ; - 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 ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] -> - (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_oop.ml b/camlp4/etc/pa_oop.ml deleted file mode 100644 index fd56158346..0000000000 --- a/camlp4/etc/pa_oop.ml +++ /dev/null @@ -1,154 +0,0 @@ -(* 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; diff --git a/camlp4/etc/pa_op.ml b/camlp4/etc/pa_op.ml deleted file mode 100644 index 5f2fff0fae..0000000000 --- a/camlp4/etc/pa_op.ml +++ /dev/null @@ -1,330 +0,0 @@ -(* 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. *) -(* In syntax generated, many cases are optimisations. *) - -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 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> - handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then - <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $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 ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -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$ : Stream.t _) = $me$ in $e$ >> -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let loc = gloc in <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <: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; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | (* empty *) -> [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list -> - [spc :: sp] ] ] - ; - 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 ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> - | "_" -> <:patt< _ >> ] ] - ; - - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_ru.ml b/camlp4/etc/pa_ru.ml deleted file mode 100644 index d3060c88c5..0000000000 --- a/camlp4/etc/pa_ru.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* 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 $opt: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; diff --git a/camlp4/etc/pa_scheme.ml b/camlp4/etc/pa_scheme.ml deleted file mode 100644 index 846a11e465..0000000000 --- a/camlp4/etc/pa_scheme.ml +++ /dev/null @@ -1,1002 +0,0 @@ -; camlp4 ./pa_schemer.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 - (define buff (ref (String.create 80))) - (define (store len x) - (if (>= len (String.length buff.val)) - (:= buff.val (^ buff.val (String.create (String.length buff.val))))) - (:= buff.val.[len] x) - (succ len)) - (define (get len) (String.sub buff.val 0 len)))) - -; Lexer - -(definerec skip_to_eol - (parser - (((` (or '\n' '\r'))) ()) - (((` _) s) (skip_to_eol s)))) - -(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) - -(definerec (ident len) - (parser - (((` '.')) (values (Buff.get len) True)) - (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) - (() (values (Buff.get len) False)))) - -(define (identifier kwt (values s dot)) - (let ((con - (try (begin (: (Hashtbl.find kwt s) unit) "") - (Not_found - (match s.[0] - ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) - (_ (if dot "LIDENTDOT" "LIDENT"))))))) - (values con s))) - -(definerec (string len) - (parser - (((` '"')) (Buff.get len)) - (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) - (((` x) s) (string (Buff.store len x) s)))) - -(definerec (end_exponent_part_under len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (values "FLOAT" (Buff.get len))))) - -(define (end_exponent_part len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (raise (Stream.Error "ill-formed floating-point constant"))))) - -(define (exponent_part len) - (parser - (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) - (((a (end_exponent_part len))) a))) - -(definerec (decimal_part len) - (parser - (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "FLOAT" (Buff.get len))))) - -(definerec (number len) - (parser - (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) - (((` '.') s) (decimal_part (Buff.store len '.') s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "INT" (Buff.get len))))) - -(define binary - (parser - (((` (as (range '0' '1') c))) c))) - -(define octal - (parser - (((` (as (range '0' '7') c))) c))) - -(define hexa - (parser - (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) - -(definerec (digits_under kind len) - (parser - (((d kind) s) (digits_under kind (Buff.store len d) s)) - (() (Buff.get len)))) - -(define (digits kind bp len) - (parser - (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) - ((s) ep - (raise_with_loc (values bp ep) (Failure "ill-formed integer constant"))))) - -(define (base_number kwt bp len) - (parser - (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) - (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) - (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) - (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) - -(definerec (operator len) - (parser - (((` '.')) (Buff.get (Buff.store len '.'))) - (() (Buff.get len)))) - -(define (char_or_quote_id x) - (parser - (((` ''')) (values "CHAR" (String.make 1 x))) - ((s) ep - (if (List.mem x no_ident) - (Stdpp.raise_with_loc (values (- ep 2) (- ep 1)) - (Stream.Error "bad quote")) - (let* ((len (Buff.store (Buff.store 0 ''') x)) - ((values s dot) (ident len s))) - (values (if dot "LIDENTDOT" "LIDENT") s)))))) - -(definerec (char len) - (parser - (((` ''')) len) - (((` x) s) (char (Buff.store len x) s)))) - -(define quote - (parser - (((` '\\') (len (char (Buff.store 0 '\\')))) - (values "CHAR" (Buff.get len))) - (((` x) s) (char_or_quote_id x s)))) - -; The system with LIDENTDOT and UIDENTDOT is not great (it would be -; better to have a token DOT (actually SPACEDOT and DOT)) but it is -; the only way (that I have found) to have a good behaviour in the -; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be -; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the -; parser rule with dot is right associative and we have to reverse -; the resulting tree (using the function leftify). -; This is a complicated issue: the behaviour of the OCaml toplevel -; is strange, anyway. For example, even without Camlp4, The OCaml -; toplevel accepts that: -; # let x = 32;; foo bar match let ) - -(definerec* - ((lexer kwt) - (parser - (((t (lexer0 kwt)) - (_ no_dot)) t))) - (no_dot - (parser - (((` '.')) ep - (Stdpp.raise_with_loc (values (- ep 1) ep) (Stream.Error "bad dot"))) - (() ()))) - ((lexer0 kwt) - (parser bp - (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) - (((` ' ') s) (after_space kwt s)) - (((` ';') (_ skip_to_eol) s) (lexer kwt s)) - (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) - (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) - (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) - (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) - (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) - (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) - (((` '"') (s (string 0))) ep - (values (values "STRING" s) (values bp ep))) - (((` ''') (tok quote)) ep (values tok (values bp ep))) - (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) - (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) - (((` '~') (tok tilde)) ep (values tok (values bp ep))) - (((` '?') (tok question)) ep (values tok (values bp ep))) - (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep - (values tok (values bp ep))) - (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep - (values tok (values bp ep))) - (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep - (values (identifier kwt (values id False)) (values bp ep))) - (((` x) (id (ident (Buff.store 0 x)))) ep - (values (identifier kwt id) (values bp ep))) - (() (values (values "EOI" "") (values bp (+ bp 1)))))) - (rparen - (parser - (((` '.')) ").") - ((_) ")"))) - ((after_space kwt) - (parser - (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) - (((x (lexer0 kwt))) x))) - (tilde - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "TILDEIDENT" s)) - (() (values "LIDENT" "~")))) - (question - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "QUESTIONIDENT" s)) - (() (values "LIDENT" "?")))) - ((minus kwt) - (parser - (((` '.')) (identifier kwt (values "-." False))) - (((` (as (range '0' '9') c)) - (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) - (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) - ((less kwt) - (parser - (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) - (values "QUOT" (^ lab ":" q))) - (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) - ((label len) - (parser - (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) - (label (Buff.store len c) s)) - (() (Buff.get len)))) - ((quotation len) - (parser - (((` '>') s) (quotation_greater len s)) - (((` x) s) (quotation (Buff.store len x) s)) - (() (failwith "quotation not terminated")))) - ((quotation_greater len) - (parser - (((` '>')) (Buff.get len)) - (((a (quotation (Buff.store len '>')))) a)))) - -(define (lexer_using kwt (values con prm)) - (match con - ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" - "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") - ()) - ("ANTIQUOT" ()) - ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) - (_ - (raise - (Token.Error - (^ "the constructor \"" con "\" is not recognized by Plexer")))))) - -(define (lexer_text (values con prm)) - (cond - ((= con "") (^ "'"prm "'")) - ((= prm "") con) - (else (^ con " \"" prm "\"")))) - -(define (lexer_gmake ()) - (let ((kwt (Hashtbl.create 89))) - {(Token.tok_func (Token.lexer_func_of_parser (lexer kwt))) - (Token.tok_using (lexer_using kwt)) - (Token.tok_removing (lambda)) - (Token.tok_match Token.default_match) - (Token.tok_text lexer_text) - (Token.tok_comm None)})) - -; Building AST - -(type sexpr - (sum - (Sacc MLast.loc sexpr sexpr) - (Schar MLast.loc string) - (Sexpr MLast.loc (list sexpr)) - (Sint MLast.loc string) - (Sfloat MLast.loc string) - (Slid MLast.loc string) - (Slist MLast.loc (list sexpr)) - (Sqid MLast.loc string) - (Squot MLast.loc string string) - (Srec MLast.loc (list sexpr)) - (Sstring MLast.loc string) - (Stid MLast.loc string) - (Suid MLast.loc string))) - -(define loc_of_sexpr - (lambda_match - ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) - (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) - (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) - loc))) -(define (error_loc loc err) - (raise_with_loc loc (Stream.Error (^ err " expected")))) -(define (error se err) (error_loc (loc_of_sexpr se) err)) - -(define strm_n "strm__") -(define (peek_fun loc) <:expr< Stream.peek >>) -(define (junk_fun loc) <:expr< Stream.junk >>) - -(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) -(define assoc_right_parsed_op_list ["and" "or" "^" "@"]) -(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) - -(define (op_apply loc e1 e2) - (lambda_match - ("and" <:expr< $e1$ && $e2$ >>) - ("or" <:expr< $e1$ || $e2$ >>) - (x <:expr< $lid:x$ $e1$ $e2$ >>))) - -(define string_se - (lambda_match - ((Sstring loc s) s) - (se (error se "string")))) - -(define mod_ident_se - (lambda_match - ((Suid _ s) [(Pcaml.rename_id.val s)]) - ((Slid _ s) [(Pcaml.rename_id.val s)]) - (se (error se "mod_ident")))) - -(define (lident_expr loc s) - (if (&& (> (String.length s) 1) (= s.[0] '`')) - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:expr< ` $s$ >>) - <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) - -(definerec* - (module_expr_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se1)) - (me (module_expr_se se2))) - <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) - ((Sexpr loc [(Slid _ "struct") . sl]) - (let ((mel (List.map str_item_se sl))) - <:module_expr< struct $list:mel$ end >>)) - ((Sexpr loc [se1 se2]) - (let* ((me1 (module_expr_se se1)) - (me2 (module_expr_se se2))) - <:module_expr< $me1$ $me2$ >>)) - ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module expr")))) - (module_type_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt1 (module_type_se se1)) - (mt2 (module_type_se se2))) - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) - ((Sexpr loc [(Slid _ "sig") . sel]) - (let ((sil (List.map sig_item_se sel))) - <:module_type< sig $list:sil$ end >>)) - ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) - (let* ((mt (module_type_se se)) - (wcl (List.map with_constr_se sel))) - <:module_type< $mt$ with $list:wcl$ >>)) - ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module type")))) - (with_constr_se - (lambda_match - ((Sexpr loc [(Slid _ "type") se1 se2]) - (let* ((tn (mod_ident_se se1)) - (te (ctyp_se se2))) - (MLast.WcTyp loc tn [] te))) - (se (error se "with constr")))) - (sig_item_se - (lambda_match - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:sig_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:sig_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (t (ctyp_se se))) - <:sig_item< value $s$ : $t$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:sig_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mb (module_type_se se))) - <:sig_item< module $s$ : $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:sig_item< module type $s$ = $mt$ >>)) - (se (error se "sig item")))) - ((str_item_se se) - (match se - ((Sexpr loc [(Slid _ "open") se]) - (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:str_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:str_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) - (let* ((r (= r "definerec")) - ((values p e) (fun_binding_se se (begin_se loc sel)))) - <:str_item< value $opt:r$ $p$ = $e$ >>)) - ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) - (let* ((r (= r "definerec*")) - (lbs (List.map let_binding_se sel))) - <:str_item< value $opt:r$ $list:lbs$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:str_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) - (let* ((i (Pcaml.rename_id.val i)) - (mb (module_binding_se se))) - <:str_item< module $i$ = $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:str_item< module type $s$ = $mt$ >>)) - (_ - (let* ((loc (loc_of_sexpr se)) - (e (expr_se se))) - <:str_item< $exp:e$ >>)))) - ((module_binding_se se) (module_expr_se se)) - (expr_se - (lambda_match - ((Sacc loc se1 se2) - (let ((e1 (expr_se se1))) - (match se2 - ((Slist loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) - ((Sexpr loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) - (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) - ((Slid loc s) (lident_expr loc s)) - ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:expr< $int:s$ >>) - ((Sfloat loc s) <:expr< $flo:s$ >>) - ((Schar loc s) <:expr< $chr:s$ >>) - ((Sstring loc s) <:expr< $str:s$ >>) - ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) - ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) - ((Sexpr loc []) <:expr< () >>) - ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) - (List.mem s assoc_left_parsed_op_list)) - (letrec - (((loop e1) - (lambda_match - ([] e1) - ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) - (loop (expr_se e1) (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s assoc_right_parsed_op_list)) - (letrec - ((loop - (lambda_match - ([] - (assert False)) - ([e1] e1) - ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) - (loop (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s and_by_couple_op_list)) - (letrec - ((loop - (lambda_match - ((or [] [_]) (assert False)) - ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) - ([e1 . (as [e2 _ . _] el)] - (let* ((a1 (op_apply loc e1 e2 s)) - (a2 (loop el))) - <:expr< $a1$ && $a2$ >>))))) - (loop (List.map expr_se sel)))) - ((Sexpr loc [(Stid _ s) se]) - (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) - ((Sexpr loc [(Slid _ "-") se]) - (let ((e (expr_se se))) <:expr< - $e$ >>)) - ((Sexpr loc [(Slid _ "if") se se1]) - (let* ((e (expr_se se)) - (e1 (expr_se se1))) - <:expr< if $e$ then $e1$ else () >>)) - ((Sexpr loc [(Slid _ "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 [(Slid _ "cond") . sel]) - (letrec - ((loop - (lambda_match - ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) - ([(Sexpr loc [se1 . sel1]) . sel] - (let* ((e1 (expr_se se1)) - (e2 (begin_se loc sel1)) - (e3 (loop sel))) - <:expr< if $e1$ then $e2$ else $e3$ >>)) - ([] <:expr< () >>) - ([se . _] (error se "cond clause"))))) - (loop sel))) - ((Sexpr loc [(Slid _ "while") se . sel]) - (let* ((e (expr_se se)) - (el (List.map expr_se sel))) - <:expr< while $e$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (e1 (expr_se se1)) - (e2 (expr_se se2)) - (el (List.map expr_se sel))) - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) - ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) - (let ((e (begin_se loc1 sel))) - (match (ipatt_opt_se sep) - ((Left p) <:expr< fun $p$ -> $e$ >>) - ((Right (values se sel)) - (List.fold_right - (lambda (se e) - (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) - [se . sel] e))))) - ((Sexpr loc [(Slid _ "lambda_match") . sel]) - (let ((pel (List.map (match_case loc) sel))) - <:expr< fun [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (let* ((r (= r "letrec")) - (lbs (List.map let_binding_se sel1)) - (e (begin_se loc sel2))) - <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) - ([(Slid _ n) (Sexpr _ sl) . sel] - (let* ((n (Pcaml.rename_id.val n)) - ((values pl el) - (List.fold_right - (lambda (se (values pl el)) - (match se - ((Sexpr _ [se1 se2]) - (values [(patt_se se1) . pl] - [(expr_se se2) . el])) - (se (error se "named let")))) - sl (values [] []))) - (e1 - (List.fold_right - (lambda (p e) <:expr< fun $p$ -> $e$ >>) - pl (begin_se loc sel))) - (e2 - (List.fold_left - (lambda (e1 e2) <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el))) - <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "let*") . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (List.fold_right - (lambda (se ek) - (let (((values p e) (let_binding_se se))) - <:expr< let $p$ = $e$ in $ek$ >>)) - sel1 (begin_se loc sel2))) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "match") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< match $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "parser") . sel]) - (let ((e - (match sel - ([(as (Slid _ _) 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 [(Slid _ "match_with_parser") se . sel]) - (let* ((me (expr_se se)) - ((values bpo sel) - (match sel - ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) - (_ (values None sel)))) - (pc (parser_cases_se loc sel)) - (e - (match bpo - ((Some bp) - <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) - (None pc)))) - (match me - ((when <:expr< $lid:x$ >> (= x strm_n)) e) - (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) - ((Sexpr loc [(Slid _ "try") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< try $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "begin") . sel]) - (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ ":=") se1 se2]) - (let* ((e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< $e1$ := $e2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) - ((Srec loc [(Slid _ "with") se . sel]) - (let* ((e (expr_se se)) - (lel (List.map (label_expr_se loc) sel))) - <:expr< { ($e$) with $list:lel$ } >>)) - ((Srec loc sel) - (let ((lel (List.map (label_expr_se loc) sel))) - <:expr< { $list:lel$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) - ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) - ((Sexpr loc [(Slid _ "assert") se]) - (let ((e (expr_se se))) <:expr< assert $e$ >>)) - ((Sexpr loc [(Slid _ "lazy") se]) - (let ((e (expr_se se))) <:expr< lazy $e$ >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) - (expr_se se) sel)) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:expr< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((e (expr_se se1)) - (el (expr_se se2))) - <:expr< [$e$ :: $el$] >>)) - ([se . sel] - (let* ((e (expr_se se)) - (el (loop sel))) - <:expr< [$e$ :: $el$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_expr_quotation loc (values typ txt))))) - ((begin_se loc) - (lambda_match - ([] <:expr< () >>) - ([se] (expr_se se)) - ((sel) - (let* ((el (List.map expr_se sel)) - (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) - <:expr< do { $list:el$ } >>)))) - (let_binding_se - (lambda_match - ((Sexpr loc [se . sel]) - (let ((e (begin_se loc sel))) - (match (ipatt_opt_se se) - ((Left p) (values p e)) - ((Right _) (fun_binding_se se e))))) - (se (error se "let_binding")))) - ((fun_binding_se se e) - (match se - ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) - ((Sexpr _ [(Slid loc s) . sel]) - (let* ((s (Pcaml.rename_id.val s)) - (e - (List.fold_right - (lambda (se e) - (let* ((loc - (values (fst (loc_of_sexpr se)) - (snd (MLast.loc_of_expr e)))) - (p (ipatt_se se))) - <:expr< fun $p$ -> $e$ >>)) - sel e)) - (p <:patt< $lid:s$ >>)) - (values p e))) - ((_) (values (ipatt_se se) e)))) - ((match_case loc) - (lambda_match - ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) - (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) - ((Sexpr loc [se . sel]) - (values (patt_se se) None (begin_se loc sel))) - (se (error se "match_case")))) - ((label_expr_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) - (se (error se "label_expr")))) - ((label_patt_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) - (se (error se "label_patt")))) - ((parser_cases_se loc) - (lambda_match - ([] <:expr< raise Stream.Failure >>) - ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] - (let* ((ekont (lambda _ (parser_cases_se loc sel))) - (act (match act - ([se] (expr_se se)) - ([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))) - ([se . _] - (error se "parser_case")))) - ((stream_pattern_se loc act ekont) - (lambda_match - ([] act) - ([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 skont ekont err) - (lambda_match - ((Sexpr loc [(Slid _ "`") se . wol]) - (let* ((wo (match wol - ([se] (Some (expr_se se))) - ([] 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 [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 [(Slid _ "?") se1 se2]) - (stream_pattern_component skont ekont (expr_se se2) se1)) - ((Slid loc s) - (let ((s (Pcaml.rename_id.val s))) - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) - (se - (error se "stream_pattern_component")))) - (patt_se - (lambda_match - ((Sacc loc se1 se2) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) - ((Slid loc "_") <:patt< _ >>) - ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) - ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:patt< $int:s$ >>) - ((Sfloat loc s) <:patt< $flo:s$ >>) - ((Schar loc s) <:patt< $chr:s$ >>) - ((Sstring loc s) <:patt< $str:s$ >>) - ((Stid loc _) (error_loc loc "patt")) - ((Sqid loc _) (error_loc loc "patt")) - ((Srec loc sel) - (let ((lpl (List.map (label_patt_se loc) sel))) - <:patt< { $list:lpl$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) - ((Sexpr loc [(Slid _ "or") se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc [(Slid _ "range") se1 se2]) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) - ((Sexpr loc [(Slid _ "as") se1 se2]) - (let* ((p1 (patt_se se1)) - (p2 (patt_se se2))) - <:patt< ($p1$ as $p2$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc []) <:patt< () >>) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:patt< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((p (patt_se se1)) - (pl (patt_se se2))) - <:patt< [$p$ :: $pl$] >>)) - ([se . sel] - (let* ((p (patt_se se)) - (pl (loop sel))) - <:patt< [$p$ :: $pl$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_patt_quotation loc (values typ txt))))) - ((ipatt_se se) - (match (ipatt_opt_se se) - ((Left p) p) - ((Right (values se _)) (error se "ipatt")))) - (ipatt_opt_se - (lambda_match - ((Slid loc "_") (Left <:patt< _ >>)) - ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) - ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) - ((Sexpr loc [(Sqid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (e (expr_se se))) - (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) - (Left <:patt< ($p$ : $t$) >>))) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) - ((Sexpr loc []) (Left <:patt< () >>)) - ((Sexpr loc [se . sel]) (Right (values se sel))) - (se (error se "ipatt")))) - (type_declaration_list_se - (lambda_match - ([se1 se2 . sel] - (let (((values n1 loc1 tpl) - (match se1 - ((Sexpr _ [(Slid loc n) . sel]) - (values n loc (List.map type_parameter_se sel))) - ((Slid loc n) - (values n loc [])) - ((se) - (error se "type declaration"))))) - [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . - (type_declaration_list_se sel)])) - ([] []) - ([se . _] (error se "type_declaration")))) - (type_parameter_se - (lambda_match - ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) - (values (String.sub s 1 (- (String.length s) 1)) (values False False))) - (se - (error se "type_parameter")))) - (ctyp_se - (lambda_match - ((Sexpr loc [(Slid _ "sum") . sel]) - (let ((cdl (List.map constructor_declaration_se sel))) - <:ctyp< [ $list:cdl$ ] >>)) - ((Srec loc sel) - (let ((ldl (List.map label_declaration_se sel))) - <:ctyp< { $list:ldl$ } >>)) - ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) - (letrec - ((loop - (lambda_match - ([] (assert False)) - ([se] (ctyp_se se)) - ([se . sel] - (let* ((t1 (ctyp_se se)) - (loc (values (fst (loc_of_sexpr se)) (snd loc))) - (t2 (loop sel))) - <:ctyp< $t1$ -> $t2$ >>))))) - (loop sel))) - ((Sexpr loc [(Slid _ "*") . sel]) - (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) - (ctyp_se se) sel)) - ((Sacc loc se1 se2) - (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) - ((Slid loc "_") <:ctyp< _ >>) - ((Slid loc s) - (if (= s.[0] ''') - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:ctyp< '$s$ >>) - <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "ctyp")))) - (constructor_declaration_se - (lambda_match - ((Sexpr loc [(Suid _ ci) . sel]) - (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) - (se - (error se "constructor_declaration")))) - (label_declaration_se - (lambda_match - ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) - (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) - ((Sexpr loc [(Slid _ lab) se]) - (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) - (se - (error se "label_declaration"))))) - -(define directive_se - (lambda_match - ((Sexpr _ [(Slid _ s)]) (values s None)) - ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) - (se (error se "directive")))) - -; Parser - -(:= Pcaml.syntax_name.val "Scheme") -(:= Pcaml.no_constructors_arity.val False) - -(begin - (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) - (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 type_declaration) - (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)) - -(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) -(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) - -(define sexpr (Grammar.Entry.create gram "sexpr")) - -(definerec leftify - (lambda_match - ((Sacc loc1 se1 se2) - (match (leftify se2) - ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) - (se2 (Sacc loc1 se1 se2)))) - (x x))) - -EXTEND - GLOBAL : implem interf top_phrase use_file str_item sig_item expr - patt sexpr / - implem : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) - | si = str_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_str_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - interf : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) - | si = sig_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_sig_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - top_phrase : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (Some <:str_item< # $n$ $opt:dp$ >>)) - | se = sexpr -> (Some (str_item_se se)) - | EOI -> None ] ] - / - use_file : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [<:str_item< # $n$ $opt:dp$ >>] True)) - | si = str_item / x = SELF -> - (let (((values sil stopped) x)) (values [si . sil] stopped)) - | EOI -> (values [] False) ] ] - / - str_item : - [ [ se = sexpr -> (str_item_se se) - | e = expr -> <:str_item< $exp:e$ >> ] ] - / - sig_item : - [ [ se = sexpr -> (sig_item_se se) ] ] - / - expr : - [ "top" - [ se = sexpr -> (expr_se se) ] ] - / - patt : - [ [ se = sexpr -> (patt_se se) ] ] - / - sexpr : - [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] - | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) - | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> - (leftify (Sacc loc (Sexpr loc sl) se)) - | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) - | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) - | a = pa_extend_keyword -> (Slid loc a) - | s = LIDENT -> (Slid loc s) - | s = UIDENT -> (Suid loc s) - | s = TILDEIDENT -> (Stid loc s) - | s = QUESTIONIDENT -> (Sqid loc s) - | s = INT -> (Sint loc s) - | s = FLOAT -> (Sfloat loc s) - | s = CHAR -> (Schar loc s) - | s = STRING -> (Sstring loc 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)))) - (Squot loc typ txt)) ] ] - / - sexpr_dot : - [ [ s = LIDENTDOT -> (Slid loc s) - | s = UIDENTDOT -> (Suid loc s) ] ] - / - pa_extend_keyword : - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - / -END diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/etc/pa_schemer.ml deleted file mode 100644 index a7d64ce4a5..0000000000 --- a/camlp4/etc/pa_schemer.ml +++ /dev/null @@ -1,1067 +0,0 @@ -(* 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 - [ [: `'.' :] -> (Buff.get len, True) - | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s - | [: :] -> (Buff.get len, False) ] -; - -value identifier kwt (s, dot) = - let con = - try do { (Hashtbl.find kwt s : unit); "" } with - [ Not_found -> - match s.[0] with - [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" - | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] - in - (con, s) -; - -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 end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -; - -value exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s - | [: a = end_exponent_part len :] -> a ] -; - -value rec decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value rec number len = - parser - [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s - | [: `'.'; s :] -> decimal_part (Buff.store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("INT", Buff.get len) ] -; - -value binary = parser [: `('0'..'1' as c) :] -> c; - -value octal = parser [: `('0'..'7' as c) :] -> c; - -value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; - -value rec digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s - | [: :] -> Buff.get len ] -; - -value digits kind bp len = - parser - [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) - | [: s :] ep -> - raise_with_loc (bp, ep) (Failure "ill-formed integer constant") ] -; - -value base_number kwt bp len = - parser - [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s - | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s - | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] -; - -value rec operator len = - parser - [ [: `'.' :] -> Buff.get (Buff.store len '.') - | [: :] -> Buff.get len ] -; - -value char_or_quote_id x = - parser - [ [: `''' :] -> ("CHAR", String.make 1 x) - | [: s :] ep -> - if List.mem x no_ident then - Stdpp.raise_with_loc (ep - 2, ep - 1) (Stream.Error "bad quote") - else - let len = Buff.store (Buff.store 0 ''') x in - let (s, dot) = ident len s in - (if dot then "LIDENTDOT" else "LIDENT", 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 ] -; - -(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) -(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) -(* the only way (that I have found) to have a good behaviour in the *) -(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) -(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) -(* parser rule with dot is right associative and we have to reverse *) -(* the resulting tree (using the function leftify). *) -(* This is a complicated issue: the behaviour of the OCaml toplevel *) -(* is strange, anyway. For example, even without Camlp4, The OCaml *) -(* toplevel accepts that: *) -(* # let x = 32;; foo bar match let ) *) - -value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t -and no_dot = - parser - [ [: `'.' :] ep -> - Stdpp.raise_with_loc (ep - 1, ep) (Stream.Error "bad dot") - | [: :] -> () ] -and lexer0 kwt = - parser bp - [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s - | [: `' '; s :] -> after_space kwt s - | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s - | [: `'(' :] -> (("", "("), (bp, bp + 1)) - | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) - | [: `'[' :] -> (("", "["), (bp, bp + 1)) - | [: `']' :] -> (("", "]"), (bp, bp + 1)) - | [: `'{' :] -> (("", "{"), (bp, bp + 1)) - | [: `'}' :] -> (("", "}"), (bp, bp + 1)) - | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) - | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) - | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) - | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) - | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) - | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) - | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> - (tok, (bp, ep)) - | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> - (tok, (bp, ep)) - | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> - (identifier kwt (id, False), (bp, ep)) - | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) - | [: :] -> (("EOI", ""), (bp, bp + 1)) ] -and rparen = - parser - [ [: `'.' :] -> ")." - | [: ___ :] -> ")" ] -and after_space kwt = - parser - [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) - | [: x = lexer0 kwt :] -> x ] -and tilde = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("TILDEIDENT", s) - | [: :] -> ("LIDENT", "~") ] -and question = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("QUESTIONIDENT", s) - | [: :] -> ("LIDENT", "?") ] -and minus kwt = - parser - [ [: `'.' :] -> identifier kwt ("-.", False) - | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ep -> - n - | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] -and less kwt = - parser - [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> - ("QUOT", lab ^ ":" ^ q) - | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] -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" | "FLOAT" | "LIDENT" | "LIDENTDOT" | - "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | - "UIDENTDOT" -> - () - | "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_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = Token.lexer_func_of_parser (lexer kwt); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* Building AST *) - -type sexpr = - [ Sacc of MLast.loc and sexpr and sexpr - | Schar of MLast.loc and string - | Sexpr of MLast.loc and list sexpr - | Sint of MLast.loc and string - | Sfloat of MLast.loc and string - | Slid of MLast.loc and string - | Slist of MLast.loc and list sexpr - | Sqid of MLast.loc and string - | Squot of MLast.loc and string and string - | Srec of MLast.loc and list sexpr - | Sstring of MLast.loc and string - | Stid of MLast.loc and string - | Suid of MLast.loc and string ] -; - -value loc_of_sexpr = - fun [ - Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | - Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | - Sstring loc _ | Stid loc _ | Suid loc _ -> - loc ] -; -value error_loc loc err = - raise_with_loc loc (Stream.Error (err ^ " expected")) -; -value error se err = error_loc (loc_of_sexpr se) err; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -value assoc_left_parsed_op_list = - ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] -; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -value op_apply loc e1 e2 = - fun - [ "and" -> <:expr< $e1$ && $e2$ >> - | "or" -> <:expr< $e1$ || $e2$ >> - | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] -; - -value string_se = - fun - [ Sstring loc s -> s - | se -> error se "string" ] -; - -value mod_ident_se = - fun - [ Suid _ s -> [Pcaml.rename_id.val s] - | Slid _ s -> [Pcaml.rename_id.val s] - | se -> error se "mod_ident" ] -; - -value lident_expr loc s = - if String.length s > 1 && s.[0] = '`' then - let s = String.sub s 1 (String.length s - 1) in - <:expr< ` $s$ >> - else <:expr< $lid:(Pcaml.rename_id.val s)$ >> -; - -value rec module_expr_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se1 in - let me = module_expr_se se2 in - <:module_expr< functor ($s$ : $mt$) -> $me$ >> - | Sexpr loc [Slid _ "struct" :: sl] -> - let mel = List.map str_item_se sl in - <:module_expr< struct $list:mel$ end >> - | Sexpr loc [se1; se2] -> - let me1 = module_expr_se se1 in - let me2 = module_expr_se se2 in - <:module_expr< $me1$ $me2$ >> - | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module expr" ] -and module_type_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt1 = module_type_se se1 in - let mt2 = module_type_se se2 in - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> - | Sexpr loc [Slid _ "sig" :: sel] -> - let sil = List.map sig_item_se sel in - <:module_type< sig $list:sil$ end >> - | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> - let mt = module_type_se se in - let wcl = List.map with_constr_se sel in - <:module_type< $mt$ with $list:wcl$ >> - | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module type" ] -and with_constr_se = - fun - [ Sexpr loc [Slid _ "type"; se1; se2] -> - let tn = mod_ident_se se1 in - let te = ctyp_se se2 in - MLast.WcTyp loc tn [] te - | se -> error se "with constr" ] -and sig_item_se = - fun - [ Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:sig_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:sig_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ "value"; Slid _ s; se] -> - let s = Pcaml.rename_id.val s in - let t = ctyp_se se in - <:sig_item< value $s$ : $t$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mb = module_type_se se in - <:sig_item< module $s$ : $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:sig_item< module type $s$ = $mt$ >> - | se -> error se "sig item" ] -and str_item_se se = - match se with - [ Sexpr loc [Slid _ "open"; se] -> - let s = mod_ident_se se in - <:str_item< open $s$ >> - | Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:str_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:str_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> - let r = r = "definerec" in - let (p, e) = fun_binding_se se (begin_se loc sel) in - <:str_item< value $opt:r$ $p$ = $e$ >> - | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> - let r = r = "definerec*" in - let lbs = List.map let_binding_se sel in - <:str_item< value $opt:r$ $list:lbs$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:str_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ i; se] -> - let i = Pcaml.rename_id.val i in - let mb = module_binding_se se in - <:str_item< module $i$ = $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:str_item< module type $s$ = $mt$ >> - | _ -> - let loc = loc_of_sexpr se in - let e = expr_se se in - <:str_item< $exp:e$ >> ] -and module_binding_se se = module_expr_se se -and expr_se = - fun - [ Sacc loc se1 se2 -> - let e1 = expr_se se1 in - match se2 with - [ Slist loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .[ $e2$ ] >> - | Sexpr loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .( $e2$ ) >> - | _ -> - let e2 = expr_se se2 in - <:expr< $e1$ . $e2$ >> ] - | Slid loc s -> lident_expr loc s - | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:expr< $int:s$ >> - | Sfloat loc s -> <:expr< $flo:s$ >> - | Schar loc s -> <:expr< $chr:s$ >> - | Sstring loc s -> <:expr< $str:s$ >> - | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [] -> <:expr< () >> - | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] - when List.mem s assoc_left_parsed_op_list -> - let rec loop e1 = - fun - [ [] -> e1 - | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] - in - loop (expr_se e1) (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s assoc_right_parsed_op_list -> - let rec loop = - fun - [ [] -> assert False - | [e1] -> e1 - | [e1 :: el] -> - let e2 = loop el in - op_apply loc e1 e2 s ] - in - loop (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s and_by_couple_op_list -> - let rec loop = - fun - [ [] | [_] -> assert False - | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> - | [e1 :: ([e2; _ :: _] as el)] -> - let a1 = op_apply loc e1 e2 s in - let a2 = loop el in - <:expr< $a1$ && $a2$ >> ] - in - loop (List.map expr_se sel) - | Sexpr loc [Stid _ s; se] -> - let e = expr_se se in - <:expr< ~ $s$ : $e$ >> - | Sexpr loc [Slid _ "-"; se] -> - let e = expr_se se in - <:expr< - $e$ >> - | Sexpr loc [Slid _ "if"; se; se1] -> - let e = expr_se se in - let e1 = expr_se se1 in - <:expr< if $e$ then $e1$ else () >> - | Sexpr loc [Slid _ "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 [Slid _ "cond" :: sel] -> - let rec loop = - fun - [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel - | [Sexpr loc [se1 :: sel1] :: sel] -> - let e1 = expr_se se1 in - let e2 = begin_se loc sel1 in - let e3 = loop sel in - <:expr< if $e1$ then $e2$ else $e3$ >> - | [] -> <:expr< () >> - | [se :: _] -> error se "cond clause" ] - in - loop sel - | Sexpr loc [Slid _ "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 [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> - let i = Pcaml.rename_id.val i in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - let el = List.map expr_se sel in - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> - | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> - | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> - let e = begin_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 [Slid _ "lambda_match" :: sel] -> - let pel = List.map (match_case loc) sel in - <:expr< fun [ $list:pel$ ] >> - | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - let r = r = "letrec" in - let lbs = List.map let_binding_se sel1 in - let e = begin_se loc sel2 in - <:expr< let $opt:r$ $list:lbs$ in $e$ >> - | [Slid _ n; Sexpr _ sl :: sel] -> - let n = Pcaml.rename_id.val n in - let (pl, el) = - List.fold_right - (fun se (pl, el) -> - match se with - [ Sexpr _ [se1; se2] -> - ([patt_se se1 :: pl], [expr_se se2 :: el]) - | se -> error se "named let" ]) - sl ([], []) - in - let e1 = - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl - (begin_se loc sel) - in - let e2 = - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el - in - <:expr< let rec $lid:n$ = $e1$ in $e2$ >> - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "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 (begin_se loc sel2) - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "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 [Slid _ "parser" :: sel] -> - let e = - match sel with - [ [(Slid _ _ 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 [Slid _ "match_with_parser"; se :: sel] -> - let me = expr_se se in - let (bpo, sel) = - match sel with - [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) - | _ -> (None, sel) ] - in - let pc = parser_cases_se loc sel in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] - | Sexpr loc [Slid _ "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 [Slid _ "begin" :: sel] -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> - | Sexpr loc [Slid _ ":="; se1; se2] -> - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< $e1$ := $e2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let el = List.map expr_se sel in - <:expr< ( $list:el$ ) >> - | Srec loc [Slid _ "with"; se :: sel] -> - let e = expr_se se in - let lel = List.map (label_expr_se loc) sel in - <:expr< { ($e$) with $list:lel$ } >> - | Srec loc sel -> - let lel = List.map (label_expr_se loc) sel in - <:expr< { $list:lel$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let e = expr_se se1 in - let t = ctyp_se se2 in - <:expr< ( $e$ : $t$ ) >> - | Sexpr loc [se] -> - let e = expr_se se in - <:expr< $e$ () >> - | Sexpr loc [Slid _ "assert"; Suid _ "False" ] -> - <:expr< assert False >> - | Sexpr loc [Slid _ "assert"; se] -> - let e = expr_se se in - <:expr< assert $e$ >> - | Sexpr loc [Slid _ "lazy"; se] -> - let e = expr_se se in - <:expr< lazy $e$ >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun e se -> - let e1 = expr_se se in - <:expr< $e$ $e1$ >>) - (expr_se se) sel - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:expr< [] >> - | [se1; Slid _ "."; 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 - | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] -and begin_se loc = - fun - [ [] -> <:expr< () >> - | [se] -> expr_se se - | sel -> - let el = List.map expr_se sel in - let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in - <:expr< do { $list:el$ } >> ] -and let_binding_se = - fun - [ Sexpr loc [se :: sel] -> - let e = begin_se loc sel in - match ipatt_opt_se se with - [ Left p -> (p, e) - | Right _ -> fun_binding_se se e ] - | se -> error se "let_binding" ] -and fun_binding_se se e = - match se with - [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) - | Sexpr _ [Slid loc s :: sel] -> - let s = Pcaml.rename_id.val s in - let e = - List.fold_right - (fun se e -> - let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - sel e - in - let p = <:patt< $lid:s$ >> in - (p, e) - | _ -> (ipatt_se se, e) ] -and match_case loc = - fun - [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> - (patt_se se, Some (expr_se sew), begin_se loc sel) - | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) - | 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 label_patt_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) - | se -> error se "label_patt" ] -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 [Slid _ "`"; 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 [Slid _ "?"; se1; se2] -> - stream_pattern_component skont ekont (expr_se se2) se1 - | Slid loc s -> - let s = Pcaml.rename_id.val s in - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> - | se -> error se "stream_pattern_component" ] -and patt_se = - fun - [ Sacc loc se1 se2 -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ . $p2$ >> - | Slid loc "_" -> <:patt< _ >> - | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:patt< $int:s$ >> - | Sfloat loc s -> <:patt< $flo:s$ >> - | Schar loc s -> <:patt< $chr:s$ >> - | Sstring loc s -> <:patt< $str:s$ >> - | Stid loc _ -> error_loc loc "patt" - | Sqid loc _ -> error_loc loc "patt" - | Srec loc sel -> - let lpl = List.map (label_patt_se loc) sel in - <:patt< { $list:lpl$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = patt_se se1 in - let t = ctyp_se se2 in - <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "or"; se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ | $p1$ >>) - (patt_se se) sel - | Sexpr loc [Slid _ "range"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ .. $p2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let pl = List.map patt_se sel in - <:patt< ( $list:pl$ ) >> - | Sexpr loc [Slid _ "as"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< ($p1$ as $p2$) >> - | 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< () >> - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:patt< [] >> - | [se1; Slid _ "."; 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 - | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] -and ipatt_se se = - match ipatt_opt_se se with - [ Left p -> p - | Right (se, _) -> error se "ipatt" ] -and ipatt_opt_se = - fun - [ Slid loc "_" -> Left <:patt< _ >> - | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [Sqid _ s; se] -> - let s = Pcaml.rename_id.val s in - let e = expr_se se in - Left <:patt< ? ( $lid:s$ = $e$ ) >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = ipatt_se se1 in - let t = ctyp_se se2 in - Left <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "values" :: 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, loc1, tpl) = - match se1 with - [ Sexpr _ [Slid loc n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Slid loc n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: - type_declaration_list_se sel] - | [] -> [] - | [se :: _] -> error se "type_declaration" ] -and type_parameter_se = - fun - [ Slid _ 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 [Slid _ "sum" :: sel] -> - let cdl = List.map constructor_declaration_se sel in - <:ctyp< [ $list:cdl$ ] >> - | Srec loc sel -> - let ldl = List.map label_declaration_se sel in - <:ctyp< { $list:ldl$ } >> - | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> - let rec loop = - fun - [ [] -> assert False - | [se] -> ctyp_se se - | [se :: sel] -> - let t1 = ctyp_se se in - let loc = (fst (loc_of_sexpr se), snd loc) in - let t2 = loop sel in - <:ctyp< $t1$ -> $t2$ >> ] - in - loop sel - | Sexpr loc [Slid _ "*" :: sel] -> - let tl = List.map ctyp_se sel in - <:ctyp< ($list:tl$) >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun t se -> - let t2 = ctyp_se se in - <:ctyp< $t$ $t2$ >>) - (ctyp_se se) sel - | Sacc loc se1 se2 -> - let t1 = ctyp_se se1 in - let t2 = ctyp_se se2 in - <:ctyp< $t1$ . $t2$ >> - | Slid loc "_" -> <:ctyp< _ >> - | Slid loc s -> - if s.[0] = ''' then - let s = String.sub s 1 (String.length s - 1) in - <:ctyp< '$s$ >> - else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "ctyp" ] -and constructor_declaration_se = - fun - [ Sexpr loc [Suid _ ci :: sel] -> - (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) - | se -> error se "constructor_declaration" ] -and label_declaration_se = - fun - [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> - (loc, Pcaml.rename_id.val lab, True, ctyp_se se) - | Sexpr loc [Slid _ lab; se] -> - (loc, Pcaml.rename_id.val lab, False, ctyp_se se) - | se -> error se "label_declaration" ] -; - -value directive_se = - fun - [ Sexpr _ [Slid _ s] -> (s, None) - | Sexpr _ [Slid _ s; se] -> - let e = expr_se se in - (s, Some e) - | se -> error se "directive" ] -; - -(* Parser *) - -Pcaml.syntax_name.val := "Scheme"; -Pcaml.no_constructors_arity.val := False; - -do { - Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); - 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 type_declaration; - 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 -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value sexpr = Grammar.Entry.create gram "sexpr"; - -value rec leftify = - fun - [ Sacc loc1 se1 se2 -> - match leftify se2 with - [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 - | se2 -> Sacc loc1 se1 se2 ] - | x -> x ] -; - -EXTEND - GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; - implem: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_str_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - interf: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | si = sig_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_sig_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - top_phrase: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - Some <:str_item< # $n$ $opt:dp$ >> - | se = sexpr -> Some (str_item_se se) - | EOI -> None ] ] - ; - use_file: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item: - [ [ se = sexpr -> str_item_se se - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - sig_item: - [ [ se = sexpr -> sig_item_se se ] ] - ; - expr: - [ "top" - [ se = sexpr -> expr_se se ] ] - ; - patt: - [ [ se = sexpr -> patt_se se ] ] - ; - sexpr: - [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] - | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl - | "("; sl = LIST0 sexpr; ")."; se = SELF -> - leftify (Sacc loc (Sexpr loc sl) se) - | "["; sl = LIST0 sexpr; "]" -> Slist loc sl - | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl - | a = pa_extend_keyword -> Slid loc a - | s = LIDENT -> Slid loc s - | s = UIDENT -> Suid loc s - | s = TILDEIDENT -> Stid loc s - | s = QUESTIONIDENT -> Sqid loc s - | s = INT -> Sint loc s - | s = FLOAT -> Sfloat loc s - | s = CHAR -> Schar loc s - | s = STRING -> Sstring loc 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 - Squot loc typ txt ] ] - ; - sexpr_dot: - [ [ s = LIDENTDOT -> Slid loc s - | s = UIDENTDOT -> Suid loc s ] ] - ; - pa_extend_keyword: - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - ; -END; diff --git a/camlp4/etc/pa_sml.ml b/camlp4/etc/pa_sml.ml deleted file mode 100644 index ee5db540d1..0000000000 --- a/camlp4/etc/pa_sml.ml +++ /dev/null @@ -1,947 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -value ocaml_records = ref False; - -Pcaml.no_constructors_arity.val := True; - -value lexer = Plexer.gmake (); - -do { - Grammar.Unsafe.gram_reinit gram lexer; - 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; -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value not_impl loc s = - raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]")) -; - -type altern 'a 'b = [ Left of 'a | Right of 'b ]; - -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 ] -; - -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 (MLast.loc_of_expr e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value expr_of_patt p = - let loc = MLast.loc_of_patt p in - match p with - [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> - | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] -; - -value apply_bind loc e bl = - let rec loop e = - fun - [ [] -> e - | [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1)] list - | [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1)] list - | [<:str_item< module $s$ = $me$ >> :: list] -> - let e = <:expr< let module $s$ = $me$ in $e$ >> in - loop e list - | [si :: list] -> - raise Exit ] - and loop_let e pel = - fun - [ [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let $list:pel$ in $e$ >> in - loop e list ] - and loop_letrec e pel = - fun - [ [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let rec $list:pel$ in $e$ >> in - loop e list ] - in - loop e (List.rev bl) -; - -value make_local loc sl1 sl2 = - try - let pl = - List.map - (fun - [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p - | _ -> raise Exit ]) - sl2 - in - let e1 = - match List.map expr_of_patt pl with - [ [e] -> e - | el -> <:expr< ($list:el$) >> ] - in - let p1 = - match pl with - [ [p] -> p - | pl -> <:patt< ($list:pl$) >> ] - in - let e = apply_bind loc e1 sl2 in - let e = apply_bind loc e sl1 in - <:str_item< value $p1$ = $e$ >> - with - [ Exit -> - do { - Printf.eprintf "\ -*** Warning: a 'local' statement will be defined global because of bindings -which cannot be defined as first class values (modules, exceptions, ...)\n"; - flush stderr; - <:str_item< declare $list:sl1 @ sl2$ end >> - } ] -; - -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 extract_label_types loc tn tal cdol = - let (cdl, aux) = - List.fold_right - (fun (loc, c, tl, aux_opt) (cdl, aux) -> - match aux_opt with - [ Some anon_record_type -> - let new_tn = tn ^ "_" ^ c in - let loc = MLast.loc_of_ctyp anon_record_type in - let aux_def = ((loc, new_tn), [], anon_record_type, []) in - let tl = [<:ctyp< $lid:new_tn$ >>] in - ([(loc, c, tl) :: cdl], [aux_def :: aux]) - | None -> ([(loc, c, tl) :: cdl], aux) ]) - cdol ([], []) - in - [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux] -; - -value function_of_clause_list loc xl = - let (fname, fname_loc, nbpat, l) = - List.fold_left - (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) -> - let (fname, fname_loc, nbpat) = - if fname = "" then (x1, loc, List.length x2) - else if x1 <> fname then - raise_with_loc loc - (Stream.Error ("'" ^ fname ^ "' expected")) - else if List.length x2 <> nbpat then - raise_with_loc loc - (Stream.Error "bad number of patterns in that clause") - else (fname, fname_loc, nbpat) - in - let x4 = - match x3 with - [ Some t -> <:expr< ($x4$ : $t$) >> - | _ -> x4 ] - in - let l = [(x2, x4) :: l] in - (fname, fname_loc, nbpat, l)) - ("", loc, 0, []) xl - in - let l = List.rev l in - let e = - match l with - [ [(pl, e)] -> - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e - | _ -> - if nbpat = 1 then - let pwel = - List.map - (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l - in - <:expr< fun [ $list:pwel$ ] >> - else - let sl = - loop 0 where rec loop n = - if n = nbpat then [] - else ["a" ^ string_of_int (n + 1) :: loop (n + 1)] - in - let e = - let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in - let pwel = - List.map - (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l - in - <:expr< match ($list:el$) with [ $list:pwel$ ] >> - in - List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ] - in - (let loc = fname_loc in <:patt< $lid:fname$ >>, e) -; - -value record_expr loc x1 = - if ocaml_records.val then <:expr< { $list:x1$ } >> - else - let list1 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_expr v in - <:class_str_item< value $id$ = $v$ >>) - x1 - in - let list2 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:class_str_item< method $id$ = $lid:id$ >>) - x1 - in - <:expr< - let module M = - struct - class a = object $list:list1 @ list2$ end; - end - in - new M.a - >> -; - -value record_match_assoc loc lpl e = - if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) - else - let pl = List.map (fun (_, p) -> p) lpl in - let e = - let el = - List.map - (fun (l, _) -> - let s = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:expr< v # $lid:s$ >>) - lpl - in - let loc = MLast.loc_of_expr e in - <:expr< let v = $e$ in ($list:el$) >> - in - let p = <:patt< ($list:pl$) >> in - (p, e) -; - -value op = - Grammar.Entry.of_parser gram "op" - (parser [: `("", "op"); `(_, x) :] -> x) -; -lexer.Token.tok_using ("", "op"); - -value special x = - if String.length x >= 2 then - match x.[0] with - [ '+' | '<' | '^' -> True - | _ -> False ] - else False -; - -value idd = - let p = - parser - [ [: `("LIDENT", x) :] -> x - | [: `("UIDENT", x) :] -> x - | [: `("", "op"); `(_, x) :] -> x - | [: `("", x) when special x :] -> x ] - in - Grammar.Entry.of_parser Pcaml.gram "ID" p -; - -value uncap s = String.uncapitalize s; - -EXTEND - GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr; - - implem: - [ [ x = interdec; EOI -> x ] ] - ; - interf: - [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ] - ; - 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: - [ [ x = sdec; l = sdecs -> [x :: l] - | ";"; l = sdecs -> l - | -> [] ] ] - ; - - 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: - [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] - | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ] - ; - 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$ >> ] ] - ; - 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 -> - let r = <:ctyp< $uid:x1$ . $x2$ >> in - loop r where rec loop = - fun - [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >> - | x -> x ] - | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ] - ; - selector: - [ [ x1 = id -> x1 - | x1 = INT -> not_impl loc "selector 1" ] ] - ; - tlabel: - [ [ x1 = selector; ":"; x2 = ctyp -> (loc, 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 = LIDENT -> <:ctyp< '$x1$ >> - | "{"; x1 = LIST1 tlabel SEP ","; "}" -> - if ocaml_records.val then <:ctyp< { $list:x1$ } >> - else - let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in - <:ctyp< < $list:list$ > >> - | "{"; "}" -> not_impl loc "ty' 3" - | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> - List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] - | "("; 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 = exp_ps -> - <: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$] >> - | "while"; x1 = expr; "do"; x2 = expr -> - <:expr< while $x1$ do { $x2$ } >> - | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" -> - <:expr< try $x1$ with [$list:x2$] >> ] - | RIGHTA - [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ] - | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ] - | 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$ >> - | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ] - | RIGHTA - [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >> - | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >> - | x1 = expr; "o"; x2 = expr -> <:expr< ooo $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$ >> - | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >> - | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ] - | LEFTA - [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] - | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> - | "#"; x1 = selector; x2 = expr -> - if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> - else <:expr< $x2$ # $lid:x1$ >> - | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] - | [ "!"; x1 = expr -> <:expr< $x1$ . val >> - | "~"; x1 = expr -> <:expr< - $x1$ >> ] - | [ x1 = LIDENT -> - match x1 with - [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >> - | "nil" -> <:expr< [] >> - | _ -> <: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$ >> - | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >> - | i = op -> - if i = "::" then <:expr< fun (x, y) -> [x :: y] >> - else <:expr< fun (x, y) -> $lid:i$ x y >> - | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" -> - List.fold_right - (fun pel x2 -> - let loc = - match pel with - [ [(p, _) :: _] -> - (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2)) - | _ -> loc ] - in - match pel with - [ [(_, <:expr< fun [$list:_$] >>) :: _] -> - <:expr< let rec $list:pel$ in $x2$ >> - | _ -> - let pel = - List.map - (fun (p, e) -> - match p with - [ <:patt< { $list:lpl$ } >> -> - record_match_assoc (MLast.loc_of_patt p) lpl e - | _ -> (p, e) ]) - pel - in - <:expr< let $list:pel$ in $x2$ >> ]) - x1 x2 - | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc 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; ";"; x2 = LIST1 SELF SEP ";"; ")" -> - <:expr< do { $list:[x1::x2]$ } >> - | "("; x1 = expr; ")" -> x1 ] ] - ; - fixity: - [ [ "infix" -> ("infix", None) - | "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 -> - match x1 with - [ <:patt< ref >> -> <:patt< {contents = $x2$} >> - | _ -> <:patt< $x1$ $x2$ >> ] ] - | "apat" - [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >> - | x1 = INT -> <:patt< $int:x1$ >> - | x1 = UIDENT -> <:patt< $uid:x1$ >> - | x1 = STRING -> <:patt< $str:x1$ >> - | "#"; x1 = STRING -> <:patt< $chr:x1$ >> - | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >> - | LIDENT "nil" -> <:patt< [] >> - | LIDENT "false" -> <:patt< False >> - | LIDENT "true" -> <:patt< True >> - | x1 = id -> <:patt< $lid:x1$ >> - | x1 = op -> <:patt< $lid:x1$ >> - | "_" -> <:patt< _ >> - | "["; "]" -> <:patt< [] >> - | "["; x1 = patt; "]" -> <:patt< [$x1$] >> - | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" -> - mklistpat loc None [x1 :: x2] - | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >> - | "("; ")" -> <:patt< () >> - | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" -> - <:patt< ($list:[x1::x2]$) >> - | "("; x1 = patt; ")" -> x1 ] ] - ; - plabel: - [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2) - | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid: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 "|" -> function_of_clause_list loc xl - | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat"); - x3 = constrain; "="; x4 = expr -> - let x1 = - match x1 with - [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1) - | _ -> not_impl loc "clause 1" ] - in - (x1, x2, x3, x4) ] ] - ; - tb: - [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs -> - let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in - ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ] - ; - 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 -> (loc, x2, [], None) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> - match x3 with - [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3) - | _ -> (loc, x2, [x3], None) ] ] ] - ; - eb: - [ [ x1 = op_op; x2 = ident -> (x2, [], []) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], []) - | x1 = op_op; x2 = ident; "="; x3 = sqid -> (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 = spec; x2 = spec_s -> [x1 :: x2] - | ";"; x1 = spec_s -> x1 ] ] - ; - spec: - [ [ "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$ >> - | "eqtype"; 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" -> <:sig_item< declare end >> - | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ] - ; - sig_item: - [ [ x = spec -> x ] ] - ; - strspec: - [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def -> - let x2 = - List.fold_left - (fun mt sdl -> - List.fold_right - (fun spl mt -> - match spl with - [ Right ([m1], m2) -> - let (m1, m2) = - match m2 with - [ <:module_expr< $uid:x$ . $_$ >> -> - if x = x1 then (m2, m1) else (m1, m2) - | _ -> (m1, m2) ] - in - let m1 = - loop m1 where rec loop = - fun - [ <:module_expr< $uid:x$ >> -> x - | <:module_expr< $uid:x$ . $y$ >> -> loop y - | _ -> not_impl loc "strspec 2" ] - in - <:module_type< $mt$ with module $[m1]$ = $m2$ >> - | _ -> not_impl loc "strspec 1" ]) - sdl mt) - x2 x3 - in - <:sig_item< module $x1$ : $x2$ >> ] ] - ; - sharing_def: - [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ] - ; - fctspec: - [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ] - ; - tyspec: - [ [ x1 = tyvars; x2 = idd -> - ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) ] ] - ; - 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 -> Left x1 - | x1 = patheqn -> Right x1 ] ] - ; - patheqn: - [ [ l = patheqn1 -> l ] ] - ; - patheqn1: - [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x) - | x = qid -> ([], x) ] ] - ; - whspec: - [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp -> - MLast.WcTyp loc x2 x1 x3 - | x1 = sqid; "="; x2 = qid -> 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 -> - match x2 with - [ Left [] -> x1 - | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> - | Right x2 -> <: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; ")" -> Right x1 - | "("; x2 = strdecs; ")" -> Left x2 ] ] - ; - 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" -> - make_local loc x1 x2 ] - | [ "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, eqn) -> - <:str_item< exception $s$ of $list:tl$ = $eqn$ >>) - 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 - | LIDENT "use"; s = STRING -> - <:str_item< #use $str:s$ >> - | x1 = fixity; list = LIST1 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) - list; - str_declare loc [] - } - | ("infix", None) -> - do { - List.iter - (fun s -> - EXTEND - expr: LEVEL "4" - [ [ x1 = expr; $s$; x2 = expr -> - <:expr< $lid:s$ ($x1$, $x2$) >> ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; $s$; - x2 = patt LEVEL "apat"; "="; x4 = expr -> - ((s, loc), [<:patt< ($x1$, $x2$) >>], - None, x4) ] ] - ; - END) - list; - str_declare loc [] - } - | _ -> not_impl loc "ldec 14" ] - | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa -> - not_impl loc "ldec 15" - | x = expr -> <:str_item< $exp:x$ >> ] ] - ; - sdec: - [ [ x = str_item -> x ] ] - ; - 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 -> [<:sig_item< module $x1$ : $x2$ >>] - | x1 = spec_s -> x1 ] ] - ; - fparamList: - [ [ "("; x1 = fparam; ")" -> [x1] - | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ] - ; - fctb: - [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "="; - x4 = module_expr -> - let list = List.flatten x2 in - let x4 = - if list = [] then x4 - else - match x4 with - [ <:module_expr< struct $list:list$ end >> -> - let si = let loc = (0, 0) in <:str_item< open AAA >> in - <:module_expr< struct $list:[si :: list]$ end >> - | _ -> not_impl loc "fctb 1" ] - in - let x4 = - match x3 with - [ Some x3 -> <:module_expr< ($x4$ : $x3$) >> - | None -> x4 ] - in - let x4 = - if list = [] then x4 - else - let mt = - let loc = - (fst (MLast.loc_of_sig_item (List.hd list)), - snd (MLast.loc_of_sig_item (List.hd (List.rev list)))) - in - <:module_type< sig $list:list$ end >> - in - <:module_expr< functor (AAA : $mt$) -> $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; OPT ";" -> (s, loc) ] -> (x, False) - | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] - ; -END; - -Pcaml.add_option "-records" (Arg.Set ocaml_records) - "Convert record into OCaml records, instead of objects"; diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml deleted file mode 100644 index c8ce441714..0000000000 --- a/camlp4/etc/parserify.ml +++ /dev/null @@ -1,301 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id$ *) - -value loc = (0, 0); - -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 gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -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 -> gensym () ] -; - -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 $subst v f$ $lid:v$ >> - | e -> semantic e ] -; - -value spc_of_parser = - 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_of_expr e = spc_of_parser (rewrite_parser e); diff --git a/camlp4/etc/parserify.mli b/camlp4/etc/parserify.mli deleted file mode 100644 index ece8b8927f..0000000000 --- a/camlp4/etc/parserify.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -value parser_of_expr : - MLast.expr -> - list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); diff --git a/camlp4/etc/pr_depend.ml b/camlp4/etc/pr_depend.ml deleted file mode 100644 index 0cf6e4412f..0000000000 --- a/camlp4/etc/pr_depend.ml +++ /dev/null @@ -1,327 +0,0 @@ -(* 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 - | x -> not_impl "ctyp" x ] -and constr_decl (_, _, tl) = list ctyp tl -and label_decl (_, _, _, t) = ctyp t -and variant = - fun - [ RfTag _ _ tl -> list ctyp tl - | RfInh t -> ctyp t ] -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 _ _ po -> option patt po - | PaLid _ _ -> () - | PaOlb _ _ peoo -> - option (fun (p, eo) -> do { patt p; option expr eo }) peoo - | 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 _ _ -> () - | 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; } -and 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 - | ExAsf _ -> () - | ExAsr _ e -> do { expr e; } - | 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 _ _ -> () - | ExInt32 _ _ -> () - | ExInt64 _ _ -> () - | ExNativeInt _ _ -> () - | ExFlo _ _ -> () - | ExLab _ _ eo -> option expr eo - | ExLaz _ 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 _ _ eo -> option expr eo - | 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; } - | 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 - | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts - | 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 - | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes - | 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 e -> do { class_expr ce; expr e; } - | 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 None -> expr e - | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t } - | 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."; diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml deleted file mode 100644 index 43e3794e17..0000000000 --- a/camlp4/etc/pr_extend.ml +++ /dev/null @@ -1,514 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value no_slist = ref False; - -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< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] -> - let (gmod, gl) = get_globals pel in - if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl]) - else raise Not_found - | [] -> ("", []) - | _ -> 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 ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e - | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> -> - Snterml e s - | <:expr< Gramext.Snterml ($uid:_$.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) -; - -value ungextend_body e = - let e = - match e with - [ <:expr< - let grammar_entry_create = Gram.Entry.create in - let $list:ll$ in $e$ - >> -> - let _ = get_locals ll in e - | _ -> e ] - in - match e with - [ <:expr< do { $list:el$ } >> -> - List.map - (fun - [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> -> - (e, unposition pos, unlevel_list ll) - | _ -> raise Not_found ]) - el - | _ -> raise Not_found ] -; - -(* 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< a_list >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, - ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], - Some <:expr< Qast.List a >>)] - when not no_slist.val - -> - 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 - [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)] - when not no_slist.val - -> - let s = - match s with - [ Srules - [([(Some <:patt< x >>, Stoken ("", str))], - Some <:expr< Qast.Str x >>)] -> - Stoken ("", str) - | s -> s ] - in - HVbox [: `S LR "SOPT"; `simple_symbol s k :] - | 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 - [: `LocInfo (MLast.loc_of_expr e) - (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 (fun e k -> HVbox [: `expr e "" k :]) 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 ] -; - -value get_gextend = - fun - [ <:expr< let $list:gl$ in $e$ >> -> - try - let (gmod, gl) = get_globals gl in - let el = ungextend_body e in - Some (gmod, gl, el) - with - [ Not_found -> None ] - | _ -> None ] -; - -value gextend e dg k = - match get_gextend e with - [ Some (gmod, gl, el) -> - BEbox - [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :]; - `extend_body (gl, el) [: :]; - `HVbox [: `S LR "END"; k :] :] - | None -> expr e "" k ] -; - -value is_gextend e = get_gextend e <> None; - -(* Printer extensions *) - -let lev = - try find_pr_level "expr1" pr_expr.pr_levels with - [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ] -in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `next e "" k :] ]; - -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 :] - | <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `gextend e "" k :] ]; - -Pcaml.add_option "-no_slist" (Arg.Set no_slist) - "Don't reconstruct SLIST and SOPT"; diff --git a/camlp4/etc/pr_extfun.ml b/camlp4/etc/pr_extfun.ml deleted file mode 100644 index 4d5c036615..0000000000 --- a/camlp4/etc/pr_extfun.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* 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 :] ]; diff --git a/camlp4/etc/pr_null.ml b/camlp4/etc/pr_null.ml deleted file mode 100644 index 40566f24d3..0000000000 --- a/camlp4/etc/pr_null.ml +++ /dev/null @@ -1,16 +0,0 @@ -(* 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 _ -> (); diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml deleted file mode 100644 index d87566726a..0000000000 --- a/camlp4/etc/pr_o.ml +++ /dev/null @@ -1,2062 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; -open Stdpp; - -value no_ss = ref True; - -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 - HVbox [: `S NO ("<pr_o: not impl: " ^ name ^ "; " ^ desc ^ ">") :] -; - -value apply_it l f = - apply_it_f l where rec apply_it_f = - fun - [ [] -> f - | [a :: l] -> a (apply_it_f l) ] -; - -value rec list elem = - fun - [ [] -> fun _ k -> k - | [x] -> fun dg k -> [: `elem x dg k :] - | [x :: l] -> fun dg k -> [: `elem x "" [: :]; list elem l dg k :] ] -; - -value rec listws elem sep el dg k = - match el with - [ [] -> k - | [x] -> [: `elem x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem x sdg [: `sep :]; listws elem sep l dg 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 :] ] -; - -value level box elem next e dg k = - let rec curr e dg k = elem curr next e dg k in - box (curr e dg k) -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**."; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "$"; "%"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "+"; - ","; "-"; "-."; "->"; "."; ".."; "/"; ":"; "::"; ":="; ":>"; ";"; ";;"; - "<"; "<-"; "<="; "<>"; "="; "=="; ">"; ">="; ">]"; ">}"; "?"; "??"; - "@"; "["; "[<"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "assert"; "asr"; - "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; - "if"; "in"; "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; - "lor"; "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private"; - "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; - "virtual"; "when"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~"; "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "( " ^ v ^ " )" - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -value conv_con = - fun - [ "True" -> "true" - | "False" -> "false" - | " True" -> "True" - | " False" -> "False" - | x -> x ] -; - -value conv_lab = - fun - [ "val" -> "contents" - | x -> var_escaped x ] -; - -(* default global loc *) - -value loc = (0, 0); - -value id_var s = - if has_special_chars s || is_infix s then - HVbox [: `S LR "("; `S LR s; `S LR ")" :] - else if is_keyword s then HVbox [: `S LR (s ^ "__") :] - else HVbox [: `S LR s :] -; - -value virtual_flag = - fun - [ True -> [: `S LR "virtual" :] - | _ -> [: :] ] -; - -value rec_flag = - fun - [ True -> [: `S LR "rec" :] - | _ -> [: :] ] -; - -(* extensible printers *) - -value sig_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_sig_item.pr_fun "top" x "" k -; -value str_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_str_item.pr_fun "top" x "" k -; -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e dg k = pr_module_expr.pr_fun "top" e "" k; -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 expr1 e dg k = pr_expr.pr_fun "expr1" e dg k; -value simple_expr e dg k = pr_expr.pr_fun "simple" e dg k; -value patt1 e dg k = pr_patt.pr_fun "patt1" e dg k; -value simple_patt e dg k = pr_patt.pr_fun "simple" e dg k; -value ctyp e dg k = pr_ctyp.pr_fun "top" e dg k; -value simple_ctyp e dg k = pr_ctyp.pr_fun "simple" e dg k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value class_sig_item x dg k = pr_class_sig_item.pr_fun "top" x "" k; -value class_str_item x dg k = pr_class_str_item.pr_fun "top" x "" k; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - -(* type core *) - -value mutable_flag = - fun - [ True -> [: `S LR "mutable" :] - | _ -> [: :] ] -; - -value private_flag = - fun - [ True -> [: `S LR "private" :] - | _ -> [: :] ] -; - -value rec labels loc b vl _ k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `label True b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] - | [v :: l] -> [: `label False b v "" [: :]; labels loc [: :] l "" k :] ] -and label is_last b (loc, f, m, t) _ k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo loc - (HVbox - [: `HVbox [: b; m; `S LR (conv_lab f); `S LR ":" :]; - `ctyp t "" [: :] :]); - k :] -; - -value rec ctyp_list tel _ k = listws simple_ctyp (S LR "*") tel "" k; - -value rec variants loc b vl dg k = - match vl with - [ [] -> [: b; k :] - | [v] -> [: `variant b v "" k; `LocInfo (snd loc, snd loc) (HVbox [: :]) :] - | [v :: l] -> - [: `variant b v "" [: :]; variants loc [: `S LR "|" :] l "" k :] ] -and variant b (loc, c, tl) _ k = - match tl with - [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo loc (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl "" k :] :] ] -; - -value rec row_fields b rfl _ k = listwbws row_field b (S LR "|") rfl "" k -and row_field b rf _ k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; - `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl "" k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t "" k :] ] -; - -value rec get_type_args t tl = - match t with - [ <:ctyp< $t1$ $t2$ >> -> get_type_args t1 [t2 :: tl] - | _ -> (t, tl) ] -; - -value module_pref = - apply_it - [level (fun x -> HOVbox x) - (fun curr next t _ k -> - match t with - [ <:ctyp< $t1$ $t2$ >> -> - let (t, tl) = get_type_args t1 [t2] in - [: curr t "" [: :]; - list - (fun t _ k -> - HOVbox [: `S NO "("; curr t "" [: :]; `S RO ")"; k :]) - tl "" k :] - | <:ctyp< $t1$ . $t2$ >> -> - [: curr t1 "" [: `S NO "." :]; `next t2 "" k :] - | _ -> [: `next t "" k :] ])] - simple_ctyp -; - -value rec class_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl dg k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl dg k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) dg k = - match (ml, v) with - [ ([f], False) -> [: `field f dg k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> - [: `field f "" [: `S RO ";" :]; meth_list (ml, v) dg k :] ] -and field (lab, t) dg k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :] -; - -(* patterns *) - -value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value raise_match_failure (bp, ep) k = - let (fname, line, char, _) = - if Pcaml.input_file.val <> "-" then - Stdpp.line_of_loc Pcaml.input_file.val (bp, ep) - else - ("-", 1, bp, ep) - in - HOVbox - [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "("; - `S LR ("\"" ^ fname ^ "\""); `S RO ","; - `S LR (string_of_int line); `S RO ","; `S LR (string_of_int char); - `S RO ")"; `S RO ")"; k :] -; - -value rec bind_list b pel _ k = - match pel with - [ [pe] -> let_binding b pe "" k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel "" k :] ] -and let_binding b (p, e) _ k = - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo loc (BEbox (let_binding0 b p e k)) -and let_binding0 b p e k = - let (pl, e) = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] - in - let b = [: b; `simple_patt p "" [: :] :] in - match (p, e) with - [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) -> - [: `HVbox - [: `HVbox b; `HVbox (list simple_patt pl "" [: `S LR ":" :]); - `ctyp t "" [: `S LR "=" :] :]; - `expr e "" [: :]; k :] - | _ -> - [: `HVbox - [: `HVbox b; `HOVbox (list simple_patt pl "" [: `S LR "=" :]) :]; - `expr e "" [: :]; k :] ] -and match_assoc_list loc pel dg k = - match pel with - [ [] -> - HVbox - [: `HVbox [: `S LR "_"; `S LR "->" :]; `raise_match_failure loc k :] - | _ -> - BEVbox - [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel "" k :] ] -and match_assoc b (p, w, e) dg k = - let s = - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p "" [: :]; - `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] - | _ -> [: `patt p "" [: `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e dg k :] :] -; - -value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) dg k = - HVbox [: `label lab; `S LR "="; `expr e dg k :] -; - -value type_params sl _ k = - match sl with - [ [] -> k - | [(s, vari)] -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - [: b; `S LO "'"; `S LR s; k :] - | sl -> - [: `S LO "("; - listws (fun (s, _) _ k -> HVbox [: `S LO "'"; `S LR s; k :]) - (S RO ",") sl "" [: `S RO ")"; k :] :] ] -; - -value constrain (t1, t2) _ k = - HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; `ctyp t2 "" k :] -; - -value type_list b tdl _ k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) _ k -> - let tn = var_escaped tn in - let cstr = list constrain cl "" k in - match te with - [ <:ctyp< '$s$ >> when not (List.mem_assoc s tp) -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | <:ctyp< [ $list:[]$ ] >> -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | _ -> - HVbox - [: `HVbox - [: b; type_params tp "" [: :]; `S LR tn; `S LR "=" :]; - `ctyp te "" [: :]; cstr :] ]) - b (S LR "and") tdl "" [: :]; - k :] -; - -value external_def (s, t, pl) _ k = - let ls = - list (fun s _ k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl "" k - in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" [: `S LR "="; ls :] :] -; - -value value_description (s, t) _ k = - HVbox - [: `HVbox [: `S LR "val"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" k :] -; - -value typevar s _ k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl _ k = - match sl with - [ [] -> k - | [s] -> [: `S LR s; k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl "" k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) _ k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration (s, mt) _ k = - match mt with - [ <:module_type< ' $_$ >> -> - HVbox [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; k :] :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] ] -and with_constraints b icl _ k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl "" k :] -and with_constraint b wc _ k = - match wc with - [ MLast.WcTyp _ p al e -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl "" [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p "" [: `S LR "=" :] :]; - `ctyp e "" k :] - | MLast.WcMod _ sl me -> - HVbox - [: b; `S LR "module"; mod_ident sl "" [: `S LR "=" :]; - `module_expr me "" k :] ] -; - -value rec module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me "" [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) _ k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] -and class_declaration b ci _ k = - class_fun_binding - [: b; virtual_flag ci.MLast.ciVir; class_type_parameters ci.MLast.ciPrm; - `S LR ci.MLast.ciNam :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ MLast.CeFun _ p cfb -> - class_fun_binding [: b; `simple_patt p "" [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; - listws type_parameter (S RO ",") tpl "" [: `S RO "]" :] :] ] -and type_parameter tp dg k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p "" [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; mutable_flag mf; `label lab; `S LR "=" :]; `expr e "" k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> - fun_binding [: b; `simple_patt p "" [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e "" k :] ] -and class_signature cs k = - match cs with - [ MLast.CtCon _ id [] -> clty_longident id "" k - | MLast.CtCon _ id tl -> - HVbox - [: `S LO "["; listws ctyp (S RO ",") tl "" [: `S RO "]" :]; - `clty_longident id "" k :] - | MLast.CtSig _ cst csf -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t "" [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `HVbox (curr mt1 "" [: `S RO ")" :]); `S LR "->" :] - in - [: `head; curr mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next dg k -> - [: curr mt "" [: :]; - `with_constraints [: `S LR "with" :] icl "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: :]; `S LO "("; - `next mt2 "" [: `S RO ")"; k :] :] - | <:module_type< $mt1$ . $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | mt -> - fun curr next dg k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: :]; - `HVbox - [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] stl "" k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s "" [: :] :] - | MLast.SgDir _ _ _ as si -> - fun curr next dg k -> [: `not_impl "sig_item" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next dg k -> - [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next dg k -> [: `value_description (s, t) "" k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:sig_item< include $mt$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next dg k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - "" k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> [: `modtype_declaration (s, mt) "" k :] - | <:sig_item< open $sl$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident sl "" k :] - | MLast.SgCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.SgClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.SgUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident i "" k :] - | <:str_item< $exp:e$ >> -> - fun curr next dg k -> - if no_ss.val then - [: `HVbox [: `S LR "let"; `S LR "_"; `S LR "=" :]; - `expr e "" k :] - else [: `HVbox [: :]; `expr e "" k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s "" [: :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next dg k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next dg k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) "" k :] - | _ -> - [: `variant [: `S LR "exception" :] (loc, c, tl) "" - [: `S LR "=" :]; - mod_ident b "" k :] ] - | <:str_item< include $me$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_expr me "" k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] tdl "" k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next dg k -> - [: `bind_list - [: `S LR "let"; if rf then [: `S LR "rec" :] else [: :] :] - pel "" k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next dg k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - "" k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | MLast.StCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.StClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.StUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -value ocaml_char = - fun - [ "'" -> "\\'" - | "\"" -> "\\\"" - | c -> c ] -; - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - [: `HVbox [: `HVbox [: :]; listws next (S RO ";") el dg k :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "expr1"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - let pel = [(p1, e1)] in - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `Vbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next dg k -> - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb [: :]; - `S LR "in"; `expr e dg k :] :] - else - [: `BEbox - [: `module_binding - [: `S LR "begin let"; `S LR "module"; `S LR m :] mb - [: :]; - `HVbox - [: `HVbox [: :]; `S LR "in"; `expr e dg [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< fun [ $list:pel$ ] >> as e -> - fun curr next dg k -> - let loc = MLast.loc_of_expr e in - if not (List.mem dg ["|"; ";"]) then - match pel with - [ [] -> - [: `S LR "fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc k :] - | [(p, None, e)] -> - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e "" k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "function"; - `match_assoc_list loc pel "" k :] :] ] - else - match pel with - [ [] -> - [: `S LR "(fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc [: `S RO ")"; k :] :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `S LO "("; - `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e "" [: `S RO ")"; k :] :] :] - else - [: `HVbox - [: `S LR "fun ["; `patt p "" [: `S LR "->" :] :]; - `expr e "" [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "begin function"; - `match_assoc_list loc pel "" k; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< match $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin match"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< try $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin try"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< if $e1$ then $e2$ else $e3$ >> as e -> - fun curr next dg k -> - let eel_e = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - if not (List.mem dg ["else"]) then - match eel_e with - [ ([], <:expr< () >>) -> - [: `BEbox [: `S LR "if"; `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 dg k :] - | (eel, <:expr< () >>) -> - let (eel, (e1f, e2f)) = - let r = List.rev eel in - (List.rev (List.tl r), List.hd r) - in - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox - [: `BEbox - [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1f "" [: :]; `S LR "then" :]; - `expr1 e2f dg k :] :] :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ] - else - match eel_e with - [ (_, <:expr< () >>) -> [: `next e "" k :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "" [: :] :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e "" k :] :] :] ] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next dg k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 "" [: `S LR d :]; - `expr e2 "" [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next dg k -> - [: `BEbox - [: `BEbox - [: `S LR "while"; `expr e1 "" [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< ($list:el$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") el "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$.val := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR ":=" :]; `expr y dg k :] - | <:expr< $x$ := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR "<-" :]; `expr y dg k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:("||" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:("or" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:(("&&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:(("&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "=" | "<>" | "<" | "<." | "<=" | ">" | ">=" | ">=." | "==" | - "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> [: `next e "" k :] - | Some x -> - [: listws next (S LR "::") el "" [: `S LR "::" :]; - `next x "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next dg k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next dg k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next dg k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next dg k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next dg k -> [: `S LR (x^"n"); k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next dg k -> [: `S LR "lazy"; `next x "" k :] - | MLast.ExAsf _ -> -(* | <:expr< assert False >> -> *) - fun curr next dg k -> [: `S LR "assert"; `S LR "false"; k :] - | MLast.ExAsr _ e -> -(* | <:expr< assert ($e$) >> -> *) - fun curr next dg k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next dg k -> - let loc = MLast.loc_of_expr e in - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next dg k -> - match get_expr_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:expr< $uid:_$ >> | <:expr< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".("; `expr y "" [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".["; `expr y "" [: `S RO "]"; k :] :] - | <:expr< $e$. val >> -> - fun curr next dg k -> [: `S LO "!"; `next e "" k :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next dg k -> - [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next dg k -> - [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; - listws expr (S RO ";") el "" [: `S RO "]"; k :] :] - | Some x -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt32 _ x -> - fun curr next dg k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - let x = x^"L" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - let x = x^"n" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> - fun curr next dg k -> [: `S LR (conv_con s); k :] - | <:expr< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next dg k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [| $list:el$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws expr (S RO ";") el "" [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next dg k -> - [: `S LO "{"; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next dg k -> - [: `HVbox [: `S LO "{"; curr e "" [: `S LR "with" :] :]; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t "" [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t1 "" [: `S LR ":>" :]; `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":>" :]; - `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< new $list:sl$ >> -> - fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :] - | <:expr< {< >} >> -> fun curr next dg k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next dg k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel dg [: `S LR ">}"; k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - match el with - [ [e] -> curr e dg k - | _ -> - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listws expr1 (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> as e -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVCbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< ($x$ as $lid:y$) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S LR "as"; `S LR (var_escaped y); k :] - | <:patt< ($x$ as $y$) >> -> - fun curr next dg k -> - [: curr y "" [: :]; `S LR "as"; `next x "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< ($list:pl$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") pl "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "patt1"; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `HVbox [: :]; listws next (S LR "::") (pl @ [x]) "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next dg k -> - match get_patt_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:patt< $uid:_$ >> | <:patt< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next dg k -> [: curr x "" [: :]; `S NO "."; - `simple_patt y "" k :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws patt (S RO ";") pl "" [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next dg k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) _ k -> - HVbox - [: `patt lab "" [: `S LR "=" :]; `patt p "" k :]) - (S RO ";") fpl "" [: `S RO "}"; k :] :] :] - | <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] ] - | <:patt< ($p$ : $ct$) >> -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `S LR ":" :]; - `ctyp ct "" [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) - -> fun curr next dg k -> [: `S LR s; k :] - | MLast.PaInt32 _ s - -> fun curr next dg k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s - -> fun curr next dg k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s - -> fun curr next dg k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:i$ >> -> fun curr next dg k -> [: `id_var i; k :] - | <:patt< $uid:i$ >> -> - fun curr next dg k -> [: `S LR (conv_con i); k :] - | <:patt< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next dg k -> [: `S LO "#"; mod_ident sl dg k :] - | <:patt< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next dg k -> - [: `S LO ("~" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next dg k -> - if i = "" then [: `S LO "?"; `simple_patt p "" k :] - else [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< ($list:_$) >> | <:patt< $_$ .. $_$ >> as p -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next dg k -> listws next (S LR "*") tl "" k - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next dg k -> - [: curr t1 "=" [: `S LR "=" :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next dg k -> [: `S LO (lab ^ ":"); `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next dg k -> - let (t, tl) = get_type_args t1 [t2] in - match tl with - [ [<:ctyp< $_$ $_$ >>] -> [: curr t2 "" [: :]; curr t1 "" k :] - | [_] -> [: `next t2 "" [: :]; curr t1 "" k :] - | _ -> - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) (S RO ",") - tl "" [: `S RO ")" :]; - curr t "" k :] ] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next dg k -> - [: `module_pref t1 "" [: `S NO "." :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< '$s$ >> -> - fun curr next dg k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:ctyp< private { $list:ftl$ } >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `HVbox [: labels loc [:`S LR "{" :] - ftl "" [: `S LR "}" :] :]; - k :] :] - | <:ctyp< { $list:ftl$ } >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl "" [: `S LR "}" :]; - k :] :] - | <:ctyp< private [ $list:ctl$ ] >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: `S LR "private" :]; - variants loc [: `S LR " " :] ctl "" [: :]; - k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; variants loc [: `S LR " " :] ctl "" [: :]; - k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[>" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next dg k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x _ k -> HVbox [: `S LR x; k :]) l "" k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[<" :] rfl "" k1; - k :] :] - | MLast.TyCls _ id -> - fun curr next dg k -> [: `S LO "#"; `class_longident id "" k :] - | MLast.TyObj _ [] False -> fun curr next dg k -> [: `S LR "<>"; k :] - | MLast.TyObj _ ml v -> - fun curr next dg k -> - [: `S LR "<"; meth_list (ml, v) "" [: `S LR ">"; k :] :] - | MLast.TyPol _ pl t -> - fun curr next dg k -> - if pl = [] then [: `ctyp t "" k :] - else [: list typevar pl "" [: `S LR "." :]; `ctyp t "" k :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< ($list:_$) >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ~ $_$ : $_$ >> | <:ctyp< ? $_$ : $_$ >> as t -> - fun curr next dg k -> - [: `S LO "("; `ctyp t "" [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next dg k -> [: `HVbox [: :]; list class_str_item s "" k :] - | MLast.CrInh _ ce pb -> - fun curr next dg k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next dg k -> [: `cvalue [: `S LR "val" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next dg k -> - [: `S LR "method"; `S LR "virtual"; private_flag pf; `label lab; - `S LR ":"; `ctyp t "" k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next dg k -> - [: `fun_binding [: `S LR "method"; private_flag pf; `label lab :] - fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; private_flag pf; `label lab; `S LR ":"; - `ctyp t "" [: `S LR "=" :] :]; - `expr fb "" k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next dg k -> - [: `HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :] :]; - `ctyp t2 "" k :] - | MLast.CrIni _ se -> - fun curr next dg k -> [: `S LR "initializer"; `expr se "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CgCtr _ t1 t2 -> - fun curr next dg k -> - [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; - `ctyp t2 "" k :] - | MLast.CgDcl _ s -> - fun curr next dg k -> - [: `HVbox [: :]; list class_sig_item s "" [: :] :] - | MLast.CgInh _ ce -> - fun curr next dg k -> [: `S LR "inherit"; `class_type ce k :] - | MLast.CgMth _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; private_flag pf; `label lab; - `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVal _ lab mf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVir _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; private_flag pf; - `label lab; `S LR ":" :]; - `ctyp t "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next dg k -> - [: `ctyp t "" [: `S LR "->" :]; curr ct "" k :] - | ct -> fun curr next dg k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next dg k -> - [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next dg k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; rec_flag rf :] lb "" - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next dg k -> [: curr ce "" [: :]; `simple_expr e "" k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next dg k -> [: `class_longident ci "" k :] - | MLast.CeCon _ ci ctcl -> - fun curr next dg k -> - [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :]; - `class_longident ci "" k :] - | MLast.CeStr _ csp cf as ce -> - let ep = snd (MLast.loc_of_class_expr ce) in - fun curr next dg k -> - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf "" [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next dg k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; let s = input_source ic (ep - bp) in output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -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 mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si "" [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - do { copy_to_end ic oc first last_pos; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si "" [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - "<length> line length for pretty printing."; - -Pcaml.add_option "-ss" (Arg.Clear no_ss) "Print double semicolons."; - -Pcaml.add_option "-no_ss" (Arg.Set no_ss) - "Do not print double semicolons (default)."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - "<string> Use this string between phrases instead of reading source."; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_op.ml b/camlp4/etc/pr_op.ml deleted file mode 100644 index 983a3a3cd7..0000000000 --- a/camlp4/etc/pr_op.ml +++ /dev/null @@ -1,503 +0,0 @@ -(* 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 :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - 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 :] ]; diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml deleted file mode 100644 index d7203e6e38..0000000000 --- a/camlp4/etc/pr_op_main.ml +++ /dev/null @@ -1,214 +0,0 @@ -(* 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 *) - -open Parserify; - -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 - 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 :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - 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 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 :] ]; diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml deleted file mode 100644 index eb14e73762..0000000000 --- a/camlp4/etc/pr_r.ml +++ /dev/null @@ -1,1898 +0,0 @@ -(* 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 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 - HVbox [: `S NO ("<pr_r: not impl: " ^ name ^ "; " ^ desc ^ ">") :] -; - -value gen_where = ref True; -value old_sequences = ref False; -value expand_declare = ref False; - -external is_printable : char -> bool = "is_printable"; - -value char_escaped = - fun - [ '\\' -> "\\\\" - | '\b' -> "\\b" - | '\n' -> "\\n" - | '\r' -> "\\r" - | '\t' -> "\\t" - | c -> - if is_printable c then String.make 1 c - else do { - let n = Char.code c in - let s = String.create 4 in - String.unsafe_set s 0 '\\'; - String.unsafe_set s 1 (Char.unsafe_chr (48 + n / 100)); - String.unsafe_set s 2 (Char.unsafe_chr (48 + n / 10 mod 10)); - String.unsafe_set s 3 (Char.unsafe_chr (48 + n mod 10)); - s - } ] -; - -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 k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "*."; "+"; "+."; - ","; "-"; "-."; "->"; "."; ".."; "/"; "/."; ":"; "::"; ":="; ":>"; - ":]"; ";"; "<"; "<="; "<>"; "="; "=="; ">"; ">="; ">}"; "?"; "@"; "["; - "[:"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "asr"; "assert"; "class"; - "constraint"; "declare"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "for"; "fun"; "functor"; "if"; "in"; - "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; - "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable"; - "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "return"; - "sig"; "struct"; "then"; "to"; "try"; "type"; "value"; "virtual"; - "when"; "where"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "\\" ^ v - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -(* default global loc *) - -value loc = (0, 0); - -(* extensible printers *) - -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e k = pr_module_expr.pr_fun "top" e "" k; -value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value expr x k = pr_expr.pr_fun "top" x "" k; -value patt x k = pr_patt.pr_fun "top" x "" k; -value ctyp x k = pr_ctyp.pr_fun "top" x "" k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value simple_expr x k = pr_expr.pr_fun "simple" x "" k; -value class_sig_item x k = - pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_str_item x k = - pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - - -(* type core *) - -value rec labels loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `label True b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ] -and label is_last b (loc, f, m, t) k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo loc - (HVbox - [: `HVbox [: b; `S LR f; `S LR ":" :]; - `HVbox [: m; `ctyp t [: :] :] :]); - k :] -; - -value rec ctyp_list tel k = listws ctyp (S LR "and") tel k; - -value rec variants loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `variant b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ] -and variant b (loc, c, tl) k = - match tl with - [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo loc (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ] -; - -value rec row_fields b rfl k = listwbws row_field b (S LR "|") rfl k -and row_field b rf k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t k :] ] -; - -(* *) - -value rec class_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) k = - match (ml, v) with - [ ([f], False) -> [: `field f k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ] -and field (lab, t) k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :] -; - -(* patterns *) - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ >> -> True - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value rec get_defined_ident = - fun - [ <:patt< $_$ . $_$ >> -> [] - | <:patt< _ >> -> [] - | <:patt< $lid:x$ >> -> [x] - | <:patt< ($p1$ as $p2$) >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $int:_$ >> -> [] - | (MLast.PaNativeInt _ _ | MLast.PaInt64 _ _ | MLast.PaInt32 _ _) -> [] - | <:patt< $flo:_$ >> -> [] - | <:patt< $str:_$ >> -> [] - | <:patt< $chr:_$ >> -> [] - | <:patt< [| $list:pl$ |] >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< ($list:pl$) >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< $uid:_$ >> -> [] - | <:patt< ` $_$ >> -> [] - | <:patt< # $list:_$ >> -> [] - | <:patt< $p1$ $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< { $list:lpl$ } >> -> - List.flatten (List.map (fun (lab, p) -> get_defined_ident p) lpl) - | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< ($p$ : $_$) >> -> get_defined_ident p - | <:patt< ~ $_$ >> -> [] - | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p - | <:patt< ? $_$ >> -> [] - | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p - | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p - | <:patt< $anti:p$ >> -> get_defined_ident p ] -; - -value un_irrefut_patt p = - match get_defined_ident p with - [ [] -> (<:patt< _ >>, <:expr< () >>) - | [i] -> (<:patt< $lid:i$ >>, <:expr< $lid:i$ >>) - | il -> - let (upl, uel) = - List.fold_right - (fun i (upl, uel) -> - ([<:patt< $lid:i$ >> :: upl], [<:expr< $lid:i$ >> :: uel])) - il ([], []) - in - (<:patt< ($list:upl$) >>, <:expr< ($list:uel$) >>) ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value rec bind_list b pel k = - match pel with - [ [pe] -> let_binding b pe k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ] -and let_binding b (p, e) k = - let (p, e) = - if is_irrefut_patt p then (p, e) - else - let (up, ue) = un_irrefut_patt p in - (up, <:expr< match $e$ with [ $p$ -> $ue$ ] >>) - in - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo loc (BEbox [: let_binding0 [: b; `patt p [: :] :] e [: :]; k :]) -and let_binding0 b e k = - let (pl, e) = expr_fun_args e in - match e with - [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> - when - let rec call_f = - fun - [ <:expr< $lid:f'$ >> -> f = f' - | <:expr< $e$ $_$ >> -> call_f e - | _ -> False ] - in - gen_where.val && call_f e -> - let (pl1, e1) = expr_fun_args <:expr< fun [ $list:pel$ ] >> in - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `HVbox - [: `HOVbox - [: `expr e [: :]; `S LR "where"; flag "rec" r; `S LR f; - `HVbox (list patt pl1 [: `S LR "=" :]) :]; - `expr e1 k :] :] - | <:expr< ($e$ : $t$) >> -> - [: `HVbox - [: `HVbox b; `HOVbox (list patt pl [: `S LR ":" :]); - `ctyp t [: `S LR "=" :] :]; - `expr e k :] - | _ -> - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `expr e k :] ] -and 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 :] :] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :]; - -value rec sequence_loop = - fun - [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] -> - let el = - match e with - [ <:expr< do { $list:el$ } >> -> el - | _ -> [e] ] - in - let r = flag "rec" r in - [: listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - sequence_loop el :] - | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] -> - [: `simple_expr e [: `S RO ";" :]; sequence_loop el :] - | [e] -> [: `expr e [: :] :] - | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :] - | [] -> [: :] ] -; - -value sequence b1 b2 b3 el k = - BEbox - [: `BEbox [: b1; b2; `HVbox [: b3; `S LR "do {" :] :]; - `HVbox [: `HVbox [: :]; sequence_loop el :]; - `HVbox [: `S LR "}"; k :] :] -; - -value rec let_sequence e = - match e with - [ <:expr< do { $list:el$ } >> -> Some el - | <:expr< let $opt:_$ $list:_$ in $e1$ >> -> - match let_sequence e1 with - [ Some _ -> Some [e] - | None -> None ] - | _ -> None ] -; - -value ifbox b1 b2 b3 e k = - if old_sequences.val then HVbox [: `HOVbox [: b1; b2; b3 :]; `expr e k :] - else - match let_sequence e with - [ Some el -> sequence b1 b2 b3 el k - | None -> HVbox [: `BEbox [: b1; b2; b3 :]; `expr e k :] ] -; - -value rec type_params sl k = - list - (fun (s, vari) k -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - HVbox [: b; `S LO "'"; `S LR s; k :]) - sl k -; - -value constrain (t1, t2) k = - HVbox [: `S LR "constraint"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] -; - -value type_list b tdl k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) k -> - let tn = var_escaped tn in - HVbox - [: `HVbox [: b; `S LR tn; type_params tp [: `S LR "=" :] :]; - `ctyp te [: :]; list constrain cl k :]) - b (S LR "and") tdl [: :]; - k :] -; - -value external_def s t pl k = - let ls = list (fun s k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl k in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t [: `S LR "="; ls :] :] -; - -value value_description s t k = - HVbox - [: `HVbox [: `S LR "value"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t k :] -; - -value typevar s k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl k = - match sl with - [ [] -> k - | [s] -> [: `S LR (var_escaped s); k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration s mt k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] -and with_constraints b icl k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :] -and with_constraint b wc k = - match wc with - [ <:with_constr< type $p$ $list:al$ = $e$ >> -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p [: `S LR "=" :] :]; - `ctyp e k :] - | <:with_constr< module $sl$ = $me$ >> -> - HVbox - [: b; `S LR "module"; mod_ident sl [: `S LR "=" :]; - `module_expr me k :] ] -and module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] -and class_declaration b ci k = - class_fun_binding - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ <:class_expr< fun $p$ -> $cfb$ >> -> - class_fun_binding [: b; `patt p [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ] -and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and simple_expr e k = - match e with - [ <:expr< $lid:_$ >> -> expr e k - | _ -> HVbox [: `S LO "("; `expr e [: `S RO ")"; k :] :] ] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and label lab = S LR (var_escaped lab) -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; flag "mutable" mf; `label lab; `S LR "=" :]; `expr e k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ] -and simple_patt p k = - match p with - [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> | - <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k - | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ] -and class_signature cs k = - match cs with - [ <:class_type< $list:id$ >> -> clty_longident id k - | <:class_type< $list:id$ [ $list:tl$ ] >> -> - HVbox - [: `clty_longident id [: :]; `S LO "["; - listws ctyp (S RO ",") tl [: `S RO "]"; k :] :] - | <:class_type< object $opt:cst$ $list:csf$ end >> -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt1 [: `S RO ")" :]; `S LR "->" :] - in - [: `head; `module_type mt2 k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next _ k -> - [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ . $mt2$ >> -> - fun curr next _ k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< ' $s$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ s); k :] - | mt -> - fun curr next _ k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next _ k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] stl k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list sig_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:sig_item< # $_$ $opt:_$ >> as si -> - fun curr next _ k -> [: `not_impl "sig_item1" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next _ k -> - [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next _ k -> [: `value_description s t k :] - | <:sig_item< include $mt$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next _ k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> [: `modtype_declaration s mt k :] - | <:sig_item< open $sl$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident sl k :] - | <:sig_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - k :] - | <:sig_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.SgUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident i k :] - | <:str_item< $exp:e$ >> -> - fun curr next _ k -> [: `HVbox [: :]; `expr e k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list str_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next _ k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next _ k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | _ -> - [: `variant [: `S LR "exception" :] (loc, c, tl) - [: `S LR "=" :]; - mod_ident b k :] ] - | <:str_item< include $me$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_expr me k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next _ k -> - [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next _ k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | <:str_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - k :] - | <:str_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.StUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -(* -EXTEND_PRINTER - pr_expr: - [ "top" (fun e x -> LocInfo (MLast.loc_of_expr e) (HOVbox x)) - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] ] ] - ; -END; -*) - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< fun [ $list:pel$ ] >> -> - fun curr next _ k -> - match pel with - [ [] -> [: `S LR "fun"; `S LR "[]"; k :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list patt [p :: pl] [: `S LR "->" :] :]; - `expr e k :] :] - else - [: `HVbox [: `S LR "fun ["; `patt p [: `S LR "->" :] :]; - `expr e [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "fun"; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] :] ] - | <:expr< match $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "match"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< match $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< match $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "match"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< try $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< try $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "try"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< try $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "try"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun curr next _ k -> - let (eel, e) = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - [: `HVbox - [: `HVbox [: :]; - `ifbox [: `S LR "if" :] [: `expr e1 [: :] :] - [: `S LR "then" :] e2 [: :]; - list - (fun (e1, e2) k -> - ifbox [: `HVbox [: `S LR "else"; `S LR "if" :] :] - [: `expr e1 [: :] :] [: `S LR "then" :] e2 k) - eel [: :]; - `ifbox [: `S LR "else" :] [: :] [: :] e k :] :] - | <:expr< do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - let (el, e) = - match List.rev el with - [ [e :: el] -> (List.rev el, e) - | [] -> ([], <:expr< () >>) ] - in - [: `HOVCbox - [: `HVbox [: :]; - `BEbox - [: `S LR "do"; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) - el [: :] :]; - `S LR "return" :]; - `expr e k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next _ k -> [: `sequence [: :] [: :] [: :] el k :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> - when old_sequences.val -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; - `expr e2 [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `sequence - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; `expr e2 [: :] :] :] - [: :] [: :] el k :] - | <:expr< while $e1$ do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - [: `BEbox - [: `BEbox [: `S LR "while"; `expr e1 [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next _ k -> - [: `sequence [: `S LR "while"; `expr e1 [: :] :] [: :] [: :] el - k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ := $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR ":=" :]; `expr y k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"||"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | <:expr< $lid:"or"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"&&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | <:expr< $lid:"&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "<" | ">" | "<=" | ">=" | ">=." | "=" | "<>" | "==" | "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next _ k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next _ k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $int:x$ >> -> fun curr next _ k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next _ k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next _ k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next _ k -> [: `S LR (x^"n"); k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next _ k -> [: `S LR "lazy"; `next x "" k :] - | <:expr< assert False >> -> - fun curr next _ k -> [: `S LR "assert"; `S LR "False"; k :] - | <:expr< assert ($e$) >> -> - fun curr next _ k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next _ k -> - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | <:expr< new $list:sl$ >> -> - fun curr next _ k -> [: `S LR "new"; `class_longident sl k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".("; `expr y [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".["; `expr y [: `S RO "]"; k :] :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next _ k -> [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next _ k -> [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) -> - fun curr next _ k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast. ExInt32 _ x -> - fun curr next _ k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - fun curr next _ k -> - let x = x^"L" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - fun curr next _ k -> - let x = x^"n" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:expr< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; listws expr (S RO ";") el [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "["; listws expr (S RO ";") el [: `S LR "::" :]; - `expr x [: `S RO "]"; k :] :] ] - | <:expr< [| $list:el$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws expr (S RO ";") el [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next _ k -> - [: `S LO "{"; - listws - (fun (lab, e) k -> - HVbox [: let_binding0 [: `patt lab [: :] :] e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; `S LO "("; - `expr e [: `S RO ")"; `S LR "with" :] :]; - listws - (fun (lab, e) k -> - HVbox [: `patt lab [: `S LR "=" :]; `expr e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; `ctyp t1 [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next _ k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :] - | <:expr< ($list:el$) >> -> - fun curr next _ k -> - [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< new $list:_$ >> as e -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox [: `HVbox [: :]; x :]); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO "." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - [: `HOVCbox - [: `S LO "["; - let rec glop pl k = - match pl with - [ [] -> failwith "simple_patt" - | [p] -> - match c with - [ None -> [: `patt p k :] - | Some x -> - [: `patt p [: `S LR "::" :]; `patt x k :] ] - | [p :: pl] -> - [: `patt p [: `S RO ";" :]; glop pl k :] ] - in - glop pl [: `S RO "]"; k :] :] :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws patt (S RO ";") pl [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) k -> - HVbox [: `patt lab [: `S LR "=" :]; `patt p k :]) - (S RO ";") fpl [: `S RO "}"; k :] :] :] - | <:patt< ($list:[p::pl]$) >> -> - fun curr next _ k -> - [: `HOVCbox - [: `S LO "("; - listws patt (S RO ",") [p :: pl] [: `S RO ")"; k :] :] :] - | <:patt< ($p$ : $ct$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `S LR ":" :]; - `ctyp ct [: `S RO ")"; k :] :] - | <:patt< ($x$ as $y$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt x [: `S LR "as" :]; - `patt y [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) -> - fun curr next _ k -> [: `S LR s; k :] - | MLast.PaInt32 _ s -> fun curr next _ k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s -> fun curr next _ k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s -> fun curr next _ k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:patt< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next _ k -> [: `S LO "#"; mod_ident sl k :] - | <:patt< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$ : $t$) >> -> - fun curr next _ k -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next _ k -> - if i = "" then [: `S LO "?"; curr p "" k :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $_$ | $_$ >> as p -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: `S LR "==" :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ! $list:pl$ . $t$ >> -> - fun curr next dg k -> - if pl = [] then [: `ctyp t k :] - else - [: `HVbox [: `S LR "!"; list typevar pl [: `S LR "." :] :]; - `ctyp t k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next _ k -> [: curr t1 "" [: :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next _ k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ lab ^ ":"); `next t "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: :]; `S NO "."; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next _ k -> - [: `S LO "("; listws ctyp (S LR "*") tl [: `S RO ")"; k :] :] - | <:ctyp< '$s$ >> -> - fun curr next _ k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:ctyp< private { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `HVbox [: labels loc [:`S LR "{" :] - ftl [: `S LR "}" :] :]; - k :] :] - | <:ctyp< { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl [: `S LR "}" :]; k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< private [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: `S LR "private" :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ =" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next _ k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1; - k :] :] - | <:ctyp< # $list:id$ >> -> - fun curr next _ k -> [: `S LO "#"; `class_longident id k :] - | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :] - | <:ctyp< < $list:ml$ $opt:v$ > >> -> - fun curr next _ k -> - [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ? $_$ : $_$ >> | <:ctyp< ~ $_$ : $_$ >> | - <:ctyp< ! $list:_$ . $_$ >> as t -> - fun curr next _ k -> - [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:class_sig_item< type $t1$ = $t2$ >> -> - fun curr next _ k -> - [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] - | <:class_sig_item< declare $list:s$ end >> -> - fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :] - | <:class_sig_item< inherit $ce$ >> -> - fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :] - | <:class_sig_item< method $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `label lab; `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "private"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "value"; flag "mutable" mf; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `S LR "private"; - `label lab; `S LR ":" :]; - `ctyp t k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next _ k -> [: `HVbox [: :]; list class_str_item s [: :] :] - | MLast.CrInh _ ce pb -> - fun curr next _ k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next _ k -> - [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next _ k -> - [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab; - `S LR ":"; `ctyp t k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next _ k -> - [: `fun_binding - [: `S LR "method"; flag "private" pf; `label lab :] fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; - `ctyp t [: `S LR "=" :] :]; - `expr fb k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next _ k -> - [: `HVbox [: `S LR "type"; `ctyp t1 [: `S LR "=" :] :]; - `ctyp t2 k :] - | MLast.CrIni _ se -> - fun curr next _ k -> [: `S LR "initializer"; `expr se k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next _ k -> - [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; - `class_type ct k :] - | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next _ k -> - [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next _ k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; flag "rec" rf :] lb - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next _ k -> [: `class_longident ci k :] - | MLast.CeCon _ ci ctcl -> - fun curr next _ k -> - [: `class_longident ci [: :]; `S LO "["; - listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] - | MLast.CeStr _ csp cf as ce -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_class_expr ce) in - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in - output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -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 mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - do { copy_to_end ic oc first last_pos; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - "<length> Maximum line length for pretty printing."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - "<string> Use this string between phrases instead of reading source."; - -Pcaml.add_option "-no_where" (Arg.Clear gen_where) - "Dont generate \"where\" statements"; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-old_seq" (Arg.Set old_sequences) - "Pretty print with old syntax for sequences."; - -Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare) - "Expand the \"declare\" items."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_rp.ml b/camlp4/etc/pr_rp.ml deleted file mode 100644 index 3487165e9f..0000000000 --- a/camlp4/etc/pr_rp.ml +++ /dev/null @@ -1,504 +0,0 @@ -(* 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 gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -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 -> gensym () ] -; - -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) - | <:expr< match $_$ strm__ with [ $list:_$ ] >> -> (<:expr< strm__ >>, 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< match $_$ strm__ with [ $list:_$ ] >> 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 :] ]; diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml deleted file mode 100644 index 11ad11af77..0000000000 --- a/camlp4/etc/pr_rp_main.ml +++ /dev/null @@ -1,206 +0,0 @@ -(* 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 *) - -open Parserify; - -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 - 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 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 :] ]; diff --git a/camlp4/etc/pr_scheme.ml b/camlp4/etc/pr_scheme.ml deleted file mode 100644 index a7c2309488..0000000000 --- a/camlp4/etc/pr_scheme.ml +++ /dev/null @@ -1,813 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id$ *) - -open Pcaml; -open Format; - -type printer_t 'a = - { pr_fun : mutable string -> next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) -and curr 'a = formatter -> ('a * string * kont) -> unit -and next 'a = formatter -> ('a * string * kont) -> unit -and kont = formatter -> unit; - -value not_impl name x ppf k = - 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 - fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k -; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr ppf (x, dg, k) = - Extfun.apply lev.pr_rules x ppf curr next dg k - in - fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x - else loop app levl ] -; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; -value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); -pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; - -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); - -value pr_expr = {pr_fun = fun []; pr_levels = []}; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); - -value pr_label_decl = {pr_fun = fun []; pr_levels = []}; -value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); -pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; - -value pr_let_binding = {pr_fun = fun []; pr_levels = []}; -pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; -value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); - -value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; -pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; -value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); - -value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; -pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; -value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); - -value pr_module_binding = {pr_fun = fun []; pr_levels = []}; -pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; -value module_binding ppf (x, k) = - pr_module_binding.pr_fun "top" ppf (x, "", k); - -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); - -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); - -value pr_patt = {pr_fun = fun []; pr_levels = []}; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); - -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); - -value pr_type_decl = {pr_fun = fun []; pr_levels = []}; -value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); -pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; - -value pr_type_params = {pr_fun = fun []; pr_levels = []}; -value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); -pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; - -value pr_with_constr = {pr_fun = fun []; pr_levels = []}; -value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); -pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; - -(* general functions *) - -value nok ppf = (); -value ks s k ppf = fprintf ppf "%s%t" s k; - -value rec list f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf (x, k) - | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] -; - -value rec listwb b f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf ((b, x), k) - | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] -; - -(* specific functions *) - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value sequence ppf (e, k) = - match e with - [ <:expr< do { $list:el$ } >> -> - fprintf ppf "@[<hv>%a@]" (list expr) (el, k) - | _ -> expr ppf (e, k) ] -; - -value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; - -value int_repr s = - if String.length s > 2 && s.[0] = '0' then - match s.[1] with - [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> - "#" ^ String.sub s 1 (String.length s - 1) - | _ -> s ] - else s -; - -value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -(* extensible pretty print functions *) - -pr_constr_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, c, []) as x -> - fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k) - | (loc, c, tl) -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< [ $list:cdl$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k) - | <:ctyp< { $list:cdl$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k) - | <:ctyp< ( $list:tl$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ -> $t2$ >> -> - fun ppf curr next dg k -> - let tl = - loop t2 where rec loop = - fun - [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] - | t -> [t] ] - in - fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp) - ([t1 :: tl], ks ")" k) - | <:ctyp< $t1$ $t2$ >> -> - fun ppf curr next dg k -> - let (t, tl) = - loop [t2] t1 where rec loop tl = - fun - [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 - | t1 -> (t1, tl) ] - in - fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ . $t2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) - | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:ctyp< ' $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s%t" s k - | <:ctyp< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; - -pr_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:expr< fun [] >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda%t" (ks ")" k) - | <:expr< fun $lid:s$ -> $e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) - | <:expr< fun [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc) - (pwel, ks ")" k) - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< let $p1$ = $e1$ in $e2$ >> -> - fun ppf curr next dg k -> - let (pel, e) = - loop [(p1, e1)] e2 where rec loop pel = - fun - [ <:expr< let $p1$ = $e1$ in $e2$ >> -> - loop [(p1, e1) :: pel] e2 - | e -> (List.rev pel, e) ] - in - let b = - match pel with - [ [_] -> "let" - | _ -> "let*" ] - in - fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b - (listwb "" let_binding) (pel, ks ")" nok) - sequence (e, ks ")" k) - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - fun ppf curr next dg k -> - let b = if rf then "letrec" else "let" in - fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b - (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) - | <:expr< if $e1$ then $e2$ else () >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) - expr (e2, nok) expr (e3, ks ")" k) - | <:expr< do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k) - | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) - expr (e2, nok) (list expr) (el, ks ")" k) - | <:expr< ($e$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) - | <:expr< ($list:el$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) - | <:expr< { $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k) - | <:expr< { ($e$) with $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) - (list record_binding) (fel, ks "}" k) - | <:expr< $e1$ := $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< [$_$ :: $_$] >> as e -> - fun ppf curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list expr) (el, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) - expr (x, ks "]" k) ] - | <:expr< lazy ($x$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) - | <:expr< $lid:s$ $e1$ $e2$ >> - when List.mem s assoc_right_parsed_op_list -> - fun ppf curr next dg k -> - let el = - loop [e1] e2 where rec loop el = - fun - [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> - loop [e1 :: el] e2 - | e -> List.rev [e :: el] ] - in - fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) - | <:expr< $e1$ $e2$ >> -> - fun ppf curr next dg k -> - let (f, el) = - loop [e2] e1 where rec loop el = - fun - [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 - | e1 -> (e1, el) ] - in - fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) - | <:expr< ~ $s$ : ($e$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) - | <:expr< $e1$ .[ $e2$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) - | <:expr< $e1$ .( $e2$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) - | <:expr< $e1$ . $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) - | <:expr< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:expr< ` $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "`%s%t" s k - | <:expr< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:expr< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | x -> - fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; - -pr_label_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, f, m, t) -> - fun ppf curr next dg k -> - fprintf ppf "(@[<hv>%s%t@ %a@]" f - (fun ppf -> if m then fprintf ppf "@ mutable" else ()) - ctyp (t, ks ")" k) ]}]; - -pr_let_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, (p, e)) -> - fun ppf curr next dg k -> - let (pl, e) = expr_fun_args e in - match pl with - [ [] -> - fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b - (if b = "" then "" else " ") patt (p, nok) - sequence (e, ks ")" k) - | _ -> - fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b - (if b = "" then "" else " ") (list patt) ([p :: pl], nok) - sequence (e, ks ")" k) ] ]}]; - -pr_match_assoc.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (p, we, e) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%t@ %a@]" - (fun ppf -> - match we with - [ Some e -> - fprintf ppf "(when@ %a@ %a" patt (p, nok) - expr (e, ks ")" nok) - | None -> patt ppf (p, nok) ]) - sequence (e, ks ")" k) ]}]; - -pr_mod_ident.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [s] -> - fun ppf curr next dg k -> - fprintf ppf "%s%t" s k - | [s :: sl] -> - fun ppf curr next dg k -> - fprintf ppf "%s.%a" s curr (sl, "", k) - | x -> - fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; - -pr_module_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, s, me) -> - fun ppf curr next dg k -> - fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt, nok) module_expr (me, ks ")" k) - | <:module_expr< struct $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item) - (sil, ks ")" k) - | <:module_expr< $me1$ $me2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) - module_expr (me2, ks ")" k) - | <:module_expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; - -pr_module_type.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt1, nok) module_type (mt2, ks ")" k) - | <:module_type< sig $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k) - | <:module_type< $mt$ with $list:wcl$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) - (list with_constr) (wcl, ks "))" k) - | <:module_type< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:patt< $p1$ | $p2$ >> -> - fun ppf curr next dg k -> - let (f, pl) = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> (p1, pl) ] - in - fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) - (pl, ks ")" k) - | <:patt< ($p1$ as $p2$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< $p1$ .. $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< [$_$ :: $_$] >> as p -> - fun ppf curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list patt) (pl, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) - patt (x, ks "]" k) ] - | <:patt< $p1$ $p2$ >> -> - fun ppf curr next dg k -> - let pl = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> [p1 :: pl] ] - in - fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) - | <:patt< ($p$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) - | <:patt< ($list:pl$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) - | <:patt< { $list:fpl$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p1, p2), k) = - fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - in - fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k) - | <:patt< ? $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "?%s%t" x k - | <:patt< ? ($lid:x$ = $e$) >> -> - fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) - | <:patt< $p1$ . $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) - | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:patt< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | <:patt< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:patt< $flo:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:sig_item< value $i$ : $t$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) - | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:sig_item< module $s$ : $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[module@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list sig_item) (s, k) - | MLast.SgUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) - | <:str_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:str_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun ppf curr next dg k -> - let b = if rf then "definerec" else "define" in - match pel with - [ [(p, e)] -> - fprintf ppf "%a" let_binding ((b, (p, e)), k) - | pel -> - fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding) - (pel, ks ")" k) ] - | <:str_item< module $s$ = $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) - | <:str_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:str_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:str_item< $exp:e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a" expr (e, k) - | <:str_item< # $s$ $opt:x$ >> -> - fun ppf curr next dg k -> - match x with - [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) - | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] - | <:str_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list str_item) (s, k) - | MLast.StUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; - -pr_type_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, ((_, tn), tp, te, cl)) -> - fun ppf curr next dg k -> - fprintf ppf "%t%t@;<1 1>%a" - (fun ppf -> - if b <> "" then fprintf ppf "%s@ " b - else ()) - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%s" tn - | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) - ctyp (te, k) ]}]; - -pr_type_params.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [(s, vari) :: tpl] -> - fun ppf curr next dg k -> - fprintf ppf "@ '%s%a" s type_params (tpl, k) - | [] -> - fun ppf curr next dg k -> () ]}]; - -pr_with_constr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ MLast.WcTyp _ m tp te -> - fun ppf curr next dg k -> - fprintf ppf "(type@ %t@;<1 1>%a" - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%a" mod_ident (m, nok) - | tp -> - fprintf ppf "(%a@ %a)" mod_ident (m, nok) - type_params (tp, nok) ]) - ctyp (te, ks ")" k) - | x -> - fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; - -(* main *) - -value output_string_eval ppf s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then pp_print_char ppf s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } - | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] -; - -value sep = Pcaml.inter_phrases; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ppf (ic, first, bp, ep) = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then pp_print_string ppf "\n" - else output_string_eval ppf str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in pp_print_string ppf s - } ] -; - -value copy_to_end ppf (ic, first, bp) = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ppf (ic, first, bp, ilen) - else pp_print_string ppf "\n" -; - -value apply_printer printer ast = - let ppf = std_formatter in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos, bp); - fprintf ppf "@[%a@]@?" printer (si, nok); - (False, ep) - }) - (True, 0) ast - in - fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos) - with x -> - do { fprintf ppf "@."; close_in ic; raise x }; - close_in ic; - } - else failwith "not implemented" -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) - "<length> Maximum line length for pretty printing."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - "<string> Use this string between phrases instead of reading source."; diff --git a/camlp4/etc/pr_schp_main.ml b/camlp4/etc/pr_schp_main.ml deleted file mode 100644 index c535111499..0000000000 --- a/camlp4/etc/pr_schp_main.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id$ *) - -open Format; -open Pcaml; -open Parserify; - -value nok = Pr_scheme.nok; -value ks = Pr_scheme.ks; -value patt = Pr_scheme.patt; -value expr = Pr_scheme.expr; -value find_pr_level = Pr_scheme.find_pr_level; -value pr_expr = Pr_scheme.pr_expr; -type printer_t 'a = Pr_scheme.printer_t 'a == - { pr_fun : mutable string -> Pr_scheme.next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = Pr_scheme.pr_level 'a == - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable Pr_scheme.pr_rule 'a } -; - -(* extensions for rebuilding syntax of parsers *) - -value parser_cases ppf (spel, k) = - let rec parser_cases ppf (spel, k) = - match spel with - [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" - | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) - | [(sp, epo, e) :: spel] -> - fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) - parser_cases (spel, k) ] - and parser_case ppf (sp, epo, e, k) = - fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) - (fun ppf -> - match epo with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | None -> () ]) - expr (e, ks ")" k) - and stream_patt ppf (sp, k) = - match sp with - [ [] -> k ppf - | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) - | [(spc, Some e)] -> - fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) - expr (e, ks ")" k) - | [(spc, None) :: spcl] -> - fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) - | [(spc, Some e) :: spcl] -> - fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) - expr (e, ks ")" nok) stream_patt (spcl, k) ] - and stream_patt_comp ppf (spc, k) = - match spc with - [ SPCterm (p, w) -> - match w with - [ Some e -> - fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) - | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] - | SPCnterm p e -> - fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) - | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] - in - parser_cases ppf (spel, k) -; - -value parser_body ppf (e, k) = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - fprintf ppf "(parser%t%t" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - (ks ")" k) - | spel -> - fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - parser_cases (spel, ks ")" k) ] -; - -value pmatch ppf (e, k) = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_schp_main.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok) - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> () ]) - parser_cases (spel, ks ")" k) -; - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <: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< fun (strm__ : $_$) -> $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) - | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml deleted file mode 100644 index 841e2bec90..0000000000 --- a/camlp4/etc/q_phony.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* 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; "" }; - -if Pcaml.syntax_name.val <> "Scheme" then - EXTEND - expr: LEVEL "top" - [ [ "IFDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if DEF $uid:c$ then $e1$ else $e2$ >> - | "IFNDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if NDEF $uid:c$ then $e1$ else $e2$ >> ] ] - ; - END -else (); diff --git a/camlp4/lib/.cvsignore b/camlp4/lib/.cvsignore deleted file mode 100644 index c77a681dd6..0000000000 --- a/camlp4/lib/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oiax] -*.cmxa -*.lib diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend deleted file mode 100644 index 0d5adc691f..0000000000 --- a/camlp4/lib/.depend +++ /dev/null @@ -1,20 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: gramext.cmi token.cmi -plexer.cmi: token.cmi -extfold.cmo: gramext.cmi grammar.cmi extfold.cmi -extfold.cmx: gramext.cmx grammar.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi -plexer.cmo: stdpp.cmi token.cmi plexer.cmi -plexer.cmx: stdpp.cmx token.cmx plexer.cmi -stdpp.cmo: stdpp.cmi -stdpp.cmx: stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile deleted file mode 100644 index ece72d1519..0000000000 --- a/camlp4/lib/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi - -installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) - -include .depend diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac deleted file mode 100644 index 90034c5c74..0000000000 --- a/camlp4/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -OCAMLCFLAGS = {INCLUDES} -OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo -INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi -TARGETS = gramlib.cma - -all Ä {TARGETS} - -{TARGETS} Ä {OBJS} - {OCAMLC} {OBJS} -a -o {TARGETS} - -steal Ä - -compare_stolen Ä - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -promote Ä - duplicate -y {OBJS} {INTF} ::boot: - -compare Ä - for i in {OBJS} {INTF} - equal -s ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/lib/Makefile.Mac.depend b/camlp4/lib/Makefile.Mac.depend deleted file mode 100644 index 8d12e3e08a..0000000000 --- a/camlp4/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/lib/extfold.ml b/camlp4/lib/extfold.ml deleted file mode 100644 index b612d15248..0000000000 --- a/camlp4/lib/extfold.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value gen_fold0 final f e entry symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> final a -; - -value gen_fold1 final f e entry symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; a = fold (f a e) :] -> final a -; - -value gen_fold0sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: v = psep; a = psymb ? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> final (kont (f a e) s) - | [: :] -> e ] -; - -value gen_fold1sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: v = psep; - a = - parser - [ [: a = psymb :] -> a - | [: a = parse_top symbl :] -> Obj.magic a - | [: :] -> raise (Stream.Error (failed symbl)) ]; - s :] -> - kont (f a accu) s - | [: :] -> accu ] - in - parser [: a = psymb; s :] -> final (kont (f a e) s) -; - -value sfold0 f e = gen_fold0 (fun x -> x) f e; -value sfold1 f e = gen_fold1 (fun x -> x) f e; -value sfold0sep f e = gen_fold0sep (fun x -> x) f e; -value sfold1sep f e = gen_fold1sep (fun x -> x) f e; - -value cons x y = [x :: y]; -value nil = []; - -value slist0 entry = gen_fold0 List.rev cons nil entry; -value slist1 entry = gen_fold1 List.rev cons nil entry; -value slist0sep entry = gen_fold0sep List.rev cons nil entry; -value slist1sep entry = gen_fold1sep List.rev cons nil entry; - -value sopt entry symbl psymb = - parser - [ [: a = psymb :] -> Some a - | [: :] -> None ] -; diff --git a/camlp4/lib/extfold.mli b/camlp4/lib/extfold.mli deleted file mode 100644 index 639631e27d..0000000000 --- a/camlp4/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value sfold0 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold1 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold0sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; -value sfold1sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; - -value slist0 : t _ 'a (list 'a); -value slist1 : t _ 'a (list 'a); -value slist0sep : tsep _ 'a (list 'a); -value slist1sep : tsep _ 'a (list 'a); - -value sopt : t _ 'a (option 'a); diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml deleted file mode 100644 index 866ea221c1..0000000000 --- a/camlp4/lib/extfun.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* camlp4r *) -(* $Id$ *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type t 'a 'b = list (matching 'a 'b) -and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -exception Failure; - -value empty = []; - -(*** Apply ***) - -value rec apply_matchings a = - fun - [ [m :: ml] -> - match m.expr a with - [ None -> apply_matchings a ml - | x -> x ] - | [] -> None ] -; - -value apply ef a = - match apply_matchings a ef with - [ Some x -> x - | None -> raise Failure ] -; - -(*** Trace ***) - -value rec list_iter_sep f s = - fun - [ [] -> () - | [x] -> f x - | [x :: l] -> do { f x; s (); list_iter_sep f s l } ] -; - -value rec print_patt = - fun - [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p ] -and print_patt2 = - fun - [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p ] -and print_patt1 = - fun - [ Econ s -> print_string s - | Estr s -> do { print_string "\""; print_string s; print_string "\"" } - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - do { - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - } - | Eapp _ | Eacc _ as p -> - do { print_string "("; print_patt p; print_string ")" } ] -; - -value print ef = - List.iter - (fun m -> - do { - print_patt m.patt; - if m.has_when then print_string " when ..." else (); - print_newline () - }) - ef -; - -(*** Extension ***) - -value insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - fun - [ [m :: ml] as gml -> - if m1.has_when && not m.has_when then [m1 :: gml] - else if not m1.has_when && m.has_when then [m :: loop ml] - else - let c = compare m1.patt m.patt in - if c < 0 then [m1 :: gml] - else if c > 0 then [m :: loop ml] - else if m.has_when then [m1 :: gml] - else [m1 :: ml] - | [] -> [m1] ] - in - loop matchings -; - -(* available extension function *) - -value extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -; diff --git a/camlp4/lib/extfun.mli b/camlp4/lib/extfun.mli deleted file mode 100644 index 01b3cbd76b..0000000000 --- a/camlp4/lib/extfun.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type t 'a 'b = 'x; - (** The type of the extensible functions of type ['a -> 'b] *) -value empty : t 'a 'b; - (** Empty extensible function *) -value apply : t 'a 'b -> 'a -> 'b; - (** Apply an extensible function *) -exception Failure; - (** Match failure while applying an extensible function *) -value print : t 'a 'b -> unit; - (** Print patterns in the order they are recorded *) - -(**/**) - -type matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b; diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml deleted file mode 100644 index 14ab3a3d1c..0000000000 --- a/camlp4/lib/fstream.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* camlp4r *) -(* $Id$ *) -(* Copyright 2001 INRIA *) - -type t 'a = { count : int; data : Lazy.t (data 'a) } -and data 'a = - [ Nil - | Cons of 'a and t 'a - | App of t 'a and t 'a ] -; - -value from f = - loop 0 where rec loop i = - {count = 0; - data = - lazy - (match f i with - [ Some x -> Cons x (loop (i + 1)) - | None -> Nil ])} -; - -value rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - [ Nil -> None - | Cons a s -> Some (a, {count = count; data = s.data}) - | App s1 s2 -> - match next s1 with - [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)}) - | None -> - match next s2 with - [ Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None ] ] ] -; - -value empty s = - match next s with - [ Some _ -> None - | None -> Some ((), s) ] -; - -value nil = {count = 0; data = lazy Nil}; -value cons a s = Cons a s; -value app s1 s2 = App s1 s2; -value flazy f = {count = 0; data = Lazy.lazy_from_fun f}; - -value of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -; - -value of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -; - -value of_channel ic = - from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ]) -; - -value iter f = - do_rec where rec do_rec strm = - match next strm with - [ Some (a, strm) -> - let _ = f a in - do_rec strm - | None -> () ] -; - -value count s = s.count; - -value count_unfrozen s = - loop 0 s where rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - [ Cons _ s -> loop (cnt + 1) s - | _ -> cnt ] - else cnt -; diff --git a/camlp4/lib/fstream.mli b/camlp4/lib/fstream.mli deleted file mode 100644 index 12926d99ff..0000000000 --- a/camlp4/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type t 'a = 'x; - (* The type of 'a functional streams *) -value from : (int -> option 'a) -> t 'a; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some <value>] for a value or [None] to specify the end of the - stream. *) - -value of_list : list 'a -> t 'a; - (* Return the stream holding the elements of the list in the same - order. *) -value of_string : string -> t char; - (* Return the stream of the characters of the string parameter. *) -value of_channel : in_channel -> t char; - (* Return the stream of the characters read from the input channel. *) - -value iter : ('a -> unit) -> t 'a -> unit; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -value next : t 'a -> option ('a * t 'a); - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -value empty : t 'a -> option (unit * t 'a); - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -value count : t 'a -> int; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -value count_unfrozen : t 'a -> int; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -value nil : t 'a; -type data 'a = 'x; -value cons : 'a -> t 'a -> data 'a; -value app : t 'a -> t 'a -> data 'a; -value flazy : (unit -> data 'a) -> t 'a; diff --git a/camlp4/lib/gramext.ml b/camlp4/lib/gramext.ml deleted file mode 100644 index 980f0918d8..0000000000 --- a/camlp4/lib/gramext.ml +++ /dev/null @@ -1,565 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Printf; - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value warning_verbose = ref True; - -value rec derive_eps = - fun - [ Slist0 _ -> True - | Slist0sep _ _ -> True - | Sopt _ -> True - | Stree t -> tree_derive_eps t - | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext | - Sself | Stoken _ -> - False ] -and tree_derive_eps = - fun - [ LocAct _ _ -> True - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> False ] -; - -value rec eq_symbol s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1 == e2 - | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 - | (Slist0 s1, Slist0 s2) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbol s1 s2 - | (Stree _, Stree _) -> False - | _ -> s1 = s2 ] -; - -value is_before s1 s2 = - match (s1, s2) with - [ (Stoken ("ANY", _), _) -> False - | (_, Stoken ("ANY", _)) -> True - | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True - | (Stoken _, Stoken _) -> False - | (Stoken _, _) -> True - | _ -> False ] -; - -value insert_tree entry_name gsymbols action tree = - let rec insert symbols tree = - match symbols with - [ [s :: sl] -> insert_in_tree s sl tree - | [] -> - match tree with - [ Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct old_action action_list -> - do { - if warning_verbose.val then do { - eprintf "<W> Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name - else (); - eprintf "some rule has been masked\n"; - flush stderr - } - else (); - LocAct action [old_action :: action_list] - } - | DeadEnd -> LocAct action [] ] ] - and insert_in_tree s sl tree = - match try_insert s sl tree with - [ Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] - and try_insert s sl tree = - match tree with - [ Node {node = s1; son = son; brother = bro} -> - if eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - [ Some bro -> bro - | None -> - Node {node = s; son = insert sl DeadEnd; brother = bro} ] - in - let t = Node {node = s1; son = son; brother = bro} in - Some t - else - match try_insert s sl bro with - [ Some bro -> - let t = Node {node = s1; son = son; brother = bro} in - Some t - | None -> None ] - | LocAct _ _ | DeadEnd -> None ] - and insert_new = - fun - [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct action [] ] - in - insert gsymbols tree -; - -value srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -; - -external action : 'a -> g_action = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value insert_level entry_name e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} ] -; - -value empty_lev lname assoc = - let assoc = - match assoc with - [ Some a -> a - | None -> LeftA ] - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -; - -value change_lev lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && warning_verbose.val then do { - eprintf "<W> Changing associativity of level \"%s\"\n" n; - flush stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && warning_verbose.val then do { - eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } -; - -value get_level entry position levs = - match position with - [ Some First -> ([], empty_lev, levs) - | Some Last -> (levs, empty_lev, []) - | Some (Level n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if is_level_labelled n lev then ([], change_lev lev n, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (Before n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if is_level_labelled n lev then ([], empty_lev, [lev :: levs]) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | Some (After n) -> - let rec get = - fun - [ [] -> - do { - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if is_level_labelled n lev then ([lev], empty_lev, levs) - else - let (levs1, rlev, levs2) = get levs in - ([lev :: levs1], rlev, levs2) ] - in - get levs - | None -> - match levs with - [ [lev :: levs] -> ([], change_lev lev "<top>", levs) - | [] -> ([], empty_lev, []) ] ] -; - -value rec check_gram entry = - fun - [ Snterm e -> - if e.egram != entry.egram then do { - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - } - else () - | Snterml e _ -> - if e.egram != entry.egram then do { - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - } - else () - | Smeta _ sl _ -> List.iter (check_gram entry) sl - | Slist0sep s t -> do { check_gram entry t; check_gram entry s } - | Slist1sep s t -> do { check_gram entry t; check_gram entry s } - | Slist0 s -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () ] -and tree_check_gram entry = - fun - [ Node {node = n; brother = bro; son = son} -> - do { - check_gram entry n; - tree_check_gram entry bro; - tree_check_gram entry son - } - | LocAct _ _ | DeadEnd -> () ] -; - -value change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] -; - -value get_initial entry = - fun - [ [Sself :: symbols] -> (True, symbols) - | symbols -> (False, symbols) ] -; - -value insert_tokens gram symbols = - let rec insert = - fun - [ Smeta _ sl _ -> List.iter insert sl - | Slist0 s -> insert s - | Slist1 s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - do { - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - [ Not_found -> - let r = ref 0 in - do { Hashtbl.add gram.gtokens tok r; r } ] - in - incr r - } - | Snterm _ | Snterml _ _ | Snext | Sself -> () ] - and tinsert = - fun - [ Node {node = s; brother = bro; son = son} -> - do { insert s; tinsert bro; tinsert son } - | LocAct _ _ | DeadEnd -> () ] - in - List.iter insert symbols -; - -value levels_of_rules entry position rules = - let elev = - match entry.edesc with - [ Dlevels elev -> elev - | Dparser _ -> - do { - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush stderr; - failwith "Grammar.extend" - } ] - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - do { - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -; - -value logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match (s1, s2) with - [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename - | (Snterm e1, Sself) -> e1.ename = entry.ename - | (Sself, Snterm e2) -> entry.ename = e2.ename - | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 - | (Slist0 s1, Slist0 s2) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbols s1 s2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | _ -> s1 = s2 ] - and eq_trees t1 t2 = - match (t1, t2) with - [ (Node n1, Node n2) -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True - | _ -> False ] - in - eq_symbols -; - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -value delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match (symbols, tree) with - [ ([s :: sl], Node n) -> - if logically_eq_symbols entry s n.node then delete_son sl n - else - match delete_in_tree symbols n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([s :: sl], _) -> None - | ([], Node n) -> - match delete_in_tree [] n.brother with - [ Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None ] - | ([], DeadEnd) -> None - | ([], LocAct _ []) -> Some (Some [], DeadEnd) - | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] - and delete_son sl n = - match delete_in_tree sl n.son with - [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some [n.node :: dsl], t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None ] - in - delete_in_tree -; - -value rec decr_keyw_use gram = - fun - [ Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - do { - decr r; - if r.val == 0 then do { - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - } - else () - } - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 s -> decr_keyw_use gram s - | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ -> () ] -and decr_keyw_use_in_tree gram = - fun - [ DeadEnd | LocAct _ _ -> () - | Node n -> - do { - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother - } ] -; - -value rec delete_rule_in_suffix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lsuffix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_suffix entry symbols levs in - [lev :: levs] ] - | [] -> raise Not_found ] -; - -value rec delete_rule_in_prefix entry symbols = - fun - [ [lev :: levs] -> - match delete_rule_in_tree entry symbols lev.lprefix with - [ Some (dsl, t) -> - do { - match dsl with - [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () ]; - match t with - [ DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; - lsuffix = lev.lsuffix; lprefix = t} - in - [lev :: levs] ] - } - | None -> - let levs = delete_rule_in_prefix entry symbols levs in - [lev :: levs] ] - | [] -> raise Not_found ] -; - -value rec delete_rule_in_level_list entry symbols levs = - match symbols with - [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs - | [Snterm e :: symbols] when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs ] -; diff --git a/camlp4/lib/gramext.mli b/camlp4/lib/gramext.mli deleted file mode 100644 index bd0fed514b..0000000000 --- a/camlp4/lib/gramext.mli +++ /dev/null @@ -1,81 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value levels_of_rules : - g_entry 'te -> option position -> - list - (option string * option g_assoc * - list (list (g_symbol 'te) * g_action)) -> - list (g_level 'te); -value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te; -external action : 'a -> g_action = "%identity"; - -value delete_rule_in_level_list : - g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) -> - list (g_level 'te); - -value warning_verbose : ref bool; diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml deleted file mode 100644 index b8c22d5073..0000000000 --- a/camlp4/lib/grammar.ml +++ /dev/null @@ -1,1064 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Gramext; -open Format; - -value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ] -; - -value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s); - -value rec print_symbol ppf = - fun - [ Smeta n sl _ -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep s t -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep s t -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> - print_symbol1 ppf s ] -and print_meta ppf n sl = - loop 0 sl where rec loop i = - fun - [ [] -> () - | [s :: sl] -> - let j = - try String.index_from n i ' ' with [ Not_found -> String.length n ] - in - do { - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } - } ] -and print_symbol1 ppf = - fun - [ Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stoken _ as s -> - fprintf ppf "(%a)" print_symbol s ] -and print_rule ppf symbols = - do { - fprintf ppf "@[<hov 0>"; - let _ = - List.fold_left - (fun sep symbol -> - do { - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ " - }) - (fun ppf -> ()) symbols - in - fprintf ppf "@]" - } -and print_level ppf pp_print_space rules = - do { - fprintf ppf "@[<hov 0>[ "; - let _ = - List.fold_left - (fun sep rule -> - do { - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space () - }) - (fun ppf -> ()) rules - in - fprintf ppf " ]@]" - } -; - -value print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[<hov 2>" sep; - match lev.lname with - [ Some n -> fprintf ppf "%a@;<1 2>" print_str n - | None -> () ]; - match lev.assoc with - [ LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" ]; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| " - }) - (fun ppf -> ()) elev - in - () -; - -value print_entry ppf e = - do { - fprintf ppf "@[<v 0>[ "; - match e.edesc with - [ Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "<parser>" ]; - fprintf ppf " ]@]" - } -; - -value iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e treated.val then () - else do { - treated.val := [e :: treated.val]; - f e; - match e.edesc with - [ Dlevels ll -> List.iter do_level ll - | Dparser _ -> () ] - } - and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } - and do_tree = - fun - [ Node n -> do_node n - | LocAct _ _ | DeadEnd -> () ] - and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } - and do_symbol = - fun - [ Smeta _ sl _ -> List.iter do_symbol sl - | Snterm e | Snterml e _ -> do_entry e - | Slist0 s | Slist1 s | Sopt s -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () ] - in - do_entry e -; - -value fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e treated.val then accu - else do { - treated.val := [e :: treated.val]; - let accu = f e accu in - match e.edesc with - [ Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu ] - } - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in - do_tree accu lev.lprefix - and do_tree accu = - fun - [ Node n -> do_node accu n - | LocAct _ _ | DeadEnd -> accu ] - and do_node accu n = - let accu = do_symbol accu n.node in - let accu = do_tree accu n.son in - do_tree accu n.brother - and do_symbol accu = - fun - [ Smeta _ sl _ -> List.fold_left do_symbol accu sl - | Snterm e | Snterml e _ -> do_entry accu e - | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> - let accu = do_symbol accu s1 in - do_symbol accu s2 - | Stree t -> do_tree accu t - | Sself | Snext | Stoken _ -> accu ] - in - do_entry init e -; - -type g = Gramext.grammar Token.t; - -external grammar_obj : g -> grammar Token.t = "%identity"; - -value floc = ref (fun _ -> failwith "internal error when computing location"); -value loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then (0, 1) - else - let a = snd (floc.val (bp - 1)) in - (a, a + 1) - else - let (bp1, bp2) = floc.val bp in - let (ep1, ep2) = floc.val (pred ep) in - (if bp1 < ep1 then bp1 else ep1, if bp2 > ep2 then bp2 else ep2) -; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = (Stoken tok as s); son = son; brother = DeadEnd} -> - get_token_list entry [last_tok :: tokl] tok son - | _ -> - if tokl = [] then None - else Some (List.rev [last_tok :: tokl], last_tok, tree) ] -; - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s ] -and name_of_tree_failed entry = - fun - [ Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok son - | _ -> None ] - in - match tokl with - [ None -> - let txt = name_of_symbol_failed entry s in - let txt = - match (s, son) with - [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt ] - in - let txt = - match bro with - [ DeadEnd | LocAct _ _ -> txt - | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | Some (tokl, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; - -value search_tree_in_entry prev_symb tree = - fun - [ Dlevels levels -> - let rec search_levels = - fun - [ [] -> tree - | [level :: levels] -> - match search_level level with - [ Some tree -> tree - | None -> search_levels levels ] ] - and search_level level = - match search_tree level.lsuffix with - [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix ] - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - [ Node n -> - match search_symbol n.node with - [ Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - [ Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother ] ] - | LocAct _ _ | DeadEnd -> None ] - and search_symbol symb = - match symb with - [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stoken _ | Stree _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist0 symb) - | None -> None ] - | Slist0sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist0sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist0sep symb sep) - | None -> None ] ] - | Slist1 symb -> - match search_symbol symb with - [ Some symb -> Some (Slist1 symb) - | None -> None ] - | Slist1sep symb sep -> - match search_symbol symb with - [ Some symb -> Some (Slist1sep symb sep) - | None -> - match search_symbol sep with - [ Some sep -> Some (Slist1sep symb sep) - | None -> None ] ] - | Sopt symb -> - match search_symbol symb with - [ Some symb -> Some (Sopt symb) - | None -> None ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -value error_verbose = ref False; - -value tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist0sep s sep -> - match Obj.magic prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Slist1sep s sep -> - match Obj.magic prev_symb_result with - [ [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" ] - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if error_verbose.val then do { - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[<v 0>@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - } - else (); - txt ^ " (in [" ^ entry.ename ^ "])" - } -; - -value symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in - tree_failed entry prev_symb_result prev_symb tree -; - -external app : Obj.t -> 'a = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if is_level_labelled lab lev then levn else lookup (succ levn) levs ] - in - match entry.edesc with - [ Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found ] -; - -value rec top_symb entry = - fun - [ Sself | Snext -> Snterm entry - | Snterml e _ -> Snterm e - | Slist1sep s sep -> Slist1sep (top_symb entry s) sep - | _ -> raise Stream.Failure ] -; - -value entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> raise Stream.Failure ] -; - -value top_tree entry = - fun - [ Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct _ _ | DeadEnd -> raise Stream.Failure ] -; - -value skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -; - -value continue entry bp a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 bp a; - act = p1 ? tree_failed entry a s son :] -> - Gramext.action (fun _ -> app act a) -; - -value do_recover parser_of_tree entry nlevn alevn bp a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty bp (parser []) :] -> a - | [: a = - continue entry bp a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] -; - -value strict_parsing = ref False; - -value recover parser_of_tree entry nlevn alevn bp a s son strm = - if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm -; - -value token_count = ref 0; - -value peek_nth n strm = - let list = Stream.npeek n strm in - do { - token_count.val := Stream.count strm + n; - let rec loop list n = - match (list, n) with - [ ([x :: _], 1) -> Some x - | ([_ :: l], n) -> loop l (n - 1) - | ([], _) -> None ] - in - loop list n - } -; - -value rec parser_of_tree entry nlevn alevn = - fun - [ DeadEnd -> parser [] - | LocAct act _ -> parser [: :] -> act - | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> - parser [: a = entry.estart alevn :] -> app act a - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = entry.estart alevn :] -> app act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - parser bp [: a = ps; act = p1 bp a :] -> app act a - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok son - | _ -> None ] - in - match tokl with - [ None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro in - parser bp - [ [: a = ps; act = p1 bp a :] -> app act a - | [: a = p2 :] -> a ] - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - parser - [ [: a = p1 :] -> a - | [: a = p2 :] -> a ] ] ] -and parser_cont p1 entry nlevn alevn s son bp a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a - | [: :] -> raise (Stream.Error (tree_failed entry a s son)) ] -and parser_of_token_list gram p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [tok :: tokl] -> - let tematch = gram.glexer.Token.tok_match tok in - match tokl with - [ [] -> - let ps strm = - match peek_nth n strm with - [ Some tok -> - let r = tematch tok in - do { for i = 1 to n do { Stream.junk strm }; Obj.repr r } - | None -> raise Stream.Failure ] - in - parser bp [: a = ps; act = p1 bp a :] -> app act a - | _ -> - let ps strm = - match peek_nth n strm with - [ Some tok -> tematch tok - | None -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser - [: a = ps; s :] -> - let act = p1 s in - app act a ] - | [] -> invalid_arg "parser_of_token_list" ] -and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> Obj.repr (List.rev a) - | Slist0sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; a = ps ? symb_failed entry v sep symb; s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | [: :] -> Obj.repr [] ] - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al = - parser - [ [: a = ps; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Obj.repr (List.rev (loop [a] s)) - | Slist1sep symb sep -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al = - parser - [ [: v = pt; - a = - parser - [ [: a = ps :] -> a - | [: a = parse_top_symb entry symb :] -> a - | [: :] -> - raise (Stream.Error (symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Obj.repr (Some a) - | [: :] -> Obj.repr None ] - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - parser bp - [: a = pt :] ep -> - let loc = loc_of_token_interval bp ep in - app a loc - | Snterm e -> parser [: a = e.estart 0 :] -> a - | Snterml e l -> parser [: a = e.estart (level_number e l) :] -> a - | Sself -> parser [: a = entry.estart 0 :] -> a - | Snext -> parser [: a = entry.estart nlevn :] -> a - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - [ Some tok -> - let r = f tok in - do { Stream.junk strm; Obj.repr r } - | None -> raise Stream.Failure ] ] -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun levn bp a -> parser [] - | [lev :: levs] -> - let p1 = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm - else - match strm with parser - [ [: a = p1 levn bp a :] -> a - | [: act = p2 :] ep -> - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] ] ] -; - -value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun levn -> parser [] - | [lev :: levs] -> - let p1 = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - match levs with - [ [] -> - fun levn strm -> - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | [: a = p1 levn :] -> a ] ] ] ] -; - -value continue_parser_of_entry entry = - match entry.edesc with - [ Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - fun levn bp a -> - parser - [ [: a = p levn bp a :] -> a - | [: :] -> a ] - | Dparser p -> fun levn bp a -> parser [] ] -; - -value empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm ] -; - -value parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = floc.val in - let old_tc = token_count.val in - fun () -> do { floc.val := old_floc; token_count.val := old_tc } - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if token_count.val - 1 <= cnt then loc - else (fst loc, snd (fun_loc (token_count.val - 1))) - with _ -> - (Stream.count cs, Stream.count cs + 1) - in - do { - floc.val := fun_loc; - token_count.val := 0; - try - let r = efun ts in - do { restore (); r } - with - [ Stream.Failure -> - let loc = get_loc () in - do { - restore (); - raise_with_loc loc - (Stream.Error ("illegal begin of " ^ entry.ename)) - } - | Stream.Error _ as exc -> - let loc = get_loc () in - do { restore (); raise_with_loc loc exc } - | exc -> - let loc = (Stream.count cs, Stream.count cs + 1) in - do { restore (); raise_with_loc loc exc } ] - } -; - -value wrap_parse entry efun cs = - let parsable = (cs, entry.egram.glexer.Token.tok_func cs) in - parse_parsable entry efun parsable -; - -value create_toktab () = Hashtbl.create 301; -value gcreate glexer = {gtokens = create_toktab (); glexer = glexer}; - -value tematch tparse tok = - match tparse tok with - [ Some p -> fun x -> p [: `x :] - | None -> Token.default_match tok ] -; -value glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -; -value create lexer = gcreate (glexer_of_lexer lexer); - -(* Extend syntax *) - -value extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - with - [ Token.Error s -> - do { - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" - } ] -; - -value extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - do { - match gram.val with - [ Some g -> - if g != entry.egram then do { - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - } - else () - | None -> gram.val := Some entry.egram ]; - extend_entry entry position rules - }) - entry_rules_list -; - -(* Deleting a rule *) - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -(* Unsafe *) - -value clear_entry e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - match e.edesc with - [ Dlevels _ -> e.edesc := Dlevels [] - | Dparser _ -> () ] - } -; - -value gram_reinit g glexer = - do { Hashtbl.clear g.gtokens; g.glexer := glexer } -; - -value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer); - -module Unsafe = - struct - value gram_reinit = gram_reinit; - value clear_entry = clear_entry; - value reinit_gram = reinit_gram; - end -; - -value find_entry e s = - let rec find_levels = - fun - [ [] -> None - | [lev :: levs] -> - match find_tree lev.lsuffix with - [ None -> - match find_tree lev.lprefix with - [ None -> find_levels levs - | x -> x ] - | x -> x ] ] - and find_symbol = - fun - [ Snterm e -> if e.ename = s then Some e else None - | Snterml e _ -> if e.ename = s then Some e else None - | Smeta _ sl _ -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep s _ -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep s _ -> find_symbol s - | Sopt s -> find_symbol s - | Stree t -> find_tree t - | Sself | Snext | Stoken _ -> None ] - and find_symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and find_tree = - fun - [ Node {node = s; brother = bro; son = son} -> - match find_symbol s with - [ None -> - match find_tree bro with - [ None -> find_tree son - | x -> x ] - | x -> x ] - | LocAct _ _ | DeadEnd -> None ] - in - match e.edesc with - [ Dlevels levs -> - match find_levels levs with - [ Some e -> e - | None -> raise Not_found ] - | Dparser _ -> raise Not_found ] -; - -value of_entry e = e.egram; - -module Entry = - struct - type te = Token.t; - type e 'a = g_entry te; - value create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - value parse (entry : e 'a) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ; - value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts); - value name e = e.ename; - value of_parser g n (p : Stream.t te -> 'a) : e 'a = - {egram = g; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value print e = printf "%a@." print_entry (obj e); - value find e s = find_entry (obj e) s; - end -; - -value tokens g con = - let list = ref [] in - do { - Hashtbl.iter - (fun (p_con, p_prm) c -> - if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) - g.gtokens; - list.val - } -; - -value glexer g = g.glexer; - -value warning_verbose = Gramext.warning_verbose; - -(* Functorial interface *) - -module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end; - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'x; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - -module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end -; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te; - type parsable = (Stream.t char * (Stream.t te * Token.location_function)); - value gram = gcreate L.lexer; - value parsable cs = (cs, L.lexer.Token.tok_func cs); - value tokens = tokens gram; - value glexer = glexer gram; - module Entry = - struct - type e 'a = g_entry te; - value create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value parse (e : e 'a) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ; - value parse_token (e : e 'a) ts : 'a = Obj.magic (e.estart 0 ts); - value name e = e.ename; - value of_parser n (p : Stream.t te -> 'a) : e 'a = - {egram = gram; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - value print e = printf "%a@." print_entry (obj e); - end - ; - module Unsafe = - struct - value gram_reinit = gram_reinit gram; - value clear_entry = Unsafe.clear_entry; - value reinit_gram = R.reinit_gram (Obj.magic gram); - end - ; - value extend = extend_entry; - value delete_rule e r = delete_rule (Entry.obj e) r; - end -; - -module GMake (L : GLexerType) = - GGMake - (struct - value reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ; - end) - L -; - -module type LexerType = sig value lexer : Token.lexer; end; - -module Make (L : LexerType) = - GGMake (struct value reinit_gram = reinit_gram; end) - (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end) -; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli deleted file mode 100644 index fe8345fb36..0000000000 --- a/camlp4/lib/grammar.mli +++ /dev/null @@ -1,209 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g = 'x; - (** The type for grammars, holding entries. *) -value gcreate : Token.glexer Token.t -> g; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -value tokens : g -> string -> list (string * int); - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -value glexer : g -> Token.glexer Token.t; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type e 'a = 'x; - value create : g -> string -> e 'a; - value parse : e 'a -> Stream.t char -> 'a; - value parse_token : e 'a -> Stream.t Token.t -> 'a; - value name : e 'a -> string; - value of_parser : g -> string -> (Stream.t Token.t -> 'a) -> e 'a; - value print : e 'a -> unit; - value find : e 'a -> string -> e Obj.t; - external obj : e 'a -> Gramext.g_entry Token.t = "%identity"; - end -; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -value of_entry : Entry.e 'a -> g; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - value gram_reinit : g -> Token.glexer Token.t -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather function [gram_reinit] *) - value reinit_gram : g -> Token.lexer -> unit; - end -; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = - sig - type te = 'x; - value lexer : Token.glexer te; - end; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'y; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather [gram_reinit] *) - (* warning: [reinit_gram] fails if used with GMake *) - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te; - -(** {6 Miscellaneous} *) - -value error_verbose : ref bool; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -value warning_verbose : ref bool; - (** Flag for displaying warnings while extension; default = [True] *) - -value strict_parsing : ref bool; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit; - (** General printer for all kinds of entries (obj entries) *) - -value iter_entry : - (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -value fold_entry : - (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig value lexer : Token.lexer; end; -module Make (L : LexerType) : S with type te = Token.t; -(*** deprecated since version 3.05; use rather the function gcreate *) -value create : Token.lexer -> g; - -(*** For system use *) - -value loc_of_token_interval : int -> int -> (int * int); -value extend : - list - (Gramext.g_entry 'te * option Gramext.position * - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol 'te) * Gramext.g_action))) -> - unit; -value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit; - -value parse_top_symb : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t; -value symb_failed_txt : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te -> - string; diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml deleted file mode 100644 index 329380b267..0000000000 --- a/camlp4/lib/plexer.ml +++ /dev/null @@ -1,1006 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Token; - -value no_quotations = ref False; - -(* The string buffering machinery *) - -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 mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -(* The lexer *) - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] -and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' | '$' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] -and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | - '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' | - '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] -and base_number len = - parser - [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s - | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s - | [: a = number len :] -> a ] -and digits kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: :] -> raise (Stream.Error "ill-formed integer constant") ] -and digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: `'_'; s :] -> digits_under kind len s - | [: :] -> ("INT", get_buff len) ] -and octal = parser [ [: `('0'..'7' as d) :] -> d ] -and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ] -and binary = parser [ [: `('0'..'1' as d) :] -> d ] -and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'_'; s :] -> number len s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: `'l' :] -> ("INT32", get_buff len) - | [: `'L' :] -> ("INT64", get_buff len) - | [: `'n' :] -> ("NATIVEINT", get_buff len) - | [: :] -> ("INT", get_buff len) ] -and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'_'; s :] -> decimal_part len s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] -and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] -and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -and end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: `'_'; s :] -> end_exponent_part_under len s - | [: :] -> ("FLOAT", get_buff len) ] -; - -value error_on_unknown_keywords = ref False; -value err loc msg = raise_with_loc loc (Token.Error msg); - -(* -value next_token_fun dfa find_kwd = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] - in - let rec next_token = - parser bp - [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] -> - next_token s - | [: `'('; s :] -> left_paren bp s - | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s } - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 3 s with - [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("TILDEIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("QUESTIONIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\013'; s :] -> quote_cr_in_comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp s - | [: `'('; s :] -> quote_left_paren_in_comment bp s - | [: `'*'; s :] -> quote_star_in_comment bp s - | [: `'"'; s :] -> quote_doublequote_in_comment bp s - | [: `_; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> comment bp s ] - and quote_cr_in_comment bp = - parser - [ [: `'\010'; s :] -> quote_any_in_comment bp s - | [: s :] -> quote_any_in_comment bp s ] - and quote_left_paren_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> left_paren_in_comment bp s ] - and quote_star_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> star_in_comment bp s ] - and quote_doublequote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: _ = string bp 0; s :] -> comment bp s ] - and quote_antislash_in_comment bp = - parser - [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s - | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] -> - quote_any_in_comment bp s - | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s - | [: `'x'; s :] -> quote_antislash_x_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> quote_in_comment bp s ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_digit_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; -*) - -value next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] in - let error_if_keyword ( ((_,id), loc) as a) = - try do { - ignore(find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) } - with [ Not_found -> a ] - in - let rec next_token after_space = - parser bp - [ [: `'\010' | '\013'; s :] ep -> - do { bolpos.val := ep; next_token True s } - | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s - | [: `'#' when bp = bolpos.val; s :] -> - if linedir 1 s then do { any_to_nl s; next_token True s } - else keyword_or_error (bp, bp + 1) "#" - | [: `'('; s :] -> left_paren bp s - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep)) - | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep)) - | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] ep -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s - | [: s :] -> - do { - match Stream.npeek 2 s with - [ [_; '''] -> do { Stream.junk s; Stream.junk s } - | _ -> () ]; - comment bp s - } ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_in_comment bp len = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] -> - quote_any_in_comment bp s - | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s - | [: a = comment bp :] -> a ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; - - -value dollar_for_antiquotation = ref True; -value specific_space_dot = ref False; - -value func kwd_table glexr = - let bolpos = ref 0 in - let find = Hashtbl.find kwd_table in - let dfa = dollar_for_antiquotation.val in - let ssd = specific_space_dot.val in - Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) -; - -value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True -and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' - ; - s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] ep -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: `'|' | '<' | ':' :] -> () - | [: :] -> () ] ] - | [: `';'; - _ = - parser - [ [: `';' :] -> () - | [: :] -> () ] :] -> - () - | [: `_ :] -> () ] -and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] -and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] -; - -value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False -; - -value error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -; - -value error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -; - -value using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - else () - | "LIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "UIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "INT" | "INT32" | "INT64" | "NATIVEINT" - | "FLOAT" | "CHAR" | "STRING" - | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" - | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Plexer")) ] -; - -value removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm else () - | _ -> () ] -; - -value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT32", "") -> "32 bits integer" - | ("INT64", "") -> "64 bits integer" - | ("NATIVEINT", "") -> "native integer" - | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] -; - -value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False -; - -value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] -; - -value tok_match = - fun - [ ("ANTIQUOT", p_prm) -> - fun - [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure ] - | tok -> Token.default_match tok ] -; - -value gmake () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - let glex = - {tok_func = func kwd_table glexr; - tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - do { glexr.val := glex; glex } -; - -value tparse = - fun - [ ("ANTIQUOT", p_prm) -> - let p = - parser - [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] -> - after_colon prm - in - Some p - | _ -> None ] -; - -value make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - {func = func kwd_table glexr; using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -; diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli deleted file mode 100644 index 32d8fe6b8e..0000000000 --- a/camlp4/lib/plexer.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** A lexical analyzer. *) - -value gmake : unit -> Token.glexer Token.t; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", s)] is the keyword [s]. -- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter. -- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter. -- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the string associated with the constructor [STRING] is - the string found in the source without any interpretation. In - particular, the backslashes are not interpreted. For example, if - the input is ["\n"] the string is *not* a string with one - element containing the character "return", but a string of two - elements: the backslash and the character ["n"]. To interpret - a string use the function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -value dollar_for_antiquotation : ref bool; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -value specific_space_dot : ref bool; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -value no_quotations : ref bool; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -value make : unit -> Token.lexer; diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml deleted file mode 100644 index a89cb15d8e..0000000000 --- a/camlp4/lib/stdpp.ml +++ /dev/null @@ -1,79 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -exception Exc_located of (int * int) and exn; - -value raise_with_loc loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; - -value line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col = - parser cnt - [: `c; s :] -> - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else - let col = col - (cnt - bp) in - (fname, lin, col, col + ep - bp) - in - let rec a_line_dir str n col = - parser - [ [: `'\n' :] -> loop str n - | [: `_; s :] -> a_line_dir str n (col + 1) s ] - in - let rec spaces col = - parser - [ [: `' '; s :] -> spaces (col + 1) s - | [: :] -> col ] - in - let rec check_string str n col = - parser - [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s - | [: `c when c <> '\n'; s :] -> - check_string (str ^ String.make 1 c) n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let check_quote n col = - parser - [ [: `'"'; s :] -> check_string "" n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let rec check_num n col = - parser - [ [: `('0'..'9' as c); s :] -> - check_num (10 * n + Char.code c - Char.code '0') (col + 1) s - | [: col = spaces col; s :] -> check_quote n col s ] - in - let begin_line = - parser - [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s - | [: a = not_a_line_dir 0 :] -> a ] - in - begin_line strm - in - let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in - do { close_in ic; r } - with - [ Sys_error _ -> (fname, 1, bp, ep) ] -; - -value loc_name = ref "loc"; diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli deleted file mode 100644 index 069e56bee3..0000000000 --- a/camlp4/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Standard definitions. *) - -exception Exc_located of (int * int) and exn; - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [raise_with_loc]. *) - -value raise_with_loc : (int * int) -> exn -> 'a; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -value line_of_loc : string -> (int * int) -> (string * int * int * int); - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -value loc_name : ref string; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml deleted file mode 100644 index e26798af9c..0000000000 --- a/camlp4/lib/token.ml +++ /dev/null @@ -1,229 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -type t = (string * string); -type pattern = (string * string); - -exception Error of string; - -type location = (int * int); -type location_function = int -> (int * int); -type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function); - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } -; -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -; - -value locerr () = invalid_arg "Lexer: location function"; -value loct_create () = (ref (Array.create 1024 None), ref False); -value loct_func (loct, ov) i = - match - if i < 0 || i >= Array.length loct.val then - if ov.val then Some (0, 0) else None - else Array.unsafe_get loct.val i - with - [ Some loc -> loc - | _ -> locerr () ] -; -value loct_add (loct, ov) i loc = - if i >= Array.length loct.val then - let new_tmax = Array.length loct.val * 2 in - if new_tmax < Sys.max_array_length then do { - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct; - loct.val.(i) := Some loc - } - else ov.val := True - else loct.val.(i) := Some loc -; - -value make_stream_and_location next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in - do { loct_add loct i loc; Some tok }) - in - (ts, loct_func loct) -; - -value lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) -; - -value lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try do { s.[0] := Stream.next cs; 1 } with [ Stream.Failure -> 0 ]) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in - (tok, loc) - in - make_stream_and_location next_token_loc -; - -(* Char and string tokens to real chars and string *) - -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 mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -value valch x = Char.code x - Char.code '0'; -value valch_a x = Char.code x - Char.code 'a' + 10; -value valch_A x = Char.code x - Char.code 'A' + 10; - -value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '"' -> ('"', i + 1) - | ''' -> (''', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found ] -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found ] -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> raise Not_found ] -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found ] -and backslash2h cod s i = - if i = String.length s then ('\\', i - 2) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1) - | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1) - | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1) - | _ -> raise Not_found ] -; - -value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] -; - -value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -; - -value eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" -; - -value eval_string (bp, ep) s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> do { - Printf.eprintf - "Warning: char %d, Invalid backslash escape in string\n%!" - (bp+i+1); - (store (store len '\\') c, i + 1) } ] ] - else (store len s.[i], i + 1) - in - loop len i -; - -value default_match = - fun - [ ("ANY", "") -> fun (con, prm) -> prm - | ("ANY", v) -> - fun (con, prm) -> if v = prm then v else raise Stream.Failure - | (p_con, "") -> - fun (con, prm) -> if con = p_con then prm else raise Stream.Failure - | (p_con, p_prm) -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure ] -; diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli deleted file mode 100644 index fbd1aefd30..0000000000 --- a/camlp4/lib/token.mli +++ /dev/null @@ -1,133 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = (string * string); - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type location = (int * int); -type location_function = int -> location; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function); - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list location) } -; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -value lexer_text : pattern -> string; - (** A simple [tok_text] function for lexers *) - -value default_match : pattern -> (string * string) -> string; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -value lexer_func_of_parser : - (Stream.t char -> ('te * location)) -> lexer_func 'te; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te; - (** A lexer function from a lexer created by [ocamllex] *) - -value make_stream_and_location : - (unit -> ('te * location)) -> (Stream.t 'te * location_function); - (** General function *) - -(** {6 Useful functions} *) - -value eval_char : string -> char; - (** Convert a char token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if an - incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)] - returns [c] *) - -value eval_string : location -> string -> string; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = (string * string); -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; diff --git a/camlp4/man/.cvsignore b/camlp4/man/.cvsignore deleted file mode 100644 index 2dc933cb1d..0000000000 --- a/camlp4/man/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4.1 -camlp4.help diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile deleted file mode 100644 index a7aa303478..0000000000 --- a/camlp4/man/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -# $Id$ - -include ../config/Makefile - -TARGET=camlp4.1 -ALIASES=camlp4o.1 camlp4r.1 mkcamlp4.1 ocpp.1 camlp4o.opt.1 camlp4r.opt.1 - -all: $(TARGET) - -clean:: - rm -f $(TARGET) - -depend: - -get_promote: - -install: - if test -n '$(MANDIR)'; then \ - $(MKDIR) $(MANDIR)/man1 ; \ - cp $(TARGET) $(MANDIR)/man1/. ; \ - for i in $(ALIASES); do \ - rm -f $(MANDIR)/man1/$$i; \ - echo '.so man1/$(TARGET)' > $(MANDIR)/man1/$$i; \ - done; \ - fi - -camlp4.1: camlp4.1.tpl - sed -e "s'LIBDIR'$(LIBDIR)'g" camlp4.1.tpl > camlp4.1 diff --git a/camlp4/man/Makefile.Mac b/camlp4/man/Makefile.Mac deleted file mode 100644 index df95e66fb5..0000000000 --- a/camlp4/man/Makefile.Mac +++ /dev/null @@ -1,31 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -TARGETS = camlp4.help - -all Ä {TARGETS} - -clean ÄÄ - delete -i {TARGETS} - -depend Ä $OutOfDate - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{MANDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} "{MANDIR}" - -camlp4.help Ä camlp4.help.tpl - streamedit -e "1,$ replace -c ° /LIBDIR/ '{P4LIBDIR}'" camlp4.help.tpl ¶ - > camlp4.help diff --git a/camlp4/man/camlp4.1.tpl b/camlp4/man/camlp4.1.tpl deleted file mode 100644 index b40b5f9f0b..0000000000 --- a/camlp4/man/camlp4.1.tpl +++ /dev/null @@ -1,302 +0,0 @@ -.TH CAMLP4 1 "" "INRIA" -.SH NAME -camlp4 - Pre-Precessor-Pretty-Printer for OCaml -.br -mkcamlp4 - Create custom camlp4 -.br -ocpp - Universal preprocessor - -.SH SYNOPSIS -.B camlp4 -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4o -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4r -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4sch -[ -load-options -] [--] [ -other-options -] -.br -.B camlp4o.cma -.br -.B camlp4r.cma -.br -.B camlp4sch.cma -.br -.B mkcamlp4 -.br -.B ocpp -[ -load-options -] -file -.LP -.br -.B camlp4o.opt -[--] [ -other-options -] -.br -.B camlp4r.opt -[--] [ -other-options -] - -.SH DESCRIPTION -.B camlp4 -is a Pre-Processor-Pretty-Printer for OCaml, parsing a source -file and printing some result on standard output. -.LP -.B camlp4o, -.B camlp4r -and -.B camlp4sch -are versions of -.B camlp4 -with some files already loaded (see further). -.LP -.B camlp4o.cma, -.B camlp4r.cma -and -.B camlp4sch.cma -are files to be loaded in ocaml toplevel to use the camlp4 machinery -.LP -.B mkcamlp4 -creates camlp4 executables with almost the same options than ocamlmktop. -See further. -.LP -.B ocpp -is an universal preprocessor, treating any kind of source file, -generating the same text with the possible quotations expanded. -.LP -.B camlp4o.opt -and -.B camlp4r.opt -are versions of camlp4o and camlp4r compiled by the native-code compiler -ocamlopt. They are faster but not extensible. And they are not available -in all installations of camlp4. - -.SH LOAD OPTIONS - -The load options select parsing and printing actions recorded in OCaml -object files (ending with .cmo or .cma). Several usage of these options -are authorized. They must precede the other options. - -.LP -An optionnal -.B \-\- -may end the load options. - -.TP -.BI \-I\ directory -Add -.I directory -in the search path for files loaded. Unless the option \-nolib is used, -the camlp4 library directory is appended to the path. Warning: there is -no automatic search in the current directory: add "\-I ." for this. -.TP -.B \-where -Print camlp4 library directory name and exit. -.TP -.B \-nolib -No automatic search for objects files in camlp4 library directory. -.TP -.BI object-file -The file is loaded in camlp4 core. - -.SH OTHER OPTIONS - -.LP -The others options are: - -.TP -.I file -Treat -.I file -as an interface file if it ends with .mli and as an implementation file -if it ends with .ml. - -.TP -.BI \-intf\ file -Treat -.I file -as an interface file, whatever its extension. -.TP -.BI \-impl\ file -Treat -.I file -as an implementation file, whatever its extension. -.TP -.B \-unsafe -Generate unsafe accesses to arrays and strings. -.TP -.B \-noassert -Do not compile assertion checks. -.TP -.B \-verbose -More verbose in parsing errors. -.TP -.BI \-QD\ file -Dump in -.I file -in case of syntax error in the result of a quotation expansion. -.TP -.BI \-o\ out-file -Print the result on out-file instead of standard output. File is opened -with open_out_bin (see OCaml library Pervasives). -.TP -.B \-v -Print the version number and exit. -.TP -.B \-help -Print the available options and exit. This print includes the options -possibly added by the loaded object files. - -.LP -The others options can be extended by loaded object files. The provided -files add the following options: - -.TP -.BI \-l\ line-length -Added by pr_o.cmo and pr_r.cmo: set the line length (default 78). -.TP -.BI \-sep\ string -Added by pr_o.cmo and pr_r.cmo: print this string between phrases instead -of comments. -.TP -.BI \-no_ss -Added by pr_o.cmo: do not print double semicolons -.TP -.BI \-D\ ident -Added by pa_macro.cmo: define the ident. -.TP -.BI \-U\ ident -Added by pa_macro.cmo: undefine the ident. - -.SH "PROVIDED FILES" -These files are installed in the directory LIBDIR/camlp4. - -.LP -Parsing files: -.nf -.ta 1c - pa_o.cmo: syntax of OCaml - pa_op.cmo: streams and parsers - pa_oop.cmo: streams and parsers (without code optimization) - pa_r.cmo: revised syntax - pa_rp.cmo: streams and parsers - pa_scheme.cmo: scheme syntax - pa_extend.cmo: syntax extension for grammars - pa_extfold.cmo: extension of pa_extend with FOLD0 and FOLD1 - pa_extfun.cmo: syntax extension for extensible functions - pa_fstream.cmo: syntax extension for functional streams - pa_macro.cmo: add macros (ifdef, define) like in C - pa_lefteval.cmo: left-to-right evaluation of parameters - pa_olabl.cmo: old syntax for labels -.fi -.LP -Printing files: -.nf -.ta 1c - pr_o.cmo: syntax of OCaml - pr_op.cmo: try to rebuild streams and parsers syntax - pr_r.cmo: revised syntax - pr_rp.cmo: try to rebuild streams and parsers syntax - pr_scheme.cmo: scheme syntax - pr_schemep.cmo: try to rebuild streams and parsers syntax - pr_extend.cmo: try to rebuild EXTEND statements - pr_extfun.cmo: try to rebuild extfun statements - pr_dump.cmo: syntax tree - pr_depend.cmo: file dependencies - pr_null.cmo: no output -.fi -.LP -Quotation expanders: -.nf -.ta 1c - q_MLast.cmo: syntax tree nodes - q_phony.cmo: keeping quotations for pretty printing -.fi -.LP -The command -.B camlp4o -is a shortcut for: -.nf -.ta 1c - camlp4 pa_o.cmo pa_op.cmo pr_dump.cmo -.fi -.LP -The command -.B camlp4r -is a shortcut for: -.nf -.ta 1c - camlp4 pa_r.cmo pa_rp.cmo pr_dump.cmo -.fi -.LP -The command -.B camlp4sch -is a shortcut for: -.nf -.ta 1c - camlp4 pa_scheme.cmo pr_dump.cmo -.fi -.LP -.LP -The file -.B camlp4o.cma -can be loaded in the toplevel to start camlp4 with OCaml syntax. -.LP -The file -.B camlp4r.cma -can be loaded in the toplevel to start camlp4 with revised syntax. -.LP -The file -.B camlp4sch.cma -can be loaded in the toplevel to start camlp4 with Scheme syntax. - -.SH "MKCAMLP4" - -.B mkcamlp4 -creates camlp4 executables with almost the same options than ocamlmktop. -The only difference is that the interfaces to be visible must be explicitly -added in the command line as ".cmi" files. For example, how to add the -the OCaml module "str": -.nf -.ta 1c 2c - mkcamlp4 -custom str.cmi str.cma -cclib -lstr \\ - -o camlp4str -.fi - -.SH "FILES" -Camlp4 library directory in the present installation: -.br -LIBDIR/camlp4 - -.SH "SEE ALSO" -Camlp4 - tutorial -.br -Camlp4 - reference manual -.br -ocamlc(1), ocaml(1). - -.SH AUTHOR -Daniel de Rauglaudre, INRIA Rocquencourt. diff --git a/camlp4/man/camlp4.help.tpl b/camlp4/man/camlp4.help.tpl deleted file mode 100644 index 8b13789179..0000000000 --- a/camlp4/man/camlp4.help.tpl +++ /dev/null @@ -1 +0,0 @@ - diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore deleted file mode 100644 index 460c5a60df..0000000000 --- a/camlp4/meta/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -camlp4r -camlp4r.opt diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend deleted file mode 100644 index 737ea5ec6b..0000000000 --- a/camlp4/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi -pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx -q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile deleted file mode 100644 index ba1481bed7..0000000000 --- a/camlp4/meta/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ - fi - -include .depend diff --git a/camlp4/meta/Makefile.Mac b/camlp4/meta/Makefile.Mac deleted file mode 100644 index 9451d5222c..0000000000 --- a/camlp4/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:" -OCAMLCFLAGS = {INCLUDES} -OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶ - pa_ifdef.cmo pr_dump.cmo -CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo -OUT = {OBJS} camlp4r - -all Ä {OUT} - -camlp4r Ä ::camlp4:camlp4 {CAMLP4RM} - delete -i camlp4r - directory ::camlp4: - domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}" - directory ::meta: - -clean ÄÄ - delete -i {OUT} - -{dependrule} - -promote Ä - duplicate -y {OUT} pa_extend.cmi ::boot: - -compare Ä - for i in {OUT} - equal -s {i} ::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y camlp4r "{BINDIR}" - -{defrules} - -pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi diff --git a/camlp4/meta/Makefile.Mac.depend b/camlp4/meta/Makefile.Mac.depend deleted file mode 100644 index 29675238e9..0000000000 --- a/camlp4/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/meta/mk_q_MLast.sh b/camlp4/meta/mk_q_MLast.sh deleted file mode 100755 index c678f350ad..0000000000 --- a/camlp4/meta/mk_q_MLast.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh -# $Id$ - -IFILE=pa_r.ml -OFILE=q_MLast.ml -( -sed -e '/^EXTEND$/,$d' $OFILE -echo EXTEND -../../boot/ocamlrun ./camlp4r -I . -I ../etc q_MLast.cmo pa_extend.cmo pr_r.cmo pr_extend.cmo -cip -quotify $IFILE | sed -e '1,/^EXTEND$/d' -e '/^END;$/,$d' -echo ' (* Antiquotations for local entries *)' -sed -e '1,/Antiquotations for local entries/d' $OFILE -) diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml deleted file mode 100644 index e8fed87b62..0000000000 --- a/camlp4/meta/pa_extend.ml +++ /dev/null @@ -1,916 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 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 loc = (int * int); - -type name 'e = { expr : 'e; tvar : string; loc : (int * int) }; - -type styp = - [ STlid of loc and string - | STapp of loc and styp and styp - | STquo of loc and string - | STself of loc and string - | STtyp of MLast.ctyp ] -; - -type text 'e = - [ TXmeta of loc and string and list (text 'e) and 'e and styp - | TXlist of loc and bool and text 'e and option (text 'e) - | TXnext of loc - | TXnterm of loc and name 'e and option string - | TXopt of loc and text 'e - | TXrules of loc and list (list (text 'e) * 'e) - | TXself of loc - | TXtok of loc and string and 'e ] -; - -type entry 'e 'p = - { name : name 'e; pos : option 'e; levels : list (level 'e 'p) } -and level 'e 'p = - { label : option string; assoc : option 'e; rules : list (rule 'e 'p) } -and rule 'e 'p = { prod : list (psymbol 'e 'p); action : option 'e } -and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p } -and symbol 'e 'p = { used : list string; text : text 'e; styp : styp } -; - -type used = [ Unused | UsedScanned | UsedNotScanned ]; - -value mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n 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 quotify = ref False; -value meta_action = ref False; - -module MetaAction = - struct - value not_impl f 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 - failwith (f ^ ", not impl: " ^ desc) - ; - value loc = (0, 0); - value rec mlist mf = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [ $mf x$ :: $mlist mf l$ ] >> ] - ; - value moption mf = - fun - [ None -> <:expr< None >> - | Some x -> <:expr< Some $mf x$ >> ] - ; - value mbool = - fun - [ False -> <:expr< False >> - | True -> <:expr< True >> ] - ; - value mloc = <:expr< (0, 0) >>; - value rec mexpr = - fun - [ MLast.ExAcc loc e1 e2 -> - <:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExApp loc e1 e2 -> - <:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExChr loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >> - | MLast.ExFun loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >> - | MLast.ExIfe loc e1 e2 e3 -> - <:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >> - | MLast.ExInt loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >> - | MLast.ExFlo loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >> - | MLast.ExLet loc rf pel e -> - <:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >> - | MLast.ExLid loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >> - | MLast.ExMat loc e pwel -> - <:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExRec loc pel eo -> - <:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >> - | MLast.ExSeq loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >> - | MLast.ExSte loc e1 e2 -> - <:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExStr loc s -> - <:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >> - | MLast.ExTry loc e pwel -> - <:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExTup loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >> - | MLast.ExTyc loc e t -> - <:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >> - | MLast.ExUid loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >> - | x -> not_impl "mexpr" x ] - and mpatt = - fun - [ MLast.PaAcc loc p1 p2 -> - <:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaAny loc -> <:expr< MLast.PaAny $mloc$ >> - | MLast.PaApp loc p1 p2 -> - <:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaInt loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >> - | MLast.PaLid loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >> - | MLast.PaOrp loc p1 p2 -> - <:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaStr loc s -> - <:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >> - | MLast.PaTup loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >> - | MLast.PaTyc loc p t -> - <:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >> - | MLast.PaUid loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >> - | x -> not_impl "mpatt" x ] - and mctyp = - fun - [ MLast.TyAcc loc t1 t2 -> - <:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyApp loc t1 t2 -> - <:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyLid loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >> - | MLast.TyQuo loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >> - | MLast.TyTup loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >> - | MLast.TyUid loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >> - | x -> not_impl "mctyp" x ] - and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >> - and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >> - ; - end -; - -value mklistexp loc = - loop True where rec loop top = - fun - [ [] -> <:expr< [] >> - | [e1 :: el] -> - let loc = - if top then loc else (fst (MLast.loc_of_expr e1), snd loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc = - loop True where rec loop top = - fun - [ [] -> <:patt< [] >> - | [p1 :: pl] -> - let loc = - if top then loc else (fst (MLast.loc_of_patt p1), snd loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -value rec quot_expr e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< None >> -> <:expr< Qast.Option None >> - | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >> - | <:expr< False >> -> <:expr< Qast.Bool False >> - | <:expr< True >> -> <:expr< Qast.Bool True >> - | <:expr< () >> -> e - | <:expr< Qast.List $_$ >> -> e - | <:expr< Qast.Option $_$ >> -> e - | <:expr< Qast.Str $_$ >> -> e - | <:expr< [] >> -> <:expr< Qast.List [] >> - | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >> - | <:expr< [$e1$ :: $e2$] >> -> - <:expr< Qast.Cons $quot_expr e1$ $quot_expr e2$ >> - | <:expr< $_$ $_$ >> -> - let (f, al) = expr_fa [] e in - match f with - [ <:expr< $uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp loc al$ >> - | <:expr< MLast.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp loc al$ >> - | <:expr< $uid:m$.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp loc al$ >> - | <:expr< $lid:f$ >> -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> <:expr< $f$ $e$ >>) - <:expr< $lid:f$ >> al - | _ -> e ] - | <:expr< {$list:pel$} >> -> - try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - [ <:patt< $lid:c$ >> -> <:expr< $str:c$ >> - | <:patt< $_$.$lid:c$ >> -> <:expr< $str:c$ >> - | _ -> raise Not_found ] - in - <:expr< ($lab$, $quot_expr e$) >>) - pel - in - <:expr< Qast.Record $mklistexp loc lel$>> - with - [ Not_found -> e ] - | <:expr< $lid:s$ >> -> - if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e - | <:expr< MLast.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $uid:m$.$uid:s$ >> -> <:expr< Qast.Node $str:m ^ "." ^ s$ [] >> - | <:expr< $uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >> - | <:expr< ($list:el$) >> -> - let el = List.map quot_expr el in - <:expr< Qast.Tuple $mklistexp loc el$ >> - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in - <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >> - | _ -> e ] -; - -value symgen = "xx"; - -value pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - [ <:patt< $lid:s$ >> -> pname ^ s - | _ -> pname ]) - "" pl -; - -value quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - [ Some <:patt< ($list:pl$) >> -> - let loc = (0, 0) in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - ([symgen ^ string_of_int cnt :: l], cnt + 1)) - ([], 1) pl - in - let l = List.rev l in - (List.map (fun s -> <:patt< $lid:s$ >>) l, - List.map (fun s -> <:expr< $lid:s$ >>) l) - in - <:expr< - let ($list:pl$) = - match $lid:pname$ with - [ Qast.Tuple $mklistpat loc pl1$ -> ($list:el1$) - | _ -> match () with [] ] - in $e$ >> - | _ -> e ]) - e psl -; - -value rec make_ctyp styp tvar = - match styp with - [ STlid loc s -> <:ctyp< $lid:s$ >> - | STapp loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >> - | STquo loc s -> <:ctyp< '$s$ >> - | STself loc x -> - if tvar = "" then - Stdpp.raise_with_loc loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else <:ctyp< '$tvar$ >> - | STtyp t -> t ] -; - -value rec make_expr gmod tvar = - fun - [ TXmeta loc n tl e t -> - let el = - List.fold_right - (fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>) - tl <:expr< [] >> - in - <:expr< - Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >> - | TXlist loc min t ts -> - let txt = make_expr gmod "" t in - match (min, ts) with - [ (False, None) -> <:expr< Gramext.Slist0 $txt$ >> - | (True, None) -> <:expr< Gramext.Slist1 $txt$ >> - | (False, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist0sep $txt$ $x$ >> - | (True, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist1sep $txt$ $x$ >> ] - | TXnext loc -> <:expr< Gramext.Snext >> - | TXnterm loc n lev -> - 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 <:expr< Gramext.Sself >> - else - <:expr< - Gramext.Snterm - ($uid:gmod$.Entry.obj - ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ] - | TXopt loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >> - | TXrules loc rl -> - <:expr< Gramext.srules $make_expr_rules loc gmod rl ""$ >> - | TXself loc -> <:expr< Gramext.Sself >> - | TXtok loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ] -and make_expr_rules loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - <:expr< [$x$ :: $txt$] >>) - sl <:expr< [] >> - in - <:expr< [($sl$, $ac$) :: $txt$] >>) - <:expr< [] >> rl -; - -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 -> if quotify.val then quotify_action psl act else 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 = make_ctyp ps.symbol.styp tvar in - let p = - match p with - [ <:patt< ($list:pl$) >> when quotify.val -> - <:patt< $lid:pname_of_ptuple pl$ >> - | _ -> p ] - in - <:expr< fun ($p$ : $t$) -> $txt$ >> ]) - e psl - in - let txt = - if meta_action.val then - <:expr< Obj.magic $MetaAction.mexpr txt$ >> - else txt - in - <:expr< Gramext.action $txt$ >> -; - -value srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in - (sl, ac)) - rl -; - -value expr_of_delete_rule loc gmod n sl = - let sl = - List.fold_right - (fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl - <:expr< [] >> - in - (<:expr< $n.expr$ >>, sl) -; - -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}; - -value slist loc min sep symb = - let t = - match sep with - [ Some s -> Some s.text - | None -> None ] - in - TXlist loc min symb.text t -; - -value sstoken loc s = - let n = mk_name loc <:expr< $lid:"a_" ^ s$ >> in - TXnterm loc n None -; - -value mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -; - -value sslist loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name loc <:expr< a_list >> in - [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_list")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_psymbol <:patt< a >> (slist loc min sep s) - (STapp loc (STlid loc "list") s.styp)] - in - let act = <:expr< Qast.List a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let used = ["a_list" :: used] in - let text = TXrules loc (srules loc "a_list" rl "") in - let styp = STquo loc "a_list" in - {used = used; text = text; styp = styp} -; - -value ssopt loc s = - let rl = - let r1 = - let prod = - let n = mk_name loc <:expr< a_opt >> in - [mk_psymbol <:patt< a >> (TXnterm loc n None) (STquo loc "a_opt")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - [ TXtok loc "" <:expr< $str:_$ >> -> - let rl = - [{prod = [{pattern = Some <:patt< x >>; symbol = s}]; - action = Some <:expr< Qast.Str x >>}] - in - let t = new_type_var () in - {used = []; text = TXrules loc (srules loc t rl ""); - styp = STquo loc t} - | _ -> s ] - in - let prod = - [mk_psymbol <:patt< a >> (TXopt loc s.text) - (STapp loc (STlid loc "option") s.styp)] - in - let act = <:expr< Qast.Option a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = ["a_opt" :: s.used] in - let text = TXrules loc (srules loc "a_opt" rl "") in - let styp = STquo loc "a_opt" in - {used = used; text = text; styp = styp} -; - -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 = srules loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules loc gmod rl e.name.tvar in - <:expr< [($lab$, $ass$, $e$) :: $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 = - let same_tvar e n = e.name.tvar = n.tvar in - List.fold_right - (fun e ll -> - match e.name.expr with - [ <:expr< $lid:_$ >> -> - if List.exists (same_tvar e) nl then ll - else if List.exists (same_tvar e) ll 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 -; - -open Pcaml; -value symbol = Grammar.Entry.create gram "symbol"; -value semi_sep = - if syntax_name.val = "Scheme" then - Grammar.Entry.of_parser gram "'/'" (parser [: `("", "/") :] -> ()) - else - Grammar.Entry.of_parser gram "';'" (parser [: `("", ";") :] -> ()) -; - -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; semi_sep -> e ] -> - text_of_extend loc "Grammar" sl el f ] ] - ; - gextend_body: - [ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] -> - text_of_functorial_extend loc g sl el ] ] - ; - delete_rule_body: - [ [ n = name; ":"; sl = LIST1 symbol SEP semi_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 semi_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; semi_sep -> f - | -> <:expr< Grammar.extend >> ] ] - ; - global: - [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> 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 semi_sep; "->"; act = expr -> - {prod = psl; action = Some act} - | psl = LIST0 psymbol SEP semi_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 = TXnterm loc name lev in - let styp = STquo loc i in - let symb = {used = [i]; 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 ] -> - if quotify.val then sslist loc False sep s - else - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let styp = STapp loc (STlid loc "list") s.styp in - let text = slist loc False sep s in - {used = used; text = text; styp = styp} - | UIDENT "LIST1"; s = SELF; - sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - if quotify.val then sslist loc True sep s - else - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let styp = STapp loc (STlid loc "list") s.styp in - let text = slist loc True sep s in - {used = used; text = text; styp = styp} - | UIDENT "OPT"; s = SELF -> - if quotify.val then ssopt loc s - else - let styp = STapp loc (STlid loc "option") s.styp in - let text = TXopt loc s.text in - {used = s.used; text = text; styp = styp} ] - | [ UIDENT "SELF" -> - {used = []; text = TXself loc; styp = STself loc "SELF"} - | UIDENT "NEXT" -> - {used = []; text = TXnext loc; styp = STself loc "NEXT"} - | "["; 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 = TXrules loc (srules loc t rl ""); - styp = STquo loc t} - | x = UIDENT -> - let text = - if quotify.val then sstoken loc x - else TXtok loc x <:expr< "" >> - in - {used = []; text = text; styp = STlid loc "string"} - | x = UIDENT; e = string -> - let text = TXtok loc x e in - {used = []; text = text; styp = STlid loc "string"} - | e = string -> - let text = TXtok loc "" e in - {used = []; text = text; styp = STlid loc "string"} - | i = UIDENT; "."; e = qualid; - lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - let n = mk_name loc <:expr< $uid:i$ . $e$ >> in - {used = [n.tvar]; text = TXnterm loc n lev; - styp = STquo loc n.tvar} - | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - {used = [n.tvar]; text = TXnterm loc n lev; - styp = STquo loc 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; - -Pcaml.add_option "-quotify" (Arg.Set quotify) - "Generate code for quotations"; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) - "Undocumented"; diff --git a/camlp4/meta/pa_extend_m.ml b/camlp4/meta/pa_extend_m.ml deleted file mode 100644 index 7e000dd7b4..0000000000 --- a/camlp4/meta/pa_extend_m.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pa_extend; - -EXTEND - symbol: LEVEL "top" - [ NONA - [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; - s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - sslist loc min sep s - | UIDENT "SOPT"; s = SELF -> - ssopt loc s ] ] - ; -END; diff --git a/camlp4/meta/pa_ifdef.ml b/camlp4/meta/pa_ifdef.ml deleted file mode 100644 index 59d448ef1b..0000000000 --- a/camlp4/meta/pa_ifdef.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* 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 ["OCAML_305"; "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." -; diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml deleted file mode 100644 index 406a3bd622..0000000000 --- a/camlp4/meta/pa_macro.ml +++ /dev/null @@ -1,251 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE <uident> - DEFINE <uident> = <expression> - DEFINE <uident> (<parameters>) = <expression> - IFDEF <uident> THEN <structure_items> END - IFDEF <uident> THEN <structure_items> ELSE <structure_items> END - IFNDEF <uident> THEN <structure_items> END - IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END - - In expressions: - - IFDEF <uident> THEN <expression> ELSE <expression> END - IFNDEF <uident> THEN <expression> ELSE <expression> END - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF <uident> THEN <pattern> ELSE <pattern> END - IFNDEF <uident> THEN <pattern> ELSE <pattern> END - - As Camlp4 options: - - -D<uident> - -U<uident> - - After having used a DEFINE <uident> followed by "= <expression>", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -#load "pa_extend.cmo"; -#load "q_MLast.cmo"; - -open Pcaml; - -type item_or_def 'a = - [ SdStr of 'a - | SdDef of string and option (list string * MLast.expr) - | SdUnd of string - | SdNop ] -; - -value rec list_remove x = - fun - [ [(y, _) :: l] when y = x -> l - | [d :: l] -> [d :: list_remove x l] - | [] -> [] ] -; - -value defined = ref []; - -value is_defined i = List.mem_assoc i defined.val; - -value loc = (0, 0); - -value subst mloc env = - loop where rec loop = - fun - [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< let $opt:rf$ $list:pel$ in $loop e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >> - | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> - try <:expr< $anti:List.assoc x env$ >> with - [ Not_found -> e ] - | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >> - | <:expr< { $list:pel$ } >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< { $list:pel$ } >> - | e -> e ] -; - -value substp mloc env = - loop where rec loop = - fun - [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> - | <:expr< $lid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $lid:x$ >> ] - | <:expr< $uid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $uid:x$ >> ] - | <:expr< $int:x$ >> -> <:patt< $int:x$ >> - | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >> - | <:expr< { $list:pel$ } >> -> - let ppl = List.map (fun (p, e) -> (p, loop e)) pel in - <:patt< { $list:ppl$ } >> - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") ] -; - -value incorrect_number loc l1 l2 = - Stdpp.raise_with_loc loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" - (List.length l2) (List.length l1))) -; - -value define eo x = - do { - match eo with - [ Some ([], e) -> - EXTEND - expr: LEVEL "simple" - [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> loc) 0 e ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$ -> - let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p ] ] - ; - END - | Some (sl, e) -> - EXTEND - expr: LEVEL "apply" - [ [ UIDENT $x$; param = SELF -> - let el = - match param with - [ <:expr< ($list:el$) >> -> el - | e -> [e] ] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst loc env e in - Pcaml.expr_reloc (fun _ -> loc) 0 e - else - incorrect_number loc el sl ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$; param = SELF -> - let pl = - match param with - [ <:patt< ($list:pl$) >> -> pl - | p -> [p] ] - in - if List.length pl = List.length sl then - let env = List.combine sl pl in - let p = substp loc env e in - Pcaml.patt_reloc (fun _ -> loc) 0 p - else - incorrect_number loc pl sl ] ] - ; - END - | None -> () ]; - defined.val := [(x, eo) :: defined.val]; - } -; - -value undef x = - try - do { - let eo = List.assoc x defined.val in - match eo with - [ Some ([], _) -> - do { - DELETE_RULE expr: UIDENT $x$ END; - DELETE_RULE patt: UIDENT $x$ END; - } - | Some (_, _) -> - do { - DELETE_RULE expr: UIDENT $x$; SELF END; - DELETE_RULE patt: UIDENT $x$; SELF END; - } - | None -> () ]; - defined.val := list_remove x defined.val; - } - with - [ Not_found -> () ] -; - -EXTEND - GLOBAL: expr patt str_item sig_item; - str_item: FIRST - [ [ x = macro_def -> - match x with - [ SdStr [si] -> si - | SdStr sil -> <:str_item< declare $list:sil$ end >> - | SdDef x eo -> do { define eo x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] - ; - macro_def: - [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def - | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then d else SdNop - | "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d1 else d2 - | "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" -> - if is_defined i then SdNop else d - | "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE"; - d2 = str_item_or_macro; "END" -> - if is_defined i then d2 else d1 ] ] - ; - str_item_or_macro: - [ [ d = macro_def -> d - | si = LIST1 str_item -> SdStr si ] ] - ; - opt_macro_value: - [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e) - | "="; e = expr -> Some ([], e) - | -> None ] ] - ; - expr: LEVEL "top" - [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - if is_defined i then e1 else e2 - | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - if is_defined i then e2 else e1 ] ] - ; - expr: LEVEL "simple" - [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >> - | LIDENT "__LOCATION__" -> - let bp = string_of_int (fst loc) in - let ep = string_of_int (snd loc) in - <:expr< ($int:bp$, $int:ep$) >> ] ] - ; - patt: - [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> - if is_defined i then p1 else p2 - | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" -> - if is_defined i then p2 else p1 ] ] - ; - uident: - [ [ i = UIDENT -> i ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String (define None)) - "<string> Define for IFDEF instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - "<string> Undefine for IFDEF instruction." -; diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml deleted file mode 100644 index dd6b499ac5..0000000000 --- a/camlp4/meta/pa_r.ml +++ /dev/null @@ -1,943 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := False; - -value help_sequences () = - do { - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 - } -; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit."; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Plexer.dollar_for_antiquotation.val := odfa; - 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 type_declaration; - 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 -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mksequence loc = - fun - [ [e] -> e - | el -> <:expr< do { $list:el$ } >> ] -; - -value mkmatchcase loc p aso w e = - let p = - match aso with - [ Some p2 -> <:patt< ($p$ as $p2$) >> - | _ -> p ] - in - (p, w, e) -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin loc f arg = - match arg with - [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >> - | MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n) - | MLast.ExInt64 loc n -> MLast.ExInt64 loc (neg_string n) - | MLast.ExNativeInt loc n -> MLast.ExNativeInt loc (neg_string n) - | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -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 (MLast.loc_of_expr e1), snd loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = - if top then loc else (fst (MLast.loc_of_patt p1), snd loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value mkexprident loc i j = - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:i$ >> j -; - -value mkassert loc e = - match e with - [ <:expr< False >> -> MLast.ExAsf loc - | _ -> MLast.ExAsr loc e ] -; - -value append_elem el e = el @ [e]; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -value ipatt = Grammar.Entry.create gram "ipatt"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value not_yet_warned_variant = ref True; -value warn_variant loc = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned = ref True; -value warn_sequence loc = - if not_yet_warned.val then do { - not_yet_warned.val := False; - Pcaml.warning.val loc - ("use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences."; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ] - | "simple" - [ i = UIDENT -> <:module_expr< $uid:i$ >> - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - str_item: - [ "top" - [ "declare"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:str_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "value"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - <:str_item< value $opt:o2b r$ $list:l$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> ] - | [ m1 = SELF; m2 = SELF -> <:module_type< $m1$ $m2$ >> ] - | [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> ] - | "simple" - [ i = UIDENT -> <:module_type< $uid:i$ >> - | i = LIDENT -> <:module_type< $lid:i$ >> - | "'"; i = ident -> <:module_type< ' $i$ >> - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - sig_item: - [ "top" - [ "declare"; st = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:sig_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "value"; i = LIDENT; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp -> - <:with_constr< type $i$ $list:tpl$ = $t$ >> - | "module"; i = mod_ident; "="; me = module_expr -> - <:with_constr< module $i$ = $me$ >> ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = SELF -> - <:expr< let $opt:o2b r$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = SELF -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "fun"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = ipatt; e = fun_def -> <:expr< fun $p$ -> $e$ >> - | "match"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< match $e$ with $p1$ -> $e1$ >> - | "try"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< try $e$ with $p1$ -> $e1$ >> - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "do"; "{"; seq = sequence; "}" -> mksequence loc seq - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - <:expr< while $e$ do { $list:seq$ } >> ] - | "where" - [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding -> - <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >> - | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >> - | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin loc "-" e - | "-."; e = SELF -> mkumin loc "-." e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >> - | "assert"; e = SELF -> mkassert loc e - | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> ] - | "simple" - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 loc s - | s = INT64 -> MLast.ExInt64 loc s - | s = NATIVEINT -> MLast.ExNativeInt loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | s = CHAR -> <:expr< $chr:s$ >> - | i = expr_ident -> i - | "["; "]" -> <:expr< [] >> - | "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp loc last el - | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >> - | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";"; - "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" -> - <:expr< ( $list:[e::el]$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Some e - | -> None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; - el = SELF -> - [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence loc el$ >>] - | e = expr; ";"; el = SELF -> [e :: el] - | e = expr; ";" -> [e] - | e = expr -> [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> (p, e) ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Some p - | -> None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Some e - | -> None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> (i, e) ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | i = UIDENT; "."; j = SELF -> mkexprident loc i j ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 loc s - | s = INT64 -> MLast.PaInt64 loc s - | s = NATIVEINT -> MLast.PaNativeInt loc s - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | "-"; s = INT -> MLast.PaInt loc (neg_string s) - | "-"; s = INT32 -> MLast.PaInt32 loc (neg_string s) - | "-"; s = INT64 -> MLast.PaInt64 loc (neg_string s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt loc (neg_string s) - | "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >> - | "["; "]" -> <:patt< [] >> - | "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat loc last pl - | "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 patt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | "_" -> <:patt< _ >> ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Some p - | -> None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - ipatt: - [ [ "{"; lpl = LIST1 label_ipatt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 ipatt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | s = LIDENT -> <:patt< $lid:s$ >> - | "_" -> <:patt< _ >> ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> (i, p) ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = LIST0 type_parameter; "="; tk = ctyp; - cl = LIST0 constrain -> - (n, tpl, tk, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ] - | LEFTA - [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ] - | LEFTA - [ "!"; pl = LIST1 typevar; "."; t = ctyp -> - <:ctyp< ! $list:pl$ . $t$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "label" NONA - [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> - | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] - | LEFTA - [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" -> - <:ctyp< ( $list:[t::tl]$ ) >> - | "("; t = SELF; ")" -> <:ctyp< $t$ >> - | "private"; "["; cdl = LIST0 constructor_declaration SEP "|"; "]" -> - <:ctyp< private [ $list:cdl$ ] >> - | "private"; "{"; ldl = LIST1 label_declaration SEP ";"; "}" -> - <:ctyp< private { $list:ldl$ } >> - | "["; cdl = LIST0 constructor_declaration SEP "|"; "]" -> - <:ctyp< [ $list:cdl$ ] >> - | "{"; ldl = LIST1 label_declaration SEP ";"; "}" -> - <:ctyp< { $list:ldl$ } >> ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp -> - (loc, i, o2b mf, t) ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - class_declaration: - [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >> - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - <:class_expr< fun $p$ -> $ce$ >> - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ ci = class_longident; "["; ctcl = LIST0 ctyp SEP ","; "]" -> - <:class_expr< $list:ci$ [ $list:ctcl$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "declare"; st = LIST0 [ s= class_str_item; ";" -> s ]; "end" -> - <:class_str_item< declare $list:st$ end >> - | "inherit"; ce = class_expr; pb = OPT as_lident -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; topt = OPT polyt; - e = fun_binding -> - <:class_str_item< method $opt:o2b pf$ $l$ $opt:topt$ = $e$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - as_lident: - [ [ "as"; i = LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | id = clty_longident; "["; tl = LIST1 ctyp SEP ","; "]" -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; - csf = LIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - <:class_sig_item< declare $list:st$ end >> - | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> - | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $opt:o2b pf$ $l$ : $t$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$ ) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; fel = LIST0 field_expr SEP ";"; ">}" -> - <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> (l, e) ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; ml = LIST0 field SEP ";"; v = OPT ".."; ">" -> - <:ctyp< < $list:ml$ $opt:o2b v$ > >> ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; rfl = row_field_list; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field_list: - [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> <:row_field< ` $i$ >> - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >> - | t = ctyp -> <:row_field< $t$ >> ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> - | "#"; sl = mod_ident -> <:patt< # $list:sl$ >> - | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = patt -> p ] ] - ; - ipatt: - [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = LIST1 name_tag; "|]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - warning_variant: - [ [ -> warn_variant loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = LIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - <:expr< do { $list:append_elem seq e$ } >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = LIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; seq = LIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - <:expr< while $e$ do { $list:seq$ } >> ] ] - ; - warning_sequence: - [ [ -> warn_sequence loc ] ] - ; -END; - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; ";" -> (si, loc) ] ] - ; - implem: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; ";" -> (si, loc) ] ] - ; - top_phrase: - [ [ ph = phrase -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - <:str_item< # $n$ $opt:dp$ >> - | sti = str_item; ";" -> sti ] ] - ; - expr: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - patt: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - (int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (0, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; -END; diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml deleted file mode 100644 index cb3566cd3e..0000000000 --- a/camlp4/meta/pa_rp.ml +++ /dev/null @@ -1,318 +0,0 @@ -(* 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. *) -(* In syntax generated, many cases are optimisations. *) - -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 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$.$_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> when v <> v' -> (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $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 ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -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 - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let loc = gloc in <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Revised Syntax grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser loc po pcl$ >> - | "parser"; 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, None)] - | spc = stream_patt_comp; ";"; - sp = LIST1 stream_patt_comp_err SEP ";" -> - [(spc, None) :: sp] - | -> [] ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr -> e ] -> - (spc, eo) ] ] - ; - 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" - [ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> - <:expr< $cstream loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "`"; e = expr -> SeTrm loc e | e = expr -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml deleted file mode 100644 index 2558c5fa93..0000000000 --- a/camlp4/meta/pr_dump.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value open_out_file () = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> do { set_binary_mode_out stdout True; stdout } ] -; - -value interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -value implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -Pcaml.print_interf.val := interf; -Pcaml.print_implem.val := implem; diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml deleted file mode 100644 index c10ad7980c..0000000000 --- a/camlp4/meta/q_MLast.ml +++ /dev/null @@ -1,1501 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value gram = Grammar.gcreate (Plexer.gmake ()); - -module Qast = - struct - type t = - [ Node of string and list t - | List of list t - | Tuple of list t - | Option of option t - | Int of string - | Str of string - | Bool of bool - | Cons of t and t - | Apply of string and list t - | Record of list (string * t) - | Loc - | Antiquot of MLast.loc and string ] - ; - value loc = (0, 0); - value rec to_expr = - fun - [ Node n al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al - <:expr< [] >> - | Tuple al -> <:expr< ($list:List.map to_expr al$) >> - | Option None -> <:expr< None >> - | Option (Some a) -> <:expr< Some $to_expr a$ >> - | Int s -> <:expr< $int:s$ >> - | Str s -> <:expr< $str:s$ >> - | Bool True -> <:expr< True >> - | Bool False -> <:expr< False >> - | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >> - | Apply f al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< $lid:f$ >> al - | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >> - | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >> - | Antiquot loc s -> - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with - [ Stdpp.Exc_located (bp, ep) exc -> - raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ] - in - <:expr< $anti:e$ >> ] - and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a); - value rec to_patt = - fun - [ Node n al -> - List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>) - <:patt< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al - <:patt< [] >> - | Tuple al -> <:patt< ($list:List.map to_patt al$) >> - | Option None -> <:patt< None >> - | Option (Some a) -> <:patt< Some $to_patt a$ >> - | Int s -> <:patt< $int:s$ >> - | Str s -> <:patt< $str:s$ >> - | Bool True -> <:patt< True >> - | Bool False -> <:patt< False >> - | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >> - | Apply _ _ -> failwith "bad pattern" - | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >> - | Loc -> <:patt< _ >> - | Antiquot loc s -> - let p = - try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with - [ Stdpp.Exc_located (bp, ep) exc -> - raise (Stdpp.Exc_located (fst loc + bp, fst loc + ep) exc) ] - in - <:patt< $anti:p$ >> ] - and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a); - end -; - -value antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot (shift + bp, shift + ep) x -; - -value sig_item = Grammar.Entry.create gram "signature item"; -value str_item = Grammar.Entry.create gram "structure item"; -value ctyp = Grammar.Entry.create gram "type"; -value patt = Grammar.Entry.create gram "pattern"; -value expr = Grammar.Entry.create gram "expression"; - -value module_type = Grammar.Entry.create gram "module type"; -value module_expr = Grammar.Entry.create gram "module expression"; - -value class_type = Grammar.Entry.create gram "class type"; -value class_expr = Grammar.Entry.create gram "class expr"; -value class_sig_item = Grammar.Entry.create gram "class signature item"; -value class_str_item = Grammar.Entry.create gram "class structure item"; - -value ipatt = Grammar.Entry.create gram "ipatt"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value a_list = Grammar.Entry.create gram "a_list"; -value a_opt = Grammar.Entry.create gram "a_opt"; -value a_UIDENT = Grammar.Entry.create gram "a_UIDENT"; -value a_LIDENT = Grammar.Entry.create gram "a_LIDENT"; -value a_INT = Grammar.Entry.create gram "a_INT"; -value a_FLOAT = Grammar.Entry.create gram "a_FLOAT"; -value a_STRING = Grammar.Entry.create gram "a_STRING"; -value a_CHAR = Grammar.Entry.create gram "a_CHAR"; -value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT"; -value a_LABEL = Grammar.Entry.create gram "a_LABEL"; -value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT"; -value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL"; - -value o2b = - fun - [ Qast.Option (Some _) -> Qast.Bool True - | Qast.Option None -> Qast.Bool False - | x -> x ] -; - -value mksequence _ = - fun - [ Qast.List [e] -> e - | el -> Qast.Node "ExSeq" [Qast.Loc; el] ] -; - -value mkmatchcase _ p aso w e = - let p = - match aso with - [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2] - | Qast.Option None -> p - | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ] - in - Qast.Tuple [p; w; e] -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin _ f arg = - match arg with - [ Qast.Node "ExInt" [Qast.Loc; Qast.Str n] when int_of_string n > 0 -> - let n = neg_string n in - Qast.Node "ExInt" [Qast.Loc; Qast.Str n] - | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 -> - let n = neg_string n in - Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] - | _ -> - match f with - [ Qast.Str f -> - let f = "~" ^ f in - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg] - | _ -> assert False ] ] -; - -value mkuminpat _ f is_int s = - let s = - match s with - [ Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" ] - in - match is_int with - [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s] - | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s] - | _ -> assert False ] -; - -value mklistexp _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [e1 :: el] -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1]; - loop False (Qast.List el)] - | a -> a ] -; - -value mklistpat _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [p1 :: pl] -> - Qast.Node "PaApp" - [Qast.Loc; - Qast.Node "PaApp" - [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1]; - loop False (Qast.List pl)] - | a -> a ] -; - -value mkexprident loc i j = - loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m = - fun - [ Qast.Node "ExAcc" [_; x; y] -> - loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y - | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ] -; - -value mkassert _ e = - match e with - [ Qast.Node "ExUid" [_; Qast.Str "False"] -> Qast.Node "ExAsf" [Qast.Loc] - | _ -> Qast.Node "ExAsr" [Qast.Loc; e] ] -; - -value append_elem el e = Qast.Apply "@" [el; Qast.List [e]]; - -value not_yet_warned_antiq = ref True; -value warn_antiq loc vers = - if not_yet_warned_antiq.val then do { - not_yet_warned_antiq.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers); - } - else () -; - -value not_yet_warned_variant = ref True; -value warn_variant _ = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val (0, 1) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned_seq = ref True; -value warn_sequence _ = - if not_yet_warned_seq.val then do { - not_yet_warned_seq.val := False; - Pcaml.warning.val (0, 1) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - Qast.Node "MeFun" [Qast.Loc; i; t; me] - | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "MeStr" [Qast.Loc; st] ] - | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ] - | [ me1 = SELF; "."; me2 = SELF -> - Qast.Node "MeAcc" [Qast.Loc; me1; me2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i] - | "("; me = SELF; ":"; mt = module_type; ")" -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "("; me = SELF; ")" -> me ] ] - ; - str_item: - [ "top" - [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "StDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration; b = rebind_exn -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "StExc" [Qast.Loc; c; tl; b] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "StExt" [Qast.Loc; i; t; pd] - | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me] - | "module"; i = a_UIDENT; mb = module_binding -> - Qast.Node "StMod" [Qast.Loc; i; mb] - | "module"; "rec"; nmtmes = SLIST1 module_rec_binding SEP "and" -> - Qast.Node "StRecMod" [Qast.Loc; nmtmes] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "StMty" [Qast.Loc; i; mt] - | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "StTyp" [Qast.Loc; tdl] - | "value"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and" -> - Qast.Node "StVal" [Qast.Loc; o2b r; l] - | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> Qast.List [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - Qast.Node "MeFun" [Qast.Loc; m; mt; mb] - | ":"; mt = module_type; "="; me = module_expr -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "="; me = module_expr -> me ] ] - ; - module_rec_binding: - [ [ m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr -> - Qast.Tuple [m; me; mt] ] ] - ; - module_type: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] - | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" -> - Qast.Node "MtWit" [Qast.Loc; mt; wcl] ] - | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "MtSig" [Qast.Loc; sg] ] - | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ] - | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i] - | "'"; i = ident -> Qast.Node "MtQuo" [Qast.Loc; i] - | "("; mt = SELF; ")" -> mt ] ] - ; - sig_item: - [ "top" - [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "SgDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "SgExc" [Qast.Loc; c; tl] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "SgExt" [Qast.Loc; i; t; pd] - | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt] - | "module"; i = a_UIDENT; mt = module_declaration -> - Qast.Node "SgMod" [Qast.Loc; i; mt] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "SgMty" [Qast.Loc; i; mt] - | "module"; "rec"; mds = SLIST1 module_rec_declaration SEP "and" -> - Qast.Node "SgRecMod" [Qast.Loc; mds] - | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "SgTyp" [Qast.Loc; tdl] - | "value"; i = a_LIDENT; ":"; t = ctyp -> - Qast.Node "SgVal" [Qast.Loc; i; t] ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> mt - | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ] - ; - module_rec_declaration: - [ [ m = a_UIDENT; ":"; mt = module_type -> Qast.Tuple [m; mt] ] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp -> - Qast.Node "WcTyp" [Qast.Loc; i; tpl; t] - | "module"; i = mod_ident; "="; me = module_expr -> - Qast.Node "WcMod" [Qast.Loc; i; me] ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - Qast.Node "ExLet" [Qast.Loc; o2b r; l; x] - | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF -> - Qast.Node "ExLmd" [Qast.Loc; m; mb; e] - | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExFun" [Qast.Loc; l] - | "fun"; p = ipatt; e = fun_def -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExMat" [Qast.Loc; e; l] - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExMat" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExTry" [Qast.Loc; e; l] - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExTry" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3] - | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] - | "where" - [ e = SELF; "where"; rf = SOPT "rec"; lb = let_binding -> - Qast.Node "ExLet" [Qast.Loc; o2b rf; Qast.List [lb]; e] ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> - Qast.Node "ExAss" [Qast.Loc; e1; e2] ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1]; - e2] ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1]; - e2] ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1]; - e2] - | e1 = SELF; ">"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1]; - e2] - | e1 = SELF; "<="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1]; - e2] - | e1 = SELF; ">="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1]; - e2] - | e1 = SELF; "="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1]; - e2] - | e1 = SELF; "<>"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1]; - e2] - | e1 = SELF; "=="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1]; - e2] - | e1 = SELF; "!="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1]; - e2] ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1]; - e2] - | e1 = SELF; "@"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1]; - e2] ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1]; - e2] - | e1 = SELF; "-"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1]; - e2] - | e1 = SELF; "+."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1]; - e2] - | e1 = SELF; "-."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1]; - e2] ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1]; - e2] - | e1 = SELF; "/"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1]; - e2] - | e1 = SELF; "*."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1]; - e2] - | e1 = SELF; "/."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1]; - e2] - | e1 = SELF; "land"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1]; - e2] - | e1 = SELF; "lor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1]; - e2] - | e1 = SELF; "lxor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1]; - e2] - | e1 = SELF; "mod"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1]; - e2] ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1]; - e2] - | e1 = SELF; "asr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1]; - e2] - | e1 = SELF; "lsl"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1]; - e2] - | e1 = SELF; "lsr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1]; - e2] ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e - | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2] - | "assert"; e = SELF -> mkassert Qast.Loc e - | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> - Qast.Node "ExAre" [Qast.Loc; e1; e2] - | e1 = SELF; "."; "["; e2 = SELF; "]" -> - Qast.Node "ExSte" [Qast.Loc; e1; e2] - | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ] - | "~-" NONA - [ "~-"; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e] - | "~-."; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ] - | "simple" - [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s] - | i = expr_ident -> i - | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp Qast.Loc last el - | "[|"; el = SLIST0 expr SEP ";"; "|]" -> - Qast.Node "ExArr" [Qast.Loc; el] - | "{"; lel = SLIST1 label_expr SEP ";"; "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None] - | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";"; - "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)] - | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"] - | "("; e = SELF; ":"; t = ctyp; ")" -> - Qast.Node "ExTyc" [Qast.Loc; e; t] - | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" -> - Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el] - | "("; e = SELF; ")" -> e ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and"; - [ "in" | ";" ]; el = SELF -> - Qast.List - [Qast.Node "ExLet" [Qast.Loc; o2b rf; l; mksequence Qast.Loc el]] - | e = expr; ";"; el = SELF -> Qast.Cons e el - | e = expr; ";" -> Qast.List [e] - | e = expr -> Qast.List [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase Qast.Loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ] - ; - expr_ident: - [ RIGHTA - [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i] - | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" - [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s] - | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s] - | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_FLOAT -> - mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s - | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat Qast.Loc last pl - | "[|"; pl = SLIST0 patt SEP ";"; "|]" -> - Qast.Node "PaArr" [Qast.Loc; pl] - | "{"; lpl = SLIST1 label_patt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" RIGHTA - [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ] - ; - ipatt: - [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp; - cl = SLIST0 constrain -> - Qast.Tuple [n; tpl; tk; cl] ] ] - ; - type_patt: - [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ] - ; - type_parameter: - [ [ "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]] - | "+"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]] - | "-"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ] - | LEFTA - [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ] - | LEFTA - [ "!"; pl = SLIST1 typevar; "."; t = SELF -> - Qast.Node "TyPol" [Qast.Loc; pl; t] ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ] - | "label" NONA - [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_QUESTIONIDENT; ":"; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] - | i = a_OPTLABEL; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] ] - | LEFTA - [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ] - | "simple" - [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i] - | "_" -> Qast.Node "TyAny" [Qast.Loc] - | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i] - | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" -> - Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl] - | "("; t = SELF; ")" -> t - | "private"; "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" -> - Qast.Node "TySum" [Qast.Loc; Qast.Bool True; cdl] - | "private"; "{"; ldl = SLIST1 label_declaration SEP ";"; "}" -> - Qast.Node "TyRec" [Qast.Loc; Qast.Bool True; ldl] - | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" -> - Qast.Node "TySum" [Qast.Loc; Qast.Bool False; cdl] - | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" -> - Qast.Node "TyRec" [Qast.Loc; Qast.Bool False; ldl] ] ] - ; - constructor_declaration: - [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" -> - Qast.Tuple [Qast.Loc; ci; cal] - | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ] - ; - label_declaration: - [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp -> - Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ] - ; - ident: - [ [ i = a_LIDENT -> i - | i = a_UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = a_UIDENT -> Qast.List [i] - | i = a_LIDENT -> Qast.List [i] - | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = SLIST1 class_declaration SEP "and" -> - Qast.Node "StCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "StClt" [Qast.Loc; ctd] ] ] - ; - sig_item: - [ [ "class"; cd = SLIST1 class_description SEP "and" -> - Qast.Node "SgCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "SgClt" [Qast.Loc; ctd] ] ] - ; - class_declaration: - [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", i); ("ciExp", cfb)] ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ] - ; - class_type_parameters: - [ [ -> Qast.Tuple [Qast.Loc; Qast.List []] - | "["; tpl = SLIST1 type_parameter SEP ","; "]" -> - Qast.Tuple [Qast.Loc; tpl] ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce] - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - Qast.Node "CeFun" [Qast.Loc; p; ce] - | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - Qast.Node "CeApp" [Qast.Loc; ce; e] ] - | "simple" - [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" -> - Qast.Node "CeCon" [Qast.Loc; ci; ctcl] - | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []] - | "object"; cspo = SOPT class_self_patt; cf = class_structure; "end" -> - Qast.Node "CeStr" [Qast.Loc; cspo; cf] - | "("; ce = SELF; ":"; ct = class_type; ")" -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] ] ] - ; - class_str_item: - [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" -> - Qast.Node "CrDcl" [Qast.Loc; st] - | "inherit"; ce = class_expr; pb = SOPT as_lident -> - Qast.Node "CrInh" [Qast.Loc; ce; pb] - | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding -> - Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CrVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; topt = SOPT polyt; - e = fun_binding -> - Qast.Node "CrMth" [Qast.Loc; l; o2b pf; e; topt] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CrCtr" [Qast.Loc; t1; t2] - | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ] - ; - as_lident: - [ [ "as"; i = a_LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | ":>"; t = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] ] ] - ; - label: - [ [ i = a_LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - Qast.Node "CtFun" [Qast.Loc; t; ct] - | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" -> - Qast.Node "CtCon" [Qast.Loc; id; tl] - | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []] - | "object"; cst = SOPT class_self_type; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - Qast.Node "CgDcl" [Qast.Loc; st] - | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs] - | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> - Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgMth" [Qast.Loc; l; o2b pf; t] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ] - ; - class_description: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", ct)] ] ] - ; - class_type_declaration: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", cs)] ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | "("; e = SELF; ":>"; t = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] - | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" -> - Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id] - | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" -> - Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ] - ; - field: - [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - class_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "["; ">"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "["; "<"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "["; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - row_field_list: - [ [ rfl = SLIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []] - | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" -> - Qast.Node "RfTag" [i; o2b ao; l] - | t = ctyp -> Qast.Node "RfInh" [t] ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s] - | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl] - | i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = patt -> p ] ] - ; - ipatt: - [ [ i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = a_TILDEIDENT; ":"; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_LABEL; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_OPTLABEL; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_QUESTIONIDENT -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ] - ; - direction_flag: - [ [ "to" -> Qast.Bool True - | "downto" -> Qast.Bool False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = SLIST1 name_tag; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - warning_variant: - [ [ -> warn_variant Qast.Loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - Qast.Node "ExSeq" [Qast.Loc; append_elem seq e] - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ] - ; - warning_sequence: - [ [ -> warn_sequence Qast.Loc ] ] - ; - (* Antiquotations for local entries *) - sequence: - [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ] - ; - expr_ident: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - patt_label_ident: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - when_expr_opt: - [ [ a = ANTIQUOT "when" -> antiquot "when" loc a ] ] - ; - mod_ident: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - clty_longident: - [ [ a = a_list -> a ] ] - ; - class_longident: - [ [ a = a_list -> a ] ] - ; - direction_flag: - [ [ a = ANTIQUOT "to" -> antiquot "to" loc a ] ] - ; - (* deprecated since version 3.05; code for compatibility *) - class_expr: LEVEL "simple" - [ [ "object"; x = ANTIQUOT; cf = class_structure; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CeStr" [Qast.Loc; antiquot "" loc x; cf] - | "object"; x = ANTIQUOT; ";"; - csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CeStr" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x) csl] ] ] - ; - class_type: - [ [ "object"; x = ANTIQUOT; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CtSig" [Qast.Loc; antiquot "" loc x; csf] - | "object"; x = ANTIQUOT; ";"; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq loc "3.05" in - Qast.Node "CtSig" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x) csf] ] ] - ; - (* deprecated since version 3.06+18; code for compatibility *) - expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "ExLet" [Qast.Loc; antiquot "rec" loc r; l; x] ] ] - ; - str_item: LEVEL "top" - [ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "StVal" [Qast.Loc; antiquot "rec" loc r; l] ] ] - ; - class_expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CeLet" [Qast.Loc; antiquot "rec" loc r; lb; ce] ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" loc pb] - | "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" loc mf; e] ] ] - ; - class_sig_item: - [ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp -> - let _ = warn_antiq loc "3.06+18" in - Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" loc mf; t] ] ] - ; -END; - -EXTEND - GLOBAL: str_item sig_item; - str_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "StDir" [Qast.Loc; n; dp] ] ] - ; - sig_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "SgDir" [Qast.Loc; n; dp] ] ] - ; - dir_param: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a - | e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; -END; - -(* Antiquotations *) - -EXTEND - module_expr: LEVEL "simple" - [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - str_item: LEVEL "top" - [ [ a = ANTIQUOT "stri" -> antiquot "stri" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - module_type: LEVEL "simple" - [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - sig_item: LEVEL "top" - [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" loc a - | a = ANTIQUOT -> antiquot "" loc a ] ] - ; - expr: LEVEL "simple" - [ [ a = ANTIQUOT "exp" -> antiquot "exp" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ] - ; - patt: LEVEL "simple" - [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ipatt: - [ [ a = ANTIQUOT "pat" -> antiquot "pat" loc a - | a = ANTIQUOT -> antiquot "" loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ctyp: LEVEL "simple" - [ [ a = ANTIQUOT "typ" -> antiquot "typ" loc a - | a = ANTIQUOT -> antiquot "" loc a - | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ] - ; - class_expr: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_str_item: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_sig_item: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - class_type: - [ [ a = ANTIQUOT -> antiquot "" loc a ] ] - ; - expr: LEVEL "simple" - [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - patt: LEVEL "simple" - [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ] - ; - a_list: - [ [ a = ANTIQUOT "list" -> antiquot "list" loc a ] ] - ; - a_opt: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" loc a ] ] - ; - a_UIDENT: - [ [ a = ANTIQUOT "uid" -> antiquot "uid" loc a - | a = ANTIQUOT -> antiquot "" loc a - | i = UIDENT -> Qast.Str i ] ] - ; - a_LIDENT: - [ [ a = ANTIQUOT "lid" -> antiquot "lid" loc a - | a = ANTIQUOT -> antiquot "" loc a - | i = LIDENT -> Qast.Str i ] ] - ; - a_INT: - [ [ a = ANTIQUOT "int" -> antiquot "int" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = INT -> Qast.Str s ] ] - ; - a_FLOAT: - [ [ a = ANTIQUOT "flo" -> antiquot "flo" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = FLOAT -> Qast.Str s ] ] - ; - a_STRING: - [ [ a = ANTIQUOT "str" -> antiquot "str" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = STRING -> Qast.Str s ] ] - ; - a_CHAR: - [ [ a = ANTIQUOT "chr" -> antiquot "chr" loc a - | a = ANTIQUOT -> antiquot "" loc a - | s = CHAR -> Qast.Str s ] ] - ; - a_TILDEIDENT: - [ [ "~"; a = ANTIQUOT -> antiquot "" loc a - | s = TILDEIDENT -> Qast.Str s ] ] - ; - a_LABEL: - [ [ s = LABEL -> Qast.Str s ] ] - ; - a_QUESTIONIDENT: - [ [ "?"; a = ANTIQUOT -> antiquot "" loc a - | s = QUESTIONIDENT -> Qast.Str s ] ] - ; - a_OPTLABEL: - [ [ s = OPTLABEL -> Qast.Str s ] ] - ; -END; - -value apply_entry e = - let f s = Grammar.Entry.parse e (Stream.of_string s) in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in - Quotation.ExAst (expr, patt) -; - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -do { - EXTEND - sig_item_eoi: - [ [ x = sig_item; EOI -> x ] ] - ; - END; - Quotation.add "sig_item" (apply_entry sig_item_eoi) -}; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -do { - EXTEND - str_item_eoi: - [ [ x = str_item; EOI -> x ] ] - ; - END; - Quotation.add "str_item" (apply_entry str_item_eoi) -}; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -do { - EXTEND - ctyp_eoi: - [ [ x = ctyp; EOI -> x ] ] - ; - END; - Quotation.add "ctyp" (apply_entry ctyp_eoi) -}; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -do { - EXTEND - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; - END; - Quotation.add "patt" (apply_entry patt_eoi) -}; - -let expr_eoi = Grammar.Entry.create gram "expression" in -do { - EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - END; - Quotation.add "expr" (apply_entry expr_eoi) -}; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -do { - EXTEND - module_type_eoi: - [ [ x = module_type; EOI -> x ] ] - ; - END; - Quotation.add "module_type" (apply_entry module_type_eoi) -}; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -do { - EXTEND - module_expr_eoi: - [ [ x = module_expr; EOI -> x ] ] - ; - END; - Quotation.add "module_expr" (apply_entry module_expr_eoi) -}; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -do { - EXTEND - class_type_eoi: - [ [ x = class_type; EOI -> x ] ] - ; - END; - Quotation.add "class_type" (apply_entry class_type_eoi) -}; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -do { - EXTEND - class_expr_eoi: - [ [ x = class_expr; EOI -> x ] ] - ; - END; - Quotation.add "class_expr" (apply_entry class_expr_eoi) -}; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -do { - EXTEND - class_sig_item_eoi: - [ [ x = class_sig_item; EOI -> x ] ] - ; - END; - Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi) -}; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -do { - EXTEND - class_str_item_eoi: - [ [ x = class_str_item; EOI -> x ] ] - ; - END; - Quotation.add "class_str_item" (apply_entry class_str_item_eoi) -}; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -do { - EXTEND - with_constr_eoi: - [ [ x = with_constr; EOI -> x ] ] - ; - END; - Quotation.add "with_constr" (apply_entry with_constr_eoi) -}; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -do { - EXTEND - row_field_eoi: - [ [ x = row_field; EOI -> x ] ] - ; - END; - Quotation.add "row_field" (apply_entry row_field_eoi) -}; diff --git a/camlp4/ocaml_src/.cvsignore b/camlp4/ocaml_src/.cvsignore deleted file mode 100644 index 2551b02453..0000000000 --- a/camlp4/ocaml_src/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -SAVED diff --git a/camlp4/ocaml_src/camlp4/.cvsignore b/camlp4/ocaml_src/camlp4/.cvsignore deleted file mode 100644 index eb4bb86b20..0000000000 --- a/camlp4/ocaml_src/camlp4/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -camlp4 -crc.ml -extract_crc diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend deleted file mode 100644 index bf82065403..0000000000 --- a/camlp4/ocaml_src/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi -pcaml.cmi: mLast.cmi spretty.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: ast2pt.cmi mLast.cmi ../odyl/odyl_main.cmi pcaml.cmi -argl.cmx: ast2pt.cmx mLast.cmi ../odyl/odyl_main.cmx pcaml.cmx -ast2pt.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/longident.cmi mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/longident.cmx mLast.cmi $(OTOP)/parsing/parsetree.cmi \ - ast2pt.cmi -pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile deleted file mode 100644 index 0e5d05762d..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../../boot/stdpp.cmo ../../boot/token.cmo ../../boot/plexer.cmo ../../boot/gramext.cmo ../../boot/grammar.cmo ../../boot/extfold.cmo ../../boot/extfun.cmo ../../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx ast2pt.cmx spretty.cmx reloc.cmx pcaml.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) -opt: $(OBJS:.cma=.cmxa) -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4) - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT) - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -c $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." - cp camlp4.cma $(LIBDIR)/camlp4/. - if [ -f camlp4.cmxa ]; \ - then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \ - else : ; \ - fi - -include .depend diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac b/camlp4/ocaml_src/camlp4/Makefile.Mac deleted file mode 100644 index b7561d8cb5..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac +++ /dev/null @@ -1,69 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::odyl: -I :::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -INTERFACES = -I "{OLIBDIR}" Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak ¶ - -I :::boot: Extfold Extfun Fstream ¶ - Gramext Grammar Plexer ¶ - Stdpp Token -I "{OTOP}utils:" Config Warnings ¶ - -I "{OTOP}parsing:" Asttypes Location Longident Parsetree ¶ - -I : Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF = "{OTOP}utils:config.cmi" "{OTOP}utils:warnings.cmi" ¶ - "{OTOP}parsing:asttypes.cmi" "{OTOP}parsing:location.cmi" ¶ - "{OTOP}parsing:longident.cmi" "{OTOP}parsing:parsetree.cmi" ¶ - ast2pt.cmo mLast.cmi pcaml.cmi spretty.cmi ¶ - quotation.cmi -CAMLP4_OBJS = :::boot:stdpp.cmo :::boot:token.cmo :::boot:plexer.cmo ¶ - :::boot:gramext.cmo :::boot:grammar.cmo :::boot:extfold.cmo :::boot:extfun.cmo ¶ - :::boot:fstream.cmo "{OTOP}utils:config.cmo" ¶ - quotation.cmo ast2pt.cmo spretty.cmo reloc.cmo pcaml.cmo ¶ - argl.cmo crc.cmo -OBJS = ::odyl:odyl.cma camlp4.cma -XOBJS = camlp4.cmxa -CAMLP4M = - -CAMLP4 = camlp4 - -all Ä {CAMLP4} - -{CAMLP4} Ä {OBJS} ::odyl:odyl.cmo - {OCAMLC} {OBJS} {CAMLP4M} ::odyl:odyl.cmo -linkall -o {CAMLP4} - -camlp4.cma Ä {CAMLP4_OBJS} - {OCAMLC} {LINKFLAGS} {CAMLP4_OBJS} -a -o camlp4.cma - -clean ÄÄ - delete -i {CAMLP4} - -{dependrule} - -promote Ä - duplicate -y {CAMLP4} :::boot: - -compare Ä - for i in {CAMLP4} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {CAMLP4} "{BINDIR}" - duplicate -y mLast.mli quotation.mli pcaml.mli spretty.mli "{P4LIBDIR}" - duplicate -y mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi ¶ - "{P4LIBDIR}" - duplicate -y camlp4.cma "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend b/camlp4/ocaml_src/camlp4/Makefile.Mac.depend deleted file mode 100644 index 3665195f77..0000000000 --- a/camlp4/ocaml_src/camlp4/Makefile.Mac.depend +++ /dev/null @@ -1,15 +0,0 @@ -pcaml.cmiÄ mLast.cmi spretty.cmi -quotation.cmiÄ mLast.cmi -reloc.cmiÄ mLast.cmi -argl.cmoÄ ast2pt.cmo mLast.cmi pcaml.cmi -argl.cmxÄ ast2pt.cmx mLast.cmi pcaml.cmx -ast2pt.cmoÄ mLast.cmi -ast2pt.cmxÄ mLast.cmi -pcaml.cmoÄ ast2pt.cmo mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi -pcaml.cmxÄ ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi -quotation.cmoÄ mLast.cmi quotation.cmi -quotation.cmxÄ mLast.cmi quotation.cmi -reloc.cmoÄ mLast.cmi reloc.cmi -reloc.cmxÄ mLast.cmi reloc.cmi -spretty.cmoÄ spretty.cmi -spretty.cmxÄ spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml deleted file mode 100644 index 0f6ac98ced..0000000000 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ /dev/null @@ -1,406 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -open Printf;; - -let rec action_arg s sl = - function - Arg.Unit f -> if s = "" then begin f (); Some sl end else None - | Arg.Bool f -> - if s = "" then - match sl with - s :: sl -> - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | [] -> None - else - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | Arg.Set r -> if s = "" then begin r := true; Some sl end else None - | Arg.Clear r -> if s = "" then begin r := false; Some sl end else None - | Arg.Rest f -> List.iter f (s :: sl); Some [] - | Arg.String f -> - if s = "" then - match sl with - s :: sl -> f s; Some sl - | [] -> None - else begin f s; Some sl end - | Arg.Set_string r -> - if s = "" then - match sl with - s :: sl -> r := s; Some sl - | [] -> None - else begin r := s; Some sl end - | Arg.Int f -> - if s = "" then - match sl with - s :: sl -> - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | Arg.Set_int r -> - if s = "" then - match sl with - s :: sl -> - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | Arg.Float f -> - if s = "" then - match sl with - s :: sl -> f (float_of_string s); Some sl - | [] -> None - else begin f (float_of_string s); Some sl end - | Arg.Set_float r -> - if s = "" then - match sl with - s :: sl -> r := float_of_string s; Some sl - | [] -> None - else begin r := float_of_string s; Some sl end - | Arg.Tuple specs -> - let rec action_args s sl = - function - [] -> Some sl - | spec :: spec_list -> - match action_arg s sl spec with - None -> action_args "" [] spec_list - | Some (s :: sl) -> action_args s sl spec_list - | Some sl -> action_args "" sl spec_list - in - action_args s sl specs - | Arg.Symbol (syms, f) -> - match if s = "" then sl else s :: sl with - s :: sl when List.mem s syms -> f s; Some sl - | _ -> None -;; - -let common_start s1 s2 = - let rec loop i = - if i == String.length s1 || i == String.length s2 then i - else if s1.[i] == s2.[i] then loop (i + 1) - else i - in - loop 0 -;; - -let rec parse_arg s sl = - function - (name, action, _) :: spec_list -> - let i = common_start s name in - if i == String.length name then - try action_arg (String.sub s i (String.length s - i)) sl action with - Arg.Bad _ -> parse_arg s sl spec_list - else parse_arg s sl spec_list - | [] -> None -;; - -let rec parse_aux spec_list anon_fun = - function - [] -> [] - | s :: sl -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - Some sl -> parse_aux spec_list anon_fun sl - | None -> s :: parse_aux spec_list anon_fun sl - else begin (anon_fun s : unit); parse_aux spec_list anon_fun sl end -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let print_location loc = - if !(Pcaml.input_file) <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in - eprintf loc_fmt !(Pcaml.input_file) line bp ep - else eprintf "At location %d-%d\n" (fst loc) (snd loc) -;; - -let print_warning loc s = print_location loc; eprintf "%s\n" s;; - -let rec parse_file pa getdir useast = - let name = !(Pcaml.input_file) in - Pcaml.warning := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - let rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - Some x -> - begin match x with - loc, "load", Some (MLast.ExStr (_, s)) -> - Odyl_main.loadfile s; pl - | loc, "directory", Some (MLast.ExStr (_, s)) -> - Odyl_main.directory s; pl - | loc, "use", Some (MLast.ExStr (_, s)) -> - List.rev_append rpl - [useast loc s (use_file pa getdir useast s), loc] - | loc, _, _ -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") - end - | None -> pl - in - pl @ loop () - else pl - in - loop () - with - x -> clear (); raise x - in - clear (); phr -and use_file pa getdir useast s = - let clear = - let v_input_file = !(Pcaml.input_file) in - fun () -> Pcaml.input_file := v_input_file - in - Pcaml.input_file := s; - try let r = parse_file pa getdir useast in clear (); r with - e -> clear (); raise e -;; - -let process pa pr getdir useast = pr (parse_file pa getdir useast);; - - -let gind = - function - (MLast.SgDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let gimd = - function - (MLast.StDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let usesig loc fname ast = MLast.SgUse (loc, fname, ast);; -let usestr loc fname ast = MLast.StUse (loc, fname, ast);; - -let process_intf () = - process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind usesig -;; -let process_impl () = - process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd usestr -;; - -type file_kind = - Intf - | Impl -;; -let file_kind = ref Intf;; -let file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -;; - -let print_version () = - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 -;; - -let align_doc key s = - let s = - let rec loop i = - if i = String.length s then "" - else if s.[i] = ' ' then loop (i + 1) - else String.sub s i (String.length s - i) - in - loop 0 - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - let rec loop i = - if i = String.length s then "", s - else if s.[i] <> '>' then loop (i + 1) - else - let p = String.sub s 0 (i + 1) in - let rec loop i = - if i >= String.length s then p, "" - else if s.[i] = ' ' then loop (i + 1) - else p, String.sub s i (String.length s - i) - in - loop (i + 1) - in - loop 0 - else "", s - else "", "" - in - let tab = - String.make (max 1 (13 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s -;; - -let make_symlist l = - match l with - [] -> "<none>" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - Arg.Symbol (symbs, _) -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc)) - l -;; - -let make_symlist l = - match l with - [] -> "<none>" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let print_usage_list l = - List.iter - (fun (key, spec, doc) -> - match spec with - Arg.Symbol (symbs, _) -> - let s = make_symlist symbs in - let synt = key ^ " " ^ s in - eprintf " %s %s\n" synt (align_doc synt doc) - | _ -> eprintf " %s %s\n" key (align_doc key doc)) - l -;; - -let usage ini_sl ext_sl = - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - <object-file> Load this file in Camlp4 core. -Other options: - <file> Parse this file.\n"; - print_usage_list ini_sl; - begin - let rec loop = - function - (y, _, _) :: _ when y = "-help" -> () - | _ :: sl -> loop sl - | [] -> eprintf " -help Display this list of options.\n" - in - loop (ini_sl @ ext_sl) - end; - if ext_sl <> [] then - begin - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl - end -;; - -let warn_noassert () = - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -" -;; - -let initial_spec_list = - ["-intf", Arg.String (fun x -> file_kind := Intf; Pcaml.input_file := x), - "<file> Parse <file> as an interface, whatever its extension."; - "-impl", Arg.String (fun x -> file_kind := Impl; Pcaml.input_file := x), - "<file> Parse <file> as an implementation, whatever its extension."; - "-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."; - "-noassert", Arg.Unit warn_noassert, "Obsolete, do not use this option."; - "-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."; - "-loc", Arg.String (fun x -> Stdpp.loc_name := x), - "<name> Name of the location variable (default: " ^ !(Stdpp.loc_name) ^ - ")"; - "-QD", Arg.String (fun x -> Pcaml.quotation_dump_file := Some x), - "<file> Dump quotation expander result in case of syntax error."; - "-o", Arg.String (fun x -> Pcaml.output_file := Some x), - "<file> Output on <file> instead of standard output."; - "-v", Arg.Unit print_version, "Print Camlp4 version and exit."] -;; - -let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;; - -let parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - Arg.Bad s -> - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 -;; - -let remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop (Sys.argv.(i) :: l) (i + 1) - in - List.rev (loop [] (!(Arg.current) + 1)) -;; - -let report_error = - function - Odyl_main.Error (fname, msg) -> - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - | exc -> Pcaml.report_error exc -;; - -let go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - begin match parse arg_spec_list anon_fun remaining_args with - [] -> () - | "-help" :: sl -> usage initial_spec_list ext_spec_list; exit 0 - | s :: sl -> - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - end; - try - if !(Pcaml.input_file) <> "" then - match !file_kind with - Intf -> process_intf () - | Impl -> process_impl () - with - exc -> - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc - | _ -> exc - in - report_error exc; Format.close_box (); Format.print_newline (); exit 2 -;; - -Odyl_main.name := "camlp4";; -Odyl_main.go := go;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml deleted file mode 100644 index b243109b73..0000000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ /dev/null @@ -1,880 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open MLast;; -open Parsetree;; -open Longident;; -open Asttypes;; - -let fast = ref false;; -let no_constructors_arity = ref false;; - -let get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -;; - -let error loc str = raise_with_loc loc (Failure str);; - -let char_of_char_token loc s = - try Token.eval_char s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let string_of_string_token loc s = - try Token.eval_string loc s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let glob_fname = ref "";; - -let mkloc (bp, ep) = - let loc_at n = - {Lexing.pos_fname = !glob_fname; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; - Lexing.pos_cnum = n} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = false} -;; - -let mkghloc (bp, ep) = - let loc_at n = - {Lexing.pos_fname = ""; Lexing.pos_lnum = 1; Lexing.pos_bol = 0; - Lexing.pos_cnum = n} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = true} -;; - -let mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};; -let mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};; -let mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};; -let mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};; -let mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};; -let mksig loc d = {psig_desc = d; psig_loc = mkloc loc};; -let mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};; -let mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};; -let mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};; -let mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};; -let mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};; -let mkpolytype t = - match t with - TyPol (_, _, _) -> t - | _ -> TyPol (MLast.loc_of_ctyp t, [], t) -;; - -let lident s = Lident s;; -let ldot l s = Ldot (l, s);; - -let conv_con = - let t = Hashtbl.create 73 in - List.iter (fun (s, s') -> Hashtbl.add t s s') - ["True", "true"; "False", "false"; " True", "True"; " False", "False"]; - fun s -> - try Hashtbl.find t s with - Not_found -> s -;; - -let conv_lab = - let t = Hashtbl.create 73 in - List.iter (fun (s, s') -> Hashtbl.add t s s') ["val", "contents"]; - fun s -> - try Hashtbl.find t s with - Not_found -> s -;; - -let array_function str name = - ldot (lident str) (if !fast then "unsafe_" ^ name else name) -;; - -let mkrf = - function - true -> Recursive - | false -> Nonrecursive -;; - -let mkli s = - let rec loop f = - function - i :: il -> loop (fun s -> ldot (f i) s) il - | [] -> f s - in - loop (fun s -> lident s) -;; - -let long_id_of_string_list loc sl = - match List.rev sl with - [] -> error loc "bad ast" - | s :: sl -> mkli s (List.rev sl) -;; - -let rec ctyp_fa al = - function - TyApp (_, f, a) -> ctyp_fa (a :: al) f - | f -> f, al -;; - -let rec ctyp_long_id = - function - TyAcc (_, m, TyLid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s - | TyAcc (_, m, TyUid (_, s)) -> - let (is_cls, li) = ctyp_long_id m in is_cls, ldot li s - | TyApp (_, m1, m2) -> - let (is_cls, li1) = ctyp_long_id m1 in - let (_, li2) = ctyp_long_id m2 in is_cls, Lapply (li1, li2) - | TyUid (_, s) -> false, lident s - | TyLid (_, s) -> false, lident s - | TyCls (loc, sl) -> true, long_id_of_string_list loc sl - | t -> error (loc_of_ctyp t) "incorrect type" -;; - -let rec ctyp = - function - TyAcc (loc, _, _) as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class (li, [], [])) - else mktyp loc (Ptyp_constr (li, [])) - | TyAli (loc, t1, t2) -> - let (t, i) = - match t1, t2 with - t, TyQuo (_, s) -> t, s - | TyQuo (_, s), t -> t, s - | _ -> error loc "incorrect alias type" - in - mktyp loc (Ptyp_alias (ctyp t, i)) - | TyAny loc -> mktyp loc Ptyp_any - | TyApp (loc, _, _) as f -> - let (f, al) = ctyp_fa [] f in - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class (li, List.map ctyp al, [])) - else mktyp loc (Ptyp_constr (li, List.map ctyp al)) - | TyArr (loc, TyLab (loc1, lab, t1), t2) -> - mktyp loc (Ptyp_arrow (lab, ctyp t1, ctyp t2)) - | TyArr (loc, TyOlb (loc1, lab, t1), t2) -> - let t1 = TyApp (loc1, TyLid (loc1, "option"), t1) in - mktyp loc (Ptyp_arrow (("?" ^ lab), ctyp t1, ctyp t2)) - | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", ctyp t1, ctyp t2)) - | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], [])) - | TyLab (loc, _, _) -> error loc "labelled type not allowed here" - | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyMan (loc, _, _) -> error loc "manifest type not allowed here" - | TyOlb (loc, lab, _) -> error loc "labelled type not allowed here" - | TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t)) - | TyQuo (loc, s) -> mktyp loc (Ptyp_var s) - | TyRec (loc, _, _) -> error loc "record type not allowed here" - | TySum (loc, _, _) -> error loc "sum type not allowed here" - | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyVrn (loc, catl, ool) -> - let catl = - List.map - (function - RfTag (c, a, t) -> Rtag (c, a, List.map ctyp t) - | RfInh t -> Rinherit (ctyp t)) - catl - in - let (clos, sl) = - match ool with - None -> true, None - | Some None -> false, None - | Some (Some sl) -> true, Some sl - in - mktyp loc (Ptyp_variant (catl, clos, sl)) -and meth_list loc fl v = - match fl with - [] -> if v then [mkfield loc Pfield_var] else [] - | (lab, t) :: fl -> - mkfield loc (Pfield (lab, ctyp (mkpolytype t))) :: meth_list loc fl v -;; - -let mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -;; -let mkmutable m = if m then Mutable else Immutable;; -let mkprivate m = if m then Private else Public;; -let mktrecord (_, n, m, t) = n, mkmutable m, ctyp (mkpolytype t);; -let mkvariant (_, c, tl) = c, List.map ctyp tl;; -let type_decl tl cl = - function - TyMan (loc, t, TyRec (_, pflag, ltl)) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) - (Some (ctyp t)) - | TyMan (loc, t, TySum (_, pflag, ctl)) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) - (Some (ctyp t)) - | TyRec (loc, pflag, ltl) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) None - | TySum (loc, pflag, ctl) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) None - | t -> - let m = - match t with - TyQuo (_, s) -> if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) - in - mktype (loc_of_ctyp t) tl cl Ptype_abstract m -;; - -let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};; - -let option f = - function - Some x -> Some (f x) - | None -> None -;; - -let expr_of_lab loc lab = - function - Some e -> e - | None -> ExLid (loc, lab) -;; - -let patt_of_lab loc lab = - function - Some p -> p - | None -> PaLid (loc, lab) -;; - -let paolab loc lab peoo = - let lab = - match lab, peoo with - "", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i - | "", _ -> error loc "bad ast" - | _ -> lab - in - let (p, eo) = - match peoo with - Some peo -> peo - | None -> PaLid (loc, lab), None - in - lab, p, eo -;; - -let rec same_type_expr ct ce = - match ct, ce with - TyLid (_, s1), ExLid (_, s2) -> s1 = s2 - | TyUid (_, s1), ExUid (_, s2) -> s1 = s2 - | TyAcc (_, t1, t2), ExAcc (_, e1, e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> false -;; - -let rec common_id loc t e = - match t, e with - TyLid (_, s1), ExLid (_, s2) when s1 = s2 -> lident s1 - | TyUid (_, s1), ExUid (_, s2) when s1 = s2 -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)), ExAcc (_, e1, ExLid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | TyAcc (_, t1, TyUid (_, s1)), ExAcc (_, e1, ExUid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" -;; - -let rec type_id loc t = - match t with - TyLid (_, s1) -> lident s1 - | TyUid (_, s1) -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)) -> ldot (type_id loc t1) s1 - | TyAcc (_, t1, TyUid (_, s1)) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" -;; - -let rec module_type_long_id = - function - MtAcc (_, m, MtUid (_, s)) -> ldot (module_type_long_id m) s - | MtAcc (_, m, MtLid (_, s)) -> ldot (module_type_long_id m) s - | MtApp (_, m1, m2) -> - Lapply (module_type_long_id m1, module_type_long_id m2) - | MtLid (_, s) -> lident s - | MtUid (_, s) -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" -;; - -let rec module_expr_long_id = - function - MeAcc (_, m, MeUid (_, s)) -> ldot (module_expr_long_id m) s - | MeUid (_, s) -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" -;; - -let mkwithc = - function - WcTyp (loc, id, tpl, ct) -> - let (params, variance) = List.split tpl in - long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; ptype_kind = Ptype_abstract; - ptype_manifest = Some (ctyp ct); ptype_loc = mkloc loc; - ptype_variance = variance} - | WcMod (loc, id, m) -> - long_id_of_string_list loc id, Pwith_module (module_expr_long_id m) -;; - -let rec patt_fa al = - function - PaApp (_, f, a) -> patt_fa (a :: al) f - | f -> f, al -;; - -let rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec patt_long_id il = - function - PaAcc (_, p, PaUid (_, i)) -> patt_long_id (i :: il) p - | p -> p, il -;; - -let rec patt_label_long_id = - function - PaAcc (_, m, PaLid (_, s)) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc (_, m, PaUid (_, s)) -> ldot (patt_label_long_id m) s - | PaUid (_, s) -> lident s - | PaLid (_, s) -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" -;; - -let rec patt = - function - PaAcc (loc, p1, p2) -> - let p = - match patt_long_id [] p1 with - PaUid (_, i), il -> - begin match p2 with - PaUid (_, s) -> - Ppat_construct - (mkli (conv_con s) (i :: il), None, - not !no_constructors_arity) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" - end - | _ -> error (loc_of_patt p2) "bad pattern" - in - mkpat loc p - | PaAli (loc, p1, p2) -> - let (p, i) = - match p1, p2 with - p, PaLid (_, s) -> p, s - | PaLid (_, s), p -> p, s - | _ -> error loc "incorrect alias pattern" - in - mkpat loc (Ppat_alias (patt p, i)) - | PaAnt (_, p) -> patt p - | PaAny loc -> mkpat loc Ppat_any - | PaApp (loc, _, _) as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - begin match (patt f).ppat_desc with - Ppat_construct (li, None, _) -> - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc (Ppat_construct (li, Some a, false)) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct (li, Some a, true)) - | Ppat_variant (s, None) -> - let a = - match al with - [a] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc (Ppat_variant (s, Some a)) - | _ -> - error (loc_of_patt f) - "this is not a constructor, it cannot be applied in a pattern" - end - | PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr (loc, s) -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt (loc, s) -> mkpat loc (Ppat_constant (Const_int (int_of_string s))) - | PaInt32 (loc, s) -> - mkpat loc (Ppat_constant (Const_int32 (Int32.of_string s))) - | PaInt64 (loc, s) -> - mkpat loc (Ppat_constant (Const_int64 (Int64.of_string s))) - | PaNativeInt (loc, s) -> - mkpat loc (Ppat_constant (Const_nativeint (Nativeint.of_string s))) - | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaLid (loc, s) -> mkpat loc (Ppat_var s) - | PaOlb (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2)) - | PaRng (loc, p1, p2) -> - begin match p1, p2 with - PaChr (loc1, c1), PaChr (loc2, c2) -> - let c1 = char_of_char_token loc1 c1 in - let c2 = char_of_char_token loc2 c2 in mkrangepat loc c1 c2 - | _ -> error loc "range pattern allowed only for characters" - end - | PaRec (loc, lpl) -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr (loc, s) -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t)) - | PaTyp (loc, sl) -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid (loc, s) -> - let ca = not !no_constructors_arity in - mkpat loc (Ppat_construct (lident (conv_con s), None, ca)) - | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) -and mklabpat (lab, p) = patt_label_long_id lab, patt p;; - -let rec expr_fa al = - function - ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec class_expr_fa al = - function - CeApp (_, ce, a) -> class_expr_fa (a :: al) ce - | ce -> ce, al -;; - -let rec sep_expr_acc l = - function - ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 - | ExUid ((bp, _ as loc), s) as e -> - begin match l with - [] -> [loc, [], e] - | ((_, ep), sl, e) :: l -> ((bp, ep), s :: sl, e) :: l - end - | e -> (loc_of_expr e, [], e) :: l -;; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -let class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = params, mkloc (fst ci.ciPrm); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -let rec expr = - function - ExAcc (loc, x, ExLid (_, "val")) -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!")), ["", expr x])) - | ExAcc (loc, _, _) as e -> - let (e, l) = - match sep_expr_acc [] e with - (loc, ml, ExUid (_, s)) :: l -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (mkli s ml, None, ca)), l - | (loc, ml, ExLid (_, s)) :: l -> - mkexp loc (Pexp_ident (mkli s ml)), l - | (_, [], e) :: l -> expr e, l - | _ -> error loc "bad ast" - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - ExLid (_, s) -> - let loc = bp, ep in - loc, mkexp loc (Pexp_field (e1, mkli (conv_lab s) ml)) - | _ -> error (loc_of_expr e2) "lowercase identifier expected") - (loc, e) l - in - e - | ExAnt (_, e) -> expr e - | ExApp (loc, _, _) as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - begin match (expr f).pexp_desc with - Pexp_construct (li, None, _) -> - let al = List.map snd al in - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc (Pexp_construct (li, Some a, false)) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct (li, Some a, true)) - | Pexp_variant (s, None) -> - let al = List.map snd al in - let a = - match al with - [a] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc (Pexp_variant (s, Some a)) - | _ -> mkexp loc (Pexp_apply (expr f, al)) - end - | ExAre (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "get")), - ["", expr e1; "", expr e2])) - | ExArr (loc, el) -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss (loc, e, v) -> - let e = - match e with - ExAcc (loc, x, ExLid (_, "val")) -> - Pexp_apply - (mkexp loc (Pexp_ident (Lident ":=")), ["", expr x; "", expr v]) - | ExAcc (loc, _, _) -> - begin match (expr e).pexp_desc with - Pexp_field (e, lab) -> Pexp_setfield (e, lab, expr v) - | _ -> error loc "bad record access" - end - | ExAre (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "set")), - ["", expr e1; "", expr e2; "", expr v]) - | ExLid (_, lab) -> Pexp_setinstvar (lab, expr v) - | ExSte (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set")), - ["", expr e1; "", expr e2; "", expr v]) - | _ -> error loc "bad left part of assignment" - in - mkexp loc e - | ExAsr (loc, e) -> mkexp loc (Pexp_assert (expr e)) - | ExChr (loc, s) -> - mkexp loc (Pexp_constant (Const_char (char_of_char_token loc s))) - | ExCoe (loc, e, t1, t2) -> - mkexp loc (Pexp_constraint (expr e, option ctyp t1, Some (ctyp t2))) - | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor (loc, i, e1, e2, df, el) -> - let e3 = ExSeq (loc, el) in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3)) - | ExFun (loc, [PaLab (_, lab, po), w, e]) -> - mkexp loc - (Pexp_function - (lab, None, [patt (patt_of_lab loc lab po), when_expr e w])) - | ExFun (loc, [PaOlb (_, lab, peoo), w, e]) -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w])) - | ExFun (loc, pel) -> - mkexp loc (Pexp_function ("", None, List.map mkpwe pel)) - | ExIfe (loc, e1, e2, e3) -> - mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3))) - | ExInt (loc, s) -> mkexp loc (Pexp_constant (Const_int (int_of_string s))) - | ExInt32 (loc, s) -> - mkexp loc (Pexp_constant (Const_int32 (Int32.of_string s))) - | ExInt64 (loc, s) -> - mkexp loc (Pexp_constant (Const_int64 (Int64.of_string s))) - | ExNativeInt (loc, s) -> - mkexp loc (Pexp_constant (Const_nativeint (Nativeint.of_string s))) - | ExLab (loc, _, _) -> error loc "labeled expression not allowed here" - | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) - | ExLet (loc, rf, pel, e) -> - mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e)) - | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s)) - | ExLmd (loc, i, me, e) -> - mkexp loc (Pexp_letmodule (i, module_expr me, expr e)) - | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel)) - | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" - | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec (loc, lel, eo) -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - Some e -> Some (expr e) - | None -> None - in - mkexp loc (Pexp_record (List.map mklabexp lel, eo)) - | ExSeq (loc, el) -> - let rec loop = - function - [] -> expr (ExUid (loc, "()")) - | [e] -> expr e - | e :: el -> - let loc = fst (loc_of_expr e), snd loc in - mkexp loc (Pexp_sequence (expr e, loop el)) - in - loop el - | ExSnd (loc, e, s) -> mkexp loc (Pexp_send (expr e, s)) - | ExSte (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "get")), - ["", expr e1; "", expr e2])) - | ExStr (loc, s) -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry (loc, e, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe pel)) - | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc (loc, e, t) -> - mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None)) - | ExUid (loc, s) -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (lident (conv_con s), None, ca)) - | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None)) - | ExWhi (loc, e1, el) -> - let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while (expr e1, expr e2)) -and label_expr = - function - ExLab (loc, lab, eo) -> lab, expr (expr_of_lab loc lab eo) - | ExOlb (loc, lab, eo) -> "?" ^ lab, expr (expr_of_lab loc lab eo) - | e -> "", expr e -and mkpe (p, e) = patt p, expr e -and mkpwe (p, w, e) = patt p, when_expr e w -and when_expr e = - function - Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w, expr e)) - | None -> expr e -and mklabexp (lab, e) = patt_label_long_id lab, expr e -and mkideexp (ide, e) = ide, expr e -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = fst (loc_of_ctyp t1), snd (loc_of_ctyp t2) in - ctyp t1, ctyp t2, mkloc loc) - cl - in - c, type_decl tl cl td -and module_type = - function - MtAcc (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun (loc, n, nt, mt) -> - mkmty loc (Pmty_functor (n, module_type nt, module_type mt)) - | MtLid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtQuo (loc, _) -> error loc "abstract module type not allowed here" - | MtSig (loc, sl) -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtWit (loc, mt, wcl) -> - mkmty loc (Pmty_with (module_type mt, List.map mkwithc wcl)) -and sig_item s l = - match s with - SgCls (loc, cd) -> - mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l - | SgClt (loc, ctd) -> - mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: l - | SgDcl (loc, sl) -> List.fold_right sig_item sl l - | SgDir (loc, _, _) -> l - | SgExc (loc, n, tl) -> - mksig loc (Psig_exception (n, List.map ctyp tl)) :: l - | SgExt (loc, n, t, p) -> mksig loc (Psig_value (n, mkvalue_desc t p)) :: l - | SgInc (loc, mt) -> mksig loc (Psig_include (module_type mt)) :: l - | SgMod (loc, n, mt) -> mksig loc (Psig_module (n, module_type mt)) :: l - | SgRecMod (loc, nmts) -> - mksig loc - (Psig_recmodule (List.map (fun (n, mt) -> n, module_type mt) nmts)) :: - l - | SgMty (loc, n, mt) -> - let si = - match mt with - MtQuo (_, _) -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) - in - mksig loc (Psig_modtype (n, si)) :: l - | SgOpn (loc, id) -> - mksig loc (Psig_open (long_id_of_string_list loc id)) :: l - | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l - | SgUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l -and module_expr = - function - MeAcc (loc, _, _) as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp (loc, me1, me2) -> - mkmod loc (Pmod_apply (module_expr me1, module_expr me2)) - | MeFun (loc, n, mt, me) -> - mkmod loc (Pmod_functor (n, module_type mt, module_expr me)) - | MeStr (loc, sl) -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc (loc, me, mt) -> - mkmod loc (Pmod_constraint (module_expr me, module_type mt)) - | MeUid (loc, s) -> mkmod loc (Pmod_ident (lident s)) -and str_item s l = - match s with - StCls (loc, cd) -> - mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l - | StClt (loc, ctd) -> - mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: l - | StDcl (loc, sl) -> List.fold_right str_item sl l - | StDir (loc, _, _) -> l - | StExc (loc, n, tl, sl) -> - let si = - match tl, sl with - tl, [] -> Pstr_exception (n, List.map ctyp tl) - | [], sl -> Pstr_exn_rebind (n, long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" - in - mkstr loc si :: l - | StExp (loc, e) -> mkstr loc (Pstr_eval (expr e)) :: l - | StExt (loc, n, t, p) -> - mkstr loc (Pstr_primitive (n, mkvalue_desc t p)) :: l - | StInc (loc, me) -> mkstr loc (Pstr_include (module_expr me)) :: l - | StMod (loc, n, me) -> mkstr loc (Pstr_module (n, module_expr me)) :: l - | StRecMod (loc, nmes) -> - mkstr loc - (Pstr_recmodule - (List.map (fun (n, mt, me) -> n, module_type mt, module_expr me) - nmes)) :: - l - | StMty (loc, n, mt) -> mkstr loc (Pstr_modtype (n, module_type mt)) :: l - | StOpn (loc, id) -> - mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l - | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l - | StUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal (loc, rf, pel) -> - mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l -and class_type = - function - CtCon (loc, id, tl) -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CtFun (loc, TyLab (_, lab, t), ct) -> - mkcty loc (Pcty_fun (lab, ctyp t, class_type ct)) - | CtFun (loc, TyOlb (loc1, lab, t), ct) -> - let t = TyApp (loc1, TyLid (loc1, "option"), t) in - mkcty loc (Pcty_fun (("?" ^ lab), ctyp t, class_type ct)) - | CtFun (loc, t, ct) -> mkcty loc (Pcty_fun ("", ctyp t, class_type ct)) - | CtSig (loc, t_o, ctfl) -> - let t = - match t_o with - Some t -> t - | None -> TyAny loc - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) -and class_sig_item c l = - match c with - CgCtr (loc, t1, t2) -> Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CgDcl (loc, cl) -> List.fold_right class_sig_item cl l - | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l - | CgMth (loc, s, pf, t) -> - Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l - | CgVal (loc, s, b, t) -> - Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l - | CgVir (loc, s, b, t) -> - Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -and class_expr = - function - CeApp (loc, _, _) as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce, el)) - | CeCon (loc, id, tl) -> - mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CeFun (loc, PaLab (_, lab, po), ce) -> - mkpcl loc - (Pcl_fun (lab, None, patt (patt_of_lab loc lab po), class_expr ce)) - | CeFun (loc, PaOlb (_, lab, peoo), ce) -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc (Pcl_fun (("?" ^ lab), option expr eo, patt p, class_expr ce)) - | CeFun (loc, p, ce) -> - mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce)) - | CeLet (loc, rf, pel, ce) -> - mkpcl loc (Pcl_let (mkrf rf, List.map mkpe pel, class_expr ce)) - | CeStr (loc, po, cfl) -> - let p = - match po with - Some p -> p - | None -> PaAny loc - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc (loc, ce, ct) -> - mkpcl loc (Pcl_constraint (class_expr ce, class_type ct)) -and class_str_item c l = - match c with - CrCtr (loc, t1, t2) -> Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CrDcl (loc, cl) -> List.fold_right class_str_item cl l - | CrInh (loc, ce, pb) -> Pcf_inher (class_expr ce, pb) :: l - | CrIni (loc, e) -> Pcf_init (expr e) :: l - | CrMth (loc, s, b, e, t) -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e, t)) in - Pcf_meth (s, mkprivate b, e, mkloc loc) :: l - | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l - | CrVir (loc, s, b, t) -> - Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -;; - -let interf ast = List.fold_right sig_item ast [];; -let implem ast = List.fold_right str_item ast [];; - -let directive loc = - function - None -> Pdir_none - | Some (ExStr (_, s)) -> Pdir_string s - | Some (ExInt (_, i)) -> Pdir_int (int_of_string i) - | Some (ExUid (_, "True")) -> Pdir_bool true - | Some (ExUid (_, "False")) -> Pdir_bool false - | Some e -> - let sl = - let rec loop = - function - ExLid (_, i) | ExUid (_, i) -> [i] - | ExAcc (_, e, ExLid (_, i)) | ExAcc (_, e, ExUid (_, i)) -> - loop e @ [i] - | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast") - in - loop e - in - Pdir_ident (long_id_of_string_list loc sl) -;; - -let phrase = - function - StDir (loc, d, dp) -> Ptop_dir (d, directive loc dp) - | si -> Ptop_def (str_item si []) -;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.mli b/camlp4/ocaml_src/camlp4/ast2pt.mli deleted file mode 100644 index d64fb6e370..0000000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val fast : bool ref;; -val no_constructors_arity : bool ref;; -val mkloc : int * int -> Location.t;; -val long_id_of_string_list : int * int -> string list -> Longident.t;; - -val str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;; -val interf : MLast.sig_item list -> Parsetree.signature;; -val implem : MLast.str_item list -> Parsetree.structure;; -val phrase : MLast.str_item -> Parsetree.toplevel_phrase;; diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli deleted file mode 100644 index 54a66b9c65..0000000000 --- a/camlp4/ocaml_src/camlp4/mLast.mli +++ /dev/null @@ -1,211 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = int * int;; - -type ctyp = - TyAcc of loc * ctyp * ctyp - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * string list - | TyLab of loc * string * ctyp - | TyLid of loc * string - | TyMan of loc * ctyp * ctyp - | TyObj of loc * (string * ctyp) list * bool - | TyOlb of loc * string * ctyp - | TyPol of loc * string list * ctyp - | TyQuo of loc * string - | TyRec of loc * bool * (loc * string * bool * ctyp) list - | TySum of loc * bool * (loc * string * ctyp list) list - | TyTup of loc * ctyp list - | TyUid of loc * string - | TyVrn of loc * row_field list * string list option option -and row_field = - RfTag of string * bool * ctyp list - | RfInh of ctyp -;; - -type 'a class_infos = - { ciLoc : loc; - ciVir : bool; - ciPrm : loc * (string * (bool * bool)) list; - ciNam : string; - ciExp : 'a } -;; - -type patt = - PaAcc of loc * patt * patt - | PaAli of loc * patt * patt - | PaAnt of loc * patt - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt list - | PaChr of loc * string - | PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt option - | PaLid of loc * string - | PaOlb of loc * string * (patt * expr option) option - | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * (patt * patt) list - | PaStr of loc * string - | PaTup of loc * patt list - | PaTyc of loc * patt * ctyp - | PaTyp of loc * string list - | PaUid of loc * string - | PaVrn of loc * string -and expr = - ExAcc of loc * expr * expr - | ExAnt of loc * expr - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr list - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp option * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * bool * expr list - | ExFun of loc * (patt * expr option * expr) list - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr option - | ExLaz of loc * expr - | ExLet of loc * bool * (patt * expr) list * expr - | ExLid of loc * string - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * (patt * expr option * expr) list - | ExNew of loc * string list - | ExOlb of loc * string * expr option - | ExOvr of loc * (string * expr) list - | ExRec of loc * (patt * expr) list * expr option - | ExSeq of loc * expr list - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * (patt * expr option * expr) list - | ExTup of loc * expr list - | ExTyc of loc * expr * ctyp - | ExUid of loc * string - | ExVrn of loc * string - | ExWhi of loc * expr * expr list -and module_type = - MtAcc of loc * module_type * module_type - | MtApp of loc * module_type * module_type - | MtFun of loc * string * module_type * module_type - | MtLid of loc * string - | MtQuo of loc * string - | MtSig of loc * sig_item list - | MtUid of loc * string - | MtWit of loc * module_type * with_constr list -and sig_item = - SgCls of loc * class_type class_infos list - | SgClt of loc * class_type class_infos list - | SgDcl of loc * sig_item list - | SgDir of loc * string * expr option - | SgExc of loc * string * ctyp list - | SgExt of loc * string * ctyp * string list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * (string * module_type) list - | SgMty of loc * string * module_type - | SgOpn of loc * string list - | SgTyp of loc * type_decl list - | SgUse of loc * string * (sig_item * loc) list - | SgVal of loc * string * ctyp -and with_constr = - WcTyp of loc * string list * (string * (bool * bool)) list * ctyp - | WcMod of loc * string list * module_expr -and module_expr = - MeAcc of loc * module_expr * module_expr - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item list - | MeTyc of loc * module_expr * module_type - | MeUid of loc * string -and str_item = - StCls of loc * class_expr class_infos list - | StClt of loc * class_type class_infos list - | StDcl of loc * str_item list - | StDir of loc * string * expr option - | StExc of loc * string * ctyp list * string list - | StExp of loc * expr - | StExt of loc * string * ctyp * string list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * (string * module_type * module_expr) list - | StMty of loc * string * module_type - | StOpn of loc * string list - | StTyp of loc * type_decl list - | StUse of loc * string * (str_item * loc) list - | StVal of loc * bool * (patt * expr) list -and type_decl = - (loc * string) * (string * (bool * bool)) list * ctyp * (ctyp * ctyp) list -and class_type = - CtCon of loc * string list * ctyp list - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp option * class_sig_item list -and class_sig_item = - CgCtr of loc * ctyp * ctyp - | CgDcl of loc * class_sig_item list - | CgInh of loc * class_type - | CgMth of loc * string * bool * ctyp - | CgVal of loc * string * bool * ctyp - | CgVir of loc * string * bool * ctyp -and class_expr = - CeApp of loc * class_expr * expr - | CeCon of loc * string list * ctyp list - | CeFun of loc * patt * class_expr - | CeLet of loc * bool * (patt * expr) list * class_expr - | CeStr of loc * patt option * class_str_item list - | CeTyc of loc * class_expr * class_type -and class_str_item = - CrCtr of loc * ctyp * ctyp - | CrDcl of loc * class_str_item list - | CrInh of loc * class_expr * string option - | CrIni of loc * expr - | CrMth of loc * string * bool * expr * ctyp option - | CrVal of loc * string * bool * expr - | CrVir of loc * string * bool * ctyp -;; - -external loc_of_ctyp : ctyp -> loc = "%field0";; -external loc_of_patt : patt -> loc = "%field0";; -external loc_of_expr : expr -> loc = "%field0";; -external loc_of_module_type : module_type -> loc = "%field0";; -external loc_of_module_expr : module_expr -> loc = "%field0";; -external loc_of_sig_item : sig_item -> loc = "%field0";; -external loc_of_str_item : str_item -> loc = "%field0";; - -external loc_of_class_type : class_type -> loc = "%field0";; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0";; -external loc_of_class_expr : class_expr -> loc = "%field0";; -external loc_of_class_str_item : class_str_item -> loc = "%field0";; diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml deleted file mode 100644 index 7258fa070e..0000000000 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ /dev/null @@ -1,464 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let version = Sys.ocaml_version;; - -let syntax_name = ref "";; - -let gram = - Grammar.gcreate - {Token.tok_func = (fun _ -> failwith "no loaded parsing module"); - Token.tok_using = (fun _ -> ()); Token.tok_removing = (fun _ -> ()); - Token.tok_match = (fun _ -> raise (Match_failure ("pcaml.ml", 23, 23))); - Token.tok_text = (fun _ -> ""); Token.tok_comm = None} -;; - -let interf = Grammar.Entry.create gram "interf";; -let implem = Grammar.Entry.create gram "implem";; -let top_phrase = Grammar.Entry.create gram "top_phrase";; -let use_file = Grammar.Entry.create gram "use_file";; -let sig_item = Grammar.Entry.create gram "sig_item";; -let str_item = Grammar.Entry.create gram "str_item";; -let module_type = Grammar.Entry.create gram "module_type";; -let module_expr = Grammar.Entry.create gram "module_expr";; -let expr = Grammar.Entry.create gram "expr";; -let patt = Grammar.Entry.create gram "patt";; -let ctyp = Grammar.Entry.create gram "type";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; - -let class_sig_item = Grammar.Entry.create gram "class_sig_item";; -let class_str_item = Grammar.Entry.create gram "class_str_item";; -let class_type = Grammar.Entry.create gram "class_type";; -let class_expr = Grammar.Entry.create gram "class_expr";; - -let parse_interf = ref (Grammar.Entry.parse interf);; -let parse_implem = ref (Grammar.Entry.parse implem);; - -let rec skip_to_eol cs = - match Stream.peek cs with - Some '\n' -> () - | Some c -> Stream.junk cs; skip_to_eol cs - | _ -> () -;; -let sync = ref skip_to_eol;; - -let input_file = ref "";; -let output_file = ref None;; - -let warning_default_function (bp, ep) txt = - Printf.eprintf "<W> loc %d %d: %s\n" bp ep txt; flush stderr -;; - -let warning = ref warning_default_function;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -List.iter (fun (n, f) -> Quotation.add n f) - ["id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$"); - "string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\"")];; - -let quotation_dump_file = ref (None : string option);; - -type err_ctx = - Finding - | Expanding - | ParsingResult of (int * int) * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -let expand_quotation loc expander shift name str = - let new_warning = - let warn = !warning in - fun (bp, ep) txt -> warn (shift + bp, shift + ep) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - Stdpp.Exc_located ((p1, p2), exc) -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) - | exc -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located (loc, exc1))) -;; - -let parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located (iloc, (Qerror (_, Locating, _) as exc)) -> - raise (Stdpp.Exc_located ((shift + fst iloc, shift + snd iloc), exc)) - | Stdpp.Exc_located (iloc, Qerror (_, Expanding, exc)) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) - | Stdpp.Exc_located (_, (Qerror (_, _, _) as exc)) -> - raise (Stdpp.Exc_located (loc, exc)) - | Stdpp.Exc_located (iloc, exc) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) -;; - -let handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" - in - let shift = fst loc + shift in - let expander = - try Quotation.find name with - exc -> - let exc1 = Qerror (name, Finding, exc) in - let loc = fst loc, shift in raise (Stdpp.Exc_located (loc, exc1)) - in - let ast = - match expander with - Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str - in - reloc (fun _ -> loc) shift ast -;; - -let parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located ((p1, p2), exc) -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry, ctx, exc) in - raise (Stdpp.Exc_located ((shift + p1, shift + p2), exc1)) -;; - -let handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = pos, pos + String.length s in - let x = parse_locate entry (fst loc) s in ast_f loc x -;; - -let expr_anti loc e = MLast.ExAnt (loc, e);; -let patt_anti loc p = MLast.PaAnt (loc, p);; -let expr_eoi = Grammar.Entry.create gram "expression";; -let patt_eoi = Grammar.Entry.create gram "pattern";; -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]; - Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]];; - -let handle_expr_quotation loc x = - handle_quotation loc fst true expr_eoi Reloc.expr x -;; - -let handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x;; - -let handle_patt_quotation loc x = - handle_quotation loc snd false patt_eoi Reloc.patt x -;; - -let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;; - -let expr_reloc = Reloc.expr;; -let patt_reloc = Reloc.patt;; - -let rename_id = ref (fun x -> x);; - -let find_line (bp, ep) str = - let rec find i line col = - if i == String.length str then line, 0, col - else if i == bp then line, col, col + ep - bp - else if str.[i] == '\n' then find (succ i) (succ line) 0 - else find (succ i) line (succ col) - in - find 0 1 0 -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let report_quotation_error name ctx = - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult (_, _) -> "parsing result of quotation" - | Locating -> "parsing") - name; - match ctx with - ParsingResult ((bp, ep), str) -> - begin match !quotation_dump_file with - Some dump_file -> - Printf.eprintf " dumping result...\n"; - flush stderr; - begin try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - with - _ -> - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - end - | None -> - if !input_file = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - end - | _ -> Printf.eprintf "\n"; flush stderr -;; - -let print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - '\n' -> - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - | ' ' -> flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - | _ -> loop ini (cnt + 1) - in - Format.open_box 2; loop 0 0; Format.close_box () -;; - -let print_file_failed file line char = - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char -;; - -let print_exn = - function - Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - Format.print_string "Assertion failed"; print_file_failed file line char - | Match_failure (file, line, char) -> - Format.print_string "Pattern matching failed"; - print_file_failed file line char - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - Format.print_string "Lexing error: "; Format.print_string str - | Failure str -> Format.print_string "Failure: "; Format.print_string str - | Invalid_argument str -> - Format.print_string "Invalid argument: "; Format.print_string str - | Sys_error msg -> - Format.print_string "I/O error: "; Format.print_string msg - | x -> - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then - begin - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do - if i > 1 then Format.print_string ", "; - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then - begin - Format.print_char '\"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '\"' - end - else Format.print_char '_' - done; - Format.print_char ')' - end -;; - -let report_error exn = - match exn with - Qerror (name, Finding, Not_found) -> - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - | Qerror (name, ctx, exn) -> report_quotation_error name ctx; print_exn exn - | e -> print_exn exn -;; - -let no_constructors_arity = Ast2pt.no_constructors_arity;; -(*value no_assert = ref False;*) - -let arg_spec_list_ref = ref [];; -let arg_spec_list () = !arg_spec_list_ref;; -let add_option name spec descr = - arg_spec_list_ref := !arg_spec_list_ref @ [name, spec, descr] -;; - -(* Printers *) - -open Spretty;; - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -let pr_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 385, 30))); - pr_levels = []} -;; -let pr_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 386, 30))); - pr_levels = []} -;; -let pr_module_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 387, 33))); - pr_levels = []} -;; -let pr_module_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 388, 33))); - pr_levels = []} -;; -let pr_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 389, 26))); - pr_levels = []} -;; -let pr_patt = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 390, 26))); - pr_levels = []} -;; -let pr_ctyp = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 391, 26))); - pr_levels = []} -;; -let pr_class_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 392, 36))); - pr_levels = []} -;; -let pr_class_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 393, 36))); - pr_levels = []} -;; -let pr_class_type = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 394, 32))); - pr_levels = []} -;; -let pr_class_expr = - {pr_fun = (fun _ -> raise (Match_failure ("pcaml.ml", 395, 32))); - pr_levels = []} -;; -let pr_expr_fun_args = ref Extfun.empty;; - -let pr_fun name pr lab = - let rec loop app = - function - [] -> (fun x dg k -> failwith ("unable to print " ^ name)) - | lev :: levl -> - if app || lev.pr_label = lab then - let next = loop true levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl - in - loop false pr.pr_levels -;; - -pr_str_item.pr_fun <- pr_fun "str_item" pr_str_item;; -pr_sig_item.pr_fun <- pr_fun "sig_item" pr_sig_item;; -pr_module_type.pr_fun <- pr_fun "module_type" pr_module_type;; -pr_module_expr.pr_fun <- pr_fun "module_expr" pr_module_expr;; -pr_expr.pr_fun <- pr_fun "expr" pr_expr;; -pr_patt.pr_fun <- pr_fun "patt" pr_patt;; -pr_ctyp.pr_fun <- pr_fun "ctyp" pr_ctyp;; -pr_class_sig_item.pr_fun <- pr_fun "class_sig_item" pr_class_sig_item;; -pr_class_str_item.pr_fun <- pr_fun "class_str_item" pr_class_str_item;; -pr_class_type.pr_fun <- pr_fun "class_type" pr_class_type;; -pr_class_expr.pr_fun <- pr_fun "class_expr" pr_class_expr;; - -let rec find_pr_level lab = - function - [] -> failwith ("level " ^ lab ^ " not found") - | lev :: levl -> if lev.pr_label = lab then lev else find_pr_level lab levl -;; - -let undef x = ref (fun _ -> failwith x);; -let print_interf = undef "no printer";; -let print_implem = undef "no printer";; - -let top_printer pr x = - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 (fun _ _ -> "", 0, 0, 0) 0 - (pr.pr_fun "top" x "" Stream.sempty); - Format.print_string " >>" -;; - -let buff = Buffer.create 73;; -let buffer_char = Buffer.add_char buff;; -let buffer_string = Buffer.add_string buff;; -let buffer_newline () = Buffer.add_char buff '\n';; - -let string_of pr x = - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> "", 0, 0, 0) 0 (pr.pr_fun "top" x "" Stream.sempty); - Buffer.contents buff -;; - -let inter_phrases = ref None;; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli deleted file mode 100644 index 8f8eacaf24..0000000000 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ /dev/null @@ -1,158 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -val syntax_name : string ref;; - -(** {6 Parsers} *) - -val parse_interf : - (char Stream.t -> (MLast.sig_item * MLast.loc) list * bool) ref;; -val parse_implem : - (char Stream.t -> (MLast.str_item * MLast.loc) list * bool) ref;; - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -val gram : Grammar.g;; - (** Grammar variable of the OCaml language *) - -val interf : ((MLast.sig_item * MLast.loc) list * bool) Grammar.Entry.e;; -val implem : ((MLast.str_item * MLast.loc) list * bool) Grammar.Entry.e;; -val top_phrase : MLast.str_item option Grammar.Entry.e;; -val use_file : (MLast.str_item list * bool) Grammar.Entry.e;; -val module_type : MLast.module_type Grammar.Entry.e;; -val module_expr : MLast.module_expr Grammar.Entry.e;; -val sig_item : MLast.sig_item Grammar.Entry.e;; -val str_item : MLast.str_item Grammar.Entry.e;; -val expr : MLast.expr Grammar.Entry.e;; -val patt : MLast.patt Grammar.Entry.e;; -val ctyp : MLast.ctyp Grammar.Entry.e;; -val let_binding : (MLast.patt * MLast.expr) Grammar.Entry.e;; -val type_declaration : MLast.type_decl Grammar.Entry.e;; -val class_sig_item : MLast.class_sig_item Grammar.Entry.e;; -val class_str_item : MLast.class_str_item Grammar.Entry.e;; -val class_expr : MLast.class_expr Grammar.Entry.e;; -val class_type : MLast.class_type Grammar.Entry.e;; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -val input_file : string ref;; - (** The file currently being parsed. *) -val output_file : string option ref;; - (** The output file, stdout if None (default) *) -val report_error : exn -> unit;; - (** Prints an error message, using the module [Format]. *) -val quotation_dump_file : string option ref;; - (** [quotation_dump_file] optionally tells the compiler to dump the - result of an expander if this result is syntactically incorrect. - If [None] (default), this result is not dumped. If [Some fname], the - result is dumped in the file [fname]. *) -val version : string;; - (** The current version of Camlp4. *) -val add_option : string -> Arg.spec -> string -> unit;; - (** Add an option to the command line options. *) -val no_constructors_arity : bool ref;; - (** [True]: dont generate constructor arity. *) -(*value no_assert : ref bool; - (** [True]: dont generate assertion checks. *) -*) - -val sync : (char Stream.t -> unit) ref;; - -val handle_expr_quotation : MLast.loc -> string * string -> MLast.expr;; -val handle_expr_locate : MLast.loc -> int * string -> MLast.expr;; - -val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;; -val handle_patt_locate : MLast.loc -> int * string -> MLast.patt;; - -val expr_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;; -val patt_reloc : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -val rename_id : (string -> string) ref;; - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - Finding - | Expanding - | ParsingResult of (int * int) * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -(** {6 Printers} *) - -open Spretty;; - -val print_interf : ((MLast.sig_item * MLast.loc) list -> unit) ref;; -val print_implem : ((MLast.str_item * MLast.loc) list -> unit) ref;; - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -val pr_sig_item : MLast.sig_item printer_t;; -val pr_str_item : MLast.str_item printer_t;; -val pr_module_type : MLast.module_type printer_t;; -val pr_module_expr : MLast.module_expr printer_t;; -val pr_expr : MLast.expr printer_t;; -val pr_patt : MLast.patt printer_t;; -val pr_ctyp : MLast.ctyp printer_t;; -val pr_class_sig_item : MLast.class_sig_item printer_t;; -val pr_class_str_item : MLast.class_str_item printer_t;; -val pr_class_type : MLast.class_type printer_t;; -val pr_class_expr : MLast.class_expr printer_t;; - -val pr_expr_fun_args : - (MLast.expr, (MLast.patt list * MLast.expr)) Extfun.t ref;; - -val find_pr_level : string -> 'a pr_level list -> 'a pr_level;; - -val top_printer : 'a printer_t -> 'a -> unit;; -val string_of : 'a printer_t -> 'a -> string;; - -val inter_phrases : string option ref;; - -(**/**) - -(* for system use *) - -val warning : (int * int -> string -> unit) ref;; -val expr_eoi : MLast.expr Grammar.Entry.e;; -val patt_eoi : MLast.patt Grammar.Entry.e;; -val arg_spec_list : unit -> (string * Arg.spec * string) list;; diff --git a/camlp4/ocaml_src/camlp4/quotation.ml b/camlp4/ocaml_src/camlp4/quotation.ml deleted file mode 100644 index 07057c968b..0000000000 --- a/camlp4/ocaml_src/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -let expanders_table = ref [];; - -let default = ref "";; -let translate = ref (fun x -> x);; - -let expander_name name = - match !translate name with - "" -> !default - | name -> name -;; - -let find name = List.assoc (expander_name name) !expanders_table;; - -let add name f = expanders_table := (name, f) :: !expanders_table;; diff --git a/camlp4/ocaml_src/camlp4/quotation.mli b/camlp4/ocaml_src/camlp4/quotation.mli deleted file mode 100644 index aba963d705..0000000000 --- a/camlp4/ocaml_src/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Quotation operations. *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -val add : string -> expander -> unit;; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -val find : string -> expander;; - (** [find name] returns the expander of the given quotation name. *) - -val default : string ref;; - (** [default] holds the default quotation name. *) - -val translate : (string -> string) ref;; - (** function translating quotation names; default = identity *) diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml deleted file mode 100644 index 980d6ce786..0000000000 --- a/camlp4/ocaml_src/camlp4/reloc.ml +++ /dev/null @@ -1,337 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open MLast;; - -let option_map f = - function - Some x -> Some (f x) - | None -> None -;; - -let rec ctyp floc sh = - let rec self = - function - TyAcc (loc, x1, x2) -> TyAcc (floc loc, self x1, self x2) - | TyAli (loc, x1, x2) -> TyAli (floc loc, self x1, self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp (loc, x1, x2) -> TyApp (floc loc, self x1, self x2) - | TyArr (loc, x1, x2) -> TyArr (floc loc, self x1, self x2) - | TyCls (loc, x1) -> TyCls (floc loc, x1) - | TyLab (loc, x1, x2) -> TyLab (floc loc, x1, self x2) - | TyLid (loc, x1) -> TyLid (floc loc, x1) - | TyMan (loc, x1, x2) -> TyMan (floc loc, self x1, self x2) - | TyObj (loc, x1, x2) -> - TyObj (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1, x2) - | TyOlb (loc, x1, x2) -> TyOlb (floc loc, x1, self x2) - | TyPol (loc, x1, x2) -> TyPol (floc loc, x1, self x2) - | TyQuo (loc, x1) -> TyQuo (floc loc, x1) - | TyRec (loc, pflag, x1) -> - TyRec - (floc loc, pflag, - List.map (fun (loc, x1, x2, x3) -> floc loc, x1, x2, self x3) x1) - | TySum (loc, pflag, x1) -> - TySum - (floc loc, pflag, - List.map (fun (loc, x1, x2) -> floc loc, x1, List.map self x2) x1) - | TyTup (loc, x1) -> TyTup (floc loc, List.map self x1) - | TyUid (loc, x1) -> TyUid (floc loc, x1) - | TyVrn (loc, x1, x2) -> - TyVrn (floc loc, List.map (row_field floc sh) x1, x2) - in - self -and row_field floc sh = - function - RfTag (x1, x2, x3) -> RfTag (x1, x2, List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) -;; - -let class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = begin let (x1, x2) = x.ciPrm in floc x1, x2 end; ciNam = x.ciNam; - ciExp = a floc sh x.ciExp} -;; - -let rec patt floc sh = - let rec self = - function - PaAcc (loc, x1, x2) -> PaAcc (floc loc, self x1, self x2) - | PaAli (loc, x1, x2) -> PaAli (floc loc, self x1, self x2) - | PaAnt (loc, x1) -> - patt (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1 - | PaAny loc -> PaAny (floc loc) - | PaApp (loc, x1, x2) -> PaApp (floc loc, self x1, self x2) - | PaArr (loc, x1) -> PaArr (floc loc, List.map self x1) - | PaChr (loc, x1) -> PaChr (floc loc, x1) - | PaInt (loc, x1) -> PaInt (floc loc, x1) - | PaInt32 (loc, x1) -> PaInt32 (floc loc, x1) - | PaInt64 (loc, x1) -> PaInt64 (floc loc, x1) - | PaNativeInt (loc, x1) -> PaNativeInt (floc loc, x1) - | PaFlo (loc, x1) -> PaFlo (floc loc, x1) - | PaLab (loc, x1, x2) -> PaLab (floc loc, x1, option_map self x2) - | PaLid (loc, x1) -> PaLid (floc loc, x1) - | PaOlb (loc, x1, x2) -> - PaOlb - (floc loc, x1, - option_map (fun (x1, x2) -> self x1, option_map (expr floc sh) x2) - x2) - | PaOrp (loc, x1, x2) -> PaOrp (floc loc, self x1, self x2) - | PaRng (loc, x1, x2) -> PaRng (floc loc, self x1, self x2) - | PaRec (loc, x1) -> - PaRec (floc loc, List.map (fun (x1, x2) -> self x1, self x2) x1) - | PaStr (loc, x1) -> PaStr (floc loc, x1) - | PaTup (loc, x1) -> PaTup (floc loc, List.map self x1) - | PaTyc (loc, x1, x2) -> PaTyc (floc loc, self x1, ctyp floc sh x2) - | PaTyp (loc, x1) -> PaTyp (floc loc, x1) - | PaUid (loc, x1) -> PaUid (floc loc, x1) - | PaVrn (loc, x1) -> PaVrn (floc loc, x1) - in - self -and expr floc sh = - let rec self = - function - ExAcc (loc, x1, x2) -> ExAcc (floc loc, self x1, self x2) - | ExAnt (loc, x1) -> - expr (fun (p1, p2) -> sh + fst loc + p1, sh + fst loc + p2) 0 x1 - | ExApp (loc, x1, x2) -> ExApp (floc loc, self x1, self x2) - | ExAre (loc, x1, x2) -> ExAre (floc loc, self x1, self x2) - | ExArr (loc, x1) -> ExArr (floc loc, List.map self x1) - | ExAsf loc -> ExAsf (floc loc) - | ExAsr (loc, x1) -> ExAsr (floc loc, self x1) - | ExAss (loc, x1, x2) -> ExAss (floc loc, self x1, self x2) - | ExChr (loc, x1) -> ExChr (floc loc, x1) - | ExCoe (loc, x1, x2, x3) -> - ExCoe - (floc loc, self x1, option_map (ctyp floc sh) x2, ctyp floc sh x3) - | ExFlo (loc, x1) -> ExFlo (floc loc, x1) - | ExFor (loc, x1, x2, x3, x4, x5) -> - ExFor (floc loc, x1, self x2, self x3, x4, List.map self x5) - | ExFun (loc, x1) -> - ExFun - (floc loc, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x1) - | ExIfe (loc, x1, x2, x3) -> ExIfe (floc loc, self x1, self x2, self x3) - | ExInt (loc, x1) -> ExInt (floc loc, x1) - | ExInt32 (loc, x1) -> ExInt32 (floc loc, x1) - | ExInt64 (loc, x1) -> ExInt64 (floc loc, x1) - | ExNativeInt (loc, x1) -> ExNativeInt (floc loc, x1) - | ExLab (loc, x1, x2) -> ExLab (floc loc, x1, option_map self x2) - | ExLaz (loc, x1) -> ExLaz (floc loc, self x1) - | ExLet (loc, x1, x2, x3) -> - ExLet - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, self x2) x2, self x3) - | ExLid (loc, x1) -> ExLid (floc loc, x1) - | ExLmd (loc, x1, x2, x3) -> - ExLmd (floc loc, x1, module_expr floc sh x2, self x3) - | ExMat (loc, x1, x2) -> - ExMat - (floc loc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExNew (loc, x1) -> ExNew (floc loc, x1) - | ExOlb (loc, x1, x2) -> ExOlb (floc loc, x1, option_map self x2) - | ExOvr (loc, x1) -> - ExOvr (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1) - | ExRec (loc, x1, x2) -> - ExRec - (floc loc, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x1, - option_map self x2) - | ExSeq (loc, x1) -> ExSeq (floc loc, List.map self x1) - | ExSnd (loc, x1, x2) -> ExSnd (floc loc, self x1, x2) - | ExSte (loc, x1, x2) -> ExSte (floc loc, self x1, self x2) - | ExStr (loc, x1) -> ExStr (floc loc, x1) - | ExTry (loc, x1, x2) -> - ExTry - (floc loc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExTup (loc, x1) -> ExTup (floc loc, List.map self x1) - | ExTyc (loc, x1, x2) -> ExTyc (floc loc, self x1, ctyp floc sh x2) - | ExUid (loc, x1) -> ExUid (floc loc, x1) - | ExVrn (loc, x1) -> ExVrn (floc loc, x1) - | ExWhi (loc, x1, x2) -> ExWhi (floc loc, self x1, List.map self x2) - in - self -and module_type floc sh = - let rec self = - function - MtAcc (loc, x1, x2) -> MtAcc (floc loc, self x1, self x2) - | MtApp (loc, x1, x2) -> MtApp (floc loc, self x1, self x2) - | MtFun (loc, x1, x2, x3) -> MtFun (floc loc, x1, self x2, self x3) - | MtLid (loc, x1) -> MtLid (floc loc, x1) - | MtQuo (loc, x1) -> MtQuo (floc loc, x1) - | MtSig (loc, x1) -> MtSig (floc loc, List.map (sig_item floc sh) x1) - | MtUid (loc, x1) -> MtUid (floc loc, x1) - | MtWit (loc, x1, x2) -> - MtWit (floc loc, self x1, List.map (with_constr floc sh) x2) - in - self -and sig_item floc sh = - let rec self = - function - SgCls (loc, x1) -> - SgCls (floc loc, List.map (class_infos class_type floc sh) x1) - | SgClt (loc, x1) -> - SgClt (floc loc, List.map (class_infos class_type floc sh) x1) - | SgDcl (loc, x1) -> SgDcl (floc loc, List.map self x1) - | SgDir (loc, x1, x2) -> SgDir (floc loc, x1, x2) - | SgExc (loc, x1, x2) -> SgExc (floc loc, x1, List.map (ctyp floc sh) x2) - | SgExt (loc, x1, x2, x3) -> SgExt (floc loc, x1, ctyp floc sh x2, x3) - | SgInc (loc, x1) -> SgInc (floc loc, module_type floc sh x1) - | SgMod (loc, x1, x2) -> SgMod (floc loc, x1, module_type floc sh x2) - | SgRecMod (loc, xxs) -> - SgRecMod - (floc loc, - List.map (fun (x1, x2) -> x1, module_type floc sh x2) xxs) - | SgMty (loc, x1, x2) -> SgMty (floc loc, x1, module_type floc sh x2) - | SgOpn (loc, x1) -> SgOpn (floc loc, x1) - | SgTyp (loc, x1) -> - SgTyp - (floc loc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2) - | SgVal (loc, x1, x2) -> SgVal (floc loc, x1, ctyp floc sh x2) - in - self -and with_constr floc sh = - let rec self = - function - WcTyp (loc, x1, x2, x3) -> WcTyp (floc loc, x1, x2, ctyp floc sh x3) - | WcMod (loc, x1, x2) -> WcMod (floc loc, x1, module_expr floc sh x2) - in - self -and module_expr floc sh = - let rec self = - function - MeAcc (loc, x1, x2) -> MeAcc (floc loc, self x1, self x2) - | MeApp (loc, x1, x2) -> MeApp (floc loc, self x1, self x2) - | MeFun (loc, x1, x2, x3) -> - MeFun (floc loc, x1, module_type floc sh x2, self x3) - | MeStr (loc, x1) -> MeStr (floc loc, List.map (str_item floc sh) x1) - | MeTyc (loc, x1, x2) -> MeTyc (floc loc, self x1, module_type floc sh x2) - | MeUid (loc, x1) -> MeUid (floc loc, x1) - in - self -and str_item floc sh = - let rec self = - function - StCls (loc, x1) -> - StCls (floc loc, List.map (class_infos class_expr floc sh) x1) - | StClt (loc, x1) -> - StClt (floc loc, List.map (class_infos class_type floc sh) x1) - | StDcl (loc, x1) -> StDcl (floc loc, List.map self x1) - | StDir (loc, x1, x2) -> StDir (floc loc, x1, x2) - | StExc (loc, x1, x2, x3) -> - StExc (floc loc, x1, List.map (ctyp floc sh) x2, x3) - | StExp (loc, x1) -> StExp (floc loc, expr floc sh x1) - | StExt (loc, x1, x2, x3) -> StExt (floc loc, x1, ctyp floc sh x2, x3) - | StInc (loc, x1) -> StInc (floc loc, module_expr floc sh x1) - | StMod (loc, x1, x2) -> StMod (floc loc, x1, module_expr floc sh x2) - | StRecMod (loc, nmtmes) -> - StRecMod - (floc loc, - List.map - (fun (n, mt, me) -> - n, module_type floc sh mt, module_expr floc sh me) - nmtmes) - | StMty (loc, x1, x2) -> StMty (floc loc, x1, module_type floc sh x2) - | StOpn (loc, x1) -> StOpn (floc loc, x1) - | StTyp (loc, x1) -> - StTyp - (floc loc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | StUse (loc, x1, x2) -> StUse (loc, x1, x2) - | StVal (loc, x1, x2) -> - StVal - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2) - in - self -and class_type floc sh = - let rec self = - function - CtCon (loc, x1, x2) -> CtCon (floc loc, x1, List.map (ctyp floc sh) x2) - | CtFun (loc, x1, x2) -> CtFun (floc loc, ctyp floc sh x1, self x2) - | CtSig (loc, x1, x2) -> - CtSig - (floc loc, option_map (ctyp floc sh) x1, - List.map (class_sig_item floc sh) x2) - in - self -and class_sig_item floc sh = - let rec self = - function - CgCtr (loc, x1, x2) -> - CgCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2) - | CgDcl (loc, x1) -> - CgDcl (floc loc, List.map (class_sig_item floc sh) x1) - | CgInh (loc, x1) -> CgInh (floc loc, class_type floc sh x1) - | CgMth (loc, x1, x2, x3) -> CgMth (floc loc, x1, x2, ctyp floc sh x3) - | CgVal (loc, x1, x2, x3) -> CgVal (floc loc, x1, x2, ctyp floc sh x3) - | CgVir (loc, x1, x2, x3) -> CgVir (floc loc, x1, x2, ctyp floc sh x3) - in - self -and class_expr floc sh = - let rec self = - function - CeApp (loc, x1, x2) -> CeApp (floc loc, self x1, expr floc sh x2) - | CeCon (loc, x1, x2) -> CeCon (floc loc, x1, List.map (ctyp floc sh) x2) - | CeFun (loc, x1, x2) -> CeFun (floc loc, patt floc sh x1, self x2) - | CeLet (loc, x1, x2, x3) -> - CeLet - (floc loc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2, - self x3) - | CeStr (loc, x1, x2) -> - CeStr - (floc loc, option_map (patt floc sh) x1, - List.map (class_str_item floc sh) x2) - | CeTyc (loc, x1, x2) -> CeTyc (floc loc, self x1, class_type floc sh x2) - in - self -and class_str_item floc sh = - let rec self = - function - CrCtr (loc, x1, x2) -> - CrCtr (floc loc, ctyp floc sh x1, ctyp floc sh x2) - | CrDcl (loc, x1) -> - CrDcl (floc loc, List.map (class_str_item floc sh) x1) - | CrInh (loc, x1, x2) -> CrInh (floc loc, class_expr floc sh x1, x2) - | CrIni (loc, x1) -> CrIni (floc loc, expr floc sh x1) - | CrMth (loc, x1, x2, x3, x4) -> - CrMth - (floc loc, x1, x2, expr floc sh x3, option_map (ctyp floc sh) x4) - | CrVal (loc, x1, x2, x3) -> CrVal (floc loc, x1, x2, expr floc sh x3) - | CrVir (loc, x1, x2, x3) -> CrVir (floc loc, x1, x2, ctyp floc sh x3) - in - self -;; diff --git a/camlp4/ocaml_src/camlp4/reloc.mli b/camlp4/ocaml_src/camlp4/reloc.mli deleted file mode 100644 index 21018b52af..0000000000 --- a/camlp4/ocaml_src/camlp4/reloc.mli +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val patt : (MLast.loc -> MLast.loc) -> int -> MLast.patt -> MLast.patt;; -val expr : (MLast.loc -> MLast.loc) -> int -> MLast.expr -> MLast.expr;; diff --git a/camlp4/ocaml_src/camlp4/spretty.ml b/camlp4/ocaml_src/camlp4/spretty.ml deleted file mode 100644 index ada592b604..0000000000 --- a/camlp4/ocaml_src/camlp4/spretty.ml +++ /dev/null @@ -1,465 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type prettyL = - SL of int * glue * string - | HL of prettyL list - | BL of prettyL list - | PL of prettyL list - | QL of prettyL list - | VL of prettyL list - | BE of prettyL list - | BV of prettyL list - | LI of (string * int * int) * prettyL -;; -type getcomm = int -> int -> string * int * int * int;; - -let quiet = ref true;; -let maxl = ref 20;; -let dt = ref 2;; -let tol = ref 1;; -let sp = ref ' ';; -let last_ep = ref 0;; -let getcomm = ref (fun _ _ -> "", 0, 0, 0);; -let prompt = ref "";; -let print_char_fun = ref (output_char stdout);; -let print_string_fun = ref (output_string stdout);; -let print_newline_fun = ref (fun () -> output_char stdout '\n');; -let lazy_tab = ref (-1);; - -let flush_tab () = - if !lazy_tab >= 0 then - begin - !print_newline_fun (); - !print_string_fun !prompt; - for i = 1 to !lazy_tab do !print_char_fun !sp done; - lazy_tab := -1 - end -;; -let print_newline_and_tab tab = lazy_tab := tab;; -let print_char c = flush_tab (); !print_char_fun c;; -let print_string s = flush_tab (); !print_string_fun s;; - -let rec print_spaces nsp = for i = 1 to nsp do print_char !sp done;; - -let end_with_tab s = - let rec loop i = - if i >= 0 then if s.[i] = ' ' then loop (i - 1) else s.[i] = '\n' - else false - in - loop (String.length s - 1) -;; - -let print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else - let (tab_aft, i_bef_tab) = - let rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else tab_aft, i - in - loop 0 (String.length s - 1) - in - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - let rec loop i = - if i = len then () - else - begin - !print_char_fun s.[i]; - let i = - if s.[i] = '\n' && (i + 1 = len || s.[i + 1] <> '\n') then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then - begin - for i = 1 to delta_ind do !print_char_fun ' ' done; i + 1 - end - else - let rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - in - loop delta_ind (i + 1) - else i + 1 - in - loop i - end - in - loop 0 -;; - -let string_np pos np = pos + np;; - -let trace_ov pos = - if not !quiet && pos > !maxl then - begin - prerr_string "<W> prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - end -;; - -let tolerate tab pos spc = pos + spc <= tab + !dt + !tol;; - -let h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - print_spaces spc; print_string x; npos -;; - -let n_print_string pos spc np x = - print_spaces spc; print_string x; string_np (pos + spc) np -;; - -let rec hnps (pos, spc as ps) = - function - SL (np, RO, _) -> string_np pos np, 1 - | SL (np, LO, _) -> string_np (pos + spc) np, 0 - | SL (np, NO, _) -> string_np pos np, 0 - | SL (np, LR, _) -> string_np (pos + spc) np, 1 - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> !maxl + 1, 0 - | BE x -> hnps_list ps x - | BV x -> !maxl + 1, 0 - | LI (_, x) -> hnps ps x -and hnps_list (pos, _ as ps) pl = - if pos > !maxl then !maxl + 1, 0 - else - match pl with - p :: pl -> hnps_list (hnps ps p) pl - | [] -> ps -;; - -let rec first = - function - SL (_, _, s) -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI (_, x) -> first x -and first_in_list = - function - p :: pl -> - begin match first p with - Some p -> Some p - | None -> first_in_list pl - end - | [] -> None -;; - -let first_is_too_big tab p = - match first p with - Some s -> tab + String.length s >= !maxl - | None -> false -;; - -let too_long tab x p = - if first_is_too_big tab p then false - else let (pos, spc) = hnps x p in pos > !maxl -;; - -let rec has_comment = - function - LI ((comm, nl_bef, tab_bef), x) :: pl -> - comm <> "" || has_comment (x :: pl) - | (HL x | BL x | PL x | QL x | VL x | BE x | BV x) :: pl -> - has_comment x || has_comment pl - | SL (_, _, _) :: pl -> has_comment pl - | [] -> false -;; - -let rec hprint_pretty tab pos spc = - function - SL (np, RO, x) -> h_print_string pos 0 np x, 1 - | SL (np, LO, x) -> h_print_string pos spc np x, 0 - | SL (np, NO, x) -> h_print_string pos 0 np x, 0 - | SL (np, LR, x) -> h_print_string pos spc np x, 1 - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> pos, spc - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> hprint_box tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; flush_tab () - end; - print_comment tab comm nl_bef tab_bef false; - hprint_pretty tab pos spc x -and hprint_box tab pos spc = - function - p :: pl -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> pos, spc -;; - -let rec print_pretty tab pos spc = - function - SL (np, RO, x) -> n_print_string pos 0 np x, 1 - | SL (np, LO, x) -> n_print_string pos spc np x, 0 - | SL (np, NO, x) -> n_print_string pos 0 np x, 0 - | SL (np, LR, x) -> n_print_string pos spc np x, 1 - | HL x as p -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do !print_char_fun ' ' done - else if comm = "" && x = BL [] then lazy_tab := -1 - else flush_tab () - end; - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab := -1 else flush_tab (); - print_pretty tab pos spc x -and print_horiz tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_horiz tab npos nspc pl - | [] -> pos, spc -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin print_spaces nspc; print_vertic_rest (npos + nspc) pl end - else - begin - print_newline_and_tab (tab + !dt); print_vertic_rest (tab + !dt) pl - end - | [] -> pos, spc -and print_vertic_rest tab = - function - p :: pl -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_vertic_rest tab pl end - | [] -> tab, 0 -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then - begin - print_newline_and_tab (tab + !dt); - print_parag_rest (tab + !dt) (tab + !dt) 0 pl - end - else if tolerate tab npos nspc then - begin - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_parag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_parag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else npos, nspc - in - print_parag_rest tab pos spc pl - | [] -> pos, spc -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin - print_spaces nspc; - print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_sparag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_sparag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_sparag_rest tab npos nspc pl - | [] -> pos, spc -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - let nspc = if npos == tab then nspc + !dt else nspc in - print_spaces nspc; print_beg_end_rest tab (npos + nspc) pl - else - begin - print_newline_and_tab (tab + !dt); - print_beg_end_rest tab (tab + !dt) pl - end - | [] -> pos, spc -and print_beg_end_rest tab pos = - function - p :: pl -> - let (pos, spc) = print_pretty (tab + !dt) pos 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_beg_end_rest tab tab pl end - | [] -> pos, 0 -;; - -let string_npos s = String.length s;; - -let rec conv = - function - S (g, s) -> SL (string_npos s, g, s) - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - begin match conv_stream x with - [PL _ as x] -> x - | x -> PL x - end - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo ((bp, ep), x) -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - !last_ep in - if len > 0 then !getcomm !last_ep len else "", 0, 0, 0 - in - last_ep := !last_ep + cnt; - let v = conv x in - last_ep := max ep !last_ep; LI ((comm, nl_bef, tab_bef), v) -and conv_stream (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some p -> Stream.junk strm__; let x = conv p in x :: conv_stream strm__ - | _ -> [] -;; - -let print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - maxl := m; - print_char_fun := pr_ch; - print_string_fun := pr_str; - print_newline_fun := pr_nl; - prompt := pr2; - getcomm := lf; - last_ep := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in () -;; diff --git a/camlp4/ocaml_src/camlp4/spretty.mli b/camlp4/ocaml_src/camlp4/spretty.mli deleted file mode 100644 index 5c62d3f6cd..0000000000 --- a/camlp4/ocaml_src/camlp4/spretty.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type getcomm = int -> int -> string * int * int * int;; - -val print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> string -> string -> - int -> getcomm -> int -> pretty -> unit;; -val quiet : bool ref;; - -val dt : int ref;; - -(*--*) - -val tol : int ref;; -val sp : char ref;; diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend deleted file mode 100644 index 0d5adc691f..0000000000 --- a/camlp4/ocaml_src/lib/.depend +++ /dev/null @@ -1,20 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: gramext.cmi token.cmi -plexer.cmi: token.cmi -extfold.cmo: gramext.cmi grammar.cmi extfold.cmi -extfold.cmx: gramext.cmx grammar.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi -plexer.cmo: stdpp.cmi token.cmi plexer.cmi -plexer.cmx: stdpp.cmx token.cmx plexer.cmi -stdpp.cmo: stdpp.cmi -stdpp.cmx: stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile deleted file mode 100644 index e19e52052b..0000000000 --- a/camlp4/ocaml_src/lib/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -all: $(TARGET) -opt: $(TARGET:.cma=.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi "$(LIBDIR)/camlp4/." - if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi - -installopt: - cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/." - tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -) - -include .depend diff --git a/camlp4/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac deleted file mode 100644 index 2fc15c630d..0000000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac +++ /dev/null @@ -1,46 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -OCAMLCFLAGS = {INCLUDES} -OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo -INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi -TARGETS = gramlib.cma - -all Ä {TARGETS} - -{TARGETS} Ä {OBJS} - {OCAMLC} {OBJS} -a -o {TARGETS} - -steal Ä - -compare_stolen Ä - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -promote Ä - duplicate -y {OBJS} {INTF} :::boot: - -compare Ä - for i in {OBJS} {INTF} - equal -s :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/lib/Makefile.Mac.depend b/camlp4/ocaml_src/lib/Makefile.Mac.depend deleted file mode 100644 index 8d12e3e08a..0000000000 --- a/camlp4/ocaml_src/lib/Makefile.Mac.depend +++ /dev/null @@ -1,13 +0,0 @@ -gramext.cmoÄ token.cmi gramext.cmi -gramext.cmxÄ token.cmx gramext.cmi -gramext.cmiÄ token.cmi -grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi -grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi -grammar.cmiÄ gramext.cmi token.cmi -plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi -plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi -plexer.cmiÄ token.cmi -stdpp.cmoÄ stdpp.cmi -stdpp.cmxÄ stdpp.cmi -token.cmoÄ token.cmi -token.cmxÄ token.cmi diff --git a/camlp4/ocaml_src/lib/extfold.ml b/camlp4/ocaml_src/lib/extfold.ml deleted file mode 100644 index 0411497f02..0000000000 --- a/camlp4/ocaml_src/lib/extfold.ml +++ /dev/null @@ -1,124 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -let gen_fold0 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> let a = fold e strm__ in final a -;; - -let gen_fold1 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in - let a = - try fold (f a e) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - final a -;; - -let gen_fold0sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try psymb strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> final (kont (f a e) strm__) - | _ -> e -;; - -let gen_fold1sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let parse_top = - function - [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try - try psymb strm__ with - Stream.Failure -> - let a = - try parse_top symbl strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - Obj.magic a - with - Stream.Failure -> raise (Stream.Error "") - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in final (kont (f a e) strm__) -;; - -let sfold0 f e = gen_fold0 (fun x -> x) f e;; -let sfold1 f e = gen_fold1 (fun x -> x) f e;; -let sfold0sep f e = gen_fold0sep (fun x -> x) f e;; -let sfold1sep f e = gen_fold1sep (fun x -> x) f e;; - -let cons x y = x :: y;; -let nil = [];; - -let slist0 entry = gen_fold0 List.rev cons nil entry;; -let slist1 entry = gen_fold1 List.rev cons nil entry;; -let slist0sep entry = gen_fold0sep List.rev cons nil entry;; -let slist1sep entry = gen_fold1sep List.rev cons nil entry;; - -let sopt entry symbl psymb (strm__ : _ Stream.t) = - try Some (psymb strm__) with - Stream.Failure -> None -;; diff --git a/camlp4/ocaml_src/lib/extfold.mli b/camlp4/ocaml_src/lib/extfold.mli deleted file mode 100644 index cb2824fb1d..0000000000 --- a/camlp4/ocaml_src/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; -val sfold1sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; - -val slist0 : (_, 'a, 'a list) t;; -val slist1 : (_, 'a, 'a list) t;; -val slist0sep : (_, 'a, 'a list) tsep;; -val slist1sep : (_, 'a, 'a list) tsep;; - -val sopt : (_, 'a, 'a option) t;; diff --git a/camlp4/ocaml_src/lib/extfun.ml b/camlp4/ocaml_src/lib/extfun.ml deleted file mode 100644 index f8a6b26ac5..0000000000 --- a/camlp4/ocaml_src/lib/extfun.ml +++ /dev/null @@ -1,105 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type ('a, 'b) t = ('a, 'b) matching list -and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -exception Failure;; - -let empty = [];; - -(*** Apply ***) - -let rec apply_matchings a = - function - m :: ml -> - begin match m.expr a with - None -> apply_matchings a ml - | x -> x - end - | [] -> None -;; - -let apply ef a = - match apply_matchings a ef with - Some x -> x - | None -> raise Failure -;; - -(*** Trace ***) - -let rec list_iter_sep f s = - function - [] -> () - | [x] -> f x - | x :: l -> f x; s (); list_iter_sep f s l -;; - -let rec print_patt = - function - Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p -and print_patt2 = - function - Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p -and print_patt1 = - function - Econ s -> print_string s - | Estr s -> print_string "\""; print_string s; print_string "\"" - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - | Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")" -;; - -let print ef = - List.iter - (fun m -> - print_patt m.patt; - if m.has_when then print_string " when ..."; - print_newline ()) - ef -;; - -(*** Extension ***) - -let insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - function - m :: ml as gml -> - if m1.has_when && not m.has_when then m1 :: gml - else if not m1.has_when && m.has_when then m :: loop ml - else - let c = compare m1.patt m.patt in - if c < 0 then m1 :: gml - else if c > 0 then m :: loop ml - else if m.has_when then m1 :: gml - else m1 :: ml - | [] -> [m1] - in - loop matchings -;; - -(* available extension function *) - -let extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -;; diff --git a/camlp4/ocaml_src/lib/extfun.mli b/camlp4/ocaml_src/lib/extfun.mli deleted file mode 100644 index 2d42fe2e84..0000000000 --- a/camlp4/ocaml_src/lib/extfun.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type ('a, 'b) t;; - (** The type of the extensible functions of type ['a -> 'b] *) -val empty : ('a, 'b) t;; - (** Empty extensible function *) -val apply : ('a, 'b) t -> 'a -> 'b;; - (** Apply an extensible function *) -exception Failure;; - (** Match failure while applying an extensible function *) -val print : ('a, 'b) t -> unit;; - (** Print patterns in the order they are recorded *) - -(**/**) - -type ('a, 'b) matching = - { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -val extend : ('a, 'b) t -> (patt * bool * ('a, 'b) expr) list -> ('a, 'b) t;; diff --git a/camlp4/ocaml_src/lib/fstream.ml b/camlp4/ocaml_src/lib/fstream.ml deleted file mode 100644 index 9ffdb71041..0000000000 --- a/camlp4/ocaml_src/lib/fstream.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -type 'a t = { count : int; data : 'a data Lazy.t } -and 'a data = - Nil - | Cons of 'a * 'a t - | App of 'a t * 'a t -;; - -let from f = - let rec loop i = - {count = 0; - data = - lazy - (match f i with - Some x -> Cons (x, loop (i + 1)) - | None -> Nil)} - in - loop 0 -;; - -let rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - Nil -> None - | Cons (a, s) -> Some (a, {count = count; data = s.data}) - | App (s1, s2) -> - match next s1 with - Some (a, s1) -> Some (a, {count = count; data = lazy (App (s1, s2))}) - | None -> - match next s2 with - Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None -;; - -let empty s = - match next s with - Some _ -> None - | None -> Some ((), s) -;; - -let nil = {count = 0; data = lazy Nil};; -let cons a s = Cons (a, s);; -let app s1 s2 = App (s1, s2);; -let flazy f = {count = 0; data = Lazy.lazy_from_fun f};; - -let of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -;; - -let of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -;; - -let of_channel ic = - from - (fun _ -> - try Some (input_char ic) with - End_of_file -> None) -;; - -let iter f = - let rec do_rec strm = - match next strm with - Some (a, strm) -> let _ = f a in do_rec strm - | None -> () - in - do_rec -;; - -let count s = s.count;; - -let count_unfrozen s = - let rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - Cons (_, s) -> loop (cnt + 1) s - | _ -> cnt - else cnt - in - loop 0 s -;; diff --git a/camlp4/ocaml_src/lib/fstream.mli b/camlp4/ocaml_src/lib/fstream.mli deleted file mode 100644 index d0e8f8b49c..0000000000 --- a/camlp4/ocaml_src/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type 'a t;; - (* The type of 'a functional streams *) -val from : (int -> 'a option) -> 'a t;; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some <value>] for a value or [None] to specify the end of the - stream. *) - -val of_list : 'a list -> 'a t;; - (* Return the stream holding the elements of the list in the same - order. *) -val of_string : string -> char t;; - (* Return the stream of the characters of the string parameter. *) -val of_channel : in_channel -> char t;; - (* Return the stream of the characters read from the input channel. *) - -val iter : ('a -> unit) -> 'a t -> unit;; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -val next : 'a t -> ('a * 'a t) option;; - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -val empty : 'a t -> (unit * 'a t) option;; - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -val count : 'a t -> int;; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -val count_unfrozen : 'a t -> int;; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -val nil : 'a t;; -type 'a data;; -val cons : 'a -> 'a t -> 'a data;; -val app : 'a t -> 'a t -> 'a data;; -val flazy : (unit -> 'a data) -> 'a t;; diff --git a/camlp4/ocaml_src/lib/gramext.ml b/camlp4/ocaml_src/lib/gramext.ml deleted file mode 100644 index 41fdd76c19..0000000000 --- a/camlp4/ocaml_src/lib/gramext.ml +++ /dev/null @@ -1,531 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Printf;; - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -let warning_verbose = ref true;; - -let rec derive_eps = - function - Slist0 _ -> true - | Slist0sep (_, _) -> true - | Sopt _ -> true - | Stree t -> tree_derive_eps t - | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _) | Snterm _ | - Snterml (_, _) | Snext | Sself | Stoken _ -> - false -and tree_derive_eps = - function - LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> false -;; - -let rec eq_symbol s1 s2 = - match s1, s2 with - Snterm e1, Snterm e2 -> e1 == e2 - | Snterml (e1, l1), Snterml (e2, l2) -> e1 == e2 && l1 = l2 - | Slist0 s1, Slist0 s2 -> eq_symbol s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbol s1 s2 - | Stree _, Stree _ -> false - | _ -> s1 = s2 -;; - -let is_before s1 s2 = - match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false - | Stoken _, _ -> true - | _ -> false -;; - -let insert_tree entry_name gsymbols action tree = - let rec insert symbols tree = - match symbols with - s :: sl -> insert_in_tree s sl tree - | [] -> - match tree with - Node {node = s; son = son; brother = bro} -> - Node {node = s; son = son; brother = insert [] bro} - | LocAct (old_action, action_list) -> - if !warning_verbose then - begin - eprintf "<W> Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name; - eprintf "some rule has been masked\n"; - flush stderr - end; - LocAct (action, (old_action :: action_list)) - | DeadEnd -> LocAct (action, []) - and insert_in_tree s sl tree = - match try_insert s sl tree with - Some t -> t - | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} - and try_insert s sl tree = - match tree with - Node {node = s1; son = son; brother = bro} -> - if eq_symbol s s1 then - let t = Node {node = s1; son = insert sl son; brother = bro} in - Some t - else if is_before s1 s || derive_eps s && not (derive_eps s1) then - let bro = - match try_insert s sl bro with - Some bro -> bro - | None -> Node {node = s; son = insert sl DeadEnd; brother = bro} - in - let t = Node {node = s1; son = son; brother = bro} in Some t - else - begin match try_insert s sl bro with - Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t - | None -> None - end - | LocAct (_, _) | DeadEnd -> None - and insert_new = - function - s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct (action, []) - in - insert gsymbols tree -;; - -let srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -;; - -external action : 'a -> g_action = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let insert_level entry_name e1 symbols action slev = - match e1 with - true -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | false -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} -;; - -let empty_lev lname assoc = - let assoc = - match assoc with - Some a -> a - | None -> LeftA - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -;; - -let change_lev lev n lname assoc = - let a = - match assoc with - None -> lev.assoc - | Some a -> - if a <> lev.assoc && !warning_verbose then - begin - eprintf "<W> Changing associativity of level \"%s\"\n" n; - flush stderr - end; - a - in - begin match lname with - Some n -> - if lname <> lev.lname && !warning_verbose then - begin eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr end - | None -> () - end; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -;; - -let get_level entry position levs = - match position with - Some First -> [], empty_lev, levs - | Some Last -> levs, empty_lev, [] - | Some (Level n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], change_lev lev n, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (Before n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], empty_lev, lev :: levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (After n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [lev], empty_lev, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | None -> - match levs with - lev :: levs -> [], change_lev lev "<top>", levs - | [] -> [], empty_lev, [] -;; - -let rec check_gram entry = - function - Snterm e -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Snterml (e, _) -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl - | Slist0sep (s, t) -> check_gram entry t; check_gram entry s - | Slist1sep (s, t) -> check_gram entry t; check_gram entry s - | Slist0 s -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () -and tree_check_gram entry = - function - Node {node = n; brother = bro; son = son} -> - check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son - | LocAct (_, _) | DeadEnd -> () -;; - -let change_to_self entry = - function - Snterm e when e == entry -> Sself - | x -> x -;; - -let get_initial entry = - function - Sself :: symbols -> true, symbols - | symbols -> false, symbols -;; - -let insert_tokens gram symbols = - let rec insert = - function - Smeta (_, sl, _) -> List.iter insert sl - | Slist0 s -> insert s - | Slist1 s -> insert s - | Slist0sep (s, t) -> insert s; insert t - | Slist1sep (s, t) -> insert s; insert t - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r - in - incr r - | Snterm _ | Snterml (_, _) | Snext | Sself -> () - and tinsert = - function - Node {node = s; brother = bro; son = son} -> - insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - in - List.iter insert symbols -;; - -let levels_of_rules entry position rules = - let elev = - match entry.edesc with - Dlevels elev -> elev - | Dparser _ -> - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush stderr; - failwith "Grammar.extend" - in - if rules = [] then elev - else - let (levs1, make_lev, levs2) = get_level entry position elev in - let (levs, _) = - List.fold_left - (fun (levs, make_lev) (lname, assoc, level) -> - let lev = make_lev lname assoc in - let lev = - List.fold_left - (fun lev (symbols, action) -> - let symbols = List.map (change_to_self entry) symbols in - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev) - lev level - in - lev :: levs, empty_lev) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -;; - -let logically_eq_symbols entry = - let rec eq_symbols s1 s2 = - match s1, s2 with - Snterm e1, Snterm e2 -> e1.ename = e2.ename - | Snterm e1, Sself -> e1.ename = entry.ename - | Sself, Snterm e2 -> entry.ename = e2.ename - | Snterml (e1, l1), Snterml (e2, l2) -> e1.ename = e2.ename && l1 = l2 - | Slist0 s1, Slist0 s2 -> eq_symbols s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbols s1 s2 - | Stree t1, Stree t2 -> eq_trees t1 t2 - | _ -> s1 = s2 - and eq_trees t1 t2 = - match t1, t2 with - Node n1, Node n2 -> - eq_symbols n1.node n2.node && eq_trees n1.son n2.son && - eq_trees n1.brother n2.brother - | (LocAct (_, _) | DeadEnd), (LocAct (_, _) | DeadEnd) -> true - | _ -> false - in - eq_symbols -;; - -(* [delete_rule_in_tree] returns - [Some (dsl, t)] if success - [dsl] = - Some (list of deleted nodes) if branch deleted - None if action replaced by previous version of action - [t] = remaining tree - [None] if failure *) - -let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match symbols, tree with - s :: sl, Node n -> - if logically_eq_symbols entry s n.node then delete_son sl n - else - begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | s :: sl, _ -> None - | [], Node n -> - begin match delete_in_tree [] n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | [], DeadEnd -> None - | [], LocAct (_, []) -> Some (Some [], DeadEnd) - | [], LocAct (_, (action :: list)) -> Some (None, LocAct (action, list)) - and delete_son sl n = - match delete_in_tree sl n.son with - Some (Some dsl, DeadEnd) -> Some (Some (n.node :: dsl), n.brother) - | Some (Some dsl, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (Some (n.node :: dsl), t) - | Some (None, t) -> - let t = Node {node = n.node; son = t; brother = n.brother} in - Some (None, t) - | None -> None - in - delete_in_tree -;; - -let rec decr_keyw_use gram = - function - Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - decr r; - if !r == 0 then - begin - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - end - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 s -> decr_keyw_use gram s - | Slist0sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Slist1sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree gram = - function - DeadEnd | LocAct (_, _) -> () - | Node n -> - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother -;; - -let rec delete_rule_in_suffix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin match t with - DeadEnd when lev.lprefix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = t; - lprefix = lev.lprefix} - in - lev :: levs - end - | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let rec delete_rule_in_prefix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin match t with - DeadEnd when lev.lsuffix == DeadEnd -> levs - | _ -> - let lev = - {assoc = lev.assoc; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = t} - in - lev :: levs - end - | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let rec delete_rule_in_level_list entry symbols levs = - match symbols with - Sself :: symbols -> delete_rule_in_suffix entry symbols levs - | Snterm e :: symbols when e == entry -> - delete_rule_in_suffix entry symbols levs - | _ -> delete_rule_in_prefix entry symbols levs -;; diff --git a/camlp4/ocaml_src/lib/gramext.mli b/camlp4/ocaml_src/lib/gramext.mli deleted file mode 100644 index bd275ae8ee..0000000000 --- a/camlp4/ocaml_src/lib/gramext.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -val levels_of_rules : - 'te g_entry -> position option -> - (string option * g_assoc option * ('te g_symbol list * g_action) list) - list -> - 'te g_level list;; -val srules : ('te g_symbol list * g_action) list -> 'te g_symbol;; -external action : 'a -> g_action = "%identity";; - -val delete_rule_in_level_list : - 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list;; - -val warning_verbose : bool ref;; diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml deleted file mode 100644 index 196a6b954a..0000000000 --- a/camlp4/ocaml_src/lib/grammar.ml +++ /dev/null @@ -1,1119 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Gramext;; -open Format;; - -let rec flatten_tree = - function - DeadEnd -> [] - | LocAct (_, _) -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b -;; - -let print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);; - -let rec print_symbol ppf = - function - Smeta (n, sl, _) -> print_meta ppf n sl - | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s - | Slist0sep (s, t) -> - fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t - | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s - | Slist1sep (s, t) -> - fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t - | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s -and print_meta ppf n sl = - let rec loop i = - function - [] -> () - | s :: sl -> - let j = - try String.index_from n i ' ' with - Not_found -> String.length n - in - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else - begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end - in - loop 0 sl -and print_symbol1 ppf = - function - Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | - Slist1 _ | Slist1sep (_, _) | Sopt _ | Stoken _ as s -> - fprintf ppf "(%a)" print_symbol s -and print_rule ppf symbols = - fprintf ppf "@[<hov 0>"; - let _ = - List.fold_left - (fun sep symbol -> - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ") - (fun ppf -> ()) symbols - in - fprintf ppf "@]" -and print_level ppf pp_print_space rules = - fprintf ppf "@[<hov 0>[ "; - let _ = - List.fold_left - (fun sep rule -> - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ()) - (fun ppf -> ()) rules - in - fprintf ppf " ]@]" -;; - -let print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - fprintf ppf "%t@[<hov 2>" sep; - begin match lev.lname with - Some n -> fprintf ppf "%a@;<1 2>" print_str n - | None -> () - end; - begin match lev.assoc with - LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" - end; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ") - (fun ppf -> ()) elev - in - () -;; - -let print_entry ppf e = - fprintf ppf "@[<v 0>[ "; - begin match e.edesc with - Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "<parser>" - end; - fprintf ppf " ]@]" -;; - -let iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e !treated then () - else - begin - treated := e :: !treated; - f e; - match e.edesc with - Dlevels ll -> List.iter do_level ll - | Dparser _ -> () - end - and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix - and do_tree = - function - Node n -> do_node n - | LocAct (_, _) | DeadEnd -> () - and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother - and do_symbol = - function - Smeta (_, sl, _) -> List.iter do_symbol sl - | Snterm e | Snterml (e, _) -> do_entry e - | Slist0 s | Slist1 s | Sopt s -> do_symbol s - | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> do_symbol s1; do_symbol s2 - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () - in - do_entry e -;; - -let fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e !treated then accu - else - begin - treated := e :: !treated; - let accu = f e accu in - match e.edesc with - Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu - end - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix - and do_tree accu = - function - Node n -> do_node accu n - | LocAct (_, _) | DeadEnd -> accu - and do_node accu n = - let accu = do_symbol accu n.node in - let accu = do_tree accu n.son in do_tree accu n.brother - and do_symbol accu = - function - Smeta (_, sl, _) -> List.fold_left do_symbol accu sl - | Snterm e | Snterml (e, _) -> do_entry accu e - | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s - | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> - let accu = do_symbol accu s1 in do_symbol accu s2 - | Stree t -> do_tree accu t - | Sself | Snext | Stoken _ -> accu - in - do_entry init e -;; - -type g = Token.t Gramext.grammar;; - -external grammar_obj : g -> Token.t grammar = "%identity";; - -let floc = ref (fun _ -> failwith "internal error when computing location");; -let loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then 0, 1 else let a = snd (!floc (bp - 1)) in a, a + 1 - else - let (bp1, bp2) = !floc bp in - let (ep1, ep2) = !floc (pred ep) in - (if bp1 < ep1 then bp1 else ep1), (if bp2 > ep2 then bp2 else ep2) -;; - -let rec name_of_symbol entry = - function - Snterm e -> "[" ^ e.ename ^ "]" - | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" -;; - -let rec get_token_list entry tokl last_tok tree = - match tree with - Node {node = Stoken tok as s; son = son; brother = DeadEnd} -> - get_token_list entry (last_tok :: tokl) tok son - | _ -> - if tokl = [] then None - else Some (List.rev (last_tok :: tokl), last_tok, tree) -;; - -let rec name_of_symbol_failed entry = - function - Slist0 s -> name_of_symbol_failed entry s - | Slist0sep (s, _) -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep (s, _) -> name_of_symbol_failed entry s - | Sopt s -> name_of_symbol_failed entry s - | Stree t -> name_of_tree_failed entry t - | s -> name_of_symbol entry s -and name_of_tree_failed entry = - function - Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin match tokl with - None -> - let txt = name_of_symbol_failed entry s in - let txt = - match s, son with - Sopt _, Node _ -> txt ^ " or " ^ name_of_tree_failed entry son - | _ -> txt - in - let txt = - match bro with - DeadEnd | LocAct (_, _) -> txt - | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro - in - txt - | Some (tokl, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl - end - | DeadEnd | LocAct (_, _) -> "???" -;; - -let search_tree_in_entry prev_symb tree = - function - Dlevels levels -> - let rec search_levels = - function - [] -> tree - | level :: levels -> - match search_level level with - Some tree -> tree - | None -> search_levels levels - and search_level level = - match search_tree level.lsuffix with - Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) - | None -> search_tree level.lprefix - and search_tree t = - if tree <> DeadEnd && t == tree then Some t - else - match t with - Node n -> - begin match search_symbol n.node with - Some symb -> - Some (Node {node = symb; son = n.son; brother = DeadEnd}) - | None -> - match search_tree n.son with - Some t -> - Some (Node {node = n.node; son = t; brother = DeadEnd}) - | None -> search_tree n.brother - end - | LocAct (_, _) | DeadEnd -> None - and search_symbol symb = - match symb with - Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | - Slist1sep (_, _) | Sopt _ | Stoken _ | Stree _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist0 symb) - | None -> None - end - | Slist0sep (symb, sep) -> - begin match search_symbol symb with - Some symb -> Some (Slist0sep (symb, sep)) - | None -> - match search_symbol sep with - Some sep -> Some (Slist0sep (symb, sep)) - | None -> None - end - | Slist1 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist1 symb) - | None -> None - end - | Slist1sep (symb, sep) -> - begin match search_symbol symb with - Some symb -> Some (Slist1sep (symb, sep)) - | None -> - match search_symbol sep with - Some sep -> Some (Slist1sep (symb, sep)) - | None -> None - end - | Sopt symb -> - begin match search_symbol symb with - Some symb -> Some (Sopt symb) - | None -> None - end - | Stree t -> - begin match search_tree t with - Some t -> Some (Stree t) - | None -> None - end - | _ -> None - in - search_levels levels - | Dparser _ -> tree -;; - -let error_verbose = ref false;; - -let tree_failed entry prev_symb_result prev_symb tree = - let txt = name_of_tree_failed entry tree in - let txt = - match prev_symb with - Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | Slist0sep (s, sep) -> - begin match Obj.magic prev_symb_result with - [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" - end - | Slist1sep (s, sep) -> - begin match Obj.magic prev_symb_result with - [] -> - let txt1 = name_of_symbol_failed entry s in - txt1 ^ " or " ^ txt ^ " expected" - | _ -> - let txt1 = name_of_symbol_failed entry sep in - txt1 ^ " or " ^ txt ^ " expected" - end - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb - in - if !error_verbose then - begin - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[<v 0>@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - end; - txt ^ " (in [" ^ entry.ename ^ "])" -;; - -let symb_failed entry prev_symb_result prev_symb symb = - let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in - tree_failed entry prev_symb_result prev_symb tree -;; - -external app : Obj.t -> 'a = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let level_number entry lab = - let rec lookup levn = - function - [] -> failwith ("unknown level " ^ lab) - | lev :: levs -> - if is_level_labelled lab lev then levn else lookup (succ levn) levs - in - match entry.edesc with - Dlevels elev -> lookup 0 elev - | Dparser _ -> raise Not_found -;; - -let rec top_symb entry = - function - Sself | Snext -> Snterm entry - | Snterml (e, _) -> Snterm e - | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep) - | _ -> raise Stream.Failure -;; - -let entry_of_symb entry = - function - Sself | Snext -> entry - | Snterm e -> e - | Snterml (e, _) -> e - | _ -> raise Stream.Failure -;; - -let top_tree entry = - function - Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct (_, _) | DeadEnd -> raise Stream.Failure -;; - -let skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -;; - -let continue entry bp a s son p1 (strm__ : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in - let act = - try p1 strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) - in - Gramext.action (fun _ -> app act a) -;; - -let do_recover - parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = - try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with - Stream.Failure -> - try - skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - strm__ - with - Stream.Failure -> - continue entry bp a s son (parser_of_tree entry nlevn alevn son) - strm__ -;; - -let strict_parsing = ref false;; - -let recover parser_of_tree entry nlevn alevn bp a s son strm = - if !strict_parsing then raise (Stream.Error (tree_failed entry a s son)) - else do_recover parser_of_tree entry nlevn alevn bp a s son strm -;; - -let token_count = ref 0;; - -let peek_nth n strm = - let list = Stream.npeek n strm in - token_count := Stream.count strm + n; - let rec loop list n = - match list, n with - x :: _, 1 -> Some x - | _ :: l, n -> loop l (n - 1) - | [], _ -> None - in - loop list n -;; - -let rec parser_of_tree entry nlevn alevn = - function - DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) - | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> - (fun (strm__ : _ Stream.t) -> - let a = entry.estart alevn strm__ in app act a) - | Node {node = Sself; son = LocAct (act, _); brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - (fun (strm__ : _ Stream.t) -> - match - try Some (entry.estart alevn strm__) with - Stream.Failure -> None - with - Some a -> app act a - | _ -> p2 strm__) - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin match tokl with - None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a) - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl - end - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - match tokl with - None -> - let ps = parser_of_symbol entry nlevn s in - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn s son in - let p2 = parser_of_tree entry nlevn alevn bro in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a - | _ -> p2 strm__) - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - fun (strm__ : _ Stream.t) -> - try p1 strm__ with - Stream.Failure -> p2 strm__ -and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) = - try p1 strm__ with - Stream.Failure -> - try recover parser_of_tree entry nlevn alevn bp a s son strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) -and parser_of_token_list gram p1 tokl = - let rec loop n = - function - tok :: tokl -> - let tematch = gram.glexer.Token.tok_match tok in - begin match tokl with - [] -> - let ps strm = - match peek_nth n strm with - Some tok -> - let r = tematch tok in - for i = 1 to n do Stream.junk strm done; Obj.repr r - | None -> raise Stream.Failure - in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a) - | _ -> - let ps strm = - match peek_nth n strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = loop (n + 1) tokl in - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in app act a - end - | [] -> invalid_arg "parser_of_token_list" - in - loop 1 tokl -and parser_of_symbol entry nlevn = - function - Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = loop [] strm__ in Obj.repr (List.rev a)) - | Slist0sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (List.rev (kont [a] strm__)) - | _ -> Obj.repr []) - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (loop [a] strm__))) - | Slist1sep (symb, sep) -> - let ps = parser_of_symbol entry nlevn symb in - let pt = parser_of_symbol entry nlevn sep in - let rec kont al (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - try parse_top_symb entry symb strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (kont [a] strm__))) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (Some a) - | _ -> Obj.repr None) - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = pt strm__ in - let ep = Stream.count strm__ in - let loc = loc_of_token_interval bp ep in app a loc) - | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__) - | Snterml (e, l) -> - (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__) - | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) - | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - Some tok -> let r = f tok in Stream.junk strm; Obj.repr r - | None -> raise Stream.Failure -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -;; - -let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;; - -let rec continue_parser_of_levels entry clevn = - function - [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> - let p1 = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - LeftA | NonA -> succ clevn - | RightA -> clevn - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - fun levn bp a strm -> - if levn > clevn then p1 levn bp a strm - else - let (strm__ : _ Stream.t) = strm in - try p1 levn bp a strm__ with - Stream.Failure -> - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm -;; - -let rec start_parser_of_levels entry clevn = - function - [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) - | lev :: levs -> - let p1 = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - DeadEnd -> p1 - | tree -> - let alevn = - match lev.assoc with - LeftA | NonA -> succ clevn - | RightA -> clevn - in - let p2 = parser_of_tree entry (succ clevn) alevn tree in - match levs with - [] -> - (fun levn strm -> - let (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm) - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - match - try Some (p2 strm__) with - Stream.Failure -> None - with - Some act -> - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | _ -> p1 levn strm__ -;; - -let continue_parser_of_entry entry = - match entry.edesc with - Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - (fun levn bp a (strm__ : _ Stream.t) -> - try p levn bp a strm__ with - Stream.Failure -> a) - | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure -;; - -let empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -;; - -let start_parser_of_entry entry = - match entry.edesc with - Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm -;; - -let parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = !floc in - let old_tc = !token_count in - fun () -> floc := old_floc; token_count := old_tc - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if !token_count - 1 <= cnt then loc - else fst loc, snd (fun_loc (!token_count - 1)) - with - _ -> Stream.count cs, Stream.count cs + 1 - in - floc := fun_loc; - token_count := 0; - try let r = efun ts in restore (); r with - Stream.Failure -> - let loc = get_loc () in - restore (); - raise_with_loc loc (Stream.Error ("illegal begin of " ^ entry.ename)) - | Stream.Error _ as exc -> - let loc = get_loc () in restore (); raise_with_loc loc exc - | exc -> - let loc = Stream.count cs, Stream.count cs + 1 in - restore (); raise_with_loc loc exc -;; - -let wrap_parse entry efun cs = - let parsable = cs, entry.egram.glexer.Token.tok_func cs in - parse_parsable entry efun parsable -;; - -let create_toktab () = Hashtbl.create 301;; -let gcreate glexer = {gtokens = create_toktab (); glexer = glexer};; - -let tematch tparse tok = - match tparse tok with - Some p -> (fun x -> p (Stream.ising x)) - | None -> Token.default_match tok -;; -let glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -;; -let create lexer = gcreate (glexer_of_lexer lexer);; - -(* Extend syntax *) - -let extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - entry.edesc <- Dlevels elev; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm - with - Token.Error s -> - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" -;; - -let extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - begin match !gram with - Some g -> - if g != entry.egram then - begin - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - end - | None -> gram := Some entry.egram - end; - extend_entry entry position rules) - entry_rules_list -;; - -(* Deleting a rule *) - -let delete_rule entry sl = - match entry.edesc with - Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - entry.edesc <- Dlevels levs; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - (fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm) - | Dparser _ -> () -;; - -(* Unsafe *) - -let clear_entry e = - e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - match e.edesc with - Dlevels _ -> e.edesc <- Dlevels [] - | Dparser _ -> () -;; - -let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer;; - -let reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);; - -module Unsafe = - struct - let gram_reinit = gram_reinit;; - let clear_entry = clear_entry;; - let reinit_gram = reinit_gram;; - end -;; - -let find_entry e s = - let rec find_levels = - function - [] -> None - | lev :: levs -> - match find_tree lev.lsuffix with - None -> - begin match find_tree lev.lprefix with - None -> find_levels levs - | x -> x - end - | x -> x - and find_symbol = - function - Snterm e -> if e.ename = s then Some e else None - | Snterml (e, _) -> if e.ename = s then Some e else None - | Smeta (_, sl, _) -> find_symbol_list sl - | Slist0 s -> find_symbol s - | Slist0sep (s, _) -> find_symbol s - | Slist1 s -> find_symbol s - | Slist1sep (s, _) -> find_symbol s - | Sopt s -> find_symbol s - | Stree t -> find_tree t - | Sself | Snext | Stoken _ -> None - and find_symbol_list = - function - s :: sl -> - begin match find_symbol s with - None -> find_symbol_list sl - | x -> x - end - | [] -> None - and find_tree = - function - Node {node = s; brother = bro; son = son} -> - begin match find_symbol s with - None -> - begin match find_tree bro with - None -> find_tree son - | x -> x - end - | x -> x - end - | LocAct (_, _) | DeadEnd -> None - in - match e.edesc with - Dlevels levs -> - begin match find_levels levs with - Some e -> e - | None -> raise Not_found - end - | Dparser _ -> raise Not_found -;; - -let of_entry e = e.egram;; - -module Entry = - struct - type te = Token.t;; - type 'a e = te g_entry;; - let create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - let parse (entry : 'a e) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ;; - let parse_token (entry : 'a e) ts : 'a = Obj.magic (entry.estart 0 ts);; - let name e = e.ename;; - let of_parser g n (p : te Stream.t -> 'a) : 'a e = - {egram = g; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let print e = printf "%a@." print_entry (obj e);; - let find e s = find_entry (obj e) s;; - end -;; - -let tokens g con = - let list = ref [] in - Hashtbl.iter - (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) - g.gtokens; - !list -;; - -let glexer g = g.glexer;; - -let warning_verbose = Gramext.warning_verbose;; - -(* Functorial interface *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - -module type ReinitType = sig val reinit_gram : g -> Token.lexer -> unit;; end -;; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te;; - type parsable = char Stream.t * (te Stream.t * Token.location_function);; - let gram = gcreate L.lexer;; - let parsable cs = cs, L.lexer.Token.tok_func cs;; - let tokens = tokens gram;; - let glexer = glexer gram;; - module Entry = - struct - type 'a e = te g_entry;; - let create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let parse (e : 'a e) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ;; - let parse_token (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts);; - let name e = e.ename;; - let of_parser n (p : te Stream.t -> 'a) : 'a e = - {egram = gram; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - let print e = printf "%a@." print_entry (obj e);; - end - ;; - module Unsafe = - struct - let gram_reinit = gram_reinit gram;; - let clear_entry = Unsafe.clear_entry;; - let reinit_gram = R.reinit_gram (Obj.magic gram);; - end - ;; - let extend = extend_entry;; - let delete_rule e r = delete_rule (Entry.obj e) r;; - end -;; - -module GMake (L : GLexerType) = - GGMake - (struct - let reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ;; - end) - (L) -;; - -module type LexerType = sig val lexer : Token.lexer;; end;; - -module Make (L : LexerType) = - GGMake (struct let reinit_gram = reinit_gram;; end) - (struct type te = Token.t;; let lexer = glexer_of_lexer L.lexer;; end) -;; diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli deleted file mode 100644 index d38b449f95..0000000000 --- a/camlp4/ocaml_src/lib/grammar.mli +++ /dev/null @@ -1,200 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g;; - (** The type for grammars, holding entries. *) -val gcreate : Token.t Token.glexer -> g;; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -val tokens : g -> string -> (string * int) list;; - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -val glexer : g -> Token.t Token.glexer;; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type 'a e;; - val create : g -> string -> 'a e;; - val parse : 'a e -> char Stream.t -> 'a;; - val parse_token : 'a e -> Token.t Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : g -> string -> (Token.t Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - val find : 'a e -> string -> Obj.t e;; - external obj : 'a e -> Token.t Gramext.g_entry = "%identity";; - end -;; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -val of_entry : 'a Entry.e -> g;; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - val gram_reinit : g -> Token.t Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : g -> Token.lexer -> unit;; - end -;; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te;; - -(** {6 Miscellaneous} *) - -val error_verbose : bool ref;; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -val warning_verbose : bool ref;; - (** Flag for displaying warnings while extension; default = [True] *) - -val strict_parsing : bool ref;; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;; - (** General printer for all kinds of entries (obj entries) *) - -val iter_entry : - ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit;; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -val fold_entry : - ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a;; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig val lexer : Token.lexer;; end;; -module Make (L : LexerType) : S with type te = Token.t;; -(*** deprecated since version 3.05; use rather the function gcreate *) -val create : Token.lexer -> g;; - -(*** For system use *) - -val loc_of_token_interval : int -> int -> int * int;; -val extend : - ('te Gramext.g_entry * Gramext.position option * - (string option * Gramext.g_assoc option * - ('te Gramext.g_symbol list * Gramext.g_action) list) - list) - list -> - unit;; -val delete_rule : 'a Entry.e -> Token.t Gramext.g_symbol list -> unit;; - -val parse_top_symb : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t;; -val symb_failed_txt : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol -> - string;; diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml deleted file mode 100644 index 4b5dcca151..0000000000 --- a/camlp4/ocaml_src/lib/plexer.ml +++ /dev/null @@ -1,1258 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Token;; - -let no_quotations = ref false;; - -(* The string buffering machinery *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -(* The lexer *) - -let stream_peek_nth n strm = - let rec loop n = - function - [] -> None - | [x] -> if n == 1 then Some x else None - | _ :: l -> loop (n - 1) l - in - loop n (Stream.npeek n strm) -;; - -let rec ident len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'' as c) -> - Stream.junk strm__; ident (store len c) strm__ - | _ -> len -and ident2 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|' | '$' as c) -> - Stream.junk strm__; ident2 (store len c) strm__ - | _ -> len -and ident3 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | - ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | '\'' | '$' as c - ) -> - Stream.junk strm__; ident3 (store len c) strm__ - | _ -> len -and base_number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('o' | 'O') -> - Stream.junk strm__; digits octal (store len 'o') strm__ - | Some ('x' | 'X') -> Stream.junk strm__; digits hexa (store len 'x') strm__ - | Some ('b' | 'B') -> - Stream.junk strm__; digits binary (store len 'b') strm__ - | _ -> number len strm__ -and digits kind len (strm__ : _ Stream.t) = - let d = - try kind strm__ with - Stream.Failure -> raise (Stream.Error "ill-formed integer constant") - in - digits_under kind (store len d) strm__ -and digits_under kind len (strm__ : _ Stream.t) = - match - try Some (kind strm__) with - Stream.Failure -> None - with - Some d -> digits_under kind (store len d) strm__ - | _ -> - match Stream.peek strm__ with - Some '_' -> Stream.junk strm__; digits_under kind len strm__ - | _ -> "INT", get_buff len -and octal (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'7' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and hexa (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' | 'a'..'f' | 'A'..'F' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and binary (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'1' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> Stream.junk strm__; number (store len c) strm__ - | Some '_' -> Stream.junk strm__; number len strm__ - | Some '.' -> Stream.junk strm__; decimal_part (store len '.') strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | Some 'l' -> Stream.junk strm__; "INT32", get_buff len - | Some 'L' -> Stream.junk strm__; "INT64", get_buff len - | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len - | _ -> "INT", get_buff len -and decimal_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; decimal_part (store len c) strm__ - | Some '_' -> Stream.junk strm__; decimal_part len strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | _ -> "FLOAT", get_buff len -and exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('+' | '-' as c) -> - Stream.junk strm__; end_exponent_part (store len c) strm__ - | _ -> end_exponent_part len strm__ -and end_exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | _ -> raise (Stream.Error "ill-formed floating-point constant") -and end_exponent_part_under len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | Some '_' -> Stream.junk strm__; end_exponent_part_under len strm__ - | _ -> "FLOAT", get_buff len -;; - -let error_on_unknown_keywords = ref false;; -let err loc msg = raise_with_loc loc (Token.Error msg);; - -(* -value next_token_fun dfa find_kwd = - let keyword_or_error loc s = - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] - in - let rec next_token = - parser bp - [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] -> - next_token s - | [: `'('; s :] -> left_paren bp s - | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s } - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = (bp, Stream.count s) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 3 s with - [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let tok = ("STRING", get_buff (string bp 0 s)) in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let tok = dollar bp 0 s in - let loc = (bp, Stream.count s) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("TILDEIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep -> - (("QUESTIONIDENT", get_buff len), (bp, ep)) - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - match strm with parser - [ [: `'<'; len = quotation bp 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bp, ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bp 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (bp, ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (bp, ep) "char not terminated" ] - and dollar bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (bp, ep) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (bp, ep) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment bp; a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bp = - parser - [ [: `'('; s :] -> left_paren_in_comment bp s - | [: `'*'; s :] -> star_in_comment bp s - | [: `'"'; _ = string bp 0; s :] -> comment bp s - | [: `'''; s :] -> quote_in_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (bp, ep) "comment not terminated" ] - and quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\013'; s :] -> quote_cr_in_comment bp s - | [: `'\\'; s :] -> quote_antislash_in_comment bp s - | [: `'('; s :] -> quote_left_paren_in_comment bp s - | [: `'*'; s :] -> quote_star_in_comment bp s - | [: `'"'; s :] -> quote_doublequote_in_comment bp s - | [: `_; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> comment bp s ] - and quote_cr_in_comment bp = - parser - [ [: `'\010'; s :] -> quote_any_in_comment bp s - | [: s :] -> quote_any_in_comment bp s ] - and quote_left_paren_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> left_paren_in_comment bp s ] - and quote_star_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> star_in_comment bp s ] - and quote_doublequote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: _ = string bp 0; s :] -> comment bp s ] - and quote_antislash_in_comment bp = - parser - [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s - | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] -> - quote_any_in_comment bp s - | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s - | [: `'x'; s :] -> quote_antislash_x_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_quote_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: s :] -> quote_in_comment bp s ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s - | [: s :] -> comment bp s ] - and quote_antislash_x_digit_in_comment bp = - parser - [ [: _ = hexa; s :] -> quote_any_in_comment bp s - | [: s :] -> comment bp s ] - and left_paren_in_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and star_in_comment bp = - parser - [ [: `')' :] -> () - | [: a = comment bp :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> False ] - and linedir_digits n s = - match stream_peek_nth n s with - [ Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s ] - and linedir_quote n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '"' -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\013' | '\010' :] ep -> bolpos.val := ep - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - if fst (snd r) > comm_bp then - let comm_loc = (comm_bp, fst (snd r)) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - r - } - with - [ Stream.Error str -> - err (Stream.count cstrm, Stream.count cstrm + 1) str ] -; -*) - -let next_token_fun dfa ssd find_kwd bolpos glexr = - let keyword_or_error loc s = - try ("", find_kwd s), loc with - Not_found -> - if !error_on_unknown_keywords then err loc ("illegal token: " ^ s) - else ("", s), loc - in - let error_if_keyword ((_, id), loc as a) = - try - ignore (find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) - with - Not_found -> a - in - let rec next_token after_space (strm__ : _ Stream.t) = - let bp = Stream.count strm__ in - match Stream.peek strm__ with - Some ('\010' | '\013') -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in bolpos := ep; next_token true s - | Some (' ' | '\t' | '\026' | '\012') -> - Stream.junk strm__; next_token true strm__ - | Some '#' when bp = !bolpos -> - Stream.junk strm__; - let s = strm__ in - if linedir 1 s then begin any_to_nl s; next_token true s end - else keyword_or_error (bp, bp + 1) "#" - | Some '(' -> Stream.junk strm__; left_paren bp strm__ - | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = bp, Stream.count s in - (try "", find_kwd id with - Not_found -> "UIDENT", id), - loc - | Some ('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = bp, Stream.count s in - (try "", find_kwd id with - Not_found -> "LIDENT", id), - loc - | Some ('1'..'9' as c) -> - Stream.junk strm__; - let tok = number (store 0 c) strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some '0' -> - Stream.junk strm__; - let tok = base_number (store 0 '0') strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some '\'' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - [_; '\''] | ['\\'; _] -> - let tok = "CHAR", get_buff (char bp 0 s) in - let loc = bp, Stream.count s in tok, loc - | _ -> keyword_or_error (bp, Stream.count s) "'" - end - | Some '\"' -> - Stream.junk strm__; - let tok = "STRING", get_buff (string bp 0 strm__) in - let loc = bp, Stream.count strm__ in tok, loc - | Some '$' -> - Stream.junk strm__; - let tok = dollar bp 0 strm__ in - let loc = bp, Stream.count strm__ in tok, loc - | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) -> - Stream.junk strm__; - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - | Some ('~' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let eb = Stream.count strm__ in - error_if_keyword (("LABEL", id), (bp, ep)) - | _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some ('?' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let eb = Stream.count strm__ in - error_if_keyword (("OPTLABEL", id), (bp, ep)) - | _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some '<' -> Stream.junk strm__; less bp strm__ - | Some (':' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('>' | '|' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | '}' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> ident2 (store 0 c1) strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('[' | '{' as c1) -> - Stream.junk strm__; - let s = strm__ in - let len = - match Stream.npeek 2 s with - ['<'; '<' | ':'] -> store 0 c1 - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - in - let ep = Stream.count s in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some '.' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some '.' -> Stream.junk strm__; ".." - | _ -> if ssd && after_space then " ." else "." - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some ';' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; ";;" - | _ -> ";" - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some '\\' -> - Stream.junk strm__; - let ep = Stream.count strm__ in - ("LIDENT", get_buff (ident3 0 strm__)), (bp, ep) - | Some c -> - Stream.junk strm__; - let ep = Stream.count strm__ in - keyword_or_error (bp, ep) (String.make 1 c) - | _ -> let _ = Stream.empty strm__ in ("EOI", ""), (bp, succ bp) - and less bp strm = - if !no_quotations then - let (strm__ : _ Stream.t) = strm in - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - else - let (strm__ : _ Stream.t) = strm in - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", ":" ^ get_buff len), (bp, ep) - | Some ':' -> - Stream.junk strm__; - let i = - try let len = ident 0 strm__ in get_buff len with - Stream.Failure -> raise (Stream.Error "") - in - begin match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep) - | _ -> raise (Stream.Error "character '<' expected") - end - | _ -> - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - and string bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let ep = Stream.count strm__ in - string bp (store (store len '\\') c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; string bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in err (bp, ep) "string not terminated" - and char bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> - Stream.junk strm__; - let s = strm__ in if len = 0 then char bp (store len '\'') s else len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; char bp (store (store len '\\') c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> Stream.junk strm__; char bp (store len c) strm__ - | _ -> let ep = Stream.count strm__ in err (bp, ep) "char not terminated" - and dollar bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' as c) -> - Stream.junk strm__; antiquot bp (store len c) strm__ - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | _ -> - let s = strm__ in - if dfa then - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - else "", get_buff (ident2 (store 0 '$') s) - and maybe_locate bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - "LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and antiquot bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' | '0'..'9' as c) -> - Stream.junk strm__; antiquot bp (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and locate_or_antiquot_rest bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; get_buff len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - locate_or_antiquot_rest bp (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; locate_or_antiquot_rest bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "antiquotation not terminated" - and quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; maybe_end_quotation bp len strm__ - | Some '<' -> - Stream.junk strm__; - quotation bp (maybe_nested_quotation bp (store len '<') strm__) strm__ - | Some '\\' -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some ('>' | '<' | '\\' as c) -> Stream.junk strm__; store len c - | _ -> store len '\\' - with - Stream.Failure -> raise (Stream.Error "") - in - quotation bp len strm__ - | Some c -> Stream.junk strm__; quotation bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bp, ep) "quotation not terminated" - and maybe_nested_quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; mstore (quotation bp (store len '<') strm__) ">>" - | Some ':' -> - Stream.junk strm__; - let len = - try ident (store len ':') strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - mstore (quotation bp (store len '<') strm__) ">>" - | _ -> len - with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> len - and maybe_end_quotation bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; len - | _ -> quotation bp (store len '>') strm__ - and left_paren bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; - let _ = - try comment bp strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try next_token true strm__ with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "(" - and comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '(' -> Stream.junk strm__; left_paren_in_comment bp strm__ - | Some '*' -> Stream.junk strm__; star_in_comment bp strm__ - | Some '\"' -> - Stream.junk strm__; - let _ = - try string bp 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - comment bp strm__ - | Some '\'' -> Stream.junk strm__; quote_in_comment bp strm__ - | Some c -> Stream.junk strm__; comment bp strm__ - | _ -> - let ep = Stream.count strm__ in err (bp, ep) "comment not terminated" - and quote_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp 0 strm__ - | _ -> - let s = strm__ in - begin match Stream.npeek 2 s with - [_; '\''] -> Stream.junk s; Stream.junk s - | _ -> () - end; - comment bp s - and quote_any_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_in_comment bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') -> - Stream.junk strm__; quote_any_in_comment bp strm__ - | Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit2_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit2_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__ - | _ -> comment bp strm__ - and left_paren_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; let s = strm__ in comment bp s; comment bp s - | _ -> comment bp strm__ - and star_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ')' -> Stream.junk strm__; () - | _ -> comment bp strm__ - and linedir n s = - match stream_peek_nth n s with - Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> false - and linedir_digits n s = - match stream_peek_nth n s with - Some ('0'..'9') -> linedir_digits (n + 1) s - | _ -> linedir_quote n s - and linedir_quote n s = - match stream_peek_nth n s with - Some (' ' | '\t') -> linedir_quote (n + 1) s - | Some '\"' -> true - | _ -> false - and any_to_nl (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('\013' | '\010') -> - Stream.junk strm__; let ep = Stream.count strm__ in bolpos := ep - | Some _ -> Stream.junk strm__; any_to_nl strm__ - | _ -> () - in - fun cstrm -> - try - let glex = !glexr in - let comm_bp = Stream.count cstrm in - let r = next_token false cstrm in - begin match glex.tok_comm with - Some list -> - if fst (snd r) > comm_bp then - let comm_loc = comm_bp, fst (snd r) in - glex.tok_comm <- Some (comm_loc :: list) - | None -> () - end; - r - with - Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str -;; - - -let dollar_for_antiquotation = ref true;; -let specific_space_dot = ref false;; - -let func kwd_table glexr = - let bolpos = ref 0 in - let find = Hashtbl.find kwd_table in - let dfa = !dollar_for_antiquotation in - let ssd = !specific_space_dot in - Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr) -;; - -let rec check_keyword_stream (strm__ : _ Stream.t) = - let _ = check strm__ in - let _ = - try Stream.empty strm__ with - Stream.Failure -> raise (Stream.Error "") - in - true -and check (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255') -> - Stream.junk strm__; check_ident strm__ - | Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.') -> - Stream.junk strm__; check_ident2 strm__ - | Some '<' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 1 s with - [':' | '<'] -> () - | _ -> check_ident2 s - end - | Some ':' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>') -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in () - | Some ('>' | '|') -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | '}') -> Stream.junk strm__; () - | _ -> check_ident2 strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some ('[' | '{') -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - ['<'; '<' | ':'] -> () - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':') -> Stream.junk strm__; () - | _ -> () - end - | Some ';' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some _ -> Stream.junk strm__; () - | _ -> raise Stream.Failure -and check_ident (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'') -> - Stream.junk strm__; check_ident strm__ - | _ -> () -and check_ident2 (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|') -> - Stream.junk strm__; check_ident2 strm__ - | _ -> () -;; - -let check_keyword s = - try check_keyword_stream (Stream.of_string s) with - _ -> false -;; - -let error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -;; - -let error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -;; - -let using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - | "LIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "UIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "INT" | "INT32" | "INT64" | "NATIVEINT" | "FLOAT" | "CHAR" | "STRING" | - "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" | "QUOTATION" | - "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ "\" is not recognized by Plexer")) -;; - -let removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm - | _ -> () -;; - -let text = - function - "", t -> "'" ^ t ^ "'" - | "LIDENT", "" -> "lowercase identifier" - | "LIDENT", t -> "'" ^ t ^ "'" - | "UIDENT", "" -> "uppercase identifier" - | "UIDENT", t -> "'" ^ t ^ "'" - | "INT", "" -> "integer" - | "INT32", "" -> "32 bits integer" - | "INT64", "" -> "64 bits integer" - | "NATIVEINT", "" -> "native integer" - | ("INT" | "INT32" | "NATIVEINT"), s -> "'" ^ s ^ "'" - | "FLOAT", "" -> "float" - | "STRING", "" -> "string" - | "CHAR", "" -> "char" - | "QUOTATION", "" -> "quotation" - | "ANTIQUOT", k -> "antiquot \"" ^ k ^ "\"" - | "LOCATE", "" -> "locate" - | "EOI", "" -> "end of input" - | con, "" -> con - | con, prm -> con ^ " \"" ^ prm ^ "\"" -;; - -let eq_before_colon p e = - let rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else false - in - loop 0 -;; - -let after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - Not_found -> "" -;; - -let tok_match = - function - "ANTIQUOT", p_prm -> - begin function - "ANTIQUOT", prm when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure - end - | tok -> Token.default_match tok -;; - -let gmake () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 972, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 972, 37))); - tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 972, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 973, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 973, 37))); - tok_comm = None} - in - let glex = - {tok_func = func kwd_table glexr; - tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - glexr := glex; glex -;; - -let tparse = - function - "ANTIQUOT", p_prm -> - let p (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> - Stream.junk strm__; after_colon prm - | _ -> raise Stream.Failure - in - Some p - | _ -> None -;; - -let make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 17))); - tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 37))); - tok_removing = - (fun _ -> raise (Match_failure ("plexer.ml", 1001, 60))); - tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 18))); - tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 37))); - tok_comm = None} - in - {func = func kwd_table glexr; using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -;; diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli deleted file mode 100644 index 601c175331..0000000000 --- a/camlp4/ocaml_src/lib/plexer.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** A lexical analyzer. *) - -val gmake : unit -> Token.t Token.glexer;; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", s)] is the keyword [s]. -- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter. -- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter. -- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the string associated with the constructor [STRING] is - the string found in the source without any interpretation. In - particular, the backslashes are not interpreted. For example, if - the input is ["\n"] the string is *not* a string with one - element containing the character "return", but a string of two - elements: the backslash and the character ["n"]. To interpret - a string use the function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -val dollar_for_antiquotation : bool ref;; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -val specific_space_dot : bool ref;; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -val no_quotations : bool ref;; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -val make : unit -> Token.lexer;; diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml deleted file mode 100644 index d91ee78c07..0000000000 --- a/camlp4/ocaml_src/lib/stdpp.ml +++ /dev/null @@ -1,99 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -exception Exc_located of (int * int) * exn;; - -let raise_with_loc loc exc = - match exc with - Exc_located (_, _) -> raise exc - | _ -> raise (Exc_located (loc, exc)) -;; - -let line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col (strm__ : _ Stream.t) = - let cnt = Stream.count strm__ in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let s = strm__ in - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else let col = col - (cnt - bp) in fname, lin, col, col + ep - bp - | _ -> raise Stream.Failure - in - let rec a_line_dir str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\n' -> Stream.junk strm__; loop str n - | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__ - | _ -> raise Stream.Failure - in - let rec spaces col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__ - | _ -> col - in - let rec check_string str n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> - Stream.junk strm__; - let col = - try spaces (col + 1) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - a_line_dir str n col strm__ - | Some c when c <> '\n' -> - Stream.junk strm__; - check_string (str ^ String.make 1 c) n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let check_quote n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__ - | _ -> not_a_line_dir col strm__ - in - let rec check_num n col (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; - check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__ - | _ -> let col = spaces col strm__ in check_quote n col strm__ - in - let begin_line (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '#' -> - Stream.junk strm__; - let col = - try spaces 1 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - check_num 0 col strm__ - | _ -> not_a_line_dir 0 strm__ - in - begin_line strm - in - let r = - try loop fname 1 with - Stream.Failure -> fname, 1, bp, ep - in - close_in ic; r - with - Sys_error _ -> fname, 1, bp, ep -;; - -let loc_name = ref "loc";; diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli deleted file mode 100644 index 68c0cb6ada..0000000000 --- a/camlp4/ocaml_src/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Standard definitions. *) - -exception Exc_located of (int * int) * exn;; - (** [Exc_located loc e] is an encapsulation of the exception [e] with - the input location [loc]. To be used in quotation expanders - and in grammars to specify some input location for an error. - Do not raise this exception directly: rather use the following - function [raise_with_loc]. *) - -val raise_with_loc : int * int -> exn -> 'a;; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -val line_of_loc : string -> int * int -> string * int * int * int;; - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -val loc_name : string ref;; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml deleted file mode 100644 index bc8faeac3e..0000000000 --- a/camlp4/ocaml_src/lib/token.ml +++ /dev/null @@ -1,223 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type t = string * string;; -type pattern = string * string;; - -exception Error of string;; - -type location = int * int;; -type location_function = int -> int * int;; -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;; - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : location list option } -;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; - -let lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -;; - -let locerr () = invalid_arg "Lexer: location function";; -let loct_create () = ref (Array.create 1024 None), ref false;; -let loct_func (loct, ov) i = - match - if i < 0 || i >= Array.length !loct then if !ov then Some (0, 0) else None - else Array.unsafe_get !loct i - with - Some loc -> loc - | _ -> locerr () -;; -let loct_add (loct, ov) i loc = - if i >= Array.length !loct then - let new_tmax = Array.length !loct * 2 in - if new_tmax < Sys.max_array_length then - let new_loct = Array.create new_tmax None in - Array.blit !loct 0 new_loct 0 (Array.length !loct); - loct := new_loct; - !loct.(i) <- Some loc - else ov := true - else !loct.(i) <- Some loc -;; - -let make_stream_and_location next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok) - in - ts, loct_func loct -;; - -let lexer_func_of_parser next_token_loc cs = - make_stream_and_location (fun () -> next_token_loc cs) -;; - -let lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try s.[0] <- Stream.next cs; 1 with - Stream.Failure -> 0) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = Lexing.lexeme_start lb, Lexing.lexeme_end lb in tok, loc - in - make_stream_and_location next_token_loc -;; - -(* Char and string tokens to real chars and string *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -let valch x = Char.code x - Char.code '0';; -let valch_a x = Char.code x - Char.code 'a' + 10;; -let valch_A x = Char.code x - Char.code 'A' + 10;; - -let rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - 'n' -> '\n', i + 1 - | 'r' -> '\r', i + 1 - | 't' -> '\t', i + 1 - | 'b' -> '\b', i + 1 - | '\\' -> '\\', i + 1 - | '\"' -> '\"', i + 1 - | '\'' -> '\'', i + 1 - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 - | _ -> raise Not_found -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found -and backslash2h cod s i = - if i = String.length s then '\\', i - 2 - else - match s.[i] with - '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1 - | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1 - | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1 - | _ -> raise Not_found -;; - -let rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i -;; - -let skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -;; - -let eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = '\'' then '\'' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - Not_found -> failwith "invalid char token" - else failwith "invalid char token" -;; - -let eval_string (bp, ep) s = - let rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '\"' then store len '\"', i + 1 - else - match s.[i] with - '\010' -> len, skip_indent s (i + 1) - | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1)) - | c -> - try let (c, i) = backslash s i in store len c, i with - Not_found -> - Printf.eprintf "Warning: char %d, Invalid backslash escape in string\n%!" - (bp + i + 1); - store (store len '\\') c, i + 1 - else store len s.[i], i + 1 - in - loop len i - in - loop 0 0 -;; - -let default_match = - function - "ANY", "" -> (fun (con, prm) -> prm) - | "ANY", v -> - (fun (con, prm) -> if v = prm then v else raise Stream.Failure) - | p_con, "" -> - (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure) - | p_con, p_prm -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure -;; diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli deleted file mode 100644 index 9ddb41069b..0000000000 --- a/camlp4/ocaml_src/lib/token.mli +++ /dev/null @@ -1,133 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = string * string;; - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string;; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type location = int * int;; -type location_function = int -> location;; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;; - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : location list option } -;; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -val lexer_text : pattern -> string;; - (** A simple [tok_text] function for lexers *) - -val default_match : pattern -> string * string -> string;; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -val lexer_func_of_parser : - (char Stream.t -> 'te * location) -> 'te lexer_func;; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func;; - (** A lexer function from a lexer created by [ocamllex] *) - -val make_stream_and_location : - (unit -> 'te * location) -> 'te Stream.t * location_function;; - (** General function *) - -(** {6 Useful functions} *) - -val eval_char : string -> char;; - (** Convert a char token, where the escape sequences (backslashes) - remain to be interpreted; raise [Failure] if an - incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)] - returns [c] *) - -val eval_string : location -> string -> string;; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = string * string;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; diff --git a/camlp4/ocaml_src/meta/.cvsignore b/camlp4/ocaml_src/meta/.cvsignore deleted file mode 100644 index 45db17209f..0000000000 --- a/camlp4/ocaml_src/meta/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4o.out -camlp4r.out diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend deleted file mode 100644 index 737ea5ec6b..0000000000 --- a/camlp4/ocaml_src/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_r.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pa_rp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi -pa_rp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx -pr_dump.cmo: ../camlp4/ast2pt.cmi $(OTOP)/utils/config.cmi ../camlp4/pcaml.cmi -pr_dump.cmx: ../camlp4/ast2pt.cmx $(OTOP)/utils/config.cmx ../camlp4/pcaml.cmx -q_MLast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi -q_MLast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile deleted file mode 100644 index 3b01659358..0000000000 --- a/camlp4/ocaml_src/meta/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES=-I ../camlp4 -I ../../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - for target in $(OBJSX) $(OBJSX:.cmx=.$(O)) ; do \ - if test -f $$target; then \ - cp $$target "$(LIBDIR)/camlp4/."; \ - fi; \ - done; \ - fi - -include .depend diff --git a/camlp4/ocaml_src/meta/Makefile.Mac b/camlp4/ocaml_src/meta/Makefile.Mac deleted file mode 100644 index b62b945c12..0000000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I ::camlp4: -I :::boot: -I "{OTOP}utils:" -OCAMLCFLAGS = {INCLUDES} -OBJS = q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo ¶ - pa_ifdef.cmo pr_dump.cmo -CAMLP4RM = pa_r.cmo pa_rp.cmo pr_dump.cmo -OUT = {OBJS} camlp4r - -all Ä {OUT} - -camlp4r Ä ::camlp4:camlp4 {CAMLP4RM} - delete -i camlp4r - directory ::camlp4: - domake -d CAMLP4=::meta:camlp4r -d CAMLP4M="-I ::meta {CAMLP4RM}" - directory ::meta: - -clean ÄÄ - delete -i {OUT} - -{dependrule} - -promote Ä - duplicate -y {OUT} pa_extend.cmi :::boot: - -compare Ä - for i in {OUT} - equal -s {i} :::boot:{i} || exit 1 - end - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y camlp4r "{BINDIR}" - -{defrules} - -pr_dump.cmo Ä ::camlp4:ast2pt.cmo "{OTOP}utils:config.cmi" ::camlp4:pcaml.cmi diff --git a/camlp4/ocaml_src/meta/Makefile.Mac.depend b/camlp4/ocaml_src/meta/Makefile.Mac.depend deleted file mode 100644 index 29675238e9..0000000000 --- a/camlp4/ocaml_src/meta/Makefile.Mac.depend +++ /dev/null @@ -1,12 +0,0 @@ -pa_extend.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_extend.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_extend_m.cmoÄ ::camlp4:mLast.cmi pa_extend.cmo -pa_extend_m.cmxÄ ::camlp4:mLast.cmi pa_extend.cmx -pa_macro.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_macro.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_r.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_r.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -pa_rp.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -pa_rp.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx -q_MLast.cmoÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmi ::camlp4:quotation.cmi -q_MLast.cmxÄ ::camlp4:mLast.cmi ::camlp4:pcaml.cmx ::camlp4:quotation.cmx diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml deleted file mode 100644 index d68baf8d59..0000000000 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ /dev/null @@ -1,2027 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; - -let 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 loc = int * int;; - -type 'e name = { expr : 'e; tvar : string; loc : int * int };; - -type styp = - STlid of loc * string - | STapp of loc * styp * styp - | STquo of loc * string - | STself of loc * string - | STtyp of MLast.ctyp -;; - -type 'e text = - TXmeta of loc * string * 'e text list * 'e * styp - | TXlist of loc * bool * 'e text * 'e text option - | TXnext of loc - | TXnterm of loc * 'e name * string option - | TXopt of loc * 'e text - | TXrules of loc * ('e text list * 'e) list - | TXself of loc - | TXtok of loc * string * 'e -;; - -type ('e, 'p) entry = - { name : 'e name; pos : 'e option; levels : ('e, 'p) level list } -and ('e, 'p) level = - { label : string option; assoc : 'e option; rules : ('e, 'p) rule list } -and ('e, 'p) rule = { prod : ('e, 'p) psymbol list; action : 'e option } -and ('e, 'p) psymbol = { pattern : 'p option; symbol : ('e, 'p) symbol } -and ('e, 'p) symbol = { used : string list; text : 'e text; styp : styp } -;; - -type used = - Unused - | UsedScanned - | UsedNotScanned -;; - -let mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n in - List.iter - (fun (r, _) -> - if !r == Unused then begin r := UsedNotScanned; modif := true end) - rll - with - Not_found -> () -;; - -let rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used -;; - -let check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref false in - List.iter - (fun e -> - let u = - match e.name.expr with - MLast.ExLid (_, _) -> 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 := UsedNotScanned) rll - with - _ -> ()) - nl; - modif := true; - while !modif do - modif := false; - Hashtbl.iter - (fun s (r, e) -> - if !r = UsedNotScanned then - begin - r := 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 - end) - ht - done; - Hashtbl.iter - (fun s (r, e) -> - if !r = Unused then - !(Pcaml.warning) e.name.loc ("Unused local entry \"" ^ s ^ "\"")) - ht -;; - -let locate n = let loc = n.loc in n.expr;; - -let new_type_var = - let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i -;; - -let 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 -;; - -let retype_rule_list_without_patterns loc rl = - try - List.map - (function - {prod = [{pattern = None; symbol = s}]; action = None} -> - {prod = [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}]; - action = Some (MLast.ExLid (loc, "x"))} - | {prod = []; action = Some _} as r -> r - | _ -> raise Exit) - rl - with - Exit -> rl -;; - -let quotify = ref false;; -let meta_action = ref false;; - -module MetaAction = - struct - let not_impl f 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 - failwith (f ^ ", not impl: " ^ desc) - ;; - let loc = 0, 0;; - let rec mlist mf = - function - [] -> MLast.ExUid (loc, "[]") - | x :: l -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), mf x), - mlist mf l) - ;; - let moption mf = - function - None -> MLast.ExUid (loc, "None") - | Some x -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), mf x) - ;; - let mbool = - function - false -> MLast.ExUid (loc, "False") - | true -> MLast.ExUid (loc, "True") - ;; - let mloc = - MLast.ExTup (loc, [MLast.ExInt (loc, "0"); MLast.ExInt (loc, "0")]) - ;; - let rec mexpr = - function - MLast.ExAcc (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExAcc")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExApp (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExApp")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExChr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExChr")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExFun (loc, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExFun")), - mloc), - mlist mpwe pwel) - | MLast.ExIfe (loc, e1, e2, e3) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExIfe")), - mloc), - mexpr e1), - mexpr e2), - mexpr e3) - | MLast.ExInt (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExInt")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExFlo (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExFlo")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExLet (loc, rf, pel, e) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExLet")), - mloc), - mbool rf), - mlist mpe pel), - mexpr e) - | MLast.ExLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.ExMat (loc, e, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExMat")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExRec (loc, pel, eo) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExRec")), - mloc), - mlist mpe pel), - moption mexpr eo) - | MLast.ExSeq (loc, el) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExSeq")), - mloc), - mlist mexpr el) - | MLast.ExSte (loc, e1, e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExSte")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExStr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExStr")), - mloc), - MLast.ExStr (loc, String.escaped s)) - | MLast.ExTry (loc, e, pwel) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTry")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExTup (loc, el) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTup")), - mloc), - mlist mexpr el) - | MLast.ExTyc (loc, e, t) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExTyc")), - mloc), - mexpr e), - mctyp t) - | MLast.ExUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "ExUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mexpr" x - and mpatt = - function - MLast.PaAcc (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaAcc")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaAny loc -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, "PaAny")), - mloc) - | MLast.PaApp (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaApp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaInt (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaInt")), - mloc), - MLast.ExStr (loc, s)) - | MLast.PaLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.PaOrp (loc, p1, p2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaOrp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaStr (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaStr")), - mloc), - MLast.ExStr (loc, String.escaped s)) - | MLast.PaTup (loc, pl) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaTup")), - mloc), - mlist mpatt pl) - | MLast.PaTyc (loc, p, t) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaTyc")), - mloc), - mpatt p), - mctyp t) - | MLast.PaUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "PaUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mpatt" x - and mctyp = - function - MLast.TyAcc (loc, t1, t2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyAcc")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyApp (loc, t1, t2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyApp")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyLid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyLid")), - mloc), - MLast.ExStr (loc, s)) - | MLast.TyQuo (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyQuo")), - mloc), - MLast.ExStr (loc, s)) - | MLast.TyTup (loc, tl) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyTup")), - mloc), - mlist mctyp tl) - | MLast.TyUid (loc, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), - MLast.ExUid (loc, "TyUid")), - mloc), - MLast.ExStr (loc, s)) - | x -> not_impl "mctyp" x - and mpe (p, e) = MLast.ExTup (loc, [mpatt p; mexpr e]) - and mpwe (p, w, e) = - MLast.ExTup (loc, [mpatt p; moption mexpr w; mexpr e]) - ;; - end -;; - -let mklistexp loc = - let rec loop top = - function - [] -> MLast.ExUid (loc, "[]") - | e1 :: el -> - let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el) - in - loop true -;; - -let mklistpat loc = - let rec loop top = - function - [] -> MLast.PaUid (loc, "[]") - | p1 :: pl -> - let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl) - in - loop true -;; - -let rec expr_fa al = - function - MLast.ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec quot_expr e = - let loc = MLast.loc_of_expr e in - match e with - MLast.ExUid (_, "None") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExUid (loc, "None")) - | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExApp (loc, MLast.ExUid (loc, "Some"), quot_expr e)) - | MLast.ExUid (_, "False") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")), - MLast.ExUid (loc, "False")) - | MLast.ExUid (_, "True") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Bool")), - MLast.ExUid (loc, "True")) - | MLast.ExUid (_, "()") -> e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")), - _) -> - e - | MLast.ExUid (_, "[]") -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExUid (loc, "[]")) - | MLast.ExApp - (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), quot_expr e), - MLast.ExUid (loc, "[]"))) - | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Cons")), - quot_expr e1), - quot_expr e2) - | MLast.ExApp (_, _, _) -> - let (f, al) = expr_fa [] e in - begin match f with - MLast.ExUid (_, c) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, c)), - mklistexp loc al) - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, c)), - mklistexp loc al) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, (m ^ "." ^ c))), - mklistexp loc al) - | MLast.ExLid (_, f) -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> MLast.ExApp (loc, f, e)) - (MLast.ExLid (loc, f)) al - | _ -> e - end - | MLast.ExRec (_, pel, None) -> - begin try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - MLast.PaLid (_, c) -> MLast.ExStr (loc, c) - | MLast.PaAcc (_, _, MLast.PaLid (_, c)) -> - MLast.ExStr (loc, c) - | _ -> raise Not_found - in - MLast.ExTup (loc, [lab; quot_expr e])) - pel - in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Record")), - mklistexp loc lel) - with - Not_found -> e - end - | MLast.ExLid (_, s) -> - if s = !(Stdpp.loc_name) then - MLast.ExAcc (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Loc")) - else e - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, s)), - MLast.ExUid (loc, "[]")) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, (m ^ "." ^ s))), - MLast.ExUid (loc, "[]")) - | MLast.ExUid (_, s) -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Node")), - MLast.ExStr (loc, s)), - MLast.ExUid (loc, "[]")) - | MLast.ExStr (_, s) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Str")), - MLast.ExStr (loc, s)) - | MLast.ExTup (_, el) -> - let el = List.map quot_expr el in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Tuple")), - mklistexp loc el) - | MLast.ExLet (_, r, pel, e) -> - let pel = List.map (fun (p, e) -> p, quot_expr e) pel in - MLast.ExLet (loc, r, pel, quot_expr e) - | _ -> e -;; - -let symgen = "xx";; - -let pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - MLast.PaLid (_, s) -> pname ^ s - | _ -> pname) - "" pl -;; - -let quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - Some (MLast.PaTup (_, pl)) -> - let loc = 0, 0 in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - (symgen ^ string_of_int cnt) :: l, cnt + 1) - ([], 1) pl - in - let l = List.rev l in - List.map (fun s -> MLast.PaLid (loc, s)) l, - List.map (fun s -> MLast.ExLid (loc, s)) l - in - MLast.ExLet - (loc, false, - [MLast.PaTup (loc, pl), - MLast.ExMat - (loc, MLast.ExLid (loc, pname), - [MLast.PaApp - (loc, - MLast.PaAcc - (loc, MLast.PaUid (loc, "Qast"), - MLast.PaUid (loc, "Tuple")), - mklistpat loc pl1), - None, MLast.ExTup (loc, el1); - MLast.PaAny loc, None, - MLast.ExMat (loc, MLast.ExUid (loc, "()"), [])])], - e) - | _ -> e) - e psl -;; - -let rec make_ctyp styp tvar = - match styp with - STlid (loc, s) -> MLast.TyLid (loc, s) - | STapp (loc, t1, t2) -> - MLast.TyApp (loc, make_ctyp t1 tvar, make_ctyp t2 tvar) - | STquo (loc, s) -> MLast.TyQuo (loc, s) - | STself (loc, x) -> - if tvar = "" then - Stdpp.raise_with_loc loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else MLast.TyQuo (loc, tvar) - | STtyp t -> t -;; - -let rec make_expr gmod tvar = - function - TXmeta (loc, n, tl, e, t) -> - let el = - List.fold_right - (fun t el -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), make_expr gmod "" t), - el)) - tl (MLast.ExUid (loc, "[]")) - in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Smeta")), - MLast.ExStr (loc, n)), - el), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "repr")), - MLast.ExTyc (loc, e, make_ctyp t tvar))) - | TXlist (loc, min, t, ts) -> - let txt = make_expr gmod "" t in - begin match min, ts with - false, None -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist0")), - txt) - | true, None -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist1")), - txt) - | false, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist0sep")), - txt), - x) - | true, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Slist1sep")), - txt), - x) - end - | TXnext loc -> - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Snext")) - | TXnterm (loc, n, lev) -> - begin match lev with - Some lab -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Snterml")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - MLast.ExTyc - (loc, n.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, n.tvar))))), - MLast.ExStr (loc, lab)) - | None -> - if n.tvar = tvar then - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself")) - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Snterm")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - MLast.ExTyc - (loc, n.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, n.tvar))))) - end - | TXopt (loc, t) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sopt")), - make_expr gmod "" t) - | TXrules (loc, rl) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "srules")), - make_expr_rules loc gmod rl "") - | TXself loc -> - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Sself")) - | TXtok (loc, s, e) -> - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Stoken")), - MLast.ExTup (loc, [MLast.ExStr (loc, s); e])) -and make_expr_rules loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), x), txt)) - sl (MLast.ExUid (loc, "[]")) - in - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), MLast.ExTup (loc, [sl; ac])), - txt)) - (MLast.ExUid (loc, "[]")) rl -;; - -let text_of_action loc psl rtvar act tvar = - let locid = MLast.PaLid (loc, !(Stdpp.loc_name)) in - let act = - match act with - Some act -> if !quotify then quotify_action psl act else act - | None -> MLast.ExUid (loc, "()") - in - let e = - MLast.ExFun - (loc, - [MLast.PaTyc - (loc, locid, - MLast.TyTup - (loc, [MLast.TyLid (loc, "int"); MLast.TyLid (loc, "int")])), - None, MLast.ExTyc (loc, act, MLast.TyQuo (loc, rtvar))]) - in - let txt = - List.fold_left - (fun txt ps -> - match ps.pattern with - None -> MLast.ExFun (loc, [MLast.PaAny loc, None, txt]) - | Some p -> - let t = make_ctyp ps.symbol.styp tvar in - let p = - match p with - MLast.PaTup (_, pl) when !quotify -> - MLast.PaLid (loc, pname_of_ptuple pl) - | _ -> p - in - MLast.ExFun (loc, [MLast.PaTyc (loc, p, t), None, txt])) - e psl - in - let txt = - if !meta_action then - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Obj"), MLast.ExLid (loc, "magic")), - MetaAction.mexpr txt) - else txt - in - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExLid (loc, "action")), - txt) -;; - -let srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in sl, ac) - rl -;; - -let expr_of_delete_rule loc gmod n sl = - let sl = - List.fold_right - (fun s e -> - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), make_expr gmod "" s.text), - e)) - sl (MLast.ExUid (loc, "[]")) - in - n.expr, sl -;; - -let rec ident_of_expr = - function - MLast.ExLid (_, s) -> s - | MLast.ExUid (_, s) -> s - | MLast.ExAcc (_, e1, e2) -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2 - | _ -> failwith "internal error in pa_extend" -;; - -let mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};; - -let slist loc min sep symb = - let t = - match sep with - Some s -> Some s.text - | None -> None - in - TXlist (loc, min, symb.text, t) -;; - -let sstoken loc s = - let n = mk_name loc (MLast.ExLid (loc, ("a_" ^ s))) in - TXnterm (loc, n, None) -;; - -let mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -;; - -let sslist loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name loc (MLast.ExLid (loc, "a_list")) in - [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None)) - (STquo (loc, "a_list"))] - in - let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_psymbol (MLast.PaLid (loc, "a")) (slist loc min sep s) - (STapp (loc, STlid (loc, "list"), s.styp))] - in - let act = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "List")), - MLast.ExLid (loc, "a")) - in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let used = "a_list" :: used in - let text = TXrules (loc, srules loc "a_list" rl "") in - let styp = STquo (loc, "a_list") in {used = used; text = text; styp = styp} -;; - -let ssopt loc s = - let rl = - let r1 = - let prod = - let n = mk_name loc (MLast.ExLid (loc, "a_opt")) in - [mk_psymbol (MLast.PaLid (loc, "a")) (TXnterm (loc, n, None)) - (STquo (loc, "a_opt"))] - in - let act = MLast.ExLid (loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - TXtok (loc, "", MLast.ExStr (_, _)) -> - let rl = - [{prod = - [{pattern = Some (MLast.PaLid (loc, "x")); symbol = s}]; - action = - Some - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), - MLast.ExUid (loc, "Str")), - MLast.ExLid (loc, "x")))}] - in - let t = new_type_var () in - {used = []; text = TXrules (loc, srules loc t rl ""); - styp = STquo (loc, t)} - | _ -> s - in - let prod = - [mk_psymbol (MLast.PaLid (loc, "a")) (TXopt (loc, s.text)) - (STapp (loc, STlid (loc, "option"), s.styp))] - in - let act = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Qast"), MLast.ExUid (loc, "Option")), - MLast.ExLid (loc, "a")) - in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = "a_opt" :: s.used in - let text = TXrules (loc, srules loc "a_opt" rl "") in - let styp = STquo (loc, "a_opt") in {used = used; text = text; styp = styp} -;; - -let text_of_entry loc gmod e = - let ent = - let x = e.name in - let loc = e.name.loc in - MLast.ExTyc - (loc, x.expr, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x.tvar))) - in - let pos = - match e.pos with - Some pos -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), pos) - | None -> MLast.ExUid (loc, "None") - in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - Some lab -> - MLast.ExApp - (loc, MLast.ExUid (loc, "Some"), MLast.ExStr (loc, lab)) - | None -> MLast.ExUid (loc, "None") - in - let ass = - match level.assoc with - Some ass -> MLast.ExApp (loc, MLast.ExUid (loc, "Some"), ass) - | None -> MLast.ExUid (loc, "None") - in - let txt = - let rl = srules loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules loc gmod rl e.name.tvar in - MLast.ExApp - (loc, - MLast.ExApp - (loc, MLast.ExUid (loc, "::"), - MLast.ExTup (loc, [lab; ass; e])), - txt) - in - txt) - e.levels (MLast.ExUid (loc, "[]")) - in - ent, pos, txt -;; - -let let_in_of_extend loc gmod functor_version gl el args = - match gl with - Some (n1 :: _ as nl) -> - check_use nl el; - let ll = - let same_tvar e n = e.name.tvar = n.tvar in - List.fold_right - (fun e ll -> - match e.name.expr with - MLast.ExLid (_, _) -> - if List.exists (same_tvar e) nl then ll - else if List.exists (same_tvar e) ll then ll - else e.name :: ll - | _ -> ll) - el [] - in - let globals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - MLast.PaAny loc, - MLast.ExTyc - (loc, e, - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x)))) - nl - in - let locals = - List.map - (fun {expr = e; tvar = x; loc = loc} -> - let i = - match e with - MLast.ExLid (_, i) -> i - | _ -> failwith "internal error in pa_extend" - in - MLast.PaLid (loc, i), - MLast.ExTyc - (loc, - MLast.ExApp - (loc, MLast.ExLid (loc, "grammar_entry_create"), - MLast.ExStr (loc, i)), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, gmod), - MLast.TyUid (loc, "Entry")), - MLast.TyLid (loc, "e")), - MLast.TyQuo (loc, x)))) - ll - in - let e = - if ll = [] then args - else if functor_version then - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "grammar_entry_create"), - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "create"))], - MLast.ExLet (loc, false, locals, args)) - else - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "grammar_entry_create"), - MLast.ExFun - (loc, - [MLast.PaLid (loc, "s"), None, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "create")), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExLid (loc, "of_entry")), - locate n1)), - MLast.ExLid (loc, "s"))])], - MLast.ExLet (loc, false, locals, args)) - in - MLast.ExLet (loc, false, globals, e) - | _ -> args -;; - -let text_of_extend loc gmod gl el f = - if !split_ext then - let args = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - ent) - in - let e = MLast.ExTup (loc, [ent; pos; txt]) in - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "aux"), - MLast.ExFun - (loc, - [MLast.PaUid (loc, "()"), None, - MLast.ExApp - (loc, f, - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), - MLast.ExUid (loc, "[]")))])], - MLast.ExApp - (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()")))) - el - in - let args = MLast.ExSeq (loc, 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 = - MLast.ExApp - (loc, - MLast.ExAcc - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExUid (loc, "Entry")), - MLast.ExLid (loc, "obj")), - ent) - in - let e = MLast.ExTup (loc, [ent; pos; txt]) in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e), el)) - el (MLast.ExUid (loc, "[]")) - in - let args = let_in_of_extend loc gmod false gl el args in - MLast.ExApp (loc, f, args) -;; - -let 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 = - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, gmod), - MLast.ExLid (loc, "extend")), - ent), - pos), - txt) - in - if !split_ext then - MLast.ExLet - (loc, false, - [MLast.PaLid (loc, "aux"), - MLast.ExFun (loc, [MLast.PaUid (loc, "()"), None, e])], - MLast.ExApp - (loc, MLast.ExLid (loc, "aux"), MLast.ExUid (loc, "()"))) - else e) - el - in - MLast.ExSeq (loc, el) - in - let_in_of_extend loc gmod true gl el args -;; - -open Pcaml;; -let symbol = Grammar.Entry.create gram "symbol";; -let semi_sep = - if !syntax_name = "Scheme" then - Grammar.Entry.of_parser gram "'/'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", "/") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) - else - Grammar.Entry.of_parser gram "';'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", ";") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (symbol : 'symbol Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let extend_body : 'extend_body Grammar.Entry.e = - grammar_entry_create "extend_body" - and gextend_body : 'gextend_body Grammar.Entry.e = - grammar_entry_create "gextend_body" - and delete_rule_body : 'delete_rule_body Grammar.Entry.e = - grammar_entry_create "delete_rule_body" - and gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e = - grammar_entry_create "gdelete_rule_body" - and efunction : 'efunction Grammar.Entry.e = - grammar_entry_create "efunction" - and global : 'global Grammar.Entry.e = grammar_entry_create "global" - and entry : 'entry Grammar.Entry.e = grammar_entry_create "entry" - and position : 'position Grammar.Entry.e = grammar_entry_create "position" - and level_list : 'level_list Grammar.Entry.e = - grammar_entry_create "level_list" - and level : 'level Grammar.Entry.e = grammar_entry_create "level" - and assoc : 'assoc Grammar.Entry.e = grammar_entry_create "assoc" - and rule_list : 'rule_list Grammar.Entry.e = - grammar_entry_create "rule_list" - and rule : 'rule Grammar.Entry.e = grammar_entry_create "rule" - and psymbol : 'psymbol Grammar.Entry.e = grammar_entry_create "psymbol" - and pattern : 'pattern Grammar.Entry.e = grammar_entry_create "pattern" - and patterns_comma : 'patterns_comma Grammar.Entry.e = - grammar_entry_create "patterns_comma" - and name : 'name Grammar.Entry.e = grammar_entry_create "name" - and qualid : 'qualid Grammar.Entry.e = grammar_entry_create "qualid" - and string : 'string Grammar.Entry.e = grammar_entry_create "string" in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "top"), - [None, None, - [[Gramext.Stoken ("", "GDELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gdelete_rule_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "DELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (delete_rule_body : 'delete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'delete_rule_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "GEXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gextend_body) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "EXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'extend_body) _ (loc : int * int) -> (e : 'expr))]]; - Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__1))])], - Gramext.action - (fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction) - (loc : int * int) -> - (text_of_extend loc "Grammar" sl el f : 'extend_body))]]; - Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) (loc : int * int) -> (e : 'e__2))])], - Gramext.action - (fun (el : 'e__2 list) (sl : 'global option) (g : string) - (loc : int * int) -> - (text_of_functorial_extend loc g sl el : 'gextend_body))]]; - Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (loc : int * int) -> - (let (e, b) = expr_of_delete_rule loc "Grammar" n sl in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Grammar"), - MLast.ExLid (loc, "delete_rule")), - e), - b) : - 'delete_rule_body))]]; - Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (g : string) - (loc : int * int) -> - (let (e, b) = expr_of_delete_rule loc g n sl in - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, g), - MLast.ExLid (loc, "delete_rule")), - e), - b) : - 'gdelete_rule_body))]]; - Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Grammar"), - MLast.ExLid (loc, "extend")) : - 'efunction)); - [Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (f : 'qualid) _ _ (loc : int * int) -> (f : 'efunction))]]; - Grammar.Entry.obj (global : 'global Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":"); - Gramext.Slist1 - (Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (sl : 'name list) _ _ (loc : int * int) -> (sl : 'global))]]; - Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (position : 'position Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))], - Gramext.action - (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name) - (loc : int * int) -> - ({name = n; pos = pos; levels = ll} : 'entry))]]; - Grammar.Entry.obj (position : 'position Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Level")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "AFTER"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "After")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "BEFORE"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (loc : int * int) -> - (MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "Before")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "LAST")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "Last")) : - 'position)); - [Gramext.Stoken ("UIDENT", "FIRST")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "First")) : - 'position))]]; - Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (level : 'level Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ll : 'level list) _ (loc : int * int) -> - (ll : 'level_list))]]; - Grammar.Entry.obj (level : 'level Grammar.Entry.e), None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("STRING", "")); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))], - Gramext.action - (fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option) - (loc : int * int) -> - ({label = lab; assoc = ass; rules = rules} : 'level))]]; - Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "NONA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), MLast.ExUid (loc, "NonA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "RIGHTA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "RightA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "LEFTA")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExAcc - (loc, MLast.ExUid (loc, "Gramext"), - MLast.ExUid (loc, "LeftA")) : - 'assoc))]]; - Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rules : 'rule list) _ (loc : int * int) -> - (retype_rule_list_without_patterns loc rules : 'rule_list)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action (fun _ _ (loc : int * int) -> ([] : 'rule_list))]]; - Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (psl : 'psymbol list) (loc : int * int) -> - ({prod = psl; action = None} : 'rule)); - [Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (act : 'expr) _ (psl : 'psymbol list) (loc : int * int) -> - ({prod = psl; action = Some act} : 'rule))]]; - Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) (loc : int * int) -> - ({pattern = None; symbol = s} : 'psymbol)); - [Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : 'pattern) (loc : int * int) -> - ({pattern = Some p; symbol = s} : 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__3))])], - Gramext.action - (fun (lev : 'e__3 option) (i : string) (loc : int * int) -> - (let name = mk_name loc (MLast.ExLid (loc, i)) in - let text = TXnterm (loc, name, lev) in - let styp = STquo (loc, i) in - let symb = {used = [i]; text = text; styp = styp} in - {pattern = None; symbol = symb} : - 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : string) (loc : int * int) -> - ({pattern = Some (MLast.PaLid (loc, p)); symbol = s} : - 'psymbol))]]; - Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None, - [Some "top", Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (loc : int * int) -> - (if !quotify then ssopt loc s - else - let styp = STapp (loc, STlid (loc, "option"), s.styp) in - let text = TXopt (loc, s.text) in - {used = s.used; text = text; styp = styp} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__5))])], - Gramext.action - (fun (sep : 'e__5 option) (s : 'symbol) _ (loc : int * int) -> - (if !quotify then sslist loc true sep s - else - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let styp = STapp (loc, STlid (loc, "list"), s.styp) in - let text = slist loc true sep s in - {used = used; text = text; styp = styp} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__4))])], - Gramext.action - (fun (sep : 'e__4 option) (s : 'symbol) _ (loc : int * int) -> - (if !quotify then sslist loc false sep s - else - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let styp = STapp (loc, STlid (loc, "list"), s.styp) in - let text = slist loc false sep s in - {used = used; text = text; styp = styp} : - 'symbol))]; - None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (s_t : 'symbol) _ (loc : int * int) -> (s_t : 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__7))])], - Gramext.action - (fun (lev : 'e__7 option) (n : 'name) (loc : int * int) -> - ({used = [n.tvar]; text = TXnterm (loc, n, lev); - styp = STquo (loc, n.tvar)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> (s : 'e__6))])], - Gramext.action - (fun (lev : 'e__6 option) (e : 'qualid) _ (i : string) - (loc : int * int) -> - (let n = - mk_name loc (MLast.ExAcc (loc, MLast.ExUid (loc, i), e)) - in - {used = [n.tvar]; text = TXnterm (loc, n, lev); - styp = STquo (loc, n.tvar)} : - 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (loc : int * int) -> - (let text = TXtok (loc, "", e) in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (x : string) (loc : int * int) -> - (let text = TXtok (loc, x, e) in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let text = - if !quotify then sstoken loc x - else TXtok (loc, x, MLast.ExStr (loc, "")) - in - {used = []; text = text; styp = STlid (loc, "string")} : - 'symbol)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rl : 'rule list) _ (loc : int * int) -> - (let rl = retype_rule_list_without_patterns loc rl in - let t = new_type_var () in - {used = used_of_rule_list rl; - text = TXrules (loc, srules loc t rl ""); - styp = STquo (loc, t)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "NEXT")], - Gramext.action - (fun _ (loc : int * int) -> - ({used = []; text = TXnext loc; styp = STself (loc, "NEXT")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "SELF")], - Gramext.action - (fun _ (loc : int * int) -> - ({used = []; text = TXself loc; styp = STself (loc, "SELF")} : - 'symbol))]]; - Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj - (patterns_comma : 'patterns_comma Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'pattern)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'pattern) _ (loc : int * int) -> (p : 'pattern)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> (MLast.PaAny loc : 'pattern)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'pattern))]]; - Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) _ (pl : 'patterns_comma) (loc : int * int) -> - (pl @ [p] : 'patterns_comma))]; - None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) (loc : int * int) -> ([p] : 'patterns_comma))]]; - Grammar.Entry.obj (name : 'name Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))], - Gramext.action - (fun (e : 'qualid) (loc : int * int) -> (mk_name loc e : 'name))]]; - Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'qualid) _ (e1 : 'qualid) (loc : int * int) -> - (MLast.ExAcc (loc, e1, e2) : 'qualid))]; - None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLid (loc, i) : 'qualid)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExUid (loc, i) : 'qualid))]]; - Grammar.Entry.obj (string : 'string Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (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 : - 'string)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExStr (loc, s) : 'string))]]]);; - -Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) "Undocumented";; diff --git a/camlp4/ocaml_src/meta/pa_extend_m.ml b/camlp4/ocaml_src/meta/pa_extend_m.ml deleted file mode 100644 index 11fd07f58a..0000000000 --- a/camlp4/ocaml_src/meta/pa_extend_m.ml +++ /dev/null @@ -1,40 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pa_extend;; - -Grammar.extend - [Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (loc : int * int) -> (ssopt loc s : 'symbol)); - [Gramext.srules - [[Gramext.Stoken ("UIDENT", "SLIST1")], - Gramext.action (fun _ (loc : int * int) -> (true : 'e__1)); - [Gramext.Stoken ("UIDENT", "SLIST0")], - Gramext.action (fun _ (loc : int * int) -> (false : 'e__1))]; - Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ (loc : int * int) -> (t : 'e__2))])], - Gramext.action - (fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1) - (loc : int * int) -> - (sslist loc min sep s : 'symbol))]]];; diff --git a/camlp4/ocaml_src/meta/pa_ifdef.ml b/camlp4/ocaml_src/meta/pa_ifdef.ml deleted file mode 100644 index 6384d6be1f..0000000000 --- a/camlp4/ocaml_src/meta/pa_ifdef.ml +++ /dev/null @@ -1,216 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -type 'a item_or_def = - SdStr of 'a - | SdDef of string - | SdUnd of string - | SdNop -;; - -let list_remove x l = - List.fold_right (fun e l -> if e = x then l else e :: l) l [] -;; - -let defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];; -let define x = defined := x :: !defined;; -let undef x = defined := list_remove x !defined;; - -Grammar.extend - (let _ = (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e) - and _ = (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e) - and _ = (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry Pcaml.expr) s - in - let def_undef_str : 'def_undef_str Grammar.Entry.e = - grammar_entry_create "def_undef_str" - and str_item_def_undef : 'str_item_def_undef Grammar.Entry.e = - grammar_entry_create "str_item_def_undef" - and def_undef_sig : 'def_undef_sig Grammar.Entry.e = - grammar_entry_create "def_undef_sig" - and sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e = - grammar_entry_create "sig_item_def_undef" - in - [Grammar.Entry.obj (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'Pcaml__expr)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); Gramext.Sself; - Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _ - (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'Pcaml__expr))]]; - Grammar.Entry.obj (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_str) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.StDcl (loc, []) - | SdUnd x -> undef x; MLast.StDcl (loc, []) - | SdNop -> MLast.StDcl (loc, []) : - 'Pcaml__str_item))]]; - Grammar.Entry.obj (def_undef_str : 'def_undef_str Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_str)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'str_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_str)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_str))]]; - Grammar.Entry.obj - (str_item_def_undef : 'str_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__str_item) (loc : int * int) -> - (SdStr si : 'str_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_str : 'def_undef_str Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_str) (loc : int * int) -> - (d : 'str_item_def_undef))]]; - Grammar.Entry.obj (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (x : 'def_undef_sig) (loc : int * int) -> - (match x with - SdStr si -> si - | SdDef x -> define x; MLast.SgDcl (loc, []) - | SdUnd x -> undef x; MLast.SgDcl (loc, []) - | SdNop -> MLast.SgDcl (loc, []) : - 'Pcaml__sig_item))]]; - Grammar.Entry.obj (def_undef_sig : 'def_undef_sig Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdUnd c : 'def_undef_sig)); - [Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (c : string) _ (loc : int * int) -> (SdDef c : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then SdNop else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e2 else e1 : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e1 : 'sig_item_def_undef) _ (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else SdNop : 'def_undef_sig)); - [Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", "then"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e)); - Gramext.Stoken ("", "else"); - Gramext.Snterm - (Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))], - Gramext.action - (fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _ - (c : string) _ (loc : int * int) -> - (if List.mem c !defined then e1 else e2 : 'def_undef_sig))]]; - Grammar.Entry.obj - (sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'Pcaml__sig_item) (loc : int * int) -> - (SdStr si : 'sig_item_def_undef)); - [Gramext.Snterm - (Grammar.Entry.obj - (def_undef_sig : 'def_undef_sig Grammar.Entry.e))], - Gramext.action - (fun (d : 'def_undef_sig) (loc : int * int) -> - (d : 'sig_item_def_undef))]]]);; - -Pcaml.add_option "-D" (Arg.String define) - "<string> Define for ifdef instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - "<string> Undefine for ifdef instruction.";; diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml deleted file mode 100644 index 599608f9fa..0000000000 --- a/camlp4/ocaml_src/meta/pa_macro.ml +++ /dev/null @@ -1,392 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE <uident> - DEFINE <uident> = <expression> - DEFINE <uident> (<parameters>) = <expression> - IFDEF <uident> THEN <structure_items> END - IFDEF <uident> THEN <structure_items> ELSE <structure_items> END - IFNDEF <uident> THEN <structure_items> END - IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END - - In expressions: - - IFDEF <uident> THEN <expression> ELSE <expression> END - IFNDEF <uident> THEN <expression> ELSE <expression> END - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF <uident> THEN <pattern> ELSE <pattern> END - IFNDEF <uident> THEN <pattern> ELSE <pattern> END - - As Camlp4 options: - - -D<uident> - -U<uident> - - After having used a DEFINE <uident> followed by "= <expression>", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -(* #load "pa_extend.cmo" *) -(* #load "q_MLast.cmo" *) - -open Pcaml;; - -type 'a item_or_def = - SdStr of 'a - | SdDef of string * (string list * MLast.expr) option - | SdUnd of string - | SdNop -;; - -let rec list_remove x = - function - (y, _) :: l when y = x -> l - | d :: l -> d :: list_remove x l - | [] -> [] -;; - -let defined = ref [];; - -let is_defined i = List.mem_assoc i !defined;; - -let loc = 0, 0;; - -let subst mloc env = - let rec loop = - function - MLast.ExLet (_, rf, pel, e) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExLet (loc, rf, pel, loop e) - | MLast.ExIfe (_, e1, e2, e3) -> - MLast.ExIfe (loc, loop e1, loop e2, loop e3) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2) - | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e -> - begin try MLast.ExAnt (loc, List.assoc x env) with - Not_found -> e - end - | MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExRec (loc, pel, None) - | e -> e - in - loop -;; - -let substp mloc env = - let rec loop = - function - MLast.ExApp (_, e1, e2) -> MLast.PaApp (loc, loop e1, loop e2) - | MLast.ExLid (_, x) -> - begin try MLast.PaAnt (loc, List.assoc x env) with - Not_found -> MLast.PaLid (loc, x) - end - | MLast.ExUid (_, x) -> - begin try MLast.PaAnt (loc, List.assoc x env) with - Not_found -> MLast.PaUid (loc, x) - end - | MLast.ExInt (_, x) -> MLast.PaInt (loc, x) - | MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let ppl = List.map (fun (p, e) -> p, loop e) pel in - MLast.PaRec (loc, ppl) - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") - in - loop -;; - -let incorrect_number loc l1 l2 = - Stdpp.raise_with_loc loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" (List.length l2) - (List.length l1))) -;; - -let define eo x = - begin match eo with - Some ([], e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (loc : int * int) -> - (Pcaml.expr_reloc (fun _ -> loc) 0 e : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (loc : int * int) -> - (let p = substp loc [] e in - Pcaml.patt_reloc (fun _ -> loc) 0 p : - 'patt))]]] - | Some (sl, e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'expr) _ (loc : int * int) -> - (let el = - match param with - MLast.ExTup (_, el) -> el - | e -> [e] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst loc env e in - Pcaml.expr_reloc (fun _ -> loc) 0 e - else incorrect_number loc el sl : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'patt) _ (loc : int * int) -> - (let pl = - match param with - MLast.PaTup (_, pl) -> pl - | p -> [p] - in - if List.length pl = List.length sl then - let env = List.combine sl pl in - let p = substp loc env e in - Pcaml.patt_reloc (fun _ -> loc) 0 p - else incorrect_number loc pl sl : - 'patt))]]] - | None -> () - end; - defined := (x, eo) :: !defined -;; - -let undef x = - try - let eo = List.assoc x !defined in - begin match eo with - Some ([], _) -> - Grammar.delete_rule expr [Gramext.Stoken ("UIDENT", x)]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x)] - | Some (_, _) -> - Grammar.delete_rule expr - [Gramext.Stoken ("UIDENT", x); Gramext.Sself]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x); Gramext.Sself] - | None -> () - end; - defined := list_remove x !defined - with - Not_found -> () -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let macro_def : 'macro_def Grammar.Entry.e = - grammar_entry_create "macro_def" - and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e = - grammar_entry_create "str_item_or_macro" - and opt_macro_value : 'opt_macro_value Grammar.Entry.e = - grammar_entry_create "opt_macro_value" - and uident : 'uident Grammar.Entry.e = grammar_entry_create "uident" in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (x : 'macro_def) (loc : int * int) -> - (match x with - SdStr [si] -> si - | SdStr sil -> MLast.StDcl (loc, sil) - | SdDef (x, eo) -> define eo x; MLast.StDcl (loc, []) - | SdUnd x -> undef x; MLast.StDcl (loc, []) - | SdNop -> MLast.StDcl (loc, []) : - 'str_item))]]; - Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d2 else d1 : 'macro_def)); - [Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then SdNop else d : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _ - (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d1 else d2 : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (d : 'str_item_or_macro) _ (i : 'uident) _ (loc : int * int) -> - (if is_defined i then d else SdNop : 'macro_def)); - [Gramext.Stoken ("", "UNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))], - Gramext.action - (fun (i : 'uident) _ (loc : int * int) -> (SdUnd i : 'macro_def)); - [Gramext.Stoken ("", "DEFINE"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (opt_macro_value : 'opt_macro_value Grammar.Entry.e))], - Gramext.action - (fun (def : 'opt_macro_value) (i : 'uident) _ (loc : int * int) -> - (SdDef (i, def) : 'macro_def))]]; - Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))], - Gramext.action - (fun (si : 'str_item list) (loc : int * int) -> - (SdStr si : 'str_item_or_macro)); - [Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (d : 'macro_def) (loc : int * int) -> - (d : 'str_item_or_macro))]]; - Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e), - None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'opt_macro_value)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Some ([], e) : 'opt_macro_value)); - [Gramext.Stoken ("", "("); - Gramext.Slist1sep - (Gramext.Stoken ("LIDENT", ""), Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ _ (pl : string list) _ (loc : int * int) -> - (Some (pl, e) : 'opt_macro_value))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then e2 else e1 : 'expr)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then e1 else e2 : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("LIDENT", "__LOCATION__")], - Gramext.action - (fun _ (loc : int * int) -> - (let bp = string_of_int (fst loc) in - let ep = string_of_int (snd loc) in - MLast.ExTup - (loc, [MLast.ExInt (loc, bp); MLast.ExInt (loc, ep)]) : - 'expr)); - [Gramext.Stoken ("LIDENT", "__FILE__")], - Gramext.action - (fun _ (loc : int * int) -> - (MLast.ExStr (loc, !(Pcaml.input_file)) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then p2 else p1 : 'patt)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (loc : int * int) -> - (if is_defined i then p1 else p2 : 'patt))]]; - Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (i : 'uident))]]]);; - -Pcaml.add_option "-D" (Arg.String (define None)) - "<string> Define for IFDEF instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - "<string> Undefine for IFDEF instruction.";; diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml deleted file mode 100644 index 013adfa8d6..0000000000 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ /dev/null @@ -1,2814 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Pcaml;; - -Pcaml.no_constructors_arity := false;; - -let help_sequences () = - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 -;; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit.";; - -let odfa = !(Plexer.dollar_for_antiquotation) in -Plexer.dollar_for_antiquotation := false; -Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); -Plexer.dollar_for_antiquotation := odfa; -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 type_declaration; -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;; - -Pcaml.parse_interf := Grammar.Entry.parse interf;; -Pcaml.parse_implem := Grammar.Entry.parse implem;; - -let o2b = - function - Some _ -> true - | None -> false -;; - -let mksequence loc = - function - [e] -> e - | el -> MLast.ExSeq (loc, el) -;; - -let mkmatchcase loc p aso w e = - let p = - match aso with - Some p2 -> MLast.PaAli (loc, p, p2) - | _ -> p - in - p, w, e -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin loc f arg = - match arg with - MLast.ExInt (_, n) -> MLast.ExInt (loc, neg_string n) - | MLast.ExInt32 (loc, n) -> MLast.ExInt32 (loc, neg_string n) - | MLast.ExInt64 (loc, n) -> MLast.ExInt64 (loc, neg_string n) - | MLast.ExNativeInt (loc, n) -> MLast.ExNativeInt (loc, neg_string n) - | MLast.ExFlo (_, n) -> MLast.ExFlo (loc, neg_string n) - | _ -> let f = "~" ^ f in MLast.ExApp (loc, MLast.ExLid (loc, f), arg) -;; - -let mklistexp loc last = - let rec loop top = - function - [] -> - begin match last with - Some e -> e - | None -> MLast.ExUid (loc, "[]") - end - | e1 :: el -> - let loc = if top then loc else fst (MLast.loc_of_expr e1), snd loc in - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), e1), loop false el) - in - loop true -;; - -let mklistpat loc last = - let rec loop top = - function - [] -> - begin match last with - Some p -> p - | None -> MLast.PaUid (loc, "[]") - end - | p1 :: pl -> - let loc = if top then loc else fst (MLast.loc_of_patt p1), snd loc in - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), p1), loop false pl) - in - loop true -;; - -let mkexprident loc i j = - let rec loop m = - function - MLast.ExAcc (_, x, y) -> loop (MLast.ExAcc (loc, m, x)) y - | e -> MLast.ExAcc (loc, m, e) - in - loop (MLast.ExUid (loc, i)) j -;; - -let mkassert loc e = - match e with - MLast.ExUid (_, "False") -> MLast.ExAsf loc - | _ -> MLast.ExAsr (loc, e) -;; - -let append_elem el e = el @ [e];; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -let ipatt = Grammar.Entry.create gram "ipatt";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let not_yet_warned_variant = ref true;; -let warn_variant loc = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned = ref true;; -let warn_sequence loc = - if !not_yet_warned then - begin - not_yet_warned := false; - !(Pcaml.warning) loc - "use of syntax of sequences deprecated since version 3.01.1" - end -;; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences.";; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__1))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__1 list) _ (loc : int * int) -> - (MLast.MeStr (loc, st) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> - (MLast.MeFun (loc, i, t, me) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) -> - (MLast.MeApp (loc, me1, me2) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) -> - (MLast.MeAcc (loc, me1, me2) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> - (MLast.MeTyc (loc, me, mt) : 'module_expr)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MeUid (loc, i) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (MLast.StExp (loc, e) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> - (MLast.StVal (loc, o2b r, l) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> - (MLast.StTyp (loc, tdl) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (MLast.StOpn (loc, i) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) -> - (MLast.StMty (loc, i, mt) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (nmtmes : 'module_rec_binding list) _ _ (loc : int * int) -> - (MLast.StRecMod (loc, nmtmes) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : string) _ (loc : int * int) -> - (MLast.StMod (loc, i, mb) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (MLast.StInc (loc, me) : 'str_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> - (MLast.StExt (loc, i, t, pd) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _ - (loc : int * int) -> - (MLast.StExc (loc, c, tl, b) : 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> (s : 'e__2))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__2 list) _ (loc : int * int) -> - (MLast.StDcl (loc, st) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> ([] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> - (MLast.MeTyc (loc, me, mt) : 'module_binding)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _ - (loc : int * int) -> - (MLast.MeFun (loc, m, mt, mb) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string) - (loc : int * int) -> - (m, mt, me : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _ - (loc : int * int) -> - (MLast.MtFun (loc, i, t, mt) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (wcl : 'with_constr list) _ (mt : 'module_type) - (loc : int * int) -> - (MLast.MtWit (loc, mt, wcl) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__3))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'e__3 list) _ (loc : int * int) -> - (MLast.MtSig (loc, sg) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) -> - (MLast.MtApp (loc, m1, m2) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) -> - (MLast.MtAcc (loc, m1, m2) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.MtQuo (loc, i) : 'module_type)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MtLid (loc, i) : 'module_type)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.MtUid (loc, i) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : string) _ (loc : int * int) -> - (MLast.SgVal (loc, i, t) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ (loc : int * int) -> - (MLast.SgTyp (loc, tdl) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (MLast.SgOpn (loc, i) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ (loc : int * int) -> - (MLast.SgMty (loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (mds : 'module_rec_declaration list) _ _ (loc : int * int) -> - (MLast.SgRecMod (loc, mds) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : string) _ (loc : int * int) -> - (MLast.SgMod (loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (MLast.SgInc (loc, mt) : 'sig_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (loc : int * int) -> - (MLast.SgExt (loc, i, t, pd) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (_, c, tl : 'constructor_declaration) _ (loc : int * int) -> - (MLast.SgExc (loc, c, tl) : 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> (s : 'e__4))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__4 list) _ (loc : int * int) -> - (MLast.SgDcl (loc, st) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _ - (loc : int * int) -> - (MLast.MtFun (loc, i, t, mt) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : string) (loc : int * int) -> - (m, mt : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> - (MLast.WcMod (loc, i, me) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'type_parameter list) (i : 'mod_ident) _ - (loc : int * int) -> - (MLast.WcTyp (loc, i, tpl, t) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExWhi (loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ (loc : int * int) -> - (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (loc : int * int) -> - (mksequence loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) -> - (MLast.ExIfe (loc, e1, e2, e3) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTry (loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTry (loc, e, l) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExMat (loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExMat (loc, e, l) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (loc : int * int) -> - (MLast.ExFun (loc, l) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _ - (loc : int * int) -> - (MLast.ExLmd (loc, m, mb, e) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _ - (loc : int * int) -> - (MLast.ExLet (loc, o2b r, l, x) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr) - (loc : int * int) -> - (MLast.ExLet (loc, o2b rf, [lb], e) : 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAss (loc, e1, e2) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "||"), e1), e2) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "&&"), e1), e2) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "!="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "=="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<>"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, ">"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "<"), e1), e2) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "@"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "^"), e1), e2) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "-"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "+"), e1), e2) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "mod"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lxor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "land"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "/"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "*"), e1), e2) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "lsl"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "asr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExLid (loc, "**"), e1), e2) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-." e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkumin loc "-" e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExLaz (loc, e) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (mkassert loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> - (MLast.ExApp (loc, e1, e2) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAcc (loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExSte (loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (MLast.ExAre (loc, e1, e2) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExApp (loc, MLast.ExLid (loc, "~-."), e) : 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (MLast.ExApp (loc, MLast.ExLid (loc, "~-"), e) : 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'expr list) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTup (loc, (e :: el)) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "()") : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _ - (loc : int * int) -> - (MLast.ExRec (loc, lel, Some e) : 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ (loc : int * int) -> - (MLast.ExRec (loc, lel, None) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'expr list) _ (loc : int * int) -> - (MLast.ExArr (loc, el) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'expr list) _ - (loc : int * int) -> - (mklistexp loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.ExUid (loc, "[]") : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExChr (loc, s) : 'expr)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExStr (loc, s) : 'expr)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExFlo (loc, s) : 'expr)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExNativeInt (loc, s) : 'expr)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt64 (loc, s) : 'expr)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt32 (loc, s) : 'expr)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.ExInt (loc, s) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) (loc : int * int) -> ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> - (e :: el : 'sequence)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5)); - [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__5))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _ - (loc : int * int) -> - ([MLast.ExLet (loc, o2b rf, l, mksequence loc el)] : 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (p, e : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (loc : int * int) -> - (mkmatchcase loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (Some e : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) -> - (i, e : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : string) (loc : int * int) -> - (mkexprident loc i j : 'expr_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExUid (loc, i) : 'expr_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLid (loc, i) : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) -> - (MLast.ExFun (loc, [p, None, e]) : 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaOrp (loc, p1, p2) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaRng (loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) -> - (MLast.PaApp (loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (MLast.PaAcc (loc, p1, p2) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patt list) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaAli (loc, p, p2) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_patt list) _ (loc : int * int) -> - (MLast.PaRec (loc, lpl) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'patt list) _ (loc : int * int) -> - (MLast.PaArr (loc, pl) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'patt list) _ - (loc : int * int) -> - (mklistpat loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "[]") : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaFlo (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaNativeInt (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt64 (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt32 (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) _ (loc : int * int) -> - (MLast.PaInt (loc, neg_string s) : 'patt)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaChr (loc, s) : 'patt)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaStr (loc, s) : 'patt)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaFlo (loc, s) : 'patt)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaNativeInt (loc, s) : 'patt)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt64 (loc, s) : 'patt)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt32 (loc, s) : 'patt)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaInt (loc, s) : 'patt)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaUid (loc, s) : 'patt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaLid (loc, s) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> (Some p : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> - (i, p : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> - (MLast.PaAcc (loc, p1, p2) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'patt_label_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaUid (loc, i) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.PaAny loc : 'ipatt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (MLast.PaLid (loc, s) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaTup (loc, (p :: pl)) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaAli (loc, p, p2) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> (MLast.PaUid (loc, "()") : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_ipatt list) _ (loc : int * int) -> - (MLast.PaRec (loc, lpl) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> - (i, p : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (cl : 'constrain list) (tk : 'ctyp) _ - (tpl : 'type_parameter list) (n : 'type_patt) (loc : int * int) -> - (n, tpl, tk, cl : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (n : string) (loc : int * int) -> (loc, n : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (t1, t2 : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (i, (false, true) : 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (i, (true, false) : 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (i, (false, false) : 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyMan (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyAli (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e))); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'typevar list) _ (loc : int * int) -> - (MLast.TyPol (loc, pl, t) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyArr (loc, t1, t2) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyOlb (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) (loc : int * int) -> - (MLast.TyLab (loc, i, t) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyApp (loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (MLast.TyAcc (loc, t1, t2) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'label_declaration list) _ (loc : int * int) -> - (MLast.TyRec (loc, false, ldl) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ (loc : int * int) -> - (MLast.TySum (loc, false, cdl) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'label_declaration list) _ _ (loc : int * int) -> - (MLast.TyRec (loc, true, ldl) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ _ (loc : int * int) -> - (MLast.TySum (loc, true, cdl) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.TyTup (loc, (t :: tl)) : 'ctyp)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.TyUid (loc, i) : 'ctyp)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.TyLid (loc, i) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action (fun _ (loc : int * int) -> (MLast.TyAny loc : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.TyQuo (loc, i) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (ci : string) (loc : int * int) -> - (loc, ci, [] : 'constructor_declaration)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "of"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cal : 'ctyp list) _ (ci : string) (loc : int * int) -> - (loc, ci, cal : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : string option) _ (i : string) - (loc : int * int) -> - (loc, i, o2b mf, t : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : string) (loc : int * int) -> - (i :: j : 'mod_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> - (MLast.StClt (loc, ctd) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_declaration list) _ (loc : int * int) -> - (MLast.StCls (loc, cd) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ (loc : int * int) -> - (MLast.SgClt (loc, ctd) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_description list) _ (loc : int * int) -> - (MLast.SgCls (loc, cd) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : string) (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> - (MLast.CeFun (loc, p, cfb) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> - (MLast.CeTyc (loc, ce, ct) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'type_parameter list) _ (loc : int * int) -> - (loc, tpl : 'class_type_parameters)); - [], - Gramext.action - (fun (loc : int * int) -> (loc, [] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) -> - (MLast.CeFun (loc, p, ce) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'let_binding list) - (rf : string option) _ (loc : int * int) -> - (MLast.CeLet (loc, o2b rf, lb, ce) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> - (MLast.CeFun (loc, p, ce) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> - (MLast.CeApp (loc, ce, e) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> - (MLast.CeTyc (loc, ce, ct) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ - (loc : int * int) -> - (MLast.CeStr (loc, cspo, cf) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) (loc : int * int) -> - (MLast.CeCon (loc, ci, []) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident) - (loc : int * int) -> - (MLast.CeCon (loc, ci, ctcl) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__6))])], - Gramext.action - (fun (cf : 'e__6 list) (loc : int * int) -> - (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (loc : int * int) -> - (MLast.CrIni (loc, se) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (MLast.CrCtr (loc, t1, t2) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label) - (pf : string option) _ (loc : int * int) -> - (MLast.CrMth (loc, l, o2b pf, e, topt) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> - (MLast.CrVir (loc, l, o2b pf, t) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _ - (loc : int * int) -> - (MLast.CrVal (loc, lab, o2b mf, e) : 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (pb : 'as_lident option) (ce : 'class_expr) _ - (loc : int * int) -> - (MLast.CrInh (loc, ce, pb) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> - (s : 'e__7))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__7 list) _ (loc : int * int) -> - (MLast.CrDcl (loc, st) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) _ (loc : int * int) -> (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, None, t) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, Some t, t2) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.ExTyc (loc, e, t) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action (fun (i : string) (loc : int * int) -> (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e))); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__8))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _ - (loc : int * int) -> - (MLast.CtSig (loc, cst, csf) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) (loc : int * int) -> - (MLast.CtCon (loc, id, []) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) (loc : int * int) -> - (MLast.CtCon (loc, id, tl) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) -> - (MLast.CtFun (loc, t, ct) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (MLast.CgCtr (loc, t1, t2) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ - (loc : int * int) -> - (MLast.CgMth (loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (loc : int * int) -> - (MLast.CgVir (loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ - (loc : int * int) -> - (MLast.CgVal (loc, l, o2b mf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (loc : int * int) -> - (MLast.CgInh (loc, cs) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> - (s : 'e__9))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__9 list) _ (loc : int * int) -> - (MLast.CgDcl (loc, st) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (loc : int * int) -> - ({MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> - (MLast.ExNew (loc, i) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> - (MLast.ExSnd (loc, e, lab) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'field_expr list) _ (loc : int * int) -> - (MLast.ExOvr (loc, fel) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, None, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExCoe (loc, e, Some t, t2) : 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - (l, e : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Sopt (Gramext.Stoken ("", "..")); Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (v : string option) (ml : 'field list) _ (loc : int * int) -> - (MLast.TyObj (loc, ml, o2b v) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ (loc : int * int) -> - (MLast.TyCls (loc, id) : 'ctyp))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : string) (loc : int * int) -> - (lab, t : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'clty_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : string) (loc : int * int) -> - (m :: l : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> ([i] : 'class_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : string) (loc : int * int) -> - (m :: l : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (rfl : 'row_field list) (loc : int * int) -> - (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (loc : int * int) -> (MLast.RfInh t : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); Gramext.Sopt (Gramext.Stoken ("", "&")); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _ - (loc : int * int) -> - (MLast.RfTag (i, o2b ao, l) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (MLast.RfTag (i, true, []) : 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ - (loc : int * int) -> - (MLast.PaOlb (loc, "", Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, None) : 'patt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, None) : 'patt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> - (MLast.PaTyp (loc, sl) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (MLast.PaVrn (loc, s) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ - (loc : int * int) -> - (MLast.PaOlb (loc, "", Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaOlb (loc, i, None) : 'ipatt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string) - (loc : int * int) -> - (MLast.PaOlb (loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, None) : 'ipatt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : string) (loc : int * int) -> - (MLast.PaLab (loc, i, Some p) : 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> - (MLast.PaTyc (loc, p, t) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, None) : 'expr)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExOlb (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, None) : 'expr)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) (loc : int * int) -> - (MLast.ExLab (loc, i, Some e) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (MLast.ExVrn (loc, s) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action (fun _ (loc : int * int) -> (false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action (fun _ (loc : int * int) -> (true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (MLast.TyVrn (loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (warn_variant loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__12))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__12 list) _ (e : 'expr) _ (loc : int * int) -> - (MLast.ExWhi (loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__11))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__11 list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ (loc : int * int) -> - (MLast.ExFor (loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__10))]); - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'e__10 list) _ (loc : int * int) -> - (MLast.ExSeq (loc, append_elem seq e) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_sequence loc : 'warning_sequence))]]]);; - -Grammar.extend - (let _ = (interf : 'interf Grammar.Entry.e) - and _ = (implem : 'implem Grammar.Entry.e) - and _ = (use_file : 'use_file Grammar.Entry.e) - and _ = (top_phrase : 'top_phrase Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry interf) s - in - let sig_item_semi : 'sig_item_semi Grammar.Entry.e = - grammar_entry_create "sig_item_semi" - and str_item_semi : 'str_item_semi Grammar.Entry.e = - grammar_entry_create "str_item_semi" - and phrase : 'phrase Grammar.Entry.e = grammar_entry_create "phrase" in - [Grammar.Entry.obj (interf : 'interf Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'interf)); - [Gramext.Snterm - (Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'interf) (si : 'sig_item_semi) - (loc : int * int) -> - (si :: sil, stopped : 'interf)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.SgDir (loc, n, dp), loc], true : 'interf))]]; - Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'sig_item) (loc : int * int) -> - (si, loc : 'sig_item_semi))]]; - Grammar.Entry.obj (implem : 'implem Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'implem)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'implem) (si : 'str_item_semi) - (loc : int * int) -> - (si :: sil, stopped : 'implem)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.StDir (loc, n, dp), loc], true : 'implem))]]; - Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'str_item) (loc : int * int) -> - (si, loc : 'str_item_semi))]]; - Grammar.Entry.obj (top_phrase : 'top_phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> (None : 'top_phrase)); - [Gramext.Snterm (Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e))], - Gramext.action - (fun (ph : 'phrase) (loc : int * int) -> (Some ph : 'top_phrase))]]; - Grammar.Entry.obj (use_file : 'use_file Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action (fun _ (loc : int * int) -> ([], false : 'use_file)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'use_file) _ (si : 'str_item) - (loc : int * int) -> - (si :: sil, stopped : 'use_file)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - ([MLast.StDir (loc, n, dp)], true : 'use_file))]]; - Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (sti : 'str_item) (loc : int * int) -> (sti : 'phrase)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ (loc : int * int) -> - (MLast.StDir (loc, n, dp) : 'phrase))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_expr_quotation loc x : - 'expr)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> 0, x - in - Pcaml.handle_expr_locate loc x : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_patt_quotation loc x : - 'patt)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (let x = - try - let i = String.index x ':' in - int_of_string (String.sub x 0 i), - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> 0, x - in - Pcaml.handle_patt_locate loc x : - 'patt))]]]);; diff --git a/camlp4/ocaml_src/meta/pa_rp.ml b/camlp4/ocaml_src/meta/pa_rp.ml deleted file mode 100644 index ad743e8708..0000000000 --- a/camlp4/ocaml_src/meta/pa_rp.ml +++ /dev/null @@ -1,641 +0,0 @@ -(* 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. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pcaml;; - -type spat_comp = - SpTrm of MLast.loc * MLast.patt * MLast.expr option - | SpNtr of MLast.loc * MLast.patt * MLast.expr - | SpStr of MLast.loc * MLast.patt -;; -type sexp_comp = - SeTrm of MLast.loc * MLast.expr - | SeNtr of MLast.loc * MLast.expr -;; - -let strm_n = "strm__";; -let peek_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "peek")) -;; -let junk_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "junk")) -;; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -let rec pattern_eq_expression p e = - match p, e with - MLast.PaLid (_, a), MLast.ExLid (_, b) -> a = b - | MLast.PaUid (_, a), MLast.ExUid (_, b) -> a = b - | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> false -;; - -let is_raise e = - match e with - MLast.ExApp (_, MLast.ExLid (_, "raise"), _) -> true - | _ -> false -;; - -let is_raise_failure e = - match e with - MLast.ExApp - (_, MLast.ExLid (_, "raise"), - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure"))) -> - true - | _ -> false -;; - -let rec handle_failure e = - match e with - MLast.ExTry - (_, te, - [MLast.PaAcc - (_, MLast.PaUid (_, "Stream"), MLast.PaUid (_, "Failure")), None, - e]) -> - handle_failure e - | MLast.ExMat (_, me, pel) -> - handle_failure me && - List.for_all - (function - _, None, e -> handle_failure e - | _ -> false) - pel - | MLast.ExLet (_, false, pel, e) -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | MLast.ExLid (_, _) | MLast.ExInt (_, _) | MLast.ExStr (_, _) | - MLast.ExChr (_, _) | MLast.ExFun (_, _) | MLast.ExUid (_, _) -> - true - | MLast.ExApp (_, MLast.ExLid (_, "raise"), e) -> - begin match e with - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure")) -> - false - | _ -> true - end - | MLast.ExApp (_, f, x) -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> false -and is_constr_apply = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false -;; - -let rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - MLast.ExLid (_, x) -> - let x = if x = v then strm_n else x in MLast.ExLid (loc, x) - | MLast.ExUid (_, _) -> e - | MLast.ExInt (_, _) -> e - | MLast.ExChr (_, _) -> e - | MLast.ExStr (_, _) -> e - | MLast.ExAcc (_, _, _) -> e - | MLast.ExLet (_, rf, pel, e) -> - MLast.ExLet (loc, rf, List.map (subst_pe v) pel, subst v e) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2) - | MLast.ExTup (_, el) -> MLast.ExTup (loc, List.map (subst v) el) - | _ -> raise Not_found -and subst_pe v (p, e) = - match p with - MLast.PaLid (_, v') when v <> v' -> p, subst v e - | _ -> raise Not_found -;; - -let stream_pattern_component skont ckont = - function - SpTrm (loc, p, wo) -> - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), wo, - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]); - MLast.PaAny loc, None, ckont]) - | SpNtr (loc, p, e) -> - let e = - match e with - MLast.ExFun - (_, - [MLast.PaTyc - (_, MLast.PaLid (_, v), - MLast.TyApp - (_, - MLast.TyAcc - (_, MLast.TyUid (_, "Stream"), MLast.TyLid (_, "t")), - MLast.TyAny _)), None, e]) - when v = strm_n -> - e - | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, strm_n)) - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise_failure ckont then - MLast.ExLet (loc, false, [p, e], skont) - else if - pattern_eq_expression - (MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p)) skont - then - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise ckont then - let tst = - if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - in - MLast.ExLet (loc, false, [p, tst], skont) - else - MLast.ExMat - (loc, - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, MLast.ExUid (loc, "None")]), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), None, skont; - MLast.PaAny loc, None, ckont]) - | SpStr (loc, p) -> - try - match p with - MLast.PaLid (_, v) -> subst v skont - | _ -> raise Not_found - with - Not_found -> - MLast.ExLet (loc, false, [p, MLast.ExLid (loc, strm_n)], skont) -;; - -let rec stream_pattern loc epo e ekont = - function - [] -> - begin match epo with - Some ep -> - MLast.ExLet - (loc, false, - [ep, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | _ -> e - end - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc -;; - -let stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p) in - let e = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - let skont = stream_pattern loc epo e ekont spcl in - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]) - in - p, w, e) - tspel - in - let pel = pel @ [MLast.PaAny loc, None, ekont ()] in - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), pel) -;; - -let rec group_terms = - function - ((SpTrm (loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel in - (p, w, loc, spcl, epo, e) :: tspel, spel - | spel -> [], spel -;; - -let rec parser_cases loc = - function - [] -> - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExUid (loc, "Failure"))) - | spel -> - match group_terms spel with - [], (spcl, epo, e) :: spel -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | tspel, spel -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel -;; - -let cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | None -> e - in - let p = - MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)) - in - MLast.ExFun (loc, [p, None, e]) -;; - -let cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - pc) - | None -> pc - in - match me with - MLast.ExLid (_, x) when x = strm_n -> e - | _ -> - MLast.ExLet - (loc, false, - [MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)), - me], - e) -;; - -(* streams *) - -let rec not_computing = - function - MLast.ExLid (_, _) | MLast.ExUid (_, _) | MLast.ExInt (_, _) | - MLast.ExFlo (_, _) | MLast.ExChr (_, _) | MLast.ExStr (_, _) -> - true - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -and is_cons_apply_not_computing = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -;; - -let slazy loc e = - match e with - MLast.ExApp (_, f, MLast.ExUid (_, "()")) -> - begin match f with - MLast.ExLid (_, _) -> f - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) - end - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) -;; - -let rec cstream gloc = - function - [] -> - let loc = gloc in - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "sempty")) - | [SeTrm (loc, e)] -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "ising")), - e) - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lsing")), - slazy loc e) - | SeTrm (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "icons")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "lcons")), - slazy loc e), - cstream gloc secl) - | [SeNtr (loc, e)] -> - if not_computing e then e - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "slazy")), - slazy loc e) - | SeNtr (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "iapp")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lapp")), - slazy loc e), - cstream gloc secl) -;; - -(* Syntax extensions in Revised Syntax grammar *) - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let parser_case : 'parser_case Grammar.Entry.e = - grammar_entry_create "parser_case" - and stream_patt : 'stream_patt Grammar.Entry.e = - grammar_entry_create "stream_patt" - and stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e = - grammar_entry_create "stream_patt_comp_err" - and stream_patt_comp : 'stream_patt_comp Grammar.Entry.e = - grammar_entry_create "stream_patt_comp" - and ipatt : 'ipatt Grammar.Entry.e = grammar_entry_create "ipatt" - and stream_expr_comp : 'stream_expr_comp Grammar.Entry.e = - grammar_entry_create "stream_expr_comp" - in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _ - (loc : int * int) -> - (cparser_match loc e po [pc] : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _ - (e : 'expr) _ (loc : int * int) -> - (cparser_match loc e po pcl : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ (loc : int * int) -> - (cparser loc po [pc] : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ - (loc : int * int) -> - (cparser loc po pcl : 'expr))]]; - Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Snterm - (Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e)); - Gramext.Stoken ("", ":]"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _ - (loc : int * int) -> - (sp, po, e : 'parser_case))]]; - Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> ([] : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Stoken ("", ";"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp) - (loc : int * int) -> - ((spc, None) :: sp : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))], - Gramext.action - (fun (spc : 'stream_patt_comp) (loc : int * int) -> - ([spc, None] : 'stream_patt))]]; - Grammar.Entry.obj - (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "?"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__1))])], - Gramext.action - (fun (eo : 'e__1 option) (spc : 'stream_patt_comp) - (loc : int * int) -> - (spc, eo : 'stream_patt_comp_err))]]; - Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (loc : int * int) -> - (SpStr (loc, p) : 'stream_patt_comp)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (p : 'patt) (loc : int * int) -> - (SpNtr (loc, p, e) : 'stream_patt_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "when"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__2))])], - Gramext.action - (fun (eo : 'e__2 option) (p : 'patt) _ (loc : int * int) -> - (SpTrm (loc, p, eo) : 'stream_patt_comp))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'ipatt))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ":]")], - Gramext.action - (fun _ (se : 'stream_expr_comp list) _ (loc : int * int) -> - (cstream loc se : 'expr))]]; - Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (SeNtr (loc, e) : 'stream_expr_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (SeTrm (loc, e) : 'stream_expr_comp))]]]);; diff --git a/camlp4/ocaml_src/meta/pr_dump.ml b/camlp4/ocaml_src/meta/pr_dump.ml deleted file mode 100644 index db42285310..0000000000 --- a/camlp4/ocaml_src/meta/pr_dump.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let open_out_file () = - match !(Pcaml.output_file) with - Some f -> open_out_bin f - | None -> set_binary_mode_out stdout true; stdout -;; - -let interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -let implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -Pcaml.print_interf := interf;; -Pcaml.print_implem := implem;; diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml deleted file mode 100644 index 70540af642..0000000000 --- a/camlp4/ocaml_src/meta/q_MLast.ml +++ /dev/null @@ -1,4700 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let gram = Grammar.gcreate (Plexer.gmake ());; - -module Qast = - struct - type t = - Node of string * t list - | List of t list - | Tuple of t list - | Option of t option - | Int of string - | Str of string - | Bool of bool - | Cons of t * t - | Apply of string * t list - | Record of (string * t) list - | Loc - | Antiquot of MLast.loc * string - ;; - let loc = 0, 0;; - let rec to_expr = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a)) - (MLast.ExAcc - (loc, MLast.ExUid (loc, "MLast"), MLast.ExUid (loc, n))) - al - | List al -> - List.fold_right - (fun a e -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a), - e)) - al (MLast.ExUid (loc, "[]")) - | Tuple al -> MLast.ExTup (loc, List.map to_expr al) - | Option None -> MLast.ExUid (loc, "None") - | Option (Some a) -> - MLast.ExApp (loc, MLast.ExUid (loc, "Some"), to_expr a) - | Int s -> MLast.ExInt (loc, s) - | Str s -> MLast.ExStr (loc, s) - | Bool true -> MLast.ExUid (loc, "True") - | Bool false -> MLast.ExUid (loc, "False") - | Cons (a1, a2) -> - MLast.ExApp - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "::"), to_expr a1), - to_expr a2) - | Apply (f, al) -> - List.fold_left (fun e a -> MLast.ExApp (loc, e, to_expr a)) - (MLast.ExLid (loc, f)) al - | Record lal -> MLast.ExRec (loc, List.map to_expr_label lal, None) - | Loc -> MLast.ExLid (loc, !(Stdpp.loc_name)) - | Antiquot (loc, s) -> - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) with - Stdpp.Exc_located ((bp, ep), exc) -> - raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc)) - in - MLast.ExAnt (loc, e) - and to_expr_label (l, a) = - MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)), - to_expr a - ;; - let rec to_patt = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.PaApp (loc, e, to_patt a)) - (MLast.PaAcc - (loc, MLast.PaUid (loc, "MLast"), MLast.PaUid (loc, n))) - al - | List al -> - List.fold_right - (fun a p -> - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a), - p)) - al (MLast.PaUid (loc, "[]")) - | Tuple al -> MLast.PaTup (loc, List.map to_patt al) - | Option None -> MLast.PaUid (loc, "None") - | Option (Some a) -> - MLast.PaApp (loc, MLast.PaUid (loc, "Some"), to_patt a) - | Int s -> MLast.PaInt (loc, s) - | Str s -> MLast.PaStr (loc, s) - | Bool true -> MLast.PaUid (loc, "True") - | Bool false -> MLast.PaUid (loc, "False") - | Cons (a1, a2) -> - MLast.PaApp - (loc, MLast.PaApp (loc, MLast.PaUid (loc, "::"), to_patt a1), - to_patt a2) - | Apply (_, _) -> failwith "bad pattern" - | Record lal -> MLast.PaRec (loc, List.map to_patt_label lal) - | Loc -> MLast.PaAny loc - | Antiquot (loc, s) -> - let p = - try Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) with - Stdpp.Exc_located ((bp, ep), exc) -> - raise (Stdpp.Exc_located ((fst loc + bp, fst loc + ep), exc)) - in - MLast.PaAnt (loc, p) - and to_patt_label (l, a) = - MLast.PaAcc (loc, MLast.PaUid (loc, "MLast"), MLast.PaLid (loc, l)), - to_patt a - ;; - end -;; - -let antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot ((shift + bp, shift + ep), x) -;; - -let sig_item = Grammar.Entry.create gram "signature item";; -let str_item = Grammar.Entry.create gram "structure item";; -let ctyp = Grammar.Entry.create gram "type";; -let patt = Grammar.Entry.create gram "pattern";; -let expr = Grammar.Entry.create gram "expression";; - -let module_type = Grammar.Entry.create gram "module type";; -let module_expr = Grammar.Entry.create gram "module expression";; - -let class_type = Grammar.Entry.create gram "class type";; -let class_expr = Grammar.Entry.create gram "class expr";; -let class_sig_item = Grammar.Entry.create gram "class signature item";; -let class_str_item = Grammar.Entry.create gram "class structure item";; - -let ipatt = Grammar.Entry.create gram "ipatt";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let a_list = Grammar.Entry.create gram "a_list";; -let a_opt = Grammar.Entry.create gram "a_opt";; -let a_UIDENT = Grammar.Entry.create gram "a_UIDENT";; -let a_LIDENT = Grammar.Entry.create gram "a_LIDENT";; -let a_INT = Grammar.Entry.create gram "a_INT";; -let a_FLOAT = Grammar.Entry.create gram "a_FLOAT";; -let a_STRING = Grammar.Entry.create gram "a_STRING";; -let a_CHAR = Grammar.Entry.create gram "a_CHAR";; -let a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";; -let a_LABEL = Grammar.Entry.create gram "a_LABEL";; -let a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";; -let a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";; - -let o2b = - function - Qast.Option (Some _) -> Qast.Bool true - | Qast.Option None -> Qast.Bool false - | x -> x -;; - -let mksequence _ = - function - Qast.List [e] -> e - | el -> Qast.Node ("ExSeq", [Qast.Loc; el]) -;; - -let mkmatchcase _ p aso w e = - let p = - match aso with - Qast.Option (Some p2) -> Qast.Node ("PaAli", [Qast.Loc; p; p2]) - | Qast.Option None -> p - | _ -> Qast.Node ("PaAli", [Qast.Loc; p; aso]) - in - Qast.Tuple [p; w; e] -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin _ f arg = - match arg with - Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) when int_of_string n > 0 -> - let n = neg_string n in Qast.Node ("ExInt", [Qast.Loc; Qast.Str n]) - | Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - when float_of_string n > 0.0 -> - let n = neg_string n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - | _ -> - match f with - Qast.Str f -> - let f = "~" ^ f in - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str f]); arg]) - | _ -> assert false -;; - -let mkuminpat _ f is_int s = - let s = - match s with - Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" - in - match is_int with - Qast.Bool true -> Qast.Node ("PaInt", [Qast.Loc; s]) - | Qast.Bool false -> Qast.Node ("PaFlo", [Qast.Loc; s]) - | _ -> assert false -;; - -let mklistexp _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (e1 :: el) -> - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExUid", [Qast.Loc; Qast.Str "::"]); - e1]); - loop false (Qast.List el)]) - | a -> a - in - loop true -;; - -let mklistpat _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (p1 :: pl) -> - Qast.Node - ("PaApp", - [Qast.Loc; - Qast.Node - ("PaApp", - [Qast.Loc; Qast.Node ("PaUid", [Qast.Loc; Qast.Str "::"]); - p1]); - loop false (Qast.List pl)]) - | a -> a - in - loop true -;; - -let mkexprident loc i j = - let rec loop m = - function - Qast.Node ("ExAcc", [_; x; y]) -> - loop (Qast.Node ("ExAcc", [Qast.Loc; m; x])) y - | e -> Qast.Node ("ExAcc", [Qast.Loc; m; e]) - in - loop (Qast.Node ("ExUid", [Qast.Loc; i])) j -;; - -let mkassert _ e = - match e with - Qast.Node ("ExUid", [_; Qast.Str "False"]) -> - Qast.Node ("ExAsf", [Qast.Loc]) - | _ -> Qast.Node ("ExAsr", [Qast.Loc; e]) -;; - -let append_elem el e = Qast.Apply ("@", [el; Qast.List [e]]);; - -let not_yet_warned_antiq = ref true;; -let warn_antiq loc vers = - if !not_yet_warned_antiq then - begin - not_yet_warned_antiq := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers) - end -;; - -let not_yet_warned_variant = ref true;; -let warn_variant _ = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) (0, 1) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned_seq = ref true;; -let warn_sequence _ = - if !not_yet_warned_seq then - begin - not_yet_warned_seq := false; - !(Pcaml.warning) (0, 1) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1") - end -;; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> - (s : 'e__1))])], - Gramext.action - (fun (a : 'e__1 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("MeFun", [Qast.Loc; i; t; me]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) (loc : int * int) -> - (Qast.Node ("MeApp", [Qast.Loc; me1; me2]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) (loc : int * int) -> - (Qast.Node ("MeAcc", [Qast.Loc; me1; me2]) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (loc : int * int) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("MeUid", [Qast.Loc; i]) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__3))])], - Gramext.action - (fun (a : 'e__3 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StTyp", [Qast.Loc; tdl]) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> - (Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : - 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (nmtmes : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : 'a_UIDENT) _ (loc : int * int) -> - (Qast.Node ("StMod", [Qast.Loc; i; mb]) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> - (Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _ - (loc : int * int) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 302, 19)) - in - Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : - 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) (loc : int * int) -> - (s : 'e__2))])], - Gramext.action - (fun (a : 'e__2 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StDcl", [Qast.Loc; st]) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action (fun (loc : int * int) -> (Qast.List [] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (loc : int * int) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (loc : int * int) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding)); - [Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _ - (loc : int * int) -> - (Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT) - (loc : int * int) -> - (Qast.Tuple [m; me; mt] : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself; Gramext.Stoken ("", ")"); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'with_constr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (wcl : 'a_list) _ (mt : 'module_type) (loc : int * int) -> - (Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__4))])], - Gramext.action - (fun (a : 'e__4 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'a_list) _ (loc : int * int) -> - (Qast.Node ("MtSig", [Qast.Loc; sg]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) (loc : int * int) -> - (Qast.Node ("MtApp", [Qast.Loc; m1; m2]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) (loc : int * int) -> - (Qast.Node ("MtAcc", [Qast.Loc; m1; m2]) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("MtQuo", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("MtLid", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgTyp", [Qast.Loc; tdl]) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (mds : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ (loc : int * int) -> - (Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ (loc : int * int) -> - (Qast.Node ("SgMod", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (loc : int * int) -> - (Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (ctl : 'constructor_declaration) _ (loc : int * int) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> - match () with - _ -> raise (Match_failure ("q_MLast.ml", 360, 19)) - in - Qast.Node ("SgExc", [Qast.Loc; c; tl]) : - 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) (loc : int * int) -> - (s : 'e__5))])], - Gramext.action - (fun (a : 'e__5 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT) - _ (loc : int * int) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (loc : int * int) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [m; mt] : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'a_list) (i : 'mod_ident) _ - (loc : int * int) -> - (Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (loc : int * int) -> - (mksequence Qast.Loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExIfe", [Qast.Loc; e1; e2; e3]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExTry", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTry", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExMat", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExMat", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _ - (loc : int * int) -> - (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__6))])], - Gramext.action - (fun (a : 'e__6 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__7))])], - Gramext.action - (fun (a : 'e__7 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr) - (loc : int * int) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) : - 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAss", [Qast.Loc; e1; e2]) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "||"]); - e1]); - e2]) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "&&"]); - e1]); - e2]) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "!="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "=="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<>"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<"]); - e1]); - e2]) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "@"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "^"]); - e1]); - e2]) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+"]); - e1]); - e2]) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "mod"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lxor"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lor"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "land"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*"]); - e1]); - e2]) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsl"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "asr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "**"]); - e1]); - e2]) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkumin Qast.Loc (Qast.Str "-.") e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkumin Qast.Loc (Qast.Str "-") e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (mkassert Qast.Loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExApp", [Qast.Loc; e1; e2]) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAcc", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExSte", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) (loc : int * int) -> - (Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]); - e]) : - 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]); - e]) : - 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (e : 'expr) _ (loc : int * int) -> (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTup", [Qast.Loc; Qast.Cons (e, el)]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ (loc : int * int) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'a_list) _ (loc : int * int) -> - (mklistexp Qast.Loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action (fun (i : 'expr_ident) (loc : int * int) -> (i : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (loc : int * int) -> - (Qast.Node ("ExChr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (loc : int * int) -> - (Qast.Node ("ExStr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (loc : int * int) -> - (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (loc : int * int) -> - (Qast.Node ("ExInt", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Option (Some e) : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) (loc : int * int) -> - (Qast.Cons (e, el) : 'sequence)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__8))])], - Gramext.action - (fun (a : 'e__8 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9)); - [Gramext.Stoken ("", "in")], - Gramext.action (fun (x : string) (loc : int * int) -> (x : 'e__9))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> - (Qast.List - [Qast.Node - ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] : - 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Tuple [p; e] : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (loc : int * int) -> - (mkmatchcase Qast.Loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some p) : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (Qast.Option (Some e) : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; e] : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : 'a_UIDENT) (loc : int * int) -> - (mkexprident Qast.Loc i j : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("ExUid", [Qast.Loc; i]) : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("ExLid", [Qast.Loc; i]) : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action (fun (e : 'expr) _ (loc : int * int) -> (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) (loc : int * int) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaOrp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaRng", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaApp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) (loc : int * int) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'a_list) _ (loc : int * int) -> - (mklistpat Qast.Loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) _ (loc : int * int) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) _ (loc : int * int) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (loc : int * int) -> - (Qast.Node ("PaChr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (loc : int * int) -> - (Qast.Node ("PaStr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (loc : int * int) -> - (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (loc : int * int) -> - (Qast.Node ("PaInt", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (loc : int * int) -> - (Qast.Option (Some p) : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; p] : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (loc : int * int) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; i]) : 'patt_label_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; i]) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ipatt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (p : 'ipatt) _ (loc : int * int) -> (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (loc : int * int) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_ipatt list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) (loc : int * int) -> - (Qast.Tuple [i; p] : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (a : 'constrain list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt) - (loc : int * int) -> - (Qast.Tuple [n; tpl; tk; cl] : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (n : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; n] : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Tuple [t1; t2] : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool true]] : - 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool true; Qast.Bool false]] : - 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool false]] : - 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyMan", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))], - Gramext.action - (fun (a : 'typevar list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyPol", [Qast.Loc; pl; t]) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_OPTLABEL) (loc : int * int) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyApp", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (loc : int * int) -> - (Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool false; ldl]) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TySum", [Qast.Loc; Qast.Bool false; cdl]) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("TyRec", [Qast.Loc; Qast.Bool true; ldl]) : 'ctyp)); - [Gramext.Stoken ("", "private"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'constructor_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("TySum", [Qast.Loc; Qast.Bool true; cdl]) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("TyTup", [Qast.Loc; Qast.Cons (t, tl)]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Node ("TyUid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (loc : int * int) -> - (Qast.Node ("TyAny", [Qast.Loc]) : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (ci : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; ci; Qast.List []] : - 'constructor_declaration)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cal : 'a_list) _ (ci : 'a_UIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__10))])], - Gramext.action - (fun (a : 'e__10 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action (fun (i : 'a_UIDENT) (loc : int * int) -> (i : 'ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (i, j) : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (loc : int * int) -> - (Qast.List [i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> - (Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (loc : int * int) -> - (Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_description list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (loc : int * int) -> - (Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__11))])], - Gramext.action - (fun (a : 'e__11 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i; - "ciExp", cfb] : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ (loc : int * int) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'type_parameter list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'a_list) _ (loc : int * int) -> - (Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters)); - [], - Gramext.action - (fun (loc : int * int) -> - (Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__12))])], - Gramext.action - (fun (a : 'e__12 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ (loc : int * int) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) (loc : int * int) -> - (Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ (loc : int * int) -> (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ (loc : int * int) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_patt option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) (loc : int * int) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) (loc : int * int) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__13))])], - Gramext.action - (fun (a : 'e__13 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (cf : 'a_list) (loc : int * int) -> (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (loc : int * int) -> (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (loc : int * int) -> - (Qast.Node ("CrIni", [Qast.Loc; se]) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__17))])], - Gramext.action - (fun (a : 'e__17 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'polyt option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__16))])], - Gramext.action - (fun (a : 'e__16 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> - (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__15))])], - Gramext.action - (fun (a : 'e__15 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _ - (loc : int * int) -> - (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (a : 'as_lident option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]], - Gramext.action - (fun (pb : 'a_opt) (ce : 'class_expr) _ (loc : int * int) -> - (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) (loc : int * int) -> - (s : 'e__14))])], - Gramext.action - (fun (a : 'e__14 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) _ (loc : int * int) -> (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action (fun (t : 'ctyp) _ (loc : int * int) -> (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_type option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__18))])], - Gramext.action - (fun (a : 'e__18 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (cst : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CtSig", [Qast.Loc; cst; csf]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) (loc : int * int) -> - (Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'a_list) _ (id : 'clty_longident) (loc : int * int) -> - (Qast.Node ("CtCon", [Qast.Loc; id; tl]) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (loc : int * int) -> (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ (loc : int * int) -> - (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__22))])], - Gramext.action - (fun (a : 'e__22 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__21))])], - Gramext.action - (fun (a : 'e__21 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ (loc : int * int) -> - (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__20))])], - Gramext.action - (fun (a : 'e__20 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ (loc : int * int) -> - (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (loc : int * int) -> - (Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) (loc : int * int) -> - (s : 'e__19))])], - Gramext.action - (fun (a : 'e__19 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (loc : int * int) -> - (Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__23))])], - Gramext.action - (fun (a : 'e__23 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", ct] : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__24))])], - Gramext.action - (fun (a : 'e__24 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) (loc : int * int) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", cs] : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ (loc : int * int) -> - (Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) (loc : int * int) -> - (Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field_expr list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) (loc : int * int) -> - (Qast.Tuple [l; e] : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "..")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__25))])], - Gramext.action - (fun (a : 'e__25 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (v : 'a_opt) (ml : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ (loc : int * int) -> - (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : 'a_LIDENT) (loc : int * int) -> - (Qast.Tuple [lab; t] : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'clty_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (m, l) : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (loc : int * int) -> - (Qast.List [i] : 'class_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : 'a_UIDENT) (loc : int * int) -> - (Qast.Cons (m, l) : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ - (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'row_field list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (rfl : 'a_list) (loc : int * int) -> (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (loc : int * int) -> - (Qast.Node ("RfInh", [t]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "&")], - Gramext.action - (fun (x : string) (loc : int * int) -> - (Qast.Str x : 'e__26))])], - Gramext.action - (fun (a : 'e__26 option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (a : 'ctyp list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("RfTag", [i; o2b ao; l]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> - (Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) : - 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (loc : int * int) -> (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (loc : int * int) -> - (Qast.Node ("PaTyp", [Qast.Loc; sl]) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action (fun (p : 'patt) (loc : int * int) -> (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) (loc : int * int) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (loc : int * int) -> (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (loc : int * int) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (loc : int * int) -> (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) (loc : int * int) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_OPTLABEL) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) (loc : int * int) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_LABEL) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_TILDEIDENT) (loc : int * int) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (loc : int * int) -> - (Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action - (fun _ (loc : int * int) -> (Qast.Bool true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _ - (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ (loc : int * int) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ (loc : int * int) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_variant Qast.Loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__29))])], - Gramext.action - (fun (a : 'e__29 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e : 'expr) _ (loc : int * int) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__28))])], - Gramext.action - (fun (a : 'e__28 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (loc : int * int) -> (e : 'e__27))])], - Gramext.action - (fun (a : 'e__27 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExSeq", [Qast.Loc; append_elem seq e]) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> - (warn_sequence Qast.Loc : 'warning_sequence))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "list" loc a : 'sequence))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'expr_ident))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'patt_label_ident))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "when")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "when" loc a : 'when_expr_opt))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'mod_ident))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'class_longident))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "to")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "to" loc a : 'direction_flag))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) (loc : int * int) -> - (cf : 'e__30))])], - Gramext.action - (fun (a : 'e__30 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csl : 'a_list) _ (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node - ("CeStr", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x, csl)]) : - 'class_expr)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node ("CeStr", [Qast.Loc; antiquot "" loc x; cf]) : - 'class_expr))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__32))])], - Gramext.action - (fun (a : 'e__32 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) _ (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node - ("CtSig", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" loc x, csf)]) : - 'class_type)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) (loc : int * int) -> - (csf : 'e__31))])], - Gramext.action - (fun (a : 'e__31 list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (x : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.05" in - Qast.Node ("CtSig", [Qast.Loc; antiquot "" loc x; csf]) : - 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" loc r; l; x]) : - 'expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("StVal", [Qast.Loc; antiquot "rec" loc r; l]) : - 'str_item))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) (loc : int * int) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (loc : int * int) -> (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _ - (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" loc r; lb; ce]) : - 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _ - (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" loc mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("ANTIQUOT", "as")], - Gramext.action - (fun (pb : string) (ce : 'class_expr) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" loc pb]) : - 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ (loc : int * int) -> - (let _ = warn_antiq loc "3.06+18" in - Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" loc mf; t]) : - 'class_sig_item))]]]);; - -Grammar.extend - (let _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry str_item) s - in - let dir_param : 'dir_param Grammar.Entry.e = - grammar_entry_create "dir_param" - in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ (loc : int * int) -> - (Qast.Node ("SgDir", [Qast.Loc; n; dp]) : 'sig_item))]]; - Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (loc : int * int) -> (Qast.Option None : 'dir_param)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (Qast.Option (Some e) : 'dir_param)); - [Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "opt" loc a : 'dir_param))]]]);; - -(* Antiquotations *) - -Grammar.extend - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'module_expr)); - [Gramext.Stoken ("ANTIQUOT", "mexp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "mexp" loc a : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'str_item)); - [Gramext.Stoken ("ANTIQUOT", "stri")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "stri" loc a : 'str_item))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'module_type)); - [Gramext.Stoken ("ANTIQUOT", "mtyp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "mtyp" loc a : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'sig_item)); - [Gramext.Stoken ("ANTIQUOT", "sigi")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "sigi" loc a : 'sig_item))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" loc a]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "exp")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "exp" loc a : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "pat" loc a : 'patt))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" loc a]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "pat" loc a : 'ipatt))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (loc : int * int) -> - (Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "typ")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "typ" loc a : 'ctyp))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_sig_item))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (loc : int * int) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) _ (loc : int * int) -> - (Qast.Node ("PaTyp", [Qast.Loc; a]) : 'patt))]]; - Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "list" loc a : 'a_list))]]; - Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "opt" loc a : 'a_opt))]]; - Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "uid")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "uid" loc a : 'a_UIDENT))]]; - Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> (Qast.Str i : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "lid")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "lid" loc a : 'a_LIDENT))]]; - Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "int")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "int" loc a : 'a_INT))]]; - Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "flo")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "flo" loc a : 'a_FLOAT))]]; - Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "" loc a : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "str")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "str" loc a : 'a_STRING))]]; - Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (loc : int * int) -> (antiquot "" loc a : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "chr")], - Gramext.action - (fun (a : string) (loc : int * int) -> - (antiquot "chr" loc a : 'a_CHAR))]]; - Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_TILDEIDENT)); - [Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (loc : int * int) -> - (antiquot "" loc a : 'a_TILDEIDENT))]]; - Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LABEL", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_LABEL))]]; - Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> - (Qast.Str s : 'a_QUESTIONIDENT)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (loc : int * int) -> - (antiquot "" loc a : 'a_QUESTIONIDENT))]]; - Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("OPTLABEL", "")], - Gramext.action - (fun (s : string) (loc : int * int) -> (Qast.Str s : 'a_OPTLABEL))]]];; - -let apply_entry e = - let f s = Grammar.Entry.parse e (Stream.of_string s) in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in Quotation.ExAst (expr, patt) -;; - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -Grammar.extend - [Grammar.Entry.obj (sig_item_eoi : 'sig_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'sig_item) (loc : int * int) -> (x : 'sig_item_eoi))]]]; -Quotation.add "sig_item" (apply_entry sig_item_eoi);; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -Grammar.extend - [Grammar.Entry.obj (str_item_eoi : 'str_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'str_item) (loc : int * int) -> (x : 'str_item_eoi))]]]; -Quotation.add "str_item" (apply_entry str_item_eoi);; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -Grammar.extend - [Grammar.Entry.obj (ctyp_eoi : 'ctyp_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'ctyp) (loc : int * int) -> (x : 'ctyp_eoi))]]]; -Quotation.add "ctyp" (apply_entry ctyp_eoi);; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -Grammar.extend - [Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (loc : int * int) -> (x : 'patt_eoi))]]]; -Quotation.add "patt" (apply_entry patt_eoi);; - -let expr_eoi = Grammar.Entry.create gram "expression" in -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (loc : int * int) -> (x : 'expr_eoi))]]]; -Quotation.add "expr" (apply_entry expr_eoi);; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -Grammar.extend - [Grammar.Entry.obj (module_type_eoi : 'module_type_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_type) (loc : int * int) -> - (x : 'module_type_eoi))]]]; -Quotation.add "module_type" (apply_entry module_type_eoi);; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -Grammar.extend - [Grammar.Entry.obj (module_expr_eoi : 'module_expr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_expr) (loc : int * int) -> - (x : 'module_expr_eoi))]]]; -Quotation.add "module_expr" (apply_entry module_expr_eoi);; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -Grammar.extend - [Grammar.Entry.obj (class_type_eoi : 'class_type_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_type) (loc : int * int) -> - (x : 'class_type_eoi))]]]; -Quotation.add "class_type" (apply_entry class_type_eoi);; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -Grammar.extend - [Grammar.Entry.obj (class_expr_eoi : 'class_expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_expr) (loc : int * int) -> - (x : 'class_expr_eoi))]]]; -Quotation.add "class_expr" (apply_entry class_expr_eoi);; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -Grammar.extend - [Grammar.Entry.obj - (class_sig_item_eoi : 'class_sig_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_sig_item) (loc : int * int) -> - (x : 'class_sig_item_eoi))]]]; -Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -Grammar.extend - [Grammar.Entry.obj - (class_str_item_eoi : 'class_str_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_str_item) (loc : int * int) -> - (x : 'class_str_item_eoi))]]]; -Quotation.add "class_str_item" (apply_entry class_str_item_eoi);; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -Grammar.extend - [Grammar.Entry.obj (with_constr_eoi : 'with_constr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'with_constr) (loc : int * int) -> - (x : 'with_constr_eoi))]]]; -Quotation.add "with_constr" (apply_entry with_constr_eoi);; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -Grammar.extend - [Grammar.Entry.obj (row_field_eoi : 'row_field_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'row_field) (loc : int * int) -> (x : 'row_field_eoi))]]]; -Quotation.add "row_field" (apply_entry row_field_eoi);; diff --git a/camlp4/ocaml_src/odyl/.cvsignore b/camlp4/ocaml_src/odyl/.cvsignore deleted file mode 100644 index 18deb61827..0000000000 --- a/camlp4/ocaml_src/odyl/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -odyl -odyl_config.ml diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend deleted file mode 100644 index b63c10b0b6..0000000000 --- a/camlp4/ocaml_src/odyl/.depend +++ /dev/null @@ -1,6 +0,0 @@ -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi -odyl.cmo: odyl_config.cmo odyl_main.cmi -odyl.cmx: odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile deleted file mode 100644 index bd59608b8e..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: odyl.cmxa odyl.cmx - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi - -include .depend diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac b/camlp4/ocaml_src/odyl/Makefile.Mac deleted file mode 100644 index 41b16d30e4..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# This file has been generated by program: do not edit! - -INCLUDES = -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} - -OBJS = odyl_config.cmo odyl_main.cmo - -all Ä odyl - -odyl Ä odyl.cma odyl.cmo - {OCAMLC} odyl.cma odyl.cmo -o odyl - -odyl.cma Ä {OBJS} - {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma - -odyl_config.cmo Ä - echo 'let standard_library =' > odyl_config.ml - echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml - echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml - {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml - -clean ÄÄ - delete -i odyl_config.ml odyl - -{dependrule} - -promote Ä $OutOfDate - -compare Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}" - duplicate -y odyl "{BINDIR}" - -{defrules} diff --git a/camlp4/ocaml_src/odyl/Makefile.Mac.depend b/camlp4/ocaml_src/odyl/Makefile.Mac.depend deleted file mode 100644 index adaff27755..0000000000 --- a/camlp4/ocaml_src/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml deleted file mode 100644 index 096e13eeb4..0000000000 --- a/camlp4/ocaml_src/odyl/odyl.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let apply_load () = - let i = ref 1 in - let stop = ref false in - while not !stop && !i < Array.length Sys.argv do - let s = Sys.argv.(!i) in - if s = "-I" && !i + 1 < Array.length Sys.argv then - begin Odyl_main.directory Sys.argv.(!i + 1); i := !i + 2 end - else if s = "-nolib" then begin Odyl_main.nolib := true; incr i end - else if s = "-where" then - begin - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - end - else if s = "--" then begin incr i; stop := true; () end - else if String.length s > 0 && s.[0] == '-' then stop := true - else if - Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - begin Odyl_main.loadfile s; incr i end - else stop := true - done -;; - -let main () = - try apply_load (); !(Odyl_main.go) () with - Odyl_main.Error (fname, str) -> - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 -;; - -Printexc.catch main ();; diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml deleted file mode 100644 index 22e5e65d93..0000000000 --- a/camlp4/ocaml_src/odyl/odyl_main.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let go = ref (fun () -> ());; -let name = ref "odyl";; - -let first_arg_no_load () = - let rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - loop (i + 1) - else i - else i - in - loop 1 -;; - -Arg.current := first_arg_no_load () - 1;; - -(* Load files in core *) - -let 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 = - function - [] -> 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 -;; - -exception Error of string * string;; - -let nolib = ref false;; -let initialized = ref false;; -let path = ref ([] : string list);; - -let loadfile file = - if not !initialized then - begin - begin Dynlink.init (); Dynlink.allow_unsafe_modules true end; - initialized := true - end; - let path = - if !nolib then !path else Odyl_config.standard_library :: !path - in - let fname = - try find_in_path (List.rev path) file with - Not_found -> raise (Error (file, "file not found in path")) - in - try Dynlink.loadfile fname with - Dynlink.Error e -> raise (Error (fname, Dynlink.error_message e)) -;; - -let directory d = path := d :: !path;; diff --git a/camlp4/ocaml_src/odyl/odyl_main.mli b/camlp4/ocaml_src/odyl/odyl_main.mli deleted file mode 100644 index be441a6c84..0000000000 --- a/camlp4/ocaml_src/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -exception Error of string * string;; - -val nolib : bool ref;; -val initialized : bool ref;; -val path : string list ref;; -val loadfile : string -> unit;; -val directory : string -> unit;; - -val go : (unit -> unit) ref;; -val name : string ref;; diff --git a/camlp4/ocaml_src/tools/camlp4_comm.mpw b/camlp4/ocaml_src/tools/camlp4_comm.mpw deleted file mode 100644 index ff837e7745..0000000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.mpw +++ /dev/null @@ -1,27 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set echo 0 - -exit if {#} < 1 - -if "{1}" =~ /(Å)¨0.mli/ - echo duplicate -y {1} {¨0}.ppi - duplicate -y "{1}" "{¨0}.ppi" -else if "{1}" =~ /(Å)¨0.ml/ - echo duplicate -y {1} {¨0}.ppo - duplicate -y "{1}" "{¨0}.ppo" -else - echo duplicate -y {1} {1}.ppo - duplicate -y "{1}" "{1}.ppo" -end diff --git a/camlp4/ocaml_src/tools/camlp4_comm.sh b/camlp4/ocaml_src/tools/camlp4_comm.sh deleted file mode 100755 index 357a929520..0000000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -if test "`basename $1 .mli`.mli" = "$1"; then - echo cp $1 `basename $1 .mli`.ppi - cp $1 `basename $1 .mli`.ppi -else - echo cp $1 `basename $1 .ml`.ppo - cp $1 `basename $1 .ml`.ppo -fi diff --git a/camlp4/ocaml_src/tools/extract_crc.mpw b/camlp4/ocaml_src/tools/extract_crc.mpw deleted file mode 100644 index 91dc4ddf9a..0000000000 --- a/camlp4/ocaml_src/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/ocaml_src/tools/extract_crc.sh b/camlp4/ocaml_src/tools/extract_crc.sh deleted file mode 100755 index e69de29bb2..0000000000 --- a/camlp4/ocaml_src/tools/extract_crc.sh +++ /dev/null diff --git a/camlp4/ocaml_src/tools/ocamlc.mpw b/camlp4/ocaml_src/tools/ocamlc.mpw deleted file mode 100644 index 7e594c03eb..0000000000 --- a/camlp4/ocaml_src/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib" {"parameters"} diff --git a/camlp4/ocaml_src/tools/ocamlc.sh b/camlp4/ocaml_src/tools/ocamlc.sh deleted file mode 100755 index ee654c2c6f..0000000000 --- a/camlp4/ocaml_src/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_src/tools/ocamlopt.sh b/camlp4/ocaml_src/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d670..0000000000 --- a/camlp4/ocaml_src/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend b/camlp4/ocaml_stuff/otherlibs/dynlink/.depend deleted file mode 100644 index e69de29bb2..0000000000 --- a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend +++ /dev/null diff --git a/camlp4/ocaml_stuff/parsing/.depend b/camlp4/ocaml_stuff/parsing/.depend deleted file mode 100644 index 4364f56e08..0000000000 --- a/camlp4/ocaml_stuff/parsing/.depend +++ /dev/null @@ -1,2 +0,0 @@ -location.cmi: ../utils/warnings.cmi -parsetree.cmi: asttypes.cmi location.cmi longident.cmi diff --git a/camlp4/ocaml_stuff/utils/.depend b/camlp4/ocaml_stuff/utils/.depend deleted file mode 100644 index 2804128851..0000000000 --- a/camlp4/ocaml_stuff/utils/.depend +++ /dev/null @@ -1,2 +0,0 @@ -config.cmo: config.cmi -config.cmx: config.cmi diff --git a/camlp4/ocpp/.cvsignore b/camlp4/ocpp/.cvsignore deleted file mode 100644 index baef26c63b..0000000000 --- a/camlp4/ocpp/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -ocpp -crc.ml diff --git a/camlp4/ocpp/.depend b/camlp4/ocpp/.depend deleted file mode 100644 index e69de29bb2..0000000000 --- a/camlp4/ocpp/.depend +++ /dev/null diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile deleted file mode 100644 index 60729e323c..0000000000 --- a/camlp4/ocpp/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../camlp4 -I ../boot -I ../odyl -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -OBJS=ocpp.cmo - -all: ocpp$(EXE) - -ocpp$(EXE): $(OBJS) - $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/quotation.cmo ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o ocpp$(EXE) - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak ocpp$(EXE) - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp ocpp$(EXE) "$(BINDIR)/." - -depend: diff --git a/camlp4/ocpp/Makefile.Mac b/camlp4/ocpp/Makefile.Mac deleted file mode 100644 index 5994a500c4..0000000000 --- a/camlp4/ocpp/Makefile.Mac +++ /dev/null @@ -1,41 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I ::odyl: -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} -OBJS = crc.cmo ocpp.cmo -INTERFACES = -I "{OLIBDIR}" Arg Array Callback Char Digest Filename Format ¶ - Gc Genlex Hashtbl Lexing List Map Obj Oo Parsing Pervasives ¶ - Printexc Printf Queue Random Set Sort Stack Stream String Sys ¶ - Weak -I ::boot: Gramext Grammar Plexer Stdpp Token -I ::camlp4: ¶ - MLast Quotation - -all Ä ocpp - -ocpp Ä {OBJS} - {OCAMLC} {LINKFLAGS} ::boot:stdpp.cmo ::camlp4:quotation.cmo ¶ - ::odyl:odyl.cma {OBJS} ::odyl:odyl.cmo -linkall -o ocpp - -clean ÄÄ - delete -i ocpp - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y {OBJS} "{P4LIBDIR}" - duplicate -y ocpp "{BINDIR}" - -depend Ä $OutOfDate - -{defrules} diff --git a/camlp4/ocpp/ocpp.ml b/camlp4/ocpp/ocpp.ml deleted file mode 100644 index afe517c0e5..0000000000 --- a/camlp4/ocpp/ocpp.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -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_buff len = String.sub buff.val 0 len; - -value rec copy_strip_locate cs = - match cs with parser - [ [: `'$' :] -> maybe_locate cs - | [: `c :] -> do { print_char c; copy_strip_locate cs } - | [: :] -> () ] -and maybe_locate cs = - match cs with parser - [ [: `'1'..'9' :] -> locate cs - | [: :] -> do { print_char '$'; copy_strip_locate cs } ] -and locate cs = - match cs with parser - [ [: `'0'..'9' :] -> locate cs - | [: `':' :] -> inside_locate cs - | [: :] -> raise (Stream.Error "colon char expected") ] -and inside_locate cs = - match cs with parser - [ [: `'$' :] -> copy_strip_locate cs - | [: `'\\'; `c :] -> do { print_char c; inside_locate cs } - | [: `c :] -> do { print_char c; inside_locate cs } - | [: :] -> raise (Stream.Error "end of file in locate directive") ] -; - -value quot name pos str = - let exp = - try - match Quotation.find name with - [ Quotation.ExStr f -> f - | _ -> raise Not_found ] - with - [ Not_found -> - Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ] - in - let new_str = - try exp True str with - [ Stdpp.Exc_located (p1, p2) exc -> - Stdpp.raise_with_loc (pos + p1, pos + p2) exc - | exc -> Stdpp.raise_with_loc (pos, pos + String.length str) exc ] - in - let cs = Stream.of_string new_str in copy_strip_locate cs -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] -> - ident (store len c) s - | [: :] -> get_buff len ] -; - -value rec copy cs = - match cs with parser - [ [: `'<' :] -> maybe_quot cs - | [: `'"' :] -> do { print_char '"'; inside_string cs } - | [: `c :] -> do { print_char c; copy cs } - | [: :] -> () ] -and maybe_quot cs = - match cs with parser - [ [: `'<' :] ep -> inside_quot "" ep 0 cs - | [: `':'; i = ident 0; `'<' ? "less char expected" :] ep -> - inside_quot i ep 0 cs - | [: :] -> do { print_char '<'; copy cs } ] -and inside_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> maybe_end_quot name pos len cs - | [: `c :] -> inside_quot name pos (store len c) cs - | [: :] -> raise (Stream.Error "end of file in quotation") ] -and maybe_end_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> do { quot name pos (get_buff len); copy cs } - | [: :] -> inside_quot name pos (store len '>') cs ] -and inside_string cs = - match cs with parser - [ [: `'"' :] -> do { print_char '"'; copy cs } - | [: `c :] -> do { print_char c; inside_string cs } - | [: :] -> raise (Stream.Error "end of file in string") ] -; - -value copy_quot cs = do { copy cs; flush stdout; }; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc file = - let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in - do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; } -; - -value file = ref ""; -Arg.parse [] (fun x -> file.val := x) "ocpp <objects> <file>"; - -value main () = - try - if file.val <> "" then - copy_quot (Stream.of_channel (open_in_bin file.val)) - else () - with exc -> - do { - print_newline (); - flush stdout; - let exc = - match exc with - [ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc } - | exc -> exc ] - in - raise exc - } -; - -Odyl_main.name.val := "ocpp"; -Odyl_main.go.val := main; diff --git a/camlp4/odyl/.cvsignore b/camlp4/odyl/.cvsignore deleted file mode 100644 index 8ae0ebb068..0000000000 --- a/camlp4/odyl/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.cm[oia] -odyl -*.lib -odyl_config.ml diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend deleted file mode 100644 index b63c10b0b6..0000000000 --- a/camlp4/odyl/.depend +++ /dev/null @@ -1,6 +0,0 @@ -odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \ - odyl_main.cmi -odyl_main.cmx: odyl_config.cmx \ - odyl_main.cmi -odyl.cmo: odyl_config.cmo odyl_main.cmi -odyl.cmx: odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile deleted file mode 100644 index 73dc854e6f..0000000000 --- a/camlp4/odyl/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -# $Id$ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: odyl.cmxa odyl.cmx - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE) - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi - -include .depend diff --git a/camlp4/odyl/Makefile.Mac b/camlp4/odyl/Makefile.Mac deleted file mode 100644 index 9814cec67e..0000000000 --- a/camlp4/odyl/Makefile.Mac +++ /dev/null @@ -1,49 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I "{OTOP}otherlibs:dynlink:" -OCAMLCFLAGS = {INCLUDES} -LINKFLAGS = {INCLUDES} - -OBJS = odyl_config.cmo odyl_main.cmo - -all Ä odyl - -odyl Ä odyl.cma odyl.cmo - {OCAMLC} odyl.cma odyl.cmo -o odyl - -odyl.cma Ä {OBJS} - {OCAMLC} {LINKFLAGS} dynlink.cma {OBJS} -a -o odyl.cma - -odyl_config.cmo Ä - echo 'let standard_library =' > odyl_config.ml - echo ' try Sys.getenv "CAMLP4LIB" with' >> odyl_config.ml - echo ' Not_found -> "'{P4LIBDIR}'"' >> odyl_config.ml - {OCAMLC} {OCAMLCFLAGS} -c odyl_config.ml - -clean ÄÄ - delete -i odyl_config.ml odyl - -{dependrule} - -promote Ä $OutOfDate - -compare Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - (newfolder "{BINDIR}" || set status 0) ³ dev:null - duplicate -y odyl.cmo odyl.cma "{P4LIBDIR}" - duplicate -y odyl "{BINDIR}" - -{defrules} diff --git a/camlp4/odyl/Makefile.Mac.depend b/camlp4/odyl/Makefile.Mac.depend deleted file mode 100644 index adaff27755..0000000000 --- a/camlp4/odyl/Makefile.Mac.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl_main.cmoÄ odyl_config.cmo odyl_main.cmi -odyl_main.cmxÄ odyl_config.cmx odyl_main.cmi -odyl.cmoÄ odyl_config.cmo odyl_main.cmi -odyl.cmxÄ odyl_config.cmx odyl_main.cmx diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml deleted file mode 100644 index 0bd4b17473..0000000000 --- a/camlp4/odyl/odyl.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value apply_load () = - let i = ref 1 in - let stop = ref False in - while not stop.val && i.val < Array.length Sys.argv do { - let s = Sys.argv.(i.val) in - if s = "-I" && i.val + 1 < Array.length Sys.argv then do { - Odyl_main.directory Sys.argv.(i.val + 1); - i.val := i.val + 2 - } - else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i } - else if s = "-where" then do { - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - } - else if s = "--" then do { incr i; stop.val := True; () } - else if String.length s > 0 && s.[0] == '-' then stop.val := True - else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then do { Odyl_main.loadfile s; incr i } - else stop.val := True - } -; - -value main () = - try do { apply_load () ; Odyl_main.go.val () } with - [ Odyl_main.Error fname str -> - do { - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 - } ] -; - -Printexc.catch main (); diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml deleted file mode 100644 index c0996568d0..0000000000 --- a/camlp4/odyl/odyl_main.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -value go = ref (fun () -> ()); -value name = ref "odyl"; - -value first_arg_no_load () = - loop 1 where rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - [ "-I" -> loop (i + 2) - | "-nolib" -> loop (i + 1) - | "-where" -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" - || Filename.check_suffix s ".cma" then loop (i + 1) - else i ] - else i -; - -Arg.current.val := first_arg_no_load () - 1; - -(* Load files in core *) - -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 -; - -exception Error of string and string; - -value nolib = ref False; -value initialized = ref False; -value path = ref ([] : list string); - -value loadfile file = - IFDEF OPT THEN - raise (Error file "native-code program cannot do a dynamic load") - ELSE do { - if not initialized.val then do { - IFDEF OPT THEN () - ELSE do { Dynlink.init (); Dynlink.allow_unsafe_modules True } - END; - initialized.val := True - } - else (); - let path = - if nolib.val then path.val - else [Odyl_config.standard_library :: path.val] - in - let fname = - try find_in_path (List.rev path) file with - [ Not_found -> raise (Error file "file not found in path") ] - in - try Dynlink.loadfile fname with - [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] - } - END -; - -value directory d = path.val := [d :: path.val]; diff --git a/camlp4/odyl/odyl_main.mli b/camlp4/odyl/odyl_main.mli deleted file mode 100644 index db47805370..0000000000 --- a/camlp4/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* $Id$ *) - -exception Error of string and string; - -value nolib : ref bool; -value initialized : ref bool; -value path : ref (list string); -value loadfile : string -> unit; -value directory : string -> unit; - -value go : ref (unit -> unit); -value name : ref string; diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh deleted file mode 100755 index 078b1d501e..0000000000 --- a/camlp4/tools/apply.sh +++ /dev/null @@ -1,31 +0,0 @@ -#!/bin/sh -# $Id$ - -ARGS1= -FILE= -while test "" != "$1"; do - case $1 in - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - - - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="../boot/$2 -nolib -I ../boot -I ../etc" - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -else - COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo" - ARGS2= -fi - -OTOP=../.. -echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2 -$OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE diff --git a/camlp4/tools/camlp4_comm.mpw b/camlp4/tools/camlp4_comm.mpw deleted file mode 100644 index 274bead93d..0000000000 --- a/camlp4/tools/camlp4_comm.mpw +++ /dev/null @@ -1,53 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -set echo 0 - -exit if {#} < 1 - -set args1 "" -set file "" -loop - break if {#} == 0 - if "{1}" =~ /Å.mlÅ/ - set file "{1}" - else - set args1 "{args1} `quote "{1}"`" - end - shift -end - -set firstline "`streamedit -e '1 exit' "{file}"`" ³ dev:null || set status 0 - -if "{firstline}" =~ /[Â ]+ camlp4r (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4r -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{firstline}" =~ /[Â ]+ camlp4 (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4 -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{file}" =~ /(Å)¨0.mli/ - echo duplicate -y {file} {¨0}.ppi - duplicate -y "{file}" "{¨0}.ppi" -else if "{file}" =~ /(Å)¨0.ml/ - echo duplicate -y {file} {¨0}.ppo - duplicate -y "{file}" "{¨0}.ppo" -else - echo duplicate -y {file} {file}.ppo - duplicate -y "{file}" "{file}.ppo" -end diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh deleted file mode 100755 index b6bb8f87ed..0000000000 --- a/camlp4/tools/camlp4_comm.sh +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -# $Id$ - -ARGS1= -FILE= -QUIET=no -while test "" != "$1"; do - case $1 in - -q) QUIET=yes;; - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" - if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM="$OTOP/boot/$COMM" - fi - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -# ARGS1="$ARGS1 -verbose" - if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi - $COMM $ARGS2 $ARGS1 $FILE -else - if test "`basename $FILE .mli`.mli" = "$FILE"; then - OFILE=`basename $FILE .mli`.ppi - else - OFILE=`basename $FILE .ml`.ppo - fi - if test "$QUIET" = "no"; then echo cp $FILE $OFILE; fi - cp $FILE $OFILE -fi diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh deleted file mode 100755 index 64a4e2b1d3..0000000000 --- a/camlp4/tools/conv.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh -DIR=`expr "$0" : "\(.*\)/.*" "|" "."` - -INCL= -FILE= -while test "" != "$1"; do - case $1 in - -I) INCL="$INCL -I $2"; shift;; - *) FILE=$1;; - esac - shift -done - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" - shift; shift - ARGS=`echo $* | sed -e "s/[()*]//g"` - $COMM $ARGS -ss $FILE -else - cat $FILE -fi diff --git a/camlp4/tools/extract_crc.mpw b/camlp4/tools/extract_crc.mpw deleted file mode 100644 index 91dc4ddf9a..0000000000 --- a/camlp4/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh deleted file mode 100755 index e69de29bb2..0000000000 --- a/camlp4/tools/extract_crc.sh +++ /dev/null diff --git a/camlp4/tools/ocamlc.mpw b/camlp4/tools/ocamlc.mpw deleted file mode 100644 index 6e21e9bf19..0000000000 --- a/camlp4/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id$ - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib:" {"parameters"} diff --git a/camlp4/tools/ocamlc.sh b/camlp4/tools/ocamlc.sh deleted file mode 100755 index ee654c2c6f..0000000000 --- a/camlp4/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/tools/ocamlopt.sh b/camlp4/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d670..0000000000 --- a/camlp4/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/top/.cvsignore b/camlp4/top/.cvsignore deleted file mode 100644 index df1824f495..0000000000 --- a/camlp4/top/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.cm[oia] diff --git a/camlp4/top/.depend b/camlp4/top/.depend deleted file mode 100644 index d7aebc7bc5..0000000000 --- a/camlp4/top/.depend +++ /dev/null @@ -1,14 +0,0 @@ -camlp4_top.cmo: ../camlp4/ast2pt.cmi ../camlp4/mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/toplevel/topdirs.cmi $(OTOP)/toplevel/toploop.cmi \ - $(OTOP)/utils/warnings.cmi -camlp4_top.cmx: ../camlp4/ast2pt.cmx ../camlp4/mLast.cmi \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/pcaml.cmx \ - $(OTOP)/toplevel/topdirs.cmx $(OTOP)/toplevel/toploop.cmx \ - $(OTOP)/utils/warnings.cmx -oprint.cmo: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmi -oprint.cmx: $(OTOP)/typing/outcometree.cmi $(OTOP)/toplevel/toploop.cmx -rprint.cmo: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/toplevel/toploop.cmi -rprint.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/toplevel/toploop.cmx diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile deleted file mode 100644 index 4ea4e46bc2..0000000000 --- a/camlp4/top/Makefile +++ /dev/null @@ -1,52 +0,0 @@ -# $Id$ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/typing -I $(OTOP)/toplevel -OCAMLCFLAGS=-warn-error A $(INCLUDES) - -CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/ast2pt.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo -TOP=camlp4_top.cmo -ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP) -SOBJS=$(CAMLP4_OBJS) ../etc/pa_scheme.cmo $(TOP) -OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP) -OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP) -OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/ast2pt.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo camlp4_top.cmo - -TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma - -all: $(TARGET) - -camlp4oo.cma: $(OOOBJS) - $(OCAMLC) $(OOOBJS) -linkall -a -o camlp4oo.cma - -camlp4o.cma: $(OOBJS) - $(OCAMLC) $(OOBJS) -linkall -a -o camlp4o.cma - -camlp4r.cma: $(ROBJS) - $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma - -camlp4sch.cma: $(SOBJS) - $(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma - -camlp4_top.cma: $(OBJS) - $(OCAMLC) $(OBJS) -a -o camlp4_top.cma - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) "$(LIBDIR)/camlp4/." - -include .depend diff --git a/camlp4/top/Makefile.Mac b/camlp4/top/Makefile.Mac deleted file mode 100644 index bb2aa44506..0000000000 --- a/camlp4/top/Makefile.Mac +++ /dev/null @@ -1,60 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id$ - -INCLUDES = -I ::camlp4: -I ::boot: -I "{OTOP}utils:" -I "{OTOP}parsing:" ¶ - -I "{OTOP}typing:" -I "{OTOP}toplevel:" -OCAMLCFLAGS = {INCLUDES} - -CAMLP4_OBJS = "{OTOP}utils:config.cmo" ::boot:stdpp.cmo ::boot:token.cmo ¶ - ::boot:plexer.cmo ¶ - ::boot:gramext.cmo ::boot:grammar.cmo ::boot:extfold.cmo ::boot:extfun.cmo ¶ - ::boot:fstream.cmo ¶ - ::camlp4:quotation.cmo ¶ - ::camlp4:ast2pt.cmo ::camlp4:reloc.cmo ::camlp4:spretty.cmo ¶ - ::camlp4:pcaml.cmo -TOP = camlp4_top.cmo -ROBJS = {CAMLP4_OBJS} ::meta:pa_r.cmo ::meta:pa_rp.cmo rprint.cmo {TOP} -OOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_op.cmo {TOP} -OOOBJS = {CAMLP4_OBJS} ::etc:pa_o.cmo ::etc:pa_oop.cmo {TOP} -OBJS = "{OTOP}utils:config.cmo" ::camlp4:quotation.cmo ::camlp4:reloc.cmo ¶ - ::camlp4:ast2pt.cmo ::camlp4:spretty.cmo ¶ - ::camlp4:pcaml.cmo camlp4_top.cmo - -TARGETS = camlp4o.cma camlp4r.cma camlp4_top.cma - -all Ä {TARGETS} - -camlp4oo.cma Ä {OOOBJS} - {OCAMLC} {OOOBJS} -linkall -a -o camlp4oo.cma - -camlp4o.cma Ä {OOBJS} - {OCAMLC} {OOBJS} -linkall -a -o camlp4o.cma - -camlp4r.cma Ä {ROBJS} - {OCAMLC} {ROBJS} -linkall -a -o camlp4r.cma - -camlp4_top.cma Ä {OBJS} - {OCAMLC} {OBJS} -a -o camlp4_top.cma - -clean ÄÄ - delete -i {TARGETS} - -{dependrule} - -get_promote Ä $OutOfDate - -install Ä - (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null - duplicate -y {TARGETS} "{P4LIBDIR}" - -{defrules} diff --git a/camlp4/top/Makefile.Mac.depend b/camlp4/top/Makefile.Mac.depend deleted file mode 100644 index 6b7096dadb..0000000000 --- a/camlp4/top/Makefile.Mac.depend +++ /dev/null @@ -1,2 +0,0 @@ -camlp4_top.cmoÄ ::camlp4:ast2pt.cmo ::camlp4:mLast.cmi ::camlp4:pcaml.cmi -camlp4_top.cmxÄ ::camlp4:ast2pt.cmx ::camlp4:mLast.cmi ::camlp4:pcaml.cmx diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml deleted file mode 100644 index 4d0d12f785..0000000000 --- a/camlp4/top/camlp4_top.ml +++ /dev/null @@ -1,172 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Parsetree; -open Lexing; -open Stdpp; - -value highlight_locations lb loc1 loc2 = - try - let pos0 = - lb.lex_abs_pos in - do { - if pos0 < 0 then raise Exit else (); - let pos_at_bol = ref 0 in - print_string "Toplevel input:\n# "; - for pos = 0 to lb.lex_buffer_len - pos0 - 1 do { - let c = lb.lex_buffer.[pos + pos0] in - if c = '\n' then do { - if pos_at_bol.val <= fst loc1 && snd loc1 <= pos then do { - print_string "\n "; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char ' ' }; - for i = fst loc1 to snd loc1 - 1 do { print_char '^' }; - print_char '\n' - } - else if pos_at_bol.val <= fst loc1 && fst loc1 < pos then do { - print_char '\r'; - print_char (if pos_at_bol.val = 0 then '#' else ' '); - print_char ' '; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char '.' }; - print_char '\n' - } - else if pos_at_bol.val <= snd loc1 && snd loc1 < pos then do { - for i = pos - 1 downto snd loc1 do { print_string "\008.\008" }; - print_char '\n' - } - else print_char '\n'; - pos_at_bol.val := pos + 1; - if pos < lb.lex_buffer_len - pos0 - 1 then - print_string " " - else () - } - else print_char c - }; - flush stdout - } - with - [ Exit -> () ] -; - -value print_location lb loc = - if String.length Toploop.input_name.val = 0 then - highlight_locations lb loc (-1, -1) - else Toploop.print_location Format.err_formatter (Ast2pt.mkloc loc) -; - -value wrap f shfn lb = - let cs = - let shift = shfn lb in - Stream.from - (fun i -> - if i < shift then Some ' ' - else do { - while - lb.lex_curr_pos >= lb.lex_buffer_len && - not lb.lex_eof_reached - do { - lb.refill_buff lb - }; - if lb.lex_curr_pos >= lb.lex_buffer_len then None - else do { - let c = lb.lex_buffer.[lb.lex_curr_pos] in - lb.lex_curr_pos := lb.lex_curr_pos + 1; - Some c - } - }) - in - try f cs with - [ Exc_located _ (Sys.Break as x) -> raise x - | End_of_file as x -> raise x - | x -> - let x = - match x with - [ Exc_located loc x -> do { print_location lb loc; x } - | x -> x ] - in - do { - match x with - [ Stream.Failure | Stream.Error _ -> Pcaml.sync.val cs - | _ -> () ]; - Format.open_hovbox 0; - Pcaml.report_error x; - Format.close_box (); - Format.print_newline (); - raise Exit - } ] -; - -value first_phrase = ref True; - -value toplevel_phrase cs = - do { - if Sys.interactive.val && first_phrase.val then do { - first_phrase.val := False; - Printf.eprintf "\tCamlp4 Parsing version %s\n\n" Pcaml.version; - flush stderr; - } - else (); - match Grammar.Entry.parse Pcaml.top_phrase cs with - [ Some phr -> Ast2pt.phrase phr - | None -> raise End_of_file ]; - } -; - -value use_file cs = - let v = Pcaml.input_file.val in - do { - Pcaml.input_file.val := Toploop.input_name.val; - let restore () = Pcaml.input_file.val := v in - try - let (pl0, eoi) = - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then - match pl with - [ [MLast.StDir _ "load" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_load Format.std_formatter s; loop () } - | [MLast.StDir _ "directory" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_directory s; loop () } - | _ -> (pl, False) ] - else (pl, True) - in - let pl = - if eoi then [] - else - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then pl @ loop () else pl - in - let r = pl0 @ pl in - let r = List.map Ast2pt.phrase r in - do { restore (); r } - with e -> - do { restore (); raise e } - } -; - -Toploop.parse_toplevel_phrase.val := - wrap toplevel_phrase (fun _ -> 0) -; - -Toploop.parse_use_file.val := - wrap use_file (fun lb -> lb.lex_curr_pos - lb.lex_start_pos) -; - -Pcaml.warning.val := - fun loc txt -> - Toploop.print_warning (Ast2pt.mkloc loc) Format.err_formatter - (Warnings.Other txt); diff --git a/camlp4/top/oprint.ml b/camlp4/top/oprint.ml deleted file mode 100644 index 15600c2411..0000000000 --- a/camlp4/top/oprint.ml +++ /dev/null @@ -1,597 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_tuple tree_list -> - fprintf ppf "@[%a@]" (print_tree_list print_tree_1 ",") tree_list - | tree -> print_tree_1 ppf tree ] - and print_tree_1 ppf = - fun - [ Oval_constr name [param] -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_simple_tree param - | Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%F" f - | Oval_char c -> fprintf ppf "%C" c - | Oval_string s -> - try fprintf ppf "%S" s with - [ Invalid_argument "String.create" -> fprintf ppf "<huge string>" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name - (cautious print_tree) tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -(* Types *) - -value rec print_list_init pr sep ppf = - fun - [ [] -> () - | [a :: l] -> do { sep ppf; pr ppf a; print_list_init pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | Otyp_poly sl ty -> - fprintf ppf "@[<hov 2>%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_tuple tyl -> - fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - fun - [ Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_constr id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields print_present tags - | Otyp_alias _ _ | Otyp_poly _ | Otyp_arrow _ _ _ | Otyp_tuple _ as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty - | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _ - | Otyp_manifest _ _ -> () ] -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " (print_typlist print_out_type ",") - tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item - print_signature_body items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - print_out_type ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type - ty1 print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist print_out_type ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item print_signature_body - items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name print_out_type - ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_phrase.val := print_out_phrase; diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml deleted file mode 100644 index 76f19fe11e..0000000000 --- a/camlp4/top/rprint.ml +++ /dev/null @@ -1,422 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name - (print_tree_list print_simple_tree "") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%.12g" f - | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c) - | Oval_string s -> - try fprintf ppf "\"%s\"" (String.escaped s) with - [ Invalid_argument "String.create" -> fprintf ppf "<huge string>" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl - | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True" - | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False" - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_tuple tree_list -> - fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - let name = - match name with - [ Oide_ident "contents" -> Oide_ident "val" - | x -> x ] - in - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree) - tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -(* Types *) - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | Otyp_poly sl ty -> - fprintf ppf "@[<hov 2>%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_constr id ([_ :: _] as tyl) -> - fprintf ppf "@[%a@;<1 2>%a@]" print_ident id - (print_typlist print_simple_out_type "") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - let rec print_tkind ppf = - fun - [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id - | Otyp_tuple tyl -> - fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[<hov>%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[|%s@[<hv>@[<hv>%a@]%a|]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields - print_present tags - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_manifest ty1 ty2 -> - fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 - | Otyp_sum constrs priv -> - fprintf ppf "@[<hv>%a[ %a ]@]" print_private priv - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_record lbls priv -> - fprintf ppf "@[<hv 2>%a{ %a }@]" print_private priv - (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls - | Otyp_abstract -> fprintf ppf "'abstract" - | Otyp_alias _ _ | Otyp_poly _ _ - | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty ] - and print_private ppf = - fun - [ Asttypes.Public -> () - | Asttypes.Private -> fprintf ppf "private " - ] - in - print_tkind ppf -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_out_type " and") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "") - print_out_type arg -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[<hv 2>`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -(* Signature items *) - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist Toploop.print_out_type.val ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s[ %a ] ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - Toploop.print_out_type.val ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty - | None -> () ] - in - fprintf ppf "@[<hv 2>@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1 - Toploop.print_out_type.val ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a;@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name Toploop.print_out_type.val ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "") - name Toploop.print_out_type.val ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[<hv 2>sig@ %a@;<1 -2>end@]" - Toploop.print_out_signature.val sg - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_abstract -> () ] -and print_out_signature ppf = - fun - [ [] -> () - | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item - | [item :: items] -> - fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item - print_out_signature items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name - Toploop.print_out_module_type.val mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name - Toploop.print_out_module_type.val mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "value" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - Toploop.print_out_type.val ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let constrain ppf (ty, ty') = - fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty - Toploop.print_out_type.val ty' - in - let print_constraints ppf params = List.iter (constrain ppf) params in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "%s %a" name type_parameter arg - | _ -> - fprintf ppf "%s@ %a" name - (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ] - in - fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =@ %a@]%a@]" kwd type_defined - Toploop.print_out_type.val ty print_constraints constraints -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[<v>%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_class_type.val := print_out_class_type; -Toploop.print_out_module_type.val := print_out_module_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_signature.val := print_out_signature; -Toploop.print_out_phrase.val := print_out_phrase; |