Add to HEAD branch

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2649 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 312 insertions, 0 deletions

diff --git a/otherlibs/labltk/compiler/parser.mly b/otherlibs/labltk/compiler/parser.mly
new file mode 100644
index 000000000..ce7895232
--- /dev/null
+++ b/otherlibs/labltk/compiler/parser.mly
@@ -0,0 +1,312 @@
+/* $Id$ */
+
+%{
+
+open Tables
+
+let lowercase s =
+  let r = String.create len:(String.length s) in
+  String.blit s pos:0 to:r to_pos:0 len:(String.length s);
+  let c = s.[0] in
+  if c >= 'A' & c <= 'Z' then r.[0] <- Char.chr(Char.code c + 32);
+  r
+
+%}
+
+/* Tokens */
+%token <string> IDENT
+%token <string> STRING
+%token EOF
+
+%token LPAREN           /* "(" */
+%token RPAREN           /* ")" */
+%token COMMA            /* "," */
+%token SEMICOLON        /* ";" */
+%token COLON            /* ":" */       
+%token QUESTION         /* "?" */
+%token LBRACKET         /* "[" */
+%token RBRACKET         /* "]" */
+%token LBRACE           /* "{" */
+%token RBRACE           /* "}" */
+
+%token TYINT            /* "int" */
+%token TYFLOAT          /* "float" */
+%token TYBOOL           /* "bool" */
+%token TYCHAR           /* "char" */
+%token TYSTRING         /* "string" */
+%token LIST             /* "list" */
+
+%token AS               /* "as" */
+%token VARIANT          /* "variant" */
+%token WIDGET           /* "widget" */
+%token OPTION           /* "option" */
+%token TYPE             /* "type" */
+%token SEQUENCE         /* "sequence" */
+%token SUBTYPE          /* "subtype" */
+%token FUNCTION         /* "function" */
+%token MODULE           /* "module" */
+%token EXTERNAL         /* "external" */
+%token UNSAFE           /* "unsafe" */
+/* Entry points */
+%start entry
+%type <unit> entry
+
+%%
+TypeName:
+   IDENT { lowercase $1 }
+ | WIDGET { "widget" }
+;
+
+/* Atomic types */
+Type0 :
+    TYINT
+      { Int }
+  | TYFLOAT
+      { Float }
+  | TYBOOL
+      { Bool }
+  | TYCHAR
+      { Char }
+  | TYSTRING
+      { String }
+  | TypeName
+      { UserDefined $1 }
+;
+
+/* with subtypes */
+Type1 : 
+    Type0
+      { $1 }
+  | TypeName LPAREN IDENT RPAREN
+     { Subtype ($1, $3) }
+  | WIDGET LPAREN IDENT RPAREN
+     { Subtype ("widget", $3) }
+  | OPTION LPAREN IDENT RPAREN
+     { Subtype ("options", $3) }
+  | Type1 AS STRING
+     { As ($1, $3) }
+;
+
+/* with list constructors */
+Type2 :
+    Type1
+     { $1 }
+  | Type1 LIST
+     { List $1 }
+;
+
+Labeled_type2 :
+    Type2
+      { "",$1 }
+  | IDENT COLON Type2
+      { $1, $3 }
+;
+
+/* products */
+Type_list :
+    Type2 COMMA Type_list
+      { $1 :: $3 }
+  | Type2
+      { [$1] }
+;
+
+/* records */
+Type_record :
+    Labeled_type2 COMMA Type_record
+      { $1 :: $3 }
+  | Labeled_type2
+      { [$1] }
+;
+
+/* callback arguments or function results*/
+FType :
+    LPAREN RPAREN
+      { Unit }
+  | LPAREN Type2 RPAREN
+      { $2 }      
+  | LPAREN Type_record RPAREN 
+      { Record $2 }
+;
+
+Type :
+    Type2
+      { $1 }
+  | FUNCTION FType
+      { Function $2 }
+;
+
+
+
+SimpleArg:
+    STRING
+      {StringArg $1}
+  | Type
+      {TypeArg ("",$1) }
+;
+
+Arg:
+    STRING
+      {StringArg $1}
+  | Type
+      {TypeArg ("",$1) }
+  | IDENT COLON Type
+      {TypeArg ($1,$3)}       
+  | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET DefaultList
+      {OptionalArgs ( $2, $5, $7 )}
+  | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET DefaultList
+      {OptionalArgs ( "widget", $5, $7 )}
+  | QUESTION IDENT COLON LBRACKET SimpleArgList RBRACKET
+      {OptionalArgs ( $2, $5, [] )}
+  | QUESTION WIDGET COLON LBRACKET SimpleArgList RBRACKET
+      {OptionalArgs ( "widget", $5, [] )}
+  | WIDGET COLON Type
+      {TypeArg ("widget",$3)}
+  | Template
+      { $1 }
+;
+
+SimpleArgList:
+    SimpleArg SEMICOLON SimpleArgList
+       { $1 :: $3}
+  | SimpleArg
+      { [$1] }
+;
+
+ArgList:
+    Arg SEMICOLON ArgList
+       { $1 :: $3}
+  | Arg
+      { [$1] }
+;
+
+/* DefaultList Only one TypeArg in ArgList and it must be unlabeled */
+DefaultList :
+    LBRACKET LBRACE ArgList RBRACE RBRACKET
+      {$3}
+
+/* Template */
+Template :
+    LBRACKET ArgList RBRACKET
+      { ListArg $2 }
+;
+
+
+/* Constructors for type declarations */
+Constructor :
+    IDENT Template
+      {{ component = Constructor; 
+         ml_name = $1;
+         var_name = getvarname $1 $2;
+         template = $2;
+         result = Unit;
+         safe = true }}
+  | IDENT LPAREN IDENT RPAREN Template
+      {{ component = Constructor; 
+         ml_name = $1;
+         var_name = $3;
+         template = $5;
+         result = Unit;
+         safe = true }}
+;
+
+AbbrevConstructor :
+    Constructor
+      { Full $1 }
+ |  IDENT
+      { Abbrev $1 }
+;
+
+Constructors :
+  Constructor Constructors
+   { $1 :: $2 }
+| Constructor
+   { [$1] }
+;
+
+AbbrevConstructors :
+  AbbrevConstructor AbbrevConstructors
+   { $1 :: $2 }
+| AbbrevConstructor
+   { [$1] }
+;
+
+Safe:
+   /* */
+  { true }
+ | UNSAFE
+  { false }
+
+Command :
+   Safe FUNCTION FType IDENT Template
+     {{component = Command; ml_name = $4; var_name = "";
+       template = $5; result = $3; safe = $1 }}
+;
+
+External :
+  Safe EXTERNAL IDENT STRING
+     {{component = External; ml_name = $3; var_name = "";
+       template = StringArg $4; result = Unit; safe = $1}}
+;
+
+Option :
+   OPTION IDENT Template
+     {{component = Constructor; ml_name = $2; var_name = getvarname $2 $3;
+       template = $3; result = Unit; safe = true }}
+   /* Abbreviated */
+|   OPTION IDENT LPAREN IDENT RPAREN Template
+     {{component = Constructor; ml_name = $2; var_name = $4;
+       template = $6; result = Unit; safe = true }}
+   /* Abbreviated */
+|  OPTION IDENT
+     { retrieve_option $2 }
+;
+
+WidgetComponents :
+  /* */
+  { [] }
+ | Command WidgetComponents
+  { $1 :: $2 }
+ | Option WidgetComponents
+  { $1 :: $2 }
+ | External WidgetComponents
+  { $1 :: $2 }
+;
+
+ModuleComponents : 
+  /* */
+  { [] }
+ | Command ModuleComponents
+  { $1 :: $2 }
+ | External ModuleComponents
+  { $1 :: $2 }
+;
+
+ParserArity :
+  /* */
+  { OneToken }
+ | SEQUENCE
+  { MultipleToken }
+;
+
+
+
+entry :
+  TYPE ParserArity TypeName LBRACE Constructors RBRACE
+    { enter_type $3 $2 $5 }
+| VARIANT TYPE ParserArity TypeName LBRACE Constructors RBRACE
+    { enter_type $4 $3 $6 variant: true }
+| TYPE ParserArity TypeName EXTERNAL
+    { enter_external_type $3 $2 }
+| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
+    { enter_subtype "options" $2 $5 $8 }
+| SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
+    { enter_subtype $3 $2 $5 $8 }
+| Command 
+    { enter_function $1 }
+| WIDGET IDENT LBRACE WidgetComponents RBRACE
+    { enter_widget $2 $4 }
+| MODULE IDENT LBRACE ModuleComponents RBRACE
+    { enter_module (lowercase $2) $4 }
+| EOF
+    { raise End_of_file }
+;