summaryrefslogtreecommitdiff
path: root/camlp4/etc/pa_scheme.ml
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/etc/pa_scheme.ml')
-rw-r--r--camlp4/etc/pa_scheme.ml1002
1 files changed, 0 insertions, 1002 deletions
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
View Lorry Controller Status