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