[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--