1003 lines
36 KiB
OCaml
1003 lines
36 KiB
OCaml
; 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
|