[MLton] cvs commit: Improved FFI.

Matthew Fluet fluet@mlton.org
Sat, 23 Jul 2005 04:55:44 -0700


fluet       05/07/23 04:55:42

  Modified:    basis-library/libs primitive.mlb
               basis-library/misc primitive.sml
               basis-library/posix primitive.sml
               bin      regression
               doc      changelog
               doc/examples/ffi Makefile export.sml ffi-export.c import.sml
                        import2.sml
               mlton/ast ast-core.fun ast-core.sig
               mlton/atoms ffi.fun ffi.sig prim.fun prim.sig
               mlton/codegen/c-codegen c-codegen.fun
               mlton/control control-flags.sig control-flags.sml
               mlton/elaborate elaborate-core.fun scope.fun
               mlton/front-end ml.grm ml.lex
  Log:
  MAIL Improved FFI.
  
  Incorporated Wesley's patch for improved FFI.  After the discussion on
  the list regarding C pointers, I went ahead and eliminated _address
  infavor of _symbol, which provides the address, getter, and setter.
  So, the FFI system now looks like:
  
  _import "symbol" [cdecl | stdcall] : cfTy;  ==>  cfTy
  _import * [cdecl | stdcall] : ptrTy -> cfTy;  ==>  ptrTy -> cfTy
  _export "symbol" [cdecl | stdcall] : cfTy;  ==> cfTy -> unit
  _symbol "symbol" [define] : ptrTy, cbTy;  ==> ptrTy * (unit -> cbTy) * (cbTy -> unit)
  _symbol * : ptrTy, cbTy;  ==> (ptrTy -> cbTy) * (ptrTy * cbTy -> unit)
  
  I'm tempted to revise _import * to
  
  _import * [cdecl | stdcall] : ptrTy, cfTy;  ==>  ptrTy -> cfTy
  
  but I don't think it is crucial.

Revision  Changes    Path
1.5       +1 -0      mlton/basis-library/libs/primitive.mlb

Index: primitive.mlb
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/primitive.mlb,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- primitive.mlb	4 Nov 2004 01:16:04 -0000	1.4
+++ primitive.mlb	23 Jul 2005 11:55:33 -0000	1.5
@@ -3,6 +3,7 @@
    "allowImport true"
    "allowPrim true"
    "allowRebindEquals true"
+   "allowSymbol true"
    "deadCode true"
    "sequenceUnit true"
    "warnMatch true"



1.156     +27 -28    mlton/basis-library/misc/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.155
retrieving revision 1.156
diff -u -r1.155 -r1.156
--- primitive.sml	13 Jul 2005 01:30:10 -0000	1.155
+++ primitive.sml	23 Jul 2005 11:55:34 -0000	1.156
@@ -241,7 +241,7 @@
 	 struct
 	    type t = Pointer.t
 
-	    val gcState = _import "gcStateAddress": t;
+	    val gcState = #2 _symbol "gcStateAddress": Pointer.t, t; ()
 	 end
       
       structure CallStack =
@@ -310,10 +310,9 @@
 
       structure CommandLine =
 	 struct
-	    val argc = fn () => _import "CommandLine_argc": int;
-	    val argv = fn () => _import "CommandLine_argv": CStringArray.t;
-	    val commandName =
-	       fn () => _import "CommandLine_commandName": CString.t;
+	    val argc = #2 _symbol "CommandLine_argc": Pointer.t, int;
+	    val argv = #2 _symbol "CommandLine_argv": Pointer.t, CStringArray.t;
+	    val commandName = #2 _symbol "CommandLine_commandName": Pointer.t, CString.t;
 	 end
 
       structure Date =
@@ -374,19 +373,19 @@
 
       structure FFI =
 	 struct
-	    val getOp = fn () => _import "MLton_FFI_op": int;
-	    val int8Array = _import "MLton_FFI_Int8": Pointer.t;
-	    val int16Array = _import "MLton_FFI_Int16": Pointer.t;
-	    val int32Array = _import "MLton_FFI_Int32": Pointer.t;
-	    val int64Array = _import "MLton_FFI_Int64": Pointer.t;
+	    val getOp = #2 _symbol "MLton_FFI_op": Pointer.t, int;
+	    val int8Array = #2 _symbol "MLton_FFI_Int8": Pointer.t, Pointer.t; ()
+	    val int16Array = #2 _symbol "MLton_FFI_Int16": Pointer.t, Pointer.t; ()
+	    val int32Array = #2 _symbol "MLton_FFI_Int32": Pointer.t, Pointer.t; ()
+	    val int64Array = #2 _symbol "MLton_FFI_Int64": Pointer.t, Pointer.t; ()
 	    val numExports = _build_const "MLton_FFI_numExports": int;
-	    val pointerArray = _import "MLton_FFI_Pointer": Pointer.t;
-	    val real32Array = _import "MLton_FFI_Real32": Pointer.t;
-	    val real64Array = _import "MLton_FFI_Real64": Pointer.t;
-	    val word8Array = _import "MLton_FFI_Word8": Pointer.t;
-	    val word16Array = _import "MLton_FFI_Word16": Pointer.t;
-	    val word32Array = _import "MLton_FFI_Word32": Pointer.t;
-	    val word64Array = _import "MLton_FFI_Word64": Pointer.t;
+	    val pointerArray = #2 _symbol "MLton_FFI_Pointer": Pointer.t, Pointer.t; ()
+	    val real32Array = #2 _symbol "MLton_FFI_Real32": Pointer.t, Pointer.t; ()
+	    val real64Array = #2 _symbol "MLton_FFI_Real64": Pointer.t, Pointer.t; ()
+	    val word8Array = #2 _symbol "MLton_FFI_Word8": Pointer.t, Pointer.t; ()
+	    val word16Array = #2 _symbol "MLton_FFI_Word16": Pointer.t, Pointer.t; ()
+	    val word32Array = #2 _symbol "MLton_FFI_Word32": Pointer.t, Pointer.t; ()
+	    val word64Array = #2 _symbol "MLton_FFI_Word64": Pointer.t, Pointer.t; ()
 	 end
 
       structure GC =
@@ -984,7 +983,7 @@
 			val forkIsEnabled =
 			   case host of
 			      Cygwin =>
-				 _import "MLton_Platform_CygwinUseMmap": bool;
+				 #2 _symbol "MLton_Platform_CygwinUseMmap": Pointer.t, bool; ()
 			    | MinGW => false
 			    | _ => true
 
@@ -1309,11 +1308,11 @@
 		  val atan2 = _prim "Real64_Math_atan2": real * real -> real;
 		  val cos = _prim "Real64_Math_cos": real -> real;
 		  val cosh = _import "cosh": real -> real;
-		  val e = _import "Real64_Math_e": real;
+		  val e = #2 _symbol "Real64_Math_e": Pointer.t, real; ()
 		  val exp = _prim "Real64_Math_exp": real -> real;
 		  val ln = _prim "Real64_Math_ln": real -> real;
 		  val log10 = _prim "Real64_Math_log10": real -> real;
-		  val pi = _import "Real64_Math_pi": real;
+		  val pi = #2 _symbol "Real64_Math_pi": Pointer.t, real; ()
 		  val pow = _import "pow": real * real -> real;
 		  val sin = _prim "Real64_Math_sin": real -> real;
 		  val sinh = _import "sinh": real -> real;
@@ -1339,9 +1338,9 @@
 	       _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
 	    val fromInt = _prim "WordS32_toReal64": int -> real;
 	    val ldexp = _prim "Real64_ldexp": real * int -> real;
-	    val maxFinite = _import "Real64_maxFinite": real;
-	    val minNormalPos = _import "Real64_minNormalPos": real;
-	    val minPos = _import "Real64_minPos": real;
+	    val maxFinite = #2 _symbol "Real64_maxFinite": Pointer.t, real; ()
+	    val minNormalPos = #2 _symbol "Real64_minNormalPos": Pointer.t, real; ()
+	    val minPos = #2 _symbol "Real64_minPos": Pointer.t, real; ()
 	    val modf = _import "Real64_modf": real * real ref -> real;
 	    val nextAfter = _import "Real64_nextAfter": real * real -> real;
 	    val round = _prim "Real64_round": real -> real;
@@ -1383,11 +1382,11 @@
 		  val atan2 = _prim "Real32_Math_atan2": real * real -> real;
 		  val cos = _prim "Real32_Math_cos": real -> real;
 		  val cosh = unary Real64.Math.cosh
-		  val e = _import "Real32_Math_e": real;
+		  val e = #2 _symbol "Real32_Math_e": Pointer.t, real; ()
 		  val exp = _prim "Real32_Math_exp": real -> real;
 		  val ln = _prim "Real32_Math_ln": real -> real;
 		  val log10 = _prim "Real32_Math_log10": real -> real;
-		  val pi = _import "Real32_Math_pi": real;
+		  val pi = #2 _symbol "Real32_Math_pi": Pointer.t, real; ()
 		  val pow = binary Real64.Math.pow
 		  val sin = _prim "Real32_Math_sin": real -> real;
 		  val sinh = unary Real64.Math.sinh
@@ -1414,9 +1413,9 @@
 	       _import "Real32_gdtoa": real * int * int * int ref -> CString.t;
 	    val fromInt = _prim "WordS32_toReal32": int -> real;
 	    val ldexp = _prim "Real32_ldexp": real * int -> real;
-	    val maxFinite = _import "Real32_maxFinite": real;
-	    val minNormalPos = _import "Real32_minNormalPos": real;
-	    val minPos = _import "Real32_minPos": real;
+	    val maxFinite = #2 _symbol "Real32_maxFinite": Pointer.t, real; ()
+	    val minNormalPos = #2 _symbol "Real32_minNormalPos": Pointer.t, real; ()
+	    val minPos = #2 _symbol "Real32_minPos": Pointer.t, real; ()
 	    val modf = _import "Real32_modf": real * real ref -> real;
 	    val signBit = _import "Real32_signBit": real -> bool;
 	    val strto = _import "Real32_strto": NullString.t -> real;



1.40      +1 -1      mlton/basis-library/posix/primitive.sml

Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -r1.39 -r1.40
--- primitive.sml	19 Jul 2005 12:41:06 -0000	1.39
+++ primitive.sml	23 Jul 2005 11:55:34 -0000	1.40
@@ -299,7 +299,7 @@
 	       end
 
 	    val ctermid = _import "Posix_ProcEnv_ctermid" : unit -> cstring;
-	    val environ = _import "Posix_ProcEnv_environ" : cstringArray;
+	    val environ = #2 _symbol "Posix_ProcEnv_environ" : Pointer.t, cstringArray; ()
 	    val getenv = _import "Posix_ProcEnv_getenv" : NullString.t -> cstring;
 	    val isatty = _import "Posix_ProcEnv_isatty" : fd -> bool;
 	    val sysconf = _import "Posix_ProcEnv_sysconf" : int -> int;



1.106     +1 -2      mlton/bin/regression

Index: regression
===================================================================
RCS file: /cvsroot/mlton/mlton/bin/regression,v
retrieving revision 1.105
retrieving revision 1.106
diff -u -r1.105 -r1.106
--- regression	15 Dec 2004 22:43:49 -0000	1.105
+++ regression	23 Jul 2005 11:55:35 -0000	1.106
@@ -127,8 +127,7 @@
 				\$(SML_LIB)/basis/mlton.mlb
 				\$(SML_LIB)/basis/sml-nj.mlb
  				ann 
-					\"allowExport true\"
-					\"allowImport true\"
+					\"allowFFI true\"
 					\"allowOverload true\"
 					\"warnMatch false\"
 				in $f.sml 



1.168     +6 -0      mlton/doc/changelog

Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.167
retrieving revision 1.168
diff -u -r1.167 -r1.168
--- changelog	21 Jul 2005 15:09:11 -0000	1.167
+++ changelog	23 Jul 2005 11:55:36 -0000	1.168
@@ -1,4 +1,10 @@
 Here are the changes since version 20041109.
+
+* 2005-07-23
+  - Overhaul of FFI.
+    Deprecated _import of C base types.
+    Added _symbol for address, getter, and setter of C base types.
+    See documentation for more detail.
 	
 * 2005-07-21
   - Update mllex and mlyacc with SML/NJ 110.55 versions.  This 



1.22      +1 -1      mlton/doc/examples/ffi/Makefile

Index: Makefile
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/Makefile,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- Makefile	18 Jan 2005 17:56:27 -0000	1.21
+++ Makefile	23 Jul 2005 11:55:36 -0000	1.22
@@ -1,6 +1,6 @@
 PATH = ../../../build/bin:$(shell echo $$PATH)
 
-mlton = mlton -default-ann 'allowExport true' -default-ann 'allowImport true'
+mlton = mlton -default-ann 'allowFFI true'
 
 .PHONY: all
 all: import import2 export iimport test_quot



1.8       +5 -0      mlton/doc/examples/ffi/export.sml

Index: export.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/export.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- export.sml	15 Jan 2004 16:06:32 -0000	1.7
+++ export.sml	23 Jul 2005 11:55:37 -0000	1.8
@@ -24,6 +24,11 @@
 val g4 = _import "g4": int -> unit;
 val _ = e (fn i => if i = 0 then () else g4 (i - 1))
 val _ = g4 13
+
+val (_, _, zzzSet) = _symbol "zzz" define: MLton.Pointer.t, int;
+val () = zzzSet 42
+val g5 = _import "g5": unit -> unit;
+val _ = g5 ()
    
 val _ = print "success\n"
 



1.5       +6 -0      mlton/doc/examples/ffi/ffi-export.c

Index: ffi-export.c
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/ffi-export.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- ffi-export.c	15 Jan 2004 16:06:32 -0000	1.4
+++ ffi-export.c	23 Jul 2005 11:55:37 -0000	1.5
@@ -27,3 +27,9 @@
 	fprintf (stderr, "g4 (%d)\n", i);
 	f4 (i);
 }
+
+void g5 () {
+	fprintf (stderr, "g5 ()\n");
+	fprintf (stderr, "zzz = %i\n", zzz);
+	fprintf (stderr, "g5 done\n");
+}



1.3       +2 -2      mlton/doc/examples/ffi/import.sml

Index: import.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/import.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- import.sml	19 Jul 2003 01:23:25 -0000	1.2
+++ import.sml	23 Jul 2005 11:55:37 -0000	1.3
@@ -13,9 +13,9 @@
 (* Call the C function *)
 val c = ffi (a, r, n)
 
-val n = _import "FFI_INT": int;
+val (addrN, getN, setN) = _symbol "FFI_INT": MLton.Pointer.t, int;
 
-val _ = print (concat [Int.toString n, "\n"])
+val _ = print (concat [Int.toString (getN ()), "\n"])
 
 val _ =
    print (if c = #"c" andalso !r = 45



1.3       +13 -17    mlton/doc/examples/ffi/import2.sml

Index: import2.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/examples/ffi/import2.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- import2.sml	6 Mar 2005 22:09:44 -0000	1.2
+++ import2.sml	23 Jul 2005 11:55:37 -0000	1.3
@@ -1,7 +1,7 @@
 (* main.sml *)
 
 (* Declare ffi to be implemented by calling the C function ffi. *)
-val ffi_addr = _import # "ffi" : MLton.Pointer.t;
+val (ffi_addr, _, _) = _symbol "ffi" : MLton.Pointer.t, MLton.Pointer.t;
 val ffi_schema = _import * : MLton.Pointer.t -> real array * int ref * int -> char;
 open Array
 
@@ -19,13 +19,13 @@
 	     then "success\n"
 	  else "fail\n")
 
-val n = _import "FFI_INT": int;
+val n = #2 (_symbol "FFI_INT": MLton.Pointer.t, int;) ()
 val _ = print (concat [Int.toString n, "\n"])
-val w = _import "FFI_WORD": word;
+val w = #2 (_symbol "FFI_WORD": MLton.Pointer.t, word;) ()
 val _ = print (concat [Word.toString w, "\n"])
-val b = _import "FFI_BOOL": bool;
+val b = #2 (_symbol "FFI_BOOL": MLton.Pointer.t, bool;) ()
 val _ = print (concat [Bool.toString b, "\n"])
-val r = _import "FFI_REAL": real;
+val r = #2 (_symbol "FFI_REAL": MLton.Pointer.t, real;) ()
 val _ = print (concat [Real.toString r, "\n"])
 
 signature OPAQUE =
@@ -55,24 +55,20 @@
       val toString = Real.toString
    end
 
-val n = _import "FFI_INT": OpaqueInt.t;
-val _ = print (concat [OpaqueInt.toString n, "\n"])
-val w = _import "FFI_WORD": OpaqueWord.t;
-val _ = print (concat [OpaqueWord.toString w, "\n"])
-val b = _import "FFI_BOOL": OpaqueBool.t;
-val _ = print (concat [OpaqueBool.toString b, "\n"])
-val r = _import "FFI_REAL": OpaqueReal.t;
-val _ = print (concat [OpaqueReal.toString r, "\n"])
+val (n_addr, n, _) = _symbol "FFI_INT": MLton.Pointer.t, OpaqueInt.t;
+val _ = print (concat [OpaqueInt.toString (n ()), "\n"])
+val (w_addr, w, _) = _symbol "FFI_WORD": MLton.Pointer.t, OpaqueWord.t;
+val _ = print (concat [OpaqueWord.toString (w ()), "\n"])
+val (b_addr, b, _) = _symbol "FFI_BOOL": MLton.Pointer.t, OpaqueBool.t;
+val _ = print (concat [OpaqueBool.toString (b ()), "\n"])
+val (r_addr, r, _) = _symbol "FFI_REAL": MLton.Pointer.t, OpaqueReal.t;
+val _ = print (concat [OpaqueReal.toString (r ()), "\n"])
 
-val n_addr = _import # "FFI_INT": MLton.Pointer.t;
 val n = MLton.Pointer.getInt32 (n_addr, 0);
 val _ = print (concat [Int.toString n, "\n"])
-val w_addr = _import # "FFI_WORD": MLton.Pointer.t;
 val w = MLton.Pointer.getWord32 (w_addr, 0);
 val _ = print (concat [Word.toString w, "\n"])
-val b_addr = _import # "FFI_BOOL": MLton.Pointer.t;
 val b = (MLton.Pointer.getInt32 (n_addr, 0)) <> 0
 val _ = print (concat [Bool.toString b, "\n"])
-val r_addr = _import # "FFI_REAL": MLton.Pointer.t;
 val r = MLton.Pointer.getReal64 (r_addr, 0)
 val _ = print (concat [Real.toString r, "\n"])



1.34      +38 -14    mlton/mlton/ast/ast-core.fun

Index: ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- ast-core.fun	19 Jun 2005 21:33:41 -0000	1.33
+++ ast-core.fun	23 Jul 2005 11:55:37 -0000	1.34
@@ -259,7 +259,7 @@
 
 structure PrimKind =
    struct
-      structure Attribute =
+      structure ImportExportAttribute =
 	 struct
 	    datatype t = Cdecl | Stdcall
 
@@ -270,15 +270,40 @@
 	    val layout = Layout.str o toString
 	 end
 
+      structure SymbolAttribute =
+	 struct
+	    datatype t = Define
+
+	    val toString: t -> string =
+	       fn Define => "define"
+
+	    val layout = Layout.str o toString
+	 end
+      
       datatype t =
-	 BuildConst of {name: string}
-       | CommandLineConst of {name: string, value: Const.t}
-       | Const of {name: string}
-       | Export of {attributes: Attribute.t list, name: string}
-       | IImport of {attributes: Attribute.t list}
-       | Import of {attributes: Attribute.t list, name: string}
-       | Symbol of {name: string}
-       | Prim of {name: string}
+	 BuildConst of {name: string, 
+			ty: Type.t}
+       | CommandLineConst of {name: string, 
+			      ty: Type.t,
+			      value: Const.t}
+       | Const of {name: string, 
+		   ty: Type.t}
+       | Export of {attributes: ImportExportAttribute.t list, 
+		    name: string,
+		    cfTy: Type.t}
+       | IImport of {attributes: ImportExportAttribute.t list,
+		     cfTy: Type.t}
+       | Import of {attributes: ImportExportAttribute.t list, 
+		    name: string,
+		    cfTy: Type.t}
+       | ISymbol of {cbTy: Type.t,
+		     ptrTy: Type.t}
+       | Prim of {name: string, 
+		  ty: Type.t}
+       | Symbol of {attributes: SymbolAttribute.t list, 
+		    name: string,
+		    cbTy: Type.t,
+		    ptrTy: Type.t}
 
       fun name pk =
 	 case pk of
@@ -288,9 +313,9 @@
 	  | Export {name, ...} => name
 	  | IImport {...} => "<iimport>"
 	  | Import {name, ...} => name
-	  | Symbol {name, ...} => name
+	  | ISymbol {...} => "<isymbol>"
 	  | Prim {name, ...} => name
-
+	  | Symbol {name, ...} => name
    end
 
 structure Priority =
@@ -328,8 +353,7 @@
   | Andalso of exp * exp
   | Orelse of exp * exp
   | While of {test: exp, expr: exp}
-  | Prim of {kind: PrimKind.t,
-	     ty: Type.t}
+  | Prim of PrimKind.t
 and decNode =
    Abstype of {body: dec,
 	       datBind: DatBind.t}
@@ -441,7 +465,7 @@
        | Orelse (e, e') =>
 	    delimit (mayAlign [layoutExpF e,
 			       seq [str "orelse ", layoutExpF e']])
-       | Prim {kind, ...} => str (PrimKind.name kind)
+       | Prim kind => str (PrimKind.name kind)
        | Raise exn => delimit (seq [str "raise ", layoutExpF exn])
        | Record r =>
 	    let



1.21      +32 -11    mlton/mlton/ast/ast-core.sig

Index: ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -r1.20 -r1.21
--- ast-core.sig	12 Jan 2005 21:56:00 -0000	1.20
+++ ast-core.sig	23 Jul 2005 11:55:38 -0000	1.21
@@ -85,22 +85,44 @@
 
       structure PrimKind:
 	 sig
-	    structure Attribute:
+	    structure ImportExportAttribute:
 	       sig
 		  datatype t = Cdecl | Stdcall
 		     
 		  val layout: t -> Layout.t
 	       end
+            
+            structure SymbolAttribute:
+               sig
+                  datatype t = Define
+		     
+		  val layout: t -> Layout.t
+               end
 	    
 	    datatype t =
-	       BuildConst of {name: string}
-	     | CommandLineConst of {name: string, value: Const.t}
-	     | Const of {name: string}
-	     | Export of {attributes: Attribute.t list, name: string}
-	     | IImport of {attributes: Attribute.t list}
-	     | Import of {attributes: Attribute.t list, name: string}
-	     | Symbol of {name: string}
-	     | Prim of {name: string}
+	       BuildConst of {name: string, 
+			      ty: Type.t}
+	     | CommandLineConst of {name: string, 
+				    ty: Type.t,
+				    value: Const.t}
+	     | Const of {name: string, 
+			 ty: Type.t}
+	     | Export of {attributes: ImportExportAttribute.t list, 
+			  name: string,
+			  cfTy: Type.t}
+	     | IImport of {attributes: ImportExportAttribute.t list,
+			   cfTy: Type.t}
+	     | Import of {attributes: ImportExportAttribute.t list, 
+			  name: string,
+			  cfTy: Type.t}
+	     | ISymbol of {cbTy: Type.t,
+                           ptrTy: Type.t}
+	     | Prim of {name: string, 
+			ty: Type.t}
+	     | Symbol of {attributes: SymbolAttribute.t list, 
+			  name: string,
+			  cbTy: Type.t,
+			  ptrTy: Type.t}
 	 end
 
       structure Priority:
@@ -129,8 +151,7 @@
 	     | Let of dec * t
 	     | List of t vector
 	     | Orelse of t * t
-	     | Prim of {kind: PrimKind.t,
-			ty: Type.t}
+	     | Prim of PrimKind.t
 	     | Raise of t
 	     | Record of t Record.t
 	     | Selector of Record.Field.t



1.8       +12 -0     mlton/mlton/atoms/ffi.fun

Index: ffi.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.fun,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- ffi.fun	4 Apr 2004 06:50:14 -0000	1.7
+++ ffi.fun	23 Jul 2005 11:55:38 -0000	1.8
@@ -17,6 +17,8 @@
 	      id: int,
 	      name: string,
 	      res: CType.t option} list ref = ref []
+val symbols: {name: string,
+              ty: CType.t} list ref = ref []
 
 fun numExports () = List.length (!exports)
 
@@ -34,6 +36,8 @@
       in
 	 id
       end
+   fun addSymbol {name, ty} = 
+      ignore (List.push (symbols, {name=name, ty=ty}))
 end
 
 val headers: string list ref = ref []
@@ -77,6 +81,14 @@
 	  end)
       val _ = print "Int MLton_FFI_op;\n"
    in
+      List.foreach
+      (!symbols, fn {name, ty} =>
+       let
+          val decl = CType.toString ty ^ " " ^ name;
+       in
+         List.push (headers, "extern " ^ decl);
+         print (decl ^ ";\n")
+       end);
       List.foreach
       (!exports, fn {args, convention, id, name, res} =>
        let



1.7       +2 -0      mlton/mlton/atoms/ffi.sig

Index: ffi.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/ffi.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ffi.sig	12 Apr 2004 17:52:48 -0000	1.6
+++ ffi.sig	23 Jul 2005 11:55:38 -0000	1.7
@@ -21,6 +21,8 @@
 		      convention: CFunction.Convention.t,
 		      name: string,
 		      res: CType.t option} -> int
+      val addSymbol: {ty: CType.t,
+                      name: string} -> unit
       val declareExports: {print: string -> unit} -> unit
       val declareHeaders: {print: string -> unit} -> unit
       val numExports: unit -> int



1.102     +18 -2     mlton/mlton/atoms/prim.fun

Index: prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -r1.101 -r1.102
--- prim.fun	19 Jun 2005 21:33:43 -0000	1.101
+++ prim.fun	23 Jul 2005 11:55:38 -0000	1.102
@@ -46,7 +46,7 @@
  | Exn_setExtendExtra (* implement exceptions *)
  | Exn_setInitExtra (* implement exceptions *)
  | FFI of 'a CFunction.t (* ssa to rssa *)
- | FFI_Symbol of {name: string} (* codegen *)
+ | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
  | GC_collect (* ssa to rssa *)
  | IntInf_add (* ssa to rssa *)
  | IntInf_andb (* ssa to rssa *)
@@ -486,7 +486,7 @@
     | Exn_setExtendExtra => Exn_setExtendExtra
     | Exn_setInitExtra => Exn_setInitExtra
     | FFI func => FFI (CFunction.map (func, f))
-    | FFI_Symbol {name} => FFI_Symbol {name = name}
+    | FFI_Symbol {name, cty} => FFI_Symbol {name = name, cty = cty}
     | GC_collect => GC_collect
     | IntInf_add => IntInf_add
     | IntInf_andb => IntInf_andb
@@ -631,6 +631,22 @@
        | Word16 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 16))
        | Word32 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 32))
        | Word64 => Pointer_getWord (WordSize.fromBits (Bits.fromInt 64))
+   end
+fun pointerSet ctype =
+   let datatype z = datatype CType.t
+   in
+      case ctype of
+	 Int8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+       | Int16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+       | Int32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+       | Int64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
+       | Pointer => Pointer_setPointer
+       | Real32 => Pointer_setReal RealSize.R32
+       | Real64 => Pointer_setReal RealSize.R64
+       | Word8 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 8))
+       | Word16 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 16))
+       | Word32 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 32))
+       | Word64 => Pointer_setWord (WordSize.fromBits (Bits.fromInt 64))
    end
 
 val reff = Ref_ref



1.76      +3 -2      mlton/mlton/atoms/prim.sig

Index: prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -r1.75 -r1.76
--- prim.sig	6 Mar 2005 22:09:44 -0000	1.75
+++ prim.sig	23 Jul 2005 11:55:38 -0000	1.76
@@ -35,7 +35,7 @@
 	     | Exn_setExtendExtra (* implement exceptions *)
 	     | Exn_setInitExtra (* implement exceptions *)
 	     | FFI of 'a CFunction.t (* ssa to rssa *)
-	     | FFI_Symbol of {name: string} (* codegen *)
+	     | FFI_Symbol of {name: string, cty: CType.t} (* codegen *)
 	     | GC_collect (* ssa to rssa *)
 	     | IntInf_add (* ssa to rssa *)
 	     | IntInf_andb (* ssa to rssa *)
@@ -215,7 +215,7 @@
 				deWeak: 'b -> 'b,
 				result: 'b} -> 'b vector
       val ffi: 'a CFunction.t -> 'a t
-      val ffiSymbol: {name: string} -> 'a t
+      val ffiSymbol: {name: string, cty: CType.t} -> 'a t
       val fromString: string -> 'a t
       val gcCollect: 'a t
       val intInfEqual: 'a t
@@ -239,6 +239,7 @@
        *)
       val maySideEffect: 'a t -> bool
       val pointerGet: CType.t -> 'a t
+      val pointerSet: CType.t -> 'a t
       val name: 'a t -> 'a Name.t
       val reff: 'a t
       val serialize: 'a t



1.107     +2 -5      mlton/mlton/codegen/c-codegen/c-codegen.fun

Index: c-codegen.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/codegen/c-codegen/c-codegen.fun,v
retrieving revision 1.106
retrieving revision 1.107
diff -u -r1.106 -r1.107
--- c-codegen.fun	19 Jun 2005 21:33:48 -0000	1.106
+++ c-codegen.fun	23 Jul 2005 11:55:39 -0000	1.107
@@ -461,13 +461,10 @@
 	      case s of
 		 Statement.PrimApp {prim, ...} =>
 		    (case Prim.name prim of
-			Prim.Name.FFI_Symbol {name, ...} =>
+			Prim.Name.FFI_Symbol {name, cty} =>
 			   doit
 			   (name, fn () =>
-			    (* Only take address of FFI_Symbol,
-			     * so no need for a type specifier
-			     *)
-			    concat ["extern ", name, ";\n"])
+			    concat ["extern ", CType.toString cty, " ", name, ";\n"])
 		      | _ => ())
 	       | _ => ())
 	  val _ =



1.4       +2 -1      mlton/mlton/control/control-flags.sig

Index: control-flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- control-flags.sig	19 Jul 2005 12:41:09 -0000	1.3
+++ control-flags.sig	23 Jul 2005 11:55:39 -0000	1.4
@@ -65,6 +65,7 @@
 	    val allowOverload: (bool,bool) t
 	    val allowPrim: (bool,bool) t
 	    val allowRebindEquals: (bool,bool) t
+	    val allowSymbol: (bool,bool) t
 	    val deadCode: (bool,bool) t
 	    val forceUsed: (unit,bool) t
 	    val ffiStr: (string,string option) t
@@ -305,4 +306,4 @@
       (*------------------------------------*)
       (*             End Flags              *)
       (*------------------------------------*)
-end
\ No newline at end of file
+end



1.5       +24 -1     mlton/mlton/control/control-flags.sml

Index: control-flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sml,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- control-flags.sml	19 Jul 2005 12:41:09 -0000	1.4
+++ control-flags.sml	23 Jul 2005 11:55:39 -0000	1.5
@@ -263,6 +263,9 @@
 				  [arg'] => Bool.fromString arg'
 				| _ => NONE}, 
 		  ac)
+	
+	fun setCur (T {cur, ...}, x) = cur := x
+	fun setDef (T {def, ...}, x) = def := x
       in
 	 val ac =
 	    {parseId = fn _ => NONE,
@@ -281,8 +284,28 @@
 	    makeBool ({name = "allowOverload", default = false, expert = false}, ac)
 	 val (allowRebindEquals, ac) =
 	    makeBool ({name = "allowRebindEquals", default = false, expert = true}, ac)
+	 val (allowSymbol, ac) =
+	    makeBool ({name = "allowSymbol", default = false, expert = false}, ac)
 	 val (deadCode, ac) =
 	    makeBool ({name = "deadCode", default = false, expert = false}, ac)
+	 val (allowFFI, ac) =
+	    make ({default = false,
+	           expert = false,
+	           toString = Bool.toString,
+	           name = "allowFFI",
+	           newCur = fn (_, b) => (setCur (allowExport, b)
+	          			  ; setCur (allowImport, b)
+	          			  ; setCur (allowSymbol, b)
+	          			  ; b),
+	           newDef = fn (_, b) => (setDef (allowExport, b)
+	          			  ; setDef (allowImport, b)
+	          			  ; setDef (allowSymbol, b)
+	          			  ; b),
+		   parseArgs = fn args' =>
+		               case args' of
+				  [arg'] => Bool.fromString arg'
+				| _ => NONE}, 
+		  ac)
 	 val (forceUsed, ac) =
 	    make ({default = false,
 		   expert = false,
@@ -769,4 +792,4 @@
 
 val _ = defaults ()
 
-end
\ No newline at end of file
+end



1.153     +472 -237  mlton/mlton/elaborate/elaborate-core.fun

Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.152
retrieving revision 1.153
diff -u -r1.152 -r1.153
--- elaborate-core.fun	21 Jul 2005 05:57:57 -0000	1.152
+++ elaborate-core.fun	23 Jul 2005 11:55:40 -0000	1.153
@@ -38,7 +38,8 @@
    structure Longvid = Longvid
    structure Longtycon = Longtycon
    structure PrimKind = PrimKind
-   structure Attribute = PrimKind.Attribute
+   structure ImportExportAttribute = PrimKind.ImportExportAttribute
+   structure SymbolAttribute = PrimKind.SymbolAttribute
    structure Priority = Priority
    structure Record = Record
    structure SortedRecord = SortedRecord
@@ -822,13 +823,13 @@
 	       end
    end
 
-fun parseAttributes (attributes: Attribute.t list): Convention.t option =
+fun parseIEAttributes (attributes: ImportExportAttribute.t list): Convention.t option =
    case attributes of
       [] => SOME Convention.Cdecl
     | [a] =>
 	 SOME (case a of
-		  Attribute.Cdecl => Convention.Cdecl
-		| Attribute.Stdcall =>
+		  ImportExportAttribute.Cdecl => Convention.Cdecl
+		| ImportExportAttribute.Stdcall =>
 		     if let
 			   open Control
 			in
@@ -841,7 +842,7 @@
 		     else Convention.Cdecl)
     | _ => NONE
 
-fun import {attributes: Attribute.t list,
+fun import {attributes: ImportExportAttribute.t list,
 	    name: string option,
 	    region: Region.t,
 	    ty: Type.t}: Type.t Prim.t =
@@ -849,15 +850,16 @@
       fun error l = Control.error (region, l, Layout.empty)
       fun invalidAttributes () =
 	 error (seq [str "invalid attributes for import: ",
-		     List.layout Attribute.layout attributes])
+		     List.layout ImportExportAttribute.layout attributes])
+      fun invalidType () =
+	 Control.error (region,
+			str "invalid type for import",
+			Type.layoutPretty ty)
    in
       case Type.parse ty of
 	 NONE =>
 	    let
-	       val () =
-		  Control.error (region,
-				 str "invalid type for import",
-				 Type.layoutPretty ty)
+	       val () = invalidType ()
 	    in
 	       Prim.bogus
 	    end
@@ -865,7 +867,7 @@
 	    let
 	       datatype z = datatype CFunction.Target.t
 	       val convention =
-		  case parseAttributes attributes of
+		  case parseIEAttributes attributes of
 		     NONE => (invalidAttributes ()
 			      ; Convention.Cdecl)
 		   | SOME c => c
@@ -895,116 +897,273 @@
 					    NONE => Indirect
 					  | SOME name => Direct name),
 			       writesStackTop = true}
-
 	    in
 	       Prim.ffi func
 	    end
    end
 
-fun fetchSymbol {attributes: Attribute.t list,
-		 name: string,
-		 primApp: {args: Cexp.t vector, 
-			   prim: Type.t Prim.t, 
-			   result: Type.t} -> Cexp.t,
-		 ty: Type.t,
-		 region: Region.t}: Cexp.t =
+fun primApp {args, prim, result: Type.t} =
    let
-      fun error l = Control.error (region, l, Layout.empty)
-      fun invalidAttributes () =
-	 error (seq [str "invalid attributes for import: ",
-		     List.layout Attribute.layout attributes])
-      val bogus = primApp {args = Vector.new0 (), 
-			   prim = Prim.bogus,
-			   result = ty}
+      val targs = Prim.extractTargs (prim,
+			             {args = Vector.map (args, Cexp.ty),
+			              deArray = Type.deArray,
+			              deArrow = Type.deArrow,
+			              deVector = Type.deVector,
+			              deWeak = Type.deWeak,
+				      result = result})
    in
-      case Type.toCType ty of
-	 NONE => 
-	    let
-	       val () =
-		  Control.error 
-		  (region,
-		   str "invalid type for import",
-		   Type.layoutPretty ty)
-	    in
-	       bogus
-	    end
-       | SOME {ctype, ...} => 
-	    (case attributes of
-		[] => 
-		   let
-		      val isBool =
-			 case Type.deConOpt ty of
-			    NONE => false
-			  | SOME (c,_) => Tycon.equals (c, Tycon.bool)
-		      val addrTy = 
-			 Type.word (WordSize.pointer ())
-		      val addrExp = 
-			 primApp
-			 {args = Vector.new0 (),
-			  prim = Prim.ffiSymbol {name = name},
-			  result = addrTy}
-		      val zeroExp =
-			 Cexp.make
-			 (Cexp.Const
-			  (fn () => Const.word (WordX.zero WordSize.default)),
-			  Type.defaultWord)
-		      val fetchTy =
-			 if isBool then Type.defaultWord else ty
-		      val fetchExp = 
-			 primApp 
-			 {args = Vector.new2 (addrExp,zeroExp),
-			  prim = Prim.pointerGet ctype,
-			  result = fetchTy}
-		   in
-		      if isBool 
-			 then Cexp.casee
-			      {kind = "",
-			       lay = fn () => Layout.empty,
-			       noMatch = Cexp.Impossible,
-			       region = Region.bogus,
-			       rules = Vector.new2
-			               ({exp = Cexp.truee,
-					 lay = NONE,
-					 pat = Cpat.falsee},
-					{exp = Cexp.falsee,
-					 lay = NONE,
-					 pat = Cpat.truee}),
-			       test = primApp
-				      {args = Vector.new2 (fetchExp, zeroExp),
-				       prim = Prim.wordEqual WordSize.default,
-				       result = ty},
-				      warnMatch = false}
-			 else fetchExp
-		   end
-	      | _ => 
-		   (invalidAttributes ()
-		    ; bogus))
+      Cexp.make (Cexp.PrimApp {args = args,
+			       prim = prim,
+			       targs = targs},
+                 result)
    end
 
-fun symbol {name: string,
-	    ty: Type.t,
-	    region: Region.t}: Type.t Prim.t =
-   case Type.toCType ty of
-      SOME {ctype = CType.Pointer, ...} =>
-	 Prim.ffiSymbol {name = name}
-    | _ =>
-	 let
-	    val () =
-	       Control.error (region,
-			      str "invalid type for import",
-			      Type.layoutPretty ty)
-	 in
-	    Prim.bogus
-	 end
+local
+   val zeroExp = Cexp.make (Cexp.Const
+			    (fn () => Const.word (WordX.zero WordSize.default)),
+			    Type.defaultWord)
+   val oneExp = Cexp.make (Cexp.Const
+			   (fn () => Const.word (WordX.one WordSize.default)),
+			   Type.defaultWord)
+
+   fun address {ctypeCbTy: CType.t,
+		expandedPtrTy: Type.t,
+		name: string}: Cexp.t =
+      primApp {args = Vector.new0 (),
+	       prim = Prim.ffiSymbol {name = name,
+				      cty = ctypeCbTy},
+	       result = expandedPtrTy}
+
+   fun fetch {ctypeCbTy, isBool,
+	      expandedCbTy,
+	      ptrExp: Cexp.t}: Cexp.t =
+      let
+	 val fetchExp = 
+	    primApp {args = Vector.new2 (ptrExp, zeroExp),
+		     prim = Prim.pointerGet ctypeCbTy,
+		     result = if isBool 
+				 then Type.defaultWord 
+				 else expandedCbTy}
+      in
+	 if not isBool then fetchExp else
+         Cexp.casee {kind = "",
+		     lay = fn () => Layout.empty,
+		     noMatch = Cexp.Impossible,
+		     region = Region.bogus,
+		     rules = Vector.new2
+		             ({exp = Cexp.truee, lay = NONE, pat = Cpat.falsee},
+			      {exp = Cexp.falsee, lay = NONE, pat = Cpat.truee}),
+		     test = primApp
+		            {args = Vector.new2 (fetchExp, zeroExp),
+			     prim = Prim.wordEqual WordSize.default,
+			     result = expandedCbTy},
+		     warnMatch = false}
+      end
+
+   fun store {ctypeCbTy, isBool,
+	      ptrExp: Cexp.t, valueExp: Cexp.t}: Cexp.t =
+      let
+	 val valueExp =
+	    if not isBool then valueExp else
+	    Cexp.casee {kind = "",
+			lay = fn () => Layout.empty,
+			noMatch = Cexp.Impossible,
+			region = Region.bogus,
+			rules = Vector.new2 
+                                ({exp = oneExp, lay = NONE, pat = Cpat.truee},
+				 {exp = zeroExp, lay = NONE, pat = Cpat.falsee}),
+			test = valueExp,
+			warnMatch = false}
+      in
+	 primApp {args = Vector.new3 (ptrExp, zeroExp, valueExp),
+		  prim = Prim.pointerSet ctypeCbTy,
+		  result = Type.unit}
+      end
+in
+   fun symbolDirect {attributes: SymbolAttribute.t list,
+		     elabedCbTy: Type.t,
+		     expandedCbTy: Type.t,
+		     elabedPtrTy: Type.t,
+		     expandedPtrTy: Type.t,
+		     name: string,
+		     region: Region.t}: Cexp.t =
+      let
+	 val ctypeCbTy =
+	    case Type.toCType expandedCbTy of
+	       SOME {ctype, ...} => ctype
+	     | NONE => 
+		  (Control.error
+		   (region, str "invalid type for _symbol object",
+		    Type.layoutPretty elabedCbTy)
+		   ; CType.Pointer)
+	 val isBool =
+	    case Type.deConOpt expandedCbTy of
+	       NONE => false
+	     | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+	 val ctypePtrTy =
+	    case Type.toCType expandedPtrTy of
+	       SOME {ctype = CType.Pointer, ...} => CType.Pointer
+	     | _ =>
+		  (Control.error
+		   (region, str "invalid type for _symbol ptr",
+		    Type.layoutPretty elabedCbTy)
+		   ; CType.Pointer)
+	 val addrExp =
+	    address {ctypeCbTy = ctypeCbTy,
+		     expandedPtrTy = expandedPtrTy,
+		     name = name}
+	 val () =
+	    if List.exists (attributes, fn attr =>
+			    attr = SymbolAttribute.Define)
+	       then Ffi.addSymbol {name = name, ty = ctypeCbTy}
+	       else ()
+	 val getArg = Var.newNoname ()
+	 val setArg = Var.newNoname ()
+	 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
+      in
+	 (Cexp.tuple o Vector.new3)
+	 (wrap (addrExp, elabedPtrTy),
+	  wrap ((Cexp.lambda o Lambda.make)
+		{arg = getArg,
+		 argType = Type.unit,
+		 body = fetch {ctypeCbTy = ctypeCbTy, 
+			       isBool = isBool,
+			       expandedCbTy = expandedCbTy,
+			       ptrExp = addrExp},
+		 mayInline = true},
+		Type.arrow (Type.unit, elabedCbTy)),
+	  wrap ((Cexp.lambda o Lambda.make)
+		{arg = setArg,
+		 argType = elabedCbTy,
+		 body = store {ctypeCbTy = ctypeCbTy,
+			       isBool = isBool,
+			       ptrExp = addrExp,
+			       valueExp = Cexp.var (setArg, expandedCbTy)},
+		 mayInline = true},
+		Type.arrow (elabedCbTy, Type.unit)))
+      end
 
-fun export {attributes, name: string, region: Region.t, ty: Type.t}: Aexp.t =
+   fun symbolIndirect {elabedCbTy: Type.t,
+		       expandedCbTy: Type.t,
+		       elabedPtrTy: Type.t,
+		       expandedPtrTy: Type.t,
+		       region: Region.t}: Cexp.t =
+      let
+	 val ctypeCbTy =
+	    case Type.toCType expandedCbTy of
+	       SOME {ctype, ...} => ctype
+	     | NONE => 
+		  (Control.error
+		   (region, str "invalid type for _symbol object",
+		    Type.layoutPretty elabedCbTy)
+		   ; CType.Pointer)
+	 val isBool =
+	    case Type.deConOpt expandedCbTy of
+	       NONE => false
+	     | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+	 val ctypePtrTy =
+	    case Type.toCType expandedPtrTy of
+	       SOME {ctype = CType.Pointer, ...} => CType.Pointer
+	     | _ =>
+		  (Control.error
+		   (region, str "invalid type for _symbol ptr",
+		    Type.layoutPretty elabedCbTy)
+		   ; CType.Pointer)
+	 fun wrap (e, t) = Cexp.make (Cexp.node e, t)
+	 val getArg = Var.newNoname ()
+	 val setArg = Var.newNoname ()
+	 val elabedSetArgTy =
+	    Type.tuple (Vector.new2 (elabedPtrTy, elabedCbTy))
+	 val setArgPtr = Var.newNoname ()
+	 val setArgValue = Var.newNoname ()
+	 val setPat =
+	    Cpat.tuple (Vector.new2 (Cpat.var (setArgPtr, expandedPtrTy), 
+				     Cpat.var (setArgValue, expandedCbTy)))
+	 val setExp = store {ctypeCbTy = ctypeCbTy,
+			     isBool = isBool,
+			     ptrExp = Cexp.var (setArgPtr, expandedPtrTy),
+			     valueExp = Cexp.var (setArgValue, expandedCbTy)}
+	 val setBody =
+	    Cexp.casee {kind = "",
+			lay = fn () => Layout.empty,
+			noMatch = Cexp.Impossible,
+			region = Region.bogus,
+			rules = Vector.new1 ({exp = setExp, lay = NONE, pat = setPat}),
+			test = Cexp.var (setArg, elabedSetArgTy),
+			warnMatch = false}
+      in
+	 (Cexp.tuple o Vector.new2)
+	 (wrap ((Cexp.lambda o Lambda.make)
+		{arg = getArg,
+		 argType = expandedPtrTy,
+		 body = fetch {ctypeCbTy = ctypeCbTy,
+			       expandedCbTy = expandedCbTy,
+			       isBool = isBool,
+			       ptrExp = Cexp.var (getArg, expandedPtrTy)},
+		 mayInline = true},
+		Type.arrow (elabedPtrTy, elabedCbTy)),
+	  wrap ((Cexp.lambda o Lambda.make)
+		{arg = setArg,
+		 argType = elabedCbTy,
+		 body = setBody,
+		 mayInline = true},
+		Type.arrow (elabedSetArgTy, Type.unit)))
+      end
+
+   fun importSymbol {attributes: ImportExportAttribute.t list,
+		     elabedCbTy: Type.t,
+		     expandedCbTy: Type.t,
+		     name: string,
+		     region: Region.t}: Cexp.t =
+      let
+	 val () =
+	    Control.warning 
+	    (region,
+	     str "_import of non-function is deprecated, use _symbol",
+	     empty)
+	 fun error l = Control.error (region, l, Layout.empty)
+	 fun invalidAttributes () =
+	    error (seq [str "invalid attributes for import: ",
+			List.layout ImportExportAttribute.layout attributes])
+	 val () =
+	    if List.isEmpty attributes
+	       then ()
+	       else invalidAttributes ()
+	 val ctypeCbTy =
+	    case Type.toCType elabedCbTy of
+	       SOME {ctype, ...} => ctype
+	     | NONE => 
+		  (Control.error
+		   (region, str "invalid type for import",
+		    Type.layoutPretty elabedCbTy)
+		   ; CType.Pointer)
+	 val isBool =
+	    case Type.deConOpt expandedCbTy of
+	       NONE => false
+	     | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+	 val addrExp =
+	    address {ctypeCbTy = ctypeCbTy,
+		     expandedPtrTy = Type.word (WordSize.pointer ()),
+		     name = name}
+      in
+	 fetch {ctypeCbTy = ctypeCbTy, 
+		isBool = isBool,
+		expandedCbTy = expandedCbTy,
+		ptrExp = addrExp}
+      end
+end
+
+fun export {attributes: ImportExportAttribute.t list,
+	    name: string, 
+	    region: Region.t, 
+	    ty: Type.t}: Aexp.t =
    let
       fun error l = Control.error (region, l, Layout.empty)
       fun invalidAttributes () =
 	 error (seq [str "invalid attributes for export: ",
-		     List.layout Attribute.layout attributes])
+		     List.layout ImportExportAttribute.layout attributes])
       val convention =
-	 case parseAttributes attributes of
+	 case parseIEAttributes attributes of
 	    NONE => (invalidAttributes ()
 		     ; Convention.Cdecl)
 	  | SOME c => c
@@ -2263,58 +2422,46 @@
 		   in
 		      Cexp.orElse (ce, ce')
 		   end
-	      | Aexp.Prim {kind, ty} => 
+	      | Aexp.Prim kind => 
 		   let
-		      val ty = elabType ty
-		      fun expandTy ty =
-			 Type.hom
-			 (ty, {con = Type.con,
-			       expandOpaque = true,
-			       record = Type.record,
-			       replaceSynonyms = false,
-			       var = Type.var})
-		      val expandedTy = expandTy ty
+		      fun elabAndExpandTy ty =
+			 let
+			    val elabedTy = elabType ty
+			    val expandedTy =
+			       Type.hom
+			       (elabedTy, {con = Type.con,
+					   expandOpaque = true,
+					   record = Type.record,
+					   replaceSynonyms = false,
+					   var = Type.var})
+			 in
+			    (elabedTy, expandedTy)
+			 end
 		      (* We use expandedTy to get the underlying primitive right
 		       * but we use wrap in the end to make the result of the
 		       * final expression be ty, because that is what the rest
 		       * of the code expects to see.
 		       *)
 		      fun wrap (e, t) = Cexp.make (Cexp.node e, t)
-		      fun primApp {args, prim, result: Type.t} =
-			 let
-			    val targs =
-			       Prim.extractTargs
-			       (prim,
-				{args = Vector.map (args, Cexp.ty),
-				 deArray = Type.deArray,
-				 deArrow = Type.deArrow,
-				 deVector = Type.deVector,
-				 deWeak = Type.deWeak,
-				 result = result})
-			 in
-			    Cexp.make (Cexp.PrimApp {args = args,
-						     prim = prim,
-						     targs = targs},
-				       result)
-			 end
-		      fun etaExtra (extra, ty, expandedTy,
-				    p: Type.t Prim.t): Cexp.t =
+		      fun etaExtra {elabedTy, expandedTy, 
+				    extra,
+				    prim: Type.t Prim.t} : Cexp.t =
 			 case Type.deArrowOpt expandedTy of
 			    NONE =>
 			       wrap (primApp {args = extra,
-					      prim = p,
-					      result = ty},
-				     ty)
+					      prim = prim,
+					      result = elabedTy},
+				     elabedTy)
 			  | SOME (argType, bodyType) =>
 			       let
 				  val arg = Var.newNoname ()
 				  fun app args =
 				     primApp {args = Vector.concat [extra, args],
-					      prim = p,
+					      prim = prim,
 					      result = bodyType}
 				  val body =
 				     case Type.deTupleOpt argType of
-					NONE =>
+					NONE => 
 					   app (Vector.new1
 						(Cexp.var (arg, argType)))
 				      | SOME ts =>
@@ -2329,16 +2476,15 @@
 					       lay = fn _ => Layout.empty,
 					       noMatch = Cexp.Impossible,
 					       region = Region.bogus,
-					       rules =
-					       Vector.new1
-					       {exp = app (Vector.map
-							   (vars, Cexp.var)),
-						lay = NONE,
-						pat =
-						(Cpat.tuple
-						 (Vector.map (vars, Cpat.var)))},
-					       test = Cexp.var (arg, argType),
-					       warnMatch = warnMatch ()}
+					       rules = Vector.new1
+					               {exp = app (Vector.map
+								   (vars, Cexp.var)),
+							lay = NONE,
+							pat = Cpat.tuple 
+							      (Vector.map 
+							       (vars, Cpat.var))},
+					        test = Cexp.var (arg, argType),
+						warnMatch = false}
 					   end
 			       in
 				  Cexp.make (Cexp.Lambda
@@ -2346,11 +2492,17 @@
 							   argType = argType,
 							   body = body,
 							   mayInline = true}),
-					     ty)
+					     elabedTy)
 			       end
-		      fun eta (p: Type.t Prim.t): Cexp.t =
-			 etaExtra (Vector.new0 (), ty, expandedTy, p)
-		      fun lookConst {default: string option, name: string} =
+		      fun eta {elabedTy, expandedTy, 
+			       prim: Type.t Prim.t} : Cexp.t =
+			 etaExtra {elabedTy = elabedTy,
+				   expandedTy = expandedTy,
+				   extra = Vector.new0 (),
+				   prim = prim}
+		      fun lookConst {default: string option, 
+				     elabedTy, expandedTy,
+				     name: string} =
 			 let
 			    fun bug () =
 			       let
@@ -2391,22 +2543,34 @@
 				  val finish =
 				     fn () => ! Const.lookup ({default = default,
 							       name = name}, ct)
-			       in
-				  Cexp.make (Cexp.Const finish, ty)
-			       end
+				  in
+				     Cexp.make (Cexp.Const finish, elabedTy)
+				  end
 			 end
 		      val check = fn (c, n) => check (c, n, region)
 		      datatype z = datatype Ast.PrimKind.t
 		   in
 		      case kind of
-			 BuildConst {name} =>
-			    (check (ElabControl.allowConstant, "_build_const")
-			     ; lookConst {default = NONE, name = name})
-		       | CommandLineConst {name, value} =>
+			 BuildConst {name, ty} =>
+			    let
+			       val () =
+				  check (ElabControl.allowConstant, 
+					 "_build_const")
+			       val (elabedTy, expandedTy) = 
+				  elabAndExpandTy ty
+			    in
+			       lookConst {default = NONE,
+					  elabedTy = elabedTy,
+					  expandedTy = expandedTy,
+					  name = name}
+			    end
+		       | CommandLineConst {name, ty, value} =>
 			    let
 			       val () =
 				  check (ElabControl.allowConstant,
 					 "_command_line_const")
+			       val (elabedTy, expandedTy) = 
+				  elabAndExpandTy ty
 			       val value =
 				  elabConst
 				  (value,
@@ -2417,106 +2581,177 @@
 				    | c => Const.toString c,
 				   {false = "false", true = "true"})
 			    in
-			       lookConst {default = SOME value, name = name}
+			       lookConst {default = SOME value, 
+					  elabedTy = elabedTy,
+					  expandedTy = expandedTy,
+					  name = name}
 			    end
-		       | Const {name} => 
-			    (check (ElabControl.allowConstant, "_const")
-			     ; lookConst {default = NONE, name = name})
-		       | Export {attributes, name} =>
-			    (check (ElabControl.allowExport, "_export")
-			     ; let
-				  val e =
-				     Env.scope
-				     (E, fn () =>
-				      (Env.openStructure
-				       (E, valOf (!Env.Structure.ffi))
-				       ; elab (export {attributes = attributes,
-						       name = name,
-						       region = region,
-						       ty = expandedTy})))
-				  val _ =
-				     unify
-				     (Cexp.ty e,
-				      Type.arrow (expandedTy, Type.unit),
-				      fn (l1, l2) =>
-				      let
-					 open Layout
-				      in
-					 (region,
-					  str "_export unify bug",
-					  align [seq [str "inferred: ", l1],
-						 seq [str "expanded: ", l2]])
-				      end)
-			       in
-				  wrap (e, Type.arrow (ty, Type.unit))
-			       end)
-		       | IImport {attributes} =>
+		       | Const {name, ty} => 
+			    let
+			       val () =
+				  check (ElabControl.allowConstant, 
+					 "_const")
+			       val (elabedTy, expandedTy) = 
+				  elabAndExpandTy ty
+			    in
+			       lookConst {default = NONE,
+					  elabedTy = elabedTy,
+					  expandedTy = expandedTy,
+					  name = name}
+			    end
+		       | Export {attributes, cfTy, name} =>
 			    let
 			       val () =
-				  check (ElabControl.allowImport, "_import")
+				  check (ElabControl.allowExport, 
+					 "_export")
+			       val (elabedTy, expandedTy) = 
+				  elabAndExpandTy cfTy
+			       val exp =
+				  Env.scope
+				  (E, fn () =>
+				   (Env.openStructure
+				    (E, valOf (!Env.Structure.ffi))
+				    ; elab (export {attributes = attributes,
+						    name = name,
+						    region = region,
+						    ty = expandedTy})))
+			       val _ =
+				  unify
+				  (Cexp.ty exp,
+				   Type.arrow (expandedTy, Type.unit),
+				   fn (l1, l2) =>
+				   let
+				      open Layout
+				   in
+				      (region,
+				       str "_export unify bug",
+				       align [seq [str "inferred: ", l1],
+					      seq [str "expanded: ", l2]])
+				   end)
 			    in
-			       case (Type.deArrowOpt ty,
-				     Type.deArrowOpt expandedTy) of
-				  (SOME ty, SOME expandedTy) =>
+			       wrap (exp, Type.arrow (elabedTy, Type.unit))
+			    end
+		       | IImport {attributes, cfTy} =>
+			    let
+			       val () =
+				  check (ElabControl.allowImport, 
+					 "_import")
+			       val (elabedCfTy, expandedCfTy) =
+				  elabAndExpandTy cfTy
+			    in
+			       case (Type.deArrowOpt elabedCfTy,
+				     Type.deArrowOpt expandedCfTy) of
+				  (SOME elabedTy, SOME expandedTy) =>
 				     let
-					val ((fptrTy,ty), 
-					     (fptrExpandedTy,expandedTy)) =
-					   (ty, expandedTy)
+					val ((elabedFPtrTy,elabedCfTy), 
+					     (expandedFPtrTy,expandedCfTy)) =
+					   (elabedTy, expandedTy)
 					val () =
-					   case Type.toCType fptrExpandedTy of
+					   case Type.toCType expandedFPtrTy of
 					      SOME {ctype = CType.Pointer, ...} => ()
 					    | _ => 
 						 Control.error
 						 (region,
 						  str "invalid type for import",
-						  Type.layoutPretty fptrExpandedTy)
+						  Type.layoutPretty expandedFPtrTy)
 					val fptr = Var.newNoname ()
-					val fptrArg = Cexp.var (fptr, fptrTy)
+					val fptrArg = Cexp.var (fptr, expandedFPtrTy)
 				     in
 					Cexp.make
 					(Cexp.Lambda
 					 (Lambda.make 
 					  {arg = fptr,
-					   argType = fptrTy,
-					   body = etaExtra (Vector.new1 fptrArg,
-							    ty, expandedTy,
-							    import
-							    {attributes = attributes,
-							     name = NONE,
-							     region = region,
-							     ty = expandedTy}),
+					   argType = elabedFPtrTy,
+					   body = etaExtra 
+                                                  {elabedTy = elabedCfTy,
+						   expandedTy = expandedCfTy,
+						   extra = Vector.new1 fptrArg,
+						   prim = import
+							  {attributes = attributes,
+							   name = NONE,
+							   region = region,
+							   ty = expandedCfTy}},
 					   mayInline = true}),
-					 Type.arrow (fptrTy, ty))
+					 Type.arrow (elabedFPtrTy, elabedCfTy))
 				     end
 				| _ => 
 				     (Control.error
 				      (region,
 				       str "invalid type for import",
-				       Type.layoutPretty ty);
-				      eta Prim.bogus)
+				       Type.layoutPretty elabedCfTy);
+				      eta {elabedTy = elabedCfTy,
+					   expandedTy = expandedCfTy,
+					   prim = Prim.bogus})
+			    end
+		       | Import {attributes, name, cfTy} =>
+			    let
+			       val () =
+				  check (ElabControl.allowImport, 
+					 "_import")
+			       val (elabedCfTy, expandedCfTy) =
+				  elabAndExpandTy cfTy
+			    in
+			       case Type.deArrowOpt expandedCfTy of
+				  NONE => 
+				     importSymbol {attributes = attributes,
+						   elabedCbTy = elabedCfTy,
+						   expandedCbTy = expandedCfTy,
+						   name = name,
+						   region = region}
+				| SOME _ =>
+				     eta ({elabedTy = elabedCfTy,
+					   expandedTy = expandedCfTy,
+					   prim = import {attributes = attributes,
+							  name = SOME name,
+							  region = region,
+							  ty = expandedCfTy}})
+			    end
+                       | ISymbol {cbTy, ptrTy} =>
+			    let
+			       val () =
+				  check (ElabControl.allowSymbol, 
+					 "_symbol")
+			       val (elabedCbTy, expandedCbTy) =
+				  elabAndExpandTy cbTy
+			       val (elabedPtrTy, expandedPtrTy) =
+				  elabAndExpandTy ptrTy
+			    in
+			       symbolIndirect {elabedCbTy = elabedCbTy,
+					       expandedCbTy = expandedCbTy,
+					       elabedPtrTy = elabedPtrTy,
+					       expandedPtrTy = expandedPtrTy,
+					       region = region}
+			    end
+		       | Prim {name, ty} => 
+			    let
+			       val () =
+				  check (ElabControl.allowPrim, 
+					 "_prim")
+			       val (elabedTy, expandedTy) = 
+				  elabAndExpandTy ty
+			    in
+			       eta {elabedTy = elabedTy,
+				    expandedTy = expandedTy,
+				    prim = Prim.fromString name}
+			    end
+                       | Symbol {attributes, cbTy, ptrTy, name} =>
+			    let
+			       val () =
+				  check (ElabControl.allowSymbol, 
+					 "_symbol")
+			       val (elabedCbTy, expandedCbTy) =
+				  elabAndExpandTy cbTy
+			       val (elabedPtrTy, expandedPtrTy) =
+				  elabAndExpandTy ptrTy
+			    in
+			       symbolDirect {attributes = attributes,
+					     elabedCbTy = elabedCbTy,
+					     expandedCbTy = expandedCbTy,
+					     elabedPtrTy = elabedPtrTy,
+					     expandedPtrTy = expandedPtrTy,
+					     name = name,
+					     region = region}
 			    end
-		       | Import {attributes, name} =>
-			    (check (ElabControl.allowImport, "_import")
-			     ; (case Type.deArrowOpt expandedTy of
-				   NONE => 
-				      wrap (fetchSymbol {attributes = attributes,
-							 name = name,
-							 primApp = primApp,
-							 region = region,
-							 ty = expandedTy}, ty)
-				 | SOME _ =>
-				      eta (import {attributes = attributes,
-						   name = SOME name,
-						   region = region,
-						   ty = expandedTy})))
-		       | Symbol {name} =>
-			    (check (ElabControl.allowImport, "_import")
-			     ; eta (symbol {name = name,
-					    region = region,
-					    ty = expandedTy}))
-		       | Prim {name} => 
-			    (check (ElabControl.allowPrim, "_prim")
-			     ; eta (Prim.fromString name))
 		   end
 	      | Aexp.Raise exn =>
 		   let



1.14      +38 -4     mlton/mlton/elaborate/scope.fun

Index: scope.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/scope.fun,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- scope.fun	19 Jun 2005 21:33:58 -0000	1.13
+++ scope.fun	23 Jul 2005 11:55:40 -0000	1.14
@@ -215,6 +215,43 @@
 	 in
 	    loop p
 	 end
+      fun loopPrimKind (kind: PrimKind.t, d: 'down): PrimKind.t * 'up =
+	 let
+	    datatype z = datatype PrimKind.t
+	    fun do1 ((a, u), f) = (f a, u)
+	    fun do2 ((a1, u1), (a2, u2), f) =
+	       (f (a1, a2), combineUp (u1, u2))
+	 in
+	    case kind of
+	        BuildConst {name, ty} =>
+		  do1 (loopTy (ty, d), fn ty =>
+		       BuildConst {name = name, ty = ty})
+	      | CommandLineConst {name, ty, value} =>
+		  do1 (loopTy (ty, d), fn ty =>
+		       CommandLineConst {name = name, ty = ty, value = value})
+	      | Const {name, ty} =>
+		  do1 (loopTy (ty, d), fn ty =>
+		       Const {name = name, ty = ty})
+	      | Export {attributes, name, cfTy} =>
+		  do1 (loopTy (cfTy, d), fn cfTy =>
+		       Export {attributes = attributes, name = name, cfTy = cfTy})
+	      | IImport {attributes, cfTy} =>
+		  do1 (loopTy (cfTy, d), fn cfTy =>
+		       IImport {attributes = attributes, cfTy = cfTy})
+	      | Import {attributes, name, cfTy} =>
+		  do1 (loopTy (cfTy, d), fn cfTy =>
+		       Import {attributes = attributes, name = name, cfTy = cfTy})
+	      | ISymbol {cbTy, ptrTy} =>
+		  do2 (loopTy (cbTy, d), loopTy (ptrTy, d), fn (cbTy, ptrTy) =>
+		       ISymbol {cbTy = cbTy, ptrTy = ptrTy})
+	      | Prim {name, ty} =>
+		  do1 (loopTy (ty, d), fn ty =>
+		       Prim {name = name, ty = ty})
+	      | Symbol {attributes, name, cbTy, ptrTy} =>
+		  do2 (loopTy (cbTy, d), loopTy (ptrTy, d), fn (cbTy, ptrTy) =>
+		       Symbol {attributes = attributes, name = name, 
+			       cbTy = cbTy, ptrTy = ptrTy})
+	 end
       fun loopDec (d: Dec.t, down: 'down): Dec.t * 'up =
 	 let
 	    fun doit n = Dec.makeRegion (n, Dec.region d)
@@ -389,10 +426,7 @@
 		   | Let (dec, e) => do2 (loopDec (dec, d), loop e, Let)
 		   | List ts => doVec (ts, List)
 		   | Orelse (e1, e2) => do2 (loop e1, loop e2, Orelse)
-		   | Prim {kind, ty} =>
-			do1 (loopTy (ty, d), fn ty =>
-			     Prim {kind = kind,
-				   ty = ty})
+		   | Prim kind => do1 (loopPrimKind (kind, d), Prim)
 		   | Raise exn => do1 (loop exn, Raise)
 		   | Record r =>
 			let



1.45      +49 -30    mlton/mlton/front-end/ml.grm

Index: ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -r1.44 -r1.45
--- ml.grm	19 Jul 2005 16:52:28 -0000	1.44
+++ ml.grm	23 Jul 2005 11:55:41 -0000	1.45
@@ -232,7 +232,9 @@
     | RBRACKET | REC | RPAREN | SEMICOLON | SHARING | SIG | SIGNATURE | STRUCT
     | STRUCTURE | THEN | TYPE | VAL | WHERE | WHILE | WILD | WITH | WITHTYPE
       (* Extensions *)
-    | BUILD_CONST | COMMAND_LINE_CONST | CONST | EXPORT | IMPORT | PRIM
+    | BUILD_CONST | COMMAND_LINE_CONST | CONST 
+    | EXPORT | IMPORT | SYMBOL 
+    | PRIM
 
 %nonterm
          aexp of Exp.node
@@ -244,7 +246,7 @@
        | app_exp of Exp.t list
        | app_exp1 of Exp.t list
        | arg_fct of Strexp.t
-       | attributes of PrimKind.Attribute.t list
+       | ieattributes of PrimKind.ImportExportAttribute.t list
        | clause of clause
        | clauses of clause list
        | clausesTop of clauses
@@ -365,6 +367,7 @@
        | strexpnode of Strexp.node
        | strid of Strid.t
        | string of string
+       | symattributes of PrimKind.SymbolAttribute.t list
        | tlabel of (Field.t * Type.t)
        | tlabels  of (Field.t * Type.t) list
        | topdec of Topdec.t
@@ -1007,45 +1010,61 @@
 					     exp_psleft,
 					     exp_psright)))
         | BUILD_CONST string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.BuildConst {name = string}, 
-                     ty = ty})
+	  (Exp.Prim (PrimKind.BuildConst {name = string, ty = ty}))
 	| COMMAND_LINE_CONST string COLON ty EQUALOP constOrBool SEMICOLON
-	  (Exp.Prim {kind = PrimKind.CommandLineConst {name = string,
-                                                       value = constOrBool},
-		     ty = ty})
+	  (Exp.Prim (PrimKind.CommandLineConst {name = string,
+                                                ty = ty,
+                                                value = constOrBool}))
         | CONST string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Const {name = string}, 
-                     ty = ty})
-	| EXPORT string attributes COLON ty SEMICOLON
-          (Exp.Prim {kind = PrimKind.Export {attributes = attributes,
-                                             name = string},
-		     ty = ty})
-	| IMPORT string attributes COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Import {attributes = attributes,
-                                             name = string},
-		     ty = ty})
-	| IMPORT ASTERISK attributes COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
-		     ty = ty})
-	| IMPORT HASH string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Symbol {name = string},
-		     ty = ty})
+	  (Exp.Prim (PrimKind.Const {name = string, ty = ty}))
+	| EXPORT string ieattributes COLON ty SEMICOLON
+          (Exp.Prim (PrimKind.Export {attributes = ieattributes,
+                                      name = string,
+                                      cfTy = ty}))
+	| IMPORT string ieattributes COLON ty SEMICOLON
+	  (Exp.Prim (PrimKind.Import {attributes = ieattributes,
+                                      cfTy = ty,
+                                      name = string}))
+	| IMPORT ASTERISK ieattributes COLON ty SEMICOLON
+          (Exp.Prim (PrimKind.IImport {attributes = ieattributes,
+                                       cfTy = ty}))
         | PRIM string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Prim {name = string}, 
-                     ty = ty})
+	  (Exp.Prim (PrimKind.Prim {name = string,
+                                    ty = ty}))
+        | SYMBOL string symattributes COLON ty COMMA ty SEMICOLON
+          (Exp.Prim (PrimKind.Symbol {attributes = symattributes,
+                                      cbTy = ty2,
+	                              ptrTy = ty1,
+                                      name = string}))
+        | SYMBOL ASTERISK COLON ty COMMA ty SEMICOLON
+          (Exp.Prim (PrimKind.ISymbol {cbTy = ty2,
+                                       ptrTy = ty1}))
 
-attributes
+ieattributes
    :
      ([])
-   | id attributes
+   | id ieattributes
      (let
 	 val id = Symbol.toString (#1 id)
       in
 	 case id of
-	    "cdecl" => PrimKind.Attribute.Cdecl :: attributes
-	  | "stdcall" => PrimKind.Attribute.Stdcall :: attributes
+	    "cdecl" => PrimKind.ImportExportAttribute.Cdecl :: ieattributes
+	  | "stdcall" => PrimKind.ImportExportAttribute.Stdcall :: ieattributes
 	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
-		  ; attributes)
+		  ; ieattributes)
+      end)
+
+symattributes
+   :
+     ([])
+   | id symattributes
+     (let
+	 val id = Symbol.toString (#1 id)
+      in
+	 case id of
+	    "define" => PrimKind.SymbolAttribute.Define :: symattributes
+	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
+		  ; symattributes)
       end)
 
 exp_2c	: exp COMMA exp_2c	(exp :: exp_2c)



1.22      +2 -0      mlton/mlton/front-end/ml.lex

Index: ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- ml.lex	19 Jul 2005 16:52:28 -0000	1.21
+++ ml.lex	23 Jul 2005 11:55:41 -0000	1.22
@@ -151,6 +151,8 @@
    (tok (Tokens.IMPORT, source, yypos, yypos + size yytext));
 <INITIAL>"_overload" =>
    (tok (Tokens.OVERLOAD, source, yypos, yypos + size yytext));
+<INITIAL>"_symbol" =>
+   (tok (Tokens.SYMBOL, source, yypos, yypos + size yytext));
 <INITIAL>"_prim" =>
    (tok (Tokens.PRIM, source, yypos, yypos + size yytext));
 <INITIAL>"_"	=> (tok (Tokens.WILD, source, yypos, yypos + 1));