[MLton-commit] r6829

Matthew Fluet fluet at mlton.org
Mon Sep 1 06:19:48 PDT 2008


Regularize elaborator type error messages for FFI constructs.
Use filters for spliting attributes.

----------------------------------------------------------------------

U   mlton/trunk/mlton/ast/ast-core.fun
U   mlton/trunk/mlton/ast/ast-core.sig
U   mlton/trunk/mlton/elaborate/elaborate-core.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/ast/ast-core.fun
===================================================================
--- mlton/trunk/mlton/ast/ast-core.fun	2008-09-01 13:19:44 UTC (rev 6828)
+++ mlton/trunk/mlton/ast/ast-core.fun	2008-09-01 13:19:47 UTC (rev 6829)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -234,6 +234,14 @@
       structure SymbolAttribute =
          struct
             datatype t = Alloc | External | Private | Public
+
+            val toString: t -> string =
+               fn Alloc => "alloc"
+                | External => "external"
+                | Private => "private"
+                | Public => "public"
+
+            val layout = Layout.str o toString
          end
 
       datatype t =

Modified: mlton/trunk/mlton/ast/ast-core.sig
===================================================================
--- mlton/trunk/mlton/ast/ast-core.sig	2008-09-01 13:19:44 UTC (rev 6828)
+++ mlton/trunk/mlton/ast/ast-core.sig	2008-09-01 13:19:47 UTC (rev 6829)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -90,6 +90,8 @@
             structure SymbolAttribute:
                sig
                   datatype t = Alloc | External | Private | Public
+
+                  val layout: t -> Layout.t
                end
 
             datatype t =

Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun	2008-09-01 13:19:44 UTC (rev 6828)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun	2008-09-01 13:19:47 UTC (rev 6829)
@@ -864,6 +864,11 @@
             else NONE
    end
 
+val isIEAttributeConvention =
+   fn ImportExportAttribute.Cdecl => true
+    | ImportExportAttribute.Stdcall => true
+    | _ => false
+
 fun parseIEAttributesConvention (attributes: ImportExportAttribute.t list) 
     : Convention.t option =
    case attributes of
@@ -885,8 +890,14 @@
            | _ => NONE)
     | _ => NONE
 
-fun parseIEAttributesScope (attributes: ImportExportAttribute.t list,
-                            defScope : SymbolScope.t)
+val isIEAttributeSymbolScope =
+   fn ImportExportAttribute.External => true
+    | ImportExportAttribute.Private => true
+    | ImportExportAttribute.Public => true
+    | _ => false
+
+fun parseIEAttributesSymbolScope (attributes: ImportExportAttribute.t list,
+                                  defScope : SymbolScope.t)
     : SymbolScope.t option = 
    case attributes of
       [] => SOME defScope
@@ -897,12 +908,6 @@
                | _ => NONE)
     | _ => NONE
 
-val splitIEAttributes = fn ImportExportAttribute.Cdecl => true
-                         | ImportExportAttribute.External => false
-                         | ImportExportAttribute.Private => false
-                         | ImportExportAttribute.Public => false
-                         | ImportExportAttribute.Stdcall => true
-
 fun import {attributes: ImportExportAttribute.t list,
             elabedTy: Type.t,
             expandedTy: Type.t,
@@ -929,16 +934,18 @@
        | SOME (args, result) =>
             let
                datatype z = datatype CFunction.Target.t
-               val { yes = convention, no = symbolScope } =
-                  List.partition (attributes, splitIEAttributes)
                val convention =
+                  List.keepAll (attributes, isIEAttributeConvention)
+               val convention =
                   case parseIEAttributesConvention convention of
                      NONE => (invalidAttributes ()
                               ; Convention.Cdecl)
                    | SOME c => c
                val symbolScope =
-                  case parseIEAttributesScope (symbolScope,
-                                               SymbolScope.External) of
+                  List.keepAll (attributes, isIEAttributeSymbolScope)
+               val symbolScope =
+                  case parseIEAttributesSymbolScope
+                       (symbolScope, SymbolScope.External) of
                      NONE => (invalidAttributes ()
                               ; SymbolScope.External)
                    | SOME s => s
@@ -1093,16 +1100,37 @@
                            valueExp = Cexp.var (setArg, expandedCbTy)},
            mayInline = true})
       end
-   
-   fun symbolScope default =
-     fn [] => SOME default
-      | [SymbolAttribute.Private] => SOME SymbolScope.Private
-      | [SymbolAttribute.Public] => SOME SymbolScope.Public
-      | [SymbolAttribute.External] => SOME SymbolScope.External
-      | _ => NONE
-   
-   val symbolScope = fn (l, default) =>
-      symbolScope default (List.removeAll (l, fn x => x = SymbolAttribute.Alloc))
+
+   val isSymbolAttributeAlloc =
+      fn SymbolAttribute.Alloc => true
+       | _ => false
+
+   fun parseSymbolAttributesAlloc (attributes: SymbolAttribute.t list)
+       : bool option =
+      case attributes of
+         [] => SOME false
+       | [a] => (case a of
+                    SymbolAttribute.Alloc => SOME true
+                  | _=> NONE)
+       | _ => NONE
+
+   val isSymbolAttributeSymbolScope =
+      fn SymbolAttribute.Private => true
+       | SymbolAttribute.Public => true
+       | SymbolAttribute.External => true
+       | _ => false
+
+   fun parseSymbolAttributesSymbolScope (attributes: SymbolAttribute.t list,
+                                         defScope: SymbolScope.t)
+       : SymbolScope.t option =
+      case attributes of
+         [] => SOME defScope
+       | [a] => (case a of
+                    SymbolAttribute.Private => SOME SymbolScope.Private
+                  | SymbolAttribute.Public => SOME SymbolScope.Public
+                  | SymbolAttribute.External => SOME SymbolScope.External
+                  | _=> NONE)
+       | _ => NONE
 in
    fun address {attributes: SymbolAttribute.t list,
                 elabedTy: Type.t,
@@ -1110,35 +1138,35 @@
                 name: string,
                 region: Region.t}: Cexp.t =
       let
-         fun error () =
+         fun error l = Control.error (region, l, Layout.empty)
+         fun invalidAttributes () =
+            error (seq [str "invalid attributes for _address: ",
+                        List.layout SymbolAttribute.layout attributes])
+         fun invalidType () =
             Control.error
             (region, str "invalid type for _address",
              Type.layoutPretty elabedTy)
          val () =
             case Type.toCPtrType expandedTy of
-               NONE => (error (); ())
+               NONE => (invalidType (); ())
              | SOME _ => ()
          val expandedPtrTy = expandedTy
-         val scope = 
-            case symbolScope (attributes, SymbolScope.External) of
-               NONE => (Control.error 
-                        (region, 
-                         str "use only one of {external,private,public} with _address",
-                         empty)
+         val () =
+            case List.keepAll (attributes, isSymbolAttributeAlloc) of
+               [] => ()
+             | _ => invalidAttributes ()
+         val symbolScope =
+            List.keepAll (attributes, isSymbolAttributeSymbolScope)
+         val symbolScope =
+            case parseSymbolAttributesSymbolScope
+                 (symbolScope, SymbolScope.External) of
+               NONE => (invalidAttributes ()
                         ; SymbolScope.External)
-             | SOME x => x
-         val () =
-            if List.exists (attributes, fn attr =>
-                            attr = SymbolAttribute.Alloc)
-               then Control.error
-                    (region,
-                     str "use of alloc with _address is forbidden",
-                     empty)
-               else ()
+             | SOME s => s
          val addrExp =
             mkAddress {expandedPtrTy = expandedPtrTy,
                        name = name,
-                       symbolScope = scope,
+                       symbolScope = symbolScope,
                        cty = NONE}
          fun wrap (e, t) = Cexp.make (Cexp.node e, t)
       in
@@ -1151,7 +1179,11 @@
                      name: string,
                      region: Region.t}: Cexp.t =
       let
-         fun error () =
+         fun error l = Control.error (region, l, Layout.empty)
+         fun invalidAttributes () =
+            error (seq [str "invalid attributes for _symbol: ",
+                        List.layout SymbolAttribute.layout attributes])
+         fun invalidType () =
             Control.error
             (region, str "invalid type for _symbol",
              Type.layoutPretty elabedTy)
@@ -1159,20 +1191,20 @@
             Exn.withEscape
             (fn escape =>
              let
-                val error = fn () =>
-                   (error ()
+                val invalidType = fn () =>
+                   (invalidType ()
                     ; ignore (escape Type.word8)
                     ; Error.bug "ElaborateCore.symbolDirect.escape")
              in
                 case Type.deTupleOpt expandedTy of
-                   NONE => error ()
+                   NONE => invalidType ()
                  | SOME tys => 
                       if Vector.length tys <> 2
-                         then error ()
+                         then invalidType ()
                          else let
                                  fun doit ty =
                                     case Type.deArrowOpt ty of
-                                       NONE => error ()
+                                       NONE => invalidType ()
                                      | SOME tys => tys
                                  val (getArgTy, getResTy) =
                                     doit (Vector.sub (tys, 0))
@@ -1181,52 +1213,54 @@
                                  val () =
                                     if Type.isUnit getArgTy 
                                        then ()
-                                       else error ()
+                                       else invalidType ()
                                  val () =
                                     if Type.isUnit setResTy
                                        then ()
-                                       else error ()
+                                       else invalidType ()
                                  val () =
                                     if Type.canUnify (getResTy, setArgTy)
                                        then ()
-                                       else error ()
+                                       else invalidType ()
                               in
                                  getResTy
                               end
              end)
          val ctypeCbTy =
             case Type.toCBaseType expandedCbTy of
-               NONE => (error (); CType.word (WordSize.word8, {signed = false}))
+               NONE => (invalidType ()
+                        ; CType.word (WordSize.word8, {signed = false}))
              | SOME {ctype, ...} => ctype
          val alloc =
-            List.exists (attributes, fn attr => attr = SymbolAttribute.Alloc)
-         val defScope = if alloc then SymbolScope.Public 
-                                 else SymbolScope.External
-         val scope = 
-            case symbolScope (attributes, defScope) of
-               NONE => (Control.error 
-                        (region, 
-                         str "use only one of {external,private,public} with _symbol",
-                         empty)
-                        ; SymbolScope.External)
-             | SOME SymbolScope.External =>
-                  if not alloc then SymbolScope.External else
-                  (Control.error
-                   (region,
-                    str "cannot {alloc}ate an {external} _symbol",
-                    empty)
-                  ; SymbolScope.Public)
-             | SOME x => x
+            List.keepAll (attributes, isSymbolAttributeAlloc)
+         val alloc =
+            case parseSymbolAttributesAlloc alloc of
+               NONE => (invalidAttributes ()
+                        ; false)
+             | SOME a => a
+         val defScope =
+            if alloc then SymbolScope.Public else SymbolScope.External
+         val symbolScope =
+            List.keepAll (attributes, isSymbolAttributeSymbolScope)
+         val symbolScope =
+            case parseSymbolAttributesSymbolScope
+                 (symbolScope, defScope) of
+               NONE => (invalidAttributes ()
+                        ; defScope)
+             | SOME s => s
          val () =
+            if alloc andalso symbolScope = SymbolScope.External
+            then invalidAttributes () else ()
+         val () =
             if not alloc then () else
             Ffi.addSymbol {name = name, 
                            ty = ctypeCbTy, 
-                           symbolScope = scope}
+                           symbolScope = symbolScope}
          val addrExp =
             mkAddress {expandedPtrTy = Type.cpointer,
                        name = name,
                        cty = SOME ctypeCbTy,
-                       symbolScope = scope}
+                       symbolScope = symbolScope}
          val symExp =
             mkSymbol {ctypeCbTy = ctypeCbTy,
                       expandedCbTy = expandedCbTy,
@@ -1240,7 +1274,7 @@
                        expandedTy: Type.t,
                        region: Region.t}: Cexp.t =
       let
-         fun error () =
+         fun invalidType () =
             Control.error
             (region, str "invalid type for _symbol",
              Type.layoutPretty elabedTy)
@@ -1248,23 +1282,23 @@
             Exn.withEscape
             (fn escape =>
              let
-                val error = fn () =>
-                   (error ()
+                val invalidType = fn () =>
+                   (invalidType ()
                     ; ignore (escape (Type.cpointer, Type.word8))
                     ; Error.bug "ElaborateCore.symbolIndirect.escape")
              in
                 case Type.deArrowOpt expandedTy of
-                   NONE => error ()
+                   NONE => invalidType ()
                  | SOME (ptrTy, symTy) =>
                       (case Type.deTupleOpt symTy of
-                          NONE => error ()
+                          NONE => invalidType ()
                         | SOME tys => 
                              if Vector.length tys <> 2
-                                then error ()
+                                then invalidType ()
                                 else let
                                         fun doit ty =
                                            case Type.deArrowOpt ty of
-                                              NONE => error ()
+                                              NONE => invalidType ()
                                             | SOME tys => tys
                                         val (getArgTy, getResTy) =
                                            doit (Vector.sub (tys, 0))
@@ -1273,26 +1307,26 @@
                                         val () =
                                            if Type.isUnit getArgTy 
                                               then ()
-                                              else error ()
+                                              else invalidType ()
                                         val () =
                                            if Type.isUnit setResTy
                                               then ()
-                                              else error ()
+                                              else invalidType ()
                                         val () =
                                            if Type.canUnify (getResTy, setArgTy)
                                               then ()
-                                              else error ()
+                                              else invalidType ()
                                      in
                                         (ptrTy, getResTy)
                                      end)
              end)
          val ctypeCbTy =
             case Type.toCBaseType expandedCbTy of
-               NONE => (error (); CType.word (WordSize.word8, {signed = false}))
+               NONE => (invalidType (); CType.word (WordSize.word8, {signed = false}))
              | SOME {ctype, ...} => ctype
          val () =
             case Type.toCPtrType expandedPtrTy of
-               NONE => (error (); ())
+               NONE => (invalidType (); ())
              | SOME _ => ()
          val ptrArg = Var.newNoname ()
          val ptrExp = Cexp.var (ptrArg, expandedPtrTy)
@@ -1324,23 +1358,26 @@
       fun invalidType () =
          Control.error 
          (region,
-          str "invalid type for _export: ",
+          str "invalid type for _export",
           Type.layoutPretty elabedTy)
-      val { yes = convention, no = symbolScope } =
-         List.partition (attributes, splitIEAttributes)
       val convention =
+         List.keepAll (attributes, isIEAttributeConvention)
+      val convention =
          case parseIEAttributesConvention convention of
             NONE => (invalidAttributes ()
                      ; Convention.Cdecl)
           | SOME c => c
       val symbolScope =
-         case parseIEAttributesScope (symbolScope, SymbolScope.Public) of
+         List.keepAll (attributes, isIEAttributeSymbolScope)
+      val symbolScope =
+         case parseIEAttributesSymbolScope
+              (symbolScope, SymbolScope.Public) of
             NONE => (invalidAttributes ()
                      ; SymbolScope.Public)
           | SOME SymbolScope.External =>
-               (error (seq [str "invalid attributes for _export: external"])
+               (invalidAttributes ()
                 ; SymbolScope.Public)
-          | SOME c => c
+          | SOME s => s
       val (exportId, args, res) =
          case Type.toCFunType expandedTy of
             NONE =>




More information about the MLton-commit mailing list