Primitives return

assoc.sml

@@ -0,0 +1,3 @@
+structure Assoc = struct
+  datatype assoc = LEFT_ASSOC | RIGHT_ASSOC
+end

concreteSyntax.sml

@@ -25,10 +25,9 @@ structure ConcreteSyntax = struct
       VAL of string * exp
     (* val rec f = fn (x_1, ... , x_n) => M *)
     | VALREC of string * string list * exp
-    (* infixl d vid_1 ... vid_n *)
-    | INFIXL of int * string list
+    (* infix d vid_1 ... vid_n *)
     (* infixr d vid_1 ... vid_n *)
-    | INFIXR of int * string list
+    | INFIX of Assoc.assoc * int * string list
     (* nonfix vid_1 ... vid_n *)
     | NONFIX of string list
 
@@ -84,11 +83,11 @@ structure ConcreteSyntax = struct
       ^ seqToString xs
       ^ " => "
       ^ expToString m
-    | INFIXL (d, vids) =>
+    | INFIX (Assoc.LEFT_ASSOC, d, vids) =>
         "infixl "
         ^ Int.toString d
         ^ vidSeqToString vids
-    | INFIXR (d, vids) =>
+    | INFIX (Assoc.RIGHT_ASSOC, d, vids) =>
         "infixr "
         ^ Int.toString d
         ^ vidSeqToString vids

env.sig

@@ -4,6 +4,7 @@ signature ENV = sig
   val empty : 'a t
   val insert : ('a t * Id.t * 'a) -> 'a t
   val insertList : ('a t * (Id.t * 'a) list) -> 'a t
+  val fromList : (Id.t * 'a) list -> 'a t
   val find : ('a t * Id.t) -> 'a option
   val findName : ('a t * string) -> (Id.t * 'a) option
 end

env.sml

@@ -6,6 +6,8 @@ structure Env : ENV = struct
   fun insertList (env, bindings) =
     foldl (fn ((x, v), env) =>
       insert (env, x, v)) env bindings
+  fun fromList bindings =
+    insertList (empty, bindings)
   fun find (env, x) =
     Option.map #2 (List.find (fn (y, _) => x = y) env)
   fun findName (env: 'a t, x: string) =

infixing.sig

@@ -1,6 +1,5 @@
 signature INFIXING = sig
-  type assoc
   exception UnboundVar of string
   exception SyntaxError
-  val infixing : (int * assoc) option Env.t -> ConcreteSyntax.exp -> Syntax.exp
+  val infixing : (int * Assoc.assoc) option Env.t -> ConcreteSyntax.exp -> Syntax.exp
 end

infixing.sml

@@ -1,10 +1,9 @@
 structure Infixing : INFIXING = struct
-  datatype assoc = LEFT_ASSOC | RIGHT_ASSOC
-
   (* exception that arises when unbound variable occur *)
   exception UnboundVar of string
   exception SyntaxError
   local
+    open Assoc
     open ConcreteSyntax
     datatype token = EXP_TOKEN of Syntax.exp | BINOP_TOKEN of Id.t * int * assoc
   in
@@ -64,23 +63,12 @@ structure Infixing : INFIXING = struct
           in
             infixingLet (Syntax.VALREC (f', xs', m') :: dec') env' dec body
           end
-      | infixingLet dec' env (INFIXL (d, vids) :: dec) body =
-          let
-            val vids' =
-              map (fn vid =>
-                case Env.findName (env, vid) of
-                     SOME (vid', _) => (vid', SOME (d, LEFT_ASSOC))
-                   | NONE => raise (UnboundVar vid)) vids
-            val env' = Env.insertList (env, vids')
-          in
-            infixingLet dec' env' dec body
-          end
-      | infixingLet dec' env (INFIXR (d, vids) :: dec) body =
+      | infixingLet dec' env (INFIX (assoc, d, vids) :: dec) body =
           let
             val vids' =
               map (fn vid =>
                 case Env.findName (env, vid) of
-                     SOME (vid', _) => (vid', SOME (d, RIGHT_ASSOC))
+                     SOME (vid', _) => (vid', SOME (d, assoc))
                    | NONE => raise (UnboundVar vid)) vids
             val env' = Env.insertList (env, vids')
           in

prim.sml

@@ -12,6 +12,10 @@ structure Prim = struct
     | toString TIMES = "*"
     | toString LE = "<="
 
+  fun priority (PLUS | MINUS) = SOME (6, Assoc.LEFT_ASSOC)
+    | priority TIMES = SOME (7, Assoc.LEFT_ASSOC)
+    | priority LE = SOME (4, Assoc.LEFT_ASSOC)
+
   fun typeOf (PLUS | MINUS | TIMES) =
         Type.FUN ([Type.INT, Type.INT], Type.INT)
     | typeOf LE =

sources.cm

@@ -8,6 +8,8 @@ Group is
   env.sml
   env.sig
   const.sml
+  assoc.sml
+  prim.sml
   syntax.sml
   concreteSyntax.sml
   typedSyntax.sml

syntax.sml

@@ -14,6 +14,8 @@ structure Syntax = struct
     | APP of exp * exp list
     (* let d in N end *)
     | LET of dec list * exp
+    (* op (+) (M_1, ... , M_n) *)
+    | PRIM of Prim.t * exp list
   (* abstract syntax tree of declaration *)
   and dec =
     (* val x = M *)
@@ -51,6 +53,12 @@ structure Syntax = struct
       ^ " in "
       ^ expToString m
       ^ " end"
+    | expToString (PRIM (p, ms)) =
+      "(op"
+      ^ Prim.toString p
+      ^ " "
+      ^ expSeqToString ms
+      ^ ")"
   and expSeqToString seq = PP.seqToString (expToString, "()", ", ", "(", ")") seq
   and decToString dec = PP.seqToString (fn
       VAL (x, m) =>

typedSyntax.sml

@@ -24,6 +24,8 @@ structure TypedSyntax = struct
     | APP of exp * exp list
     (* let d in N end *)
     | LET of dec list * exp
+    (* op (+) (M_1, ... , M_n) *)
+    | PRIM of Prim.t * exp list
   and dec =
     (* val x : T = M *)
       VAL of id * exp
@@ -60,6 +62,12 @@ structure TypedSyntax = struct
         ^ " in "
         ^ expToString m
         ^ " end"
+    | expBodyToString (PRIM (p, ms)) =
+        "(op"
+        ^ Prim.toString p
+        ^ " "
+        ^ expSeqToString ms
+        ^ ")"
   and expSeqToString seq = PP.seqToString (expToString, "()", ", ", "(", ")") seq
   and decToString dec = PP.seqToString (fn
       VAL (x, m) =>

typing.sml

@@ -81,6 +81,14 @@ structure Typing : TYPING = struct
           end
       | g env (Syntax.LET (dec, m)) =
           typingLet [] env dec m
+      | g env (Syntax.PRIM (p, ms)) =
+          let
+            val t = Type.genvar ()
+            val ms' = map (g env) ms
+          in
+            unify (Prim.typeOf p, Type.FUN (expSeqTypeOf ms', t));
+            E (PRIM (p, ms'), t)
+          end
     and typingLet dec' env [] body =
           let 
             val body' = g env body
@@ -121,6 +129,8 @@ structure Typing : TYPING = struct
       | derefExpBody (LET (dec, m)) =
           (List.app derefDec dec;
            derefExp m)
+      | derefExpBody (PRIM (_, ms)) =
+          List.app derefExp ms
       | derefExpBody _ = ()
     (* replace type variable with appropriate type in body of typed declaration *)
     and derefDec (VAL ((_, t), m)) =

udon.grm

@@ -117,9 +117,9 @@ ATDEC : VAL VID EQUAL EXP
       | VAL REC VID EQUAL FN VIDSEQ FATARROW EXP
           (ConcreteSyntax.VALREC (VID, VIDSEQ, EXP))
       | INFIX DIGIT_OPT NVID
-          (ConcreteSyntax.INFIXL (getOpt (DIGIT_OPT, 0), NVID))
+          (ConcreteSyntax.INFIX (Assoc.LEFT_ASSOC, getOpt (DIGIT_OPT, 0), NVID))
       | INFIXR DIGIT_OPT NVID
-          (ConcreteSyntax.INFIXR (getOpt (DIGIT_OPT, 0), NVID))
+          (ConcreteSyntax.INFIX (Assoc.RIGHT_ASSOC, getOpt (DIGIT_OPT, 0), NVID))
       | NONFIX NVID
           (ConcreteSyntax.NONFIX NVID)
 

udon.sml

@@ -7,11 +7,21 @@ structure UdonParser = Join(structure LrParser = LrParser
                            structure ParserData = UdonLrVals.ParserData
                            structure Lex = UdonLex)
 
+val primitives =
+  [(Id.gensym "+", Prim.PLUS),
+   (Id.gensym "-", Prim.MINUS),
+   (Id.gensym "*", Prim.TIMES),
+   (Id.gensym "<=", Prim.LE)]
+
 fun exec exp stat =
   ((print
     o TypedSyntax.expToString
-    o Typing.f Env.empty
-    o Infixing.infixing Env.empty) exp
+    o Typing.f
+        (Env.fromList (map (fn (id, p) =>
+          (id, Prim.typeOf p)) primitives))
+    o Infixing.infixing
+        (Env.fromList (map (fn (id, p) =>
+          (id, Prim.priority p)) primitives))) exp
    handle
      Infixing.SyntaxError =>
        print "Syntax error"