[MLton] implement _address and _symbol

Wesley W. Terpstra wesley@terpstra.ca
Thu, 21 Jul 2005 01:01:50 +0200


--J/dobhs11T7y2rNN
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
Content-Transfer-Encoding: quoted-printable

Here's a preliminary patch.
It mostly works for me, but I don't know enough about MLton to judge.
There are a few problems remaining:

1. I don't know how to get MLton to output a symbol, so for now the 'define'
   attribute is ignored. How would I go about getting MLton to generate it?

2. Obviously, I didn't do anything about forcing the use of pointer pins.

3. When using _symbol *, somehow the wrong type shows up:
Error: test.sml 17.10.
  Function applied to incorrect argument.
    expects: [?.pointer] * _
    but got: [MLton.Pointer.t] * _
    in: setip (addr, 5)
=2E.. because of this I have not been able to test _symbol *.

val addr =3D _address "x" : MLton.Pointer.t;
val (getip, setip) =3D _symbol * : MLton.Pointer.t, int;
val () =3D setip (addr, 5)

At any rate, _symbol "x" and _address "x" work.

I was surprised to find that _import *: MLton.Pointer.t -> int; was rejecte=
d.
It remains rejected, and _import "x": int; now issues a warning.

On Sun, Jul 17, 2005 at 06:42:19PM -0400, Matthew Fluet wrote:
> I'm fairly confident that one could accomplish this task without needing=
=20
> to touch more than:
>  mlton/front-end/ml.lex : add _symbol and _address as keywords
>  mlton/front-end/ml.grm : add productions for _symbol and _address
>  mlton/ast/ast-core.{sig,fun} : add PrimKind.Address for an AST node=20
>     corresponding to _address; you'll find that there is already=20
>     PrimKind.Symbol, which has been serving as the AST node corresponding=
=20
>     to _import #.
>  mlton/elaborate/elaborate-core.fun : this is where the heavy lifting=20
>     happens; all of the current FFI primitives are grouped together

I also had to add pointerSet.
So atoms/prim.{sig.fun} got changed too.
Then there were the 'allow* true' flags so control-flags.{sig,sml} too.
I did not create 'allowFFI' since I found the code there confusing. =3D)

> rename PrimKind.Symbol to PrimKind.Address.

I did this, as well as introducing a different PrimKind.Symbol.

There's also this annoyance:
Warning: <basis>/misc/primitive.sml 1386.13.
  _import of constant is deprecated. Use _symbol.
Warning: <basis>/misc/primitive.sml 1390.14.
  _import of constant is deprecated. Use _symbol.
Warning: <basis>/misc/primitive.sml 1417.22.
  _import of constant is deprecated. Use _symbol.
Warning: <basis>/misc/primitive.sml 1418.25.
  _import of constant is deprecated. Use _symbol.
Warning: <basis>/misc/primitive.sml 1419.19.
  _import of constant is deprecated. Use _symbol.

Should I convert the basis to use (#1 _symbol "x" : X;) () instead of
_import "x": X; -- or do you wish we had _fetch "x": X; now? ;-)

All in all, I am amazed at how easy it has been so far. The only bug (aside
=66rom the type problem above) was setting bools with the opposite value.

--=20
Wesley W. Terpstra

--J/dobhs11T7y2rNN
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="symbol.patch"

? symbol.patch
? test
? test.c
? test.sml
? mlton/4364.sml
Index: mlton/ast/ast-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.fun,v
retrieving revision 1.33
diff -u -r1.33 ast-core.fun
--- mlton/ast/ast-core.fun	19 Jun 2005 21:33:41 -0000	1.33
+++ mlton/ast/ast-core.fun	20 Jul 2005 22:53:11 -0000
@@ -270,27 +270,40 @@
 	    val layout = Layout.str o toString
 	 end
 
+      structure SymAttribute =
+	 struct
+	    datatype t = Define
+
+	    val toString: t -> string =
+	       fn Define => "define"
+
+	    val layout = Layout.str o toString
+	 end
+
       datatype t =
-	 BuildConst of {name: string}
+	 Address of {name: string}
+       | 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}
+       | ISymbol of {attributes: SymAttribute.t list}
+       | Symbol of {attributes: SymAttribute.t list, name: string}
 
       fun name pk =
 	 case pk of
-	    BuildConst {name, ...} => name
+	    Address {name, ...} => name
+	  | BuildConst {name, ...} => name
 	  | CommandLineConst {name, ...} => name
 	  | Const {name, ...} => name
 	  | Export {name, ...} => name
 	  | IImport {...} => "<iimport>"
 	  | Import {name, ...} => name
-	  | Symbol {name, ...} => name
 	  | Prim {name, ...} => name
-
+	  | Symbol {name, ...} => name
+	  | ISymbol {...} => "<isymbol>"
    end
 
 structure Priority =
Index: mlton/ast/ast-core.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/ast/ast-core.sig,v
retrieving revision 1.20
diff -u -r1.20 ast-core.sig
--- mlton/ast/ast-core.sig	12 Jan 2005 21:56:00 -0000	1.20
+++ mlton/ast/ast-core.sig	20 Jul 2005 22:53:11 -0000
@@ -91,16 +91,25 @@
 		     
 		  val layout: t -> Layout.t
 	       end
+            
+            structure SymAttribute:
+               sig
+                  datatype t = Define
+		     
+		  val layout: t -> Layout.t
+               end
 	    
 	    datatype t =
-	       BuildConst of {name: string}
+	       Address of {name: string}
+	     | 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}
+	     | ISymbol of {attributes: SymAttribute.t list}
+	     | Symbol of {attributes: SymAttribute.t list, name: string}
 	 end
 
       structure Priority:
Index: mlton/atoms/prim.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.fun,v
retrieving revision 1.101
diff -u -r1.101 prim.fun
--- mlton/atoms/prim.fun	19 Jun 2005 21:33:43 -0000	1.101
+++ mlton/atoms/prim.fun	20 Jul 2005 22:53:11 -0000
@@ -632,6 +632,22 @@
        | 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
 val serialize = MLton_serialize
Index: mlton/atoms/prim.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/prim.sig,v
retrieving revision 1.75
diff -u -r1.75 prim.sig
--- mlton/atoms/prim.sig	6 Mar 2005 22:09:44 -0000	1.75
+++ mlton/atoms/prim.sig	20 Jul 2005 22:53:11 -0000
@@ -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
Index: mlton/control/control-flags.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sig,v
retrieving revision 1.3
diff -u -r1.3 control-flags.sig
--- mlton/control/control-flags.sig	19 Jul 2005 12:41:09 -0000	1.3
+++ mlton/control/control-flags.sig	20 Jul 2005 22:53:11 -0000
@@ -59,12 +59,14 @@
 	 sig
 	    type ('args, 'st) t
 
+	    val allowAddress: (bool,bool) t
 	    val allowConstant: (bool,bool) t
 	    val allowExport: (bool,bool) t
 	    val allowImport: (bool,bool) t
 	    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
Index: mlton/control/control-flags.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control-flags.sml,v
retrieving revision 1.4
diff -u -r1.4 control-flags.sml
--- mlton/control/control-flags.sml	19 Jul 2005 12:41:09 -0000	1.4
+++ mlton/control/control-flags.sml	20 Jul 2005 22:53:11 -0000
@@ -269,6 +269,8 @@
 	     parseIdAndArgs = fn _ => NONE,
 	     withDef = fn () => (fn () => ()),
 	     snapshot = fn () => fn () => (fn () => ())}
+	 val (allowAddress, ac) =
+	    makeBool ({name = "allowAddress", default = false, expert = false}, ac)
 	 val (allowConstant, ac) =
 	    makeBool ({name = "allowConstant", default = false, expert = true}, ac)
 	 val (allowExport, ac) =
@@ -281,6 +283,8 @@
 	    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 (forceUsed, ac) =
Index: mlton/elaborate/elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.151
diff -u -r1.151 elaborate-core.fun
--- mlton/elaborate/elaborate-core.fun	19 Jun 2005 21:33:58 -0000	1.151
+++ mlton/elaborate/elaborate-core.fun	20 Jul 2005 22:53:11 -0000
@@ -39,6 +39,7 @@
    structure Longtycon = Longtycon
    structure PrimKind = PrimKind
    structure Attribute = PrimKind.Attribute
+   structure SymAttribute = PrimKind.SymAttribute
    structure Priority = Priority
    structure Record = Record
    structure SortedRecord = SortedRecord
@@ -889,87 +890,7 @@
 	    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 =
-   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}
-   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))
-   end
-
-fun symbol {name: string,
+fun address {name: string,
 	    ty: Type.t,
 	    region: Region.t}: Type.t Prim.t =
    case Type.toCType ty of
@@ -979,12 +900,208 @@
 	 let
 	    val () =
 	       Control.error (region,
-			      str "invalid type for import",
+			      str "invalid type for _address (must be pointer)",
 			      Type.layoutPretty ty)
 	 in
 	    Prim.bogus
 	 end
 
+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
+
+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 fetchSymbol {ptr: Cexp.t,
+                 ty: Type.t,
+                 region: Region.t}: Cexp.t =
+   case Type.toCType ty of
+      NONE => 
+        let
+	   val () = Control.error (region,
+	                           str "invalid type for _symbol",
+	                           Type.layoutPretty ty)
+	in
+           primApp {args = Vector.new0 (), prim = Prim.bogus, result = ty}
+	end
+    | SOME {ctype, ...} => 
+	let
+	   val isBool =
+              case Type.deConOpt ty of
+	         NONE => false
+	       | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+           val fetchExp = 
+              primApp {args = Vector.new2 (ptr, zeroExp),
+		       prim = Prim.pointerGet ctype,
+		       result = if isBool then Type.defaultWord else ty}
+        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 = ty},
+                      warnMatch = false}
+	end
+
+fun storeSymbol {ptr: Cexp.t,
+                 value: Var.t,
+                 ty: Type.t,
+                 region: Region.t}: Cexp.t =
+   case Type.toCType ty of
+      NONE => 
+        (* do not give an error b/c fetchSymbol did *)
+        primApp {args = Vector.new0 (), prim = Prim.bogus, result = Type.unit}
+    | SOME {ctype, ...} => 
+	let
+	   val isBool =
+              case Type.deConOpt ty of
+	         NONE => false
+	       | SOME (c,_) => Tycon.equals (c, Tycon.bool)
+           val varExp = Cexp.var (value, ty)
+           val varExp =
+              if not isBool then varExp 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 = varExp,
+                          warnMatch = false}
+        in
+           primApp {args = Vector.new3 (ptr, zeroExp, varExp),
+		    prim = Prim.pointerSet ctype,
+		    result = Type.unit}
+	end
+
+fun symbolName {attributes: SymAttribute.t list,
+                name: string,
+                ty: Type.t,
+                region: Region.t}: Cexp.t =
+  let
+     val getarg = Var.newNoname ()
+     val setarg = Var.newNoname ()
+     val ptr =
+         primApp {args = Vector.new0 (),
+		  prim = Prim.ffiSymbol {name = name},
+		  result = Type.word (WordSize.pointer ())}
+  in
+     Cexp.tuple (Vector.new2 (
+        Cexp.lambda (
+           Lambda.make { arg = getarg,
+                         argType = Type.unit,
+                         body = fetchSymbol { ptr=ptr, ty=ty, region=region },
+                         mayInline = true}),
+        Cexp.lambda (
+           Lambda.make { arg = setarg,
+                         argType = ty,
+                         body = storeSymbol { ptr=ptr, value=setarg, ty=ty, region=region },
+                         mayInline = true})))
+  end
+
+fun symbolStar {attributes: SymAttribute.t list,
+                tyt: Type.t,
+                region: Region.t}: Cexp.t =
+  let
+     val tyv = Type.deTuple tyt
+     val typ = Vector.sub (tyv, 0)
+     val ty  = Vector.sub (tyv, 1)
+     
+     val getarg  = Var.newNoname ()
+     val setarg  = Var.newNoname ()
+     val setarg1 = Var.newNoname ()
+     val setarg2 = Var.newNoname ()
+     
+     val getptr = Cexp.var (getarg,  Type.word (WordSize.pointer ()))
+     val setptr = Cexp.var (setarg1, Type.word (WordSize.pointer ()))
+     
+     val fetchExp = fetchSymbol { ptr=getptr, ty=ty, region=region }
+     val storeExp = storeSymbol { ptr=setptr, value=setarg2, ty=ty, region=region }
+     
+     val setpat  = Cpat.tuple (Vector.new2 (Cpat.var (setarg1, typ), 
+                                            Cpat.var (setarg2, ty)))
+     val setbody = Cexp.casee {kind = "",
+                               lay = fn () => Layout.empty,
+                               noMatch = Cexp.Impossible,
+                               region = Region.bogus,
+                               rules = Vector.new1
+                                  ({exp = storeExp, lay = NONE, pat = setpat}),
+                               test = Cexp.var (setarg, tyt),
+                               warnMatch = false}
+  in
+   case Type.toCType typ of
+      SOME {ctype = CType.Pointer, ...} =>
+         Cexp.tuple (Vector.new2 (
+            Cexp.lambda (
+               Lambda.make { arg = getarg,
+                             argType = typ,
+                             body = fetchExp,
+                             mayInline = true}),
+            Cexp.lambda (
+               Lambda.make { arg = setarg,
+                             argType = tyt,
+                             body = setbody,
+                             mayInline = true})))
+    | _ =>
+	 let
+	    val () =
+	       Control.error (region,
+			      str "invalid type for _symbol (must be pointer)",
+			      Type.layoutPretty typ)
+	 in
+            primApp {args = Vector.new0 (), prim = Prim.bogus, result = tyt}
+	 end
+  end
+
+fun importSymbol {attributes: Attribute.t list,
+		  name: string,
+		  ty: Type.t,
+		  region: Region.t}: Cexp.t =
+   let
+      val addrExp = 
+         primApp {args = Vector.new0 (),
+		  prim = Prim.ffiSymbol {name = name},
+		  result = Type.word (WordSize.pointer ())}
+   in
+      case attributes of
+         [] => 
+          (Control.warning (region,
+                            str "_import of constant is deprecated. Use _symbol",
+			    empty);
+           fetchSymbol { ptr=addrExp, ty=ty, region=region })
+       | _ => 
+          (Control.error (region, 
+                          seq [str "invalid attributes for import: ",
+		               List.layout Attribute.layout attributes],
+                          empty);
+           primApp {args = Vector.new0 (), prim = Prim.bogus, result = ty})
+   end
+
 fun export {attributes, name: string, region: Region.t, ty: Type.t}: Aexp.t =
    let
       fun error l = Control.error (region, l, Layout.empty)
@@ -2268,23 +2385,6 @@
 		       * 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 =
 			 case Type.deArrowOpt expandedTy of
@@ -2387,7 +2487,12 @@
 		      datatype z = datatype Ast.PrimKind.t
 		   in
 		      case kind of
-			 BuildConst {name} =>
+		         Address {name} =>
+			    (check (ElabControl.allowAddress, "_address")
+			     ; eta (address {name = name,
+					     region = region,
+					     ty = expandedTy}))
+	               | BuildConst {name} =>
 			    (check (ElabControl.allowConstant, "_build_const")
 			     ; lookConst {default = NONE, name = name})
 		       | CommandLineConst {name, value} =>
@@ -2487,24 +2592,29 @@
 			    (check (ElabControl.allowImport, "_import")
 			     ; (case Type.deArrowOpt expandedTy of
 				   NONE => 
-				      wrap (fetchSymbol {attributes = attributes,
-							 name = name,
-							 primApp = primApp,
-							 region = region,
-							 ty = expandedTy}, ty)
+                                       wrap (importSymbol {attributes = attributes,
+						           name = name,
+							   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}))
+                                       eta (import {attributes = attributes,
+					            name = SOME name,
+						    region = region,
+						    ty = expandedTy})))
 		       | Prim {name} => 
 			    (check (ElabControl.allowPrim, "_prim")
 			     ; eta (Prim.fromString name))
+                       | ISymbol {attributes} =>
+                            (check (ElabControl.allowSymbol, "_symbol")
+                             ; symbolStar {attributes = attributes,
+                                           region = region,
+                                           tyt = expandedTy})
+                       | Symbol {attributes, name} =>
+                            (check (ElabControl.allowSymbol, "_symbol")
+			     ; symbolName {name = name,
+			                   attributes = attributes,
+					   region = region,
+					   ty = expandedTy})
 		   end
 	      | Aexp.Raise exn =>
 		   let
Index: mlton/front-end/ml.grm
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.grm,v
retrieving revision 1.44
diff -u -r1.44 ml.grm
--- mlton/front-end/ml.grm	19 Jul 2005 16:52:28 -0000	1.44
+++ mlton/front-end/ml.grm	20 Jul 2005 22:53:12 -0000
@@ -232,7 +232,8 @@
     | 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
+    | ADDRESS | BUILD_CONST | COMMAND_LINE_CONST | CONST | EXPORT | IMPORT 
+    | SYMBOL | PRIM
 
 %nonterm
          aexp of Exp.node
@@ -365,6 +366,7 @@
        | strexpnode of Strexp.node
        | strid of Strid.t
        | string of string
+       | symattributes of PrimKind.SymAttribute.t list
        | tlabel of (Field.t * Type.t)
        | tlabels  of (Field.t * Type.t) list
        | topdec of Topdec.t
@@ -1006,6 +1008,9 @@
 	    (Exp.Let (decs, Exp.makeRegion' (Exp.Seq (Vector.fromList exp_ps),
 					     exp_psleft,
 					     exp_psright)))
+        | ADDRESS string COLON ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.Address {name = string},
+                     ty = ty})
         | BUILD_CONST string COLON ty SEMICOLON
 	  (Exp.Prim {kind = PrimKind.BuildConst {name = string}, 
                      ty = ty})
@@ -1025,14 +1030,27 @@
                                              name = string},
 		     ty = ty})
 	| IMPORT ASTERISK attributes COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
-		     ty = ty})
+          (Exp.Prim {kind = PrimKind.IImport {attributes = attributes},
+		      ty = ty})
 	| IMPORT HASH string COLON ty SEMICOLON
-	  (Exp.Prim {kind = PrimKind.Symbol {name = string},
-		     ty = ty})
+	  (Control.warning 
+           (reg (IMPORTleft, SEMICOLONright),
+            Layout.str "_import # is deprecated.  Use _address",
+            Layout.empty)
+	   ; Exp.Prim {kind = PrimKind.Address {name = string},
+		       ty = ty})
         | PRIM string COLON ty SEMICOLON
 	  (Exp.Prim {kind = PrimKind.Prim {name = string}, 
                      ty = ty})
+        | SYMBOL string symattributes COLON ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.Symbol {attributes = symattributes,
+                                             name = string},
+                     ty = ty})
+        | SYMBOL ASTERISK symattributes COLON ty COMMA ty SEMICOLON
+          (Exp.Prim {kind = PrimKind.ISymbol {attributes = symattributes},
+                     ty = Type.makeRegion' (
+                             Type.tuple (Vector.new2 (ty1, ty2)),
+                             ty1left, ty2right)})
 
 attributes
    :
@@ -1046,6 +1064,19 @@
 	  | "stdcall" => PrimKind.Attribute.Stdcall :: attributes
 	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
 		  ; attributes)
+      end)
+
+symattributes
+   :
+     ([])
+   | id symattributes
+     (let
+	 val id = Symbol.toString (#1 id)
+      in
+	 case id of
+	    "define" => PrimKind.SymAttribute.Define :: symattributes
+	  | _ => (error (reg (idleft, idright), concat ["invalid attribute", id])
+		  ; symattributes)
       end)
 
 exp_2c	: exp COMMA exp_2c	(exp :: exp_2c)
Index: mlton/front-end/ml.lex
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/front-end/ml.lex,v
retrieving revision 1.21
diff -u -r1.21 ml.lex
--- mlton/front-end/ml.lex	19 Jul 2005 16:52:28 -0000	1.21
+++ mlton/front-end/ml.lex	20 Jul 2005 22:53:12 -0000
@@ -139,6 +139,8 @@
 %%
 <INITIAL>{ws}	=> (continue ());
 <INITIAL>{eol}	=> (Source.newline (source, yypos); continue ());
+<INITIAL>"_address" =>
+   (tok (Tokens.ADDRESS, source, yypos, yypos + size yytext));
 <INITIAL>"_build_const" =>
    (tok (Tokens.BUILD_CONST, source, yypos, yypos + size yytext));
 <INITIAL>"_command_line_const" =>
@@ -151,6 +153,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));

--J/dobhs11T7y2rNN--