public static RecordTypeDescriptor Create(Type type, string name, string uid, RecordTypeDescriptor parentrtd)
{
var rtd = new RecordTypeDescriptor
{
type = type,
Name = name,
predicate = type.GetMethod(name + "?"),
uid = uid,
@sealed = type.IsSealed,
Parent = parentrtd
};
Records.typedescriptors[type] = rtd;
MethodInfo ci = type.GetMethod("make");
var pari = ci.GetParameters();
int pcount = pari.Length;
if (pcount < 9 && !(pcount == 1 && pari[0].ParameterType == typeof(object[])))
{
rtd.Constructor = CreateCallable(ci);
}
else
{
rtd.Constructor = Closure.Create(Delegate.CreateDelegate(typeof(CallTargetN), ci)) as Callable;
}
rtd.Predicate = Closure.Create(Delegate.CreateDelegate(typeof(CallTarget1), rtd.predicate)) as Callable;
var flds = new List<FieldDescriptor>();
foreach (FieldInfo fi in type.GetFields(BindingFlags.Public | BindingFlags.Instance | BindingFlags.DeclaredOnly))
{
var fd = new FieldDescriptor { Name = fi.Name };
fd.field = fi;
var pi = type.GetProperty(fi.Name);
fd.accessor = pi.GetGetMethod();
fd.Accessor = CreateCallable(fd.accessor);
if (pi.CanWrite)
{
fd.mutator = pi.GetSetMethod();
fd.Mutator = CreateCallable(fd.mutator);
}
else
{
fd.Mutator = Builtins.FALSE;
}
flds.Add(fd);
}
rtd.fields = flds.ToArray();
return rtd;
}
static void GeneratePredicate(string n, RecordTypeDescriptor rtd, TypeGen tg)
{
// predicate
MethodBuilder pb = tg.TypeBuilder.DefineMethod(n + "?", MethodAttributes.Public | MethodAttributes.Static,
typeof(object), new Type[] { typeof(object) });
pb.DefineParameter(1, ParameterAttributes.None, "obj");
ILGenerator pgen = pb.GetILGenerator();
pgen.Emit(OpCodes.Ldarg_0);
pgen.Emit(OpCodes.Isinst, tg.TypeBuilder);
pgen.Emit(OpCodes.Ldnull);
pgen.Emit(OpCodes.Cgt_Un);
pgen.Emit(OpCodes.Call, typeof(RuntimeHelpers).GetMethod("BooleanToObject"));
pgen.Emit(OpCodes.Ret);
rtd.predicate = pb;
}
static void GenerateConstructor(RecordTypeDescriptor rtd, TypeGen tg, Type parenttype)
{
// constructor logic
{
List<Type> paramtypes = new List<Type>();
List<FieldDescriptor> allfields = new List<FieldDescriptor>(rtd.GetAllFields());
int diff = allfields.Count - rtd.Fields.Length;
foreach (FieldDescriptor var in allfields)
{
paramtypes.Add(var.Type);
}
List<Type> parenttypes = new List<Type>();
for (int i = 0; i < diff; i++)
{
parenttypes.Add(typeof(object)); //TODO: fix this, it looks broken
}
if (paramtypes.Count < 9)
{
CodeGen cg = tg.DefineConstructor(paramtypes.ToArray());
CodeGen mk = tg.DefineMethod(MethodAttributes.Public | MethodAttributes.Static, "make",
tg.TypeBuilder, paramtypes.ToArray(), allfields.ConvertAll(x => x.Name).ToArray());
for (int i = 0; i < allfields.Count; i++)
{
cg.DefineParameter(i + 1, ParameterAttributes.None, allfields[i].Name);
}
int fi = 0;
cg.EmitThis();
for (fi = 0; fi < diff; fi++)
{
cg.EmitArgGet(fi);
mk.EmitArgGet(fi);
}
// improve get constructor to look for protected constructors too
cg.Emit(OpCodes.Call, (rtd.Parent == null ? parenttype.GetConstructor(Type.EmptyTypes) : rtd.Parent.DefaultConstructor));
foreach (FieldDescriptor fd in rtd.Fields)
{
cg.EmitThis();
cg.EmitArgGet(fi);
cg.EmitFieldSet(fd.field);
mk.EmitArgGet(fi);
fi++;
}
mk.EmitNew(cg.MethodBase as ConstructorInfo);
mk.EmitReturn();
cg.EmitReturn();
rtd.cg = cg;
}
else
{
CodeGen cg = tg.DefineConstructor(paramtypes.ToArray());
CodeGen mk = tg.DefineMethod(MethodAttributes.Public | MethodAttributes.Static, "make",
tg.TypeBuilder, new Type[] { typeof(object[]) }, new string[] { "args" });
for (int i = 0; i < allfields.Count; i++)
{
cg.DefineParameter(i + 1, ParameterAttributes.None, allfields[i].Name);
}
int fi = 0;
cg.EmitThis();
for (fi = 0; fi < diff; fi++)
{
cg.EmitArgGet(fi);
mk.EmitArgGet(0);
mk.EmitConstant(fi);
mk.Emit(OpCodes.Ldelem, typeof(object));
}
cg.Emit(OpCodes.Call, (rtd.Parent == null ? typeof(object).GetConstructor(Type.EmptyTypes) : rtd.Parent.DefaultConstructor));
foreach (FieldDescriptor fd in rtd.Fields)
{
cg.EmitThis();
cg.EmitArgGet(fi);
cg.EmitFieldSet(fd.field);
mk.EmitArgGet(0);
mk.EmitConstant(fi);
mk.Emit(OpCodes.Ldelem, typeof(object));
fi++;
}
mk.EmitNew(cg.MethodBase as ConstructorInfo);
mk.EmitReturn();
cg.EmitReturn();
rtd.cg = cg;
}
}
}
static void GenerateFields(object fields, string n, RecordTypeDescriptor rtd, TypeGen tg, object fieldtypes)
{
object[] f = RequiresNotNull<object[]>(fields);
object[] ftypes = RequiresNotNull<object[]>(fieldtypes);
List<FieldDescriptor> rtd_fields = new List<FieldDescriptor>();
for (int i = 0; i < f.Length; i++)
{
Cons c = (Cons) f[i];
// check for recursive definition
Type t = rtd.Name == SymbolTable.IdToString((SymbolId)ftypes[i]) ?
rtd.tg.TypeBuilder :
ClrGenerator.ExtractTypeInfo(List(SymbolTable.StringToObject("quote"), ftypes[i]));
// can this ever be null given ExtractTypeInfo throws?
if (t == null)
{
ClrGenerator.ClrSyntaxError("GenerateFields", "type not found", ftypes[i]);
}
string fname = SymbolTable.IdToString(RequiresNotNull<SymbolId>(Second(c)));
// we use standard names here, they will be mapped to the given names
string aname = n + "-" + fname;
string mname = n + "-" + fname + "-set!";
var fd = new FieldDescriptor { Name = fname };
FieldAttributes fattrs = FieldAttributes.Public | FieldAttributes.InitOnly;
if (c.car == SymbolTable.StringToObject("mutable"))
{
fd.mutable = true;
fattrs &= ~FieldAttributes.InitOnly;
}
FieldSlot s = tg.AddField(t, fname, fattrs) as FieldSlot;
fd.field = s.Field;
PropertyBuilder pi = tg.TypeBuilder.DefineProperty(fname, PropertyAttributes.None, t, new Type[0]);
// accesor
MethodBuilder ab = tg.TypeBuilder.DefineMethod(aname, MethodAttributes.Public | MethodAttributes.Static,
t, new Type[] { tg.TypeBuilder });
ab.DefineParameter(1, ParameterAttributes.None, n);
ILGenerator agen = ab.GetILGenerator();
agen.Emit(OpCodes.Ldarg_0);
//agen.Emit(OpCodes.Castclass, tg.TypeBuilder);
agen.Emit(OpCodes.Ldfld, fd.field);
agen.Emit(OpCodes.Ret);
fd.accessor = ab;
pi.SetGetMethod(ab);
// mutator
if (fd.mutable)
{
MethodBuilder mb = tg.TypeBuilder.DefineMethod(mname, MethodAttributes.Public | MethodAttributes.Static,
typeof(object), new Type[] { tg.TypeBuilder, t });
mb.DefineParameter(1, ParameterAttributes.None, n);
ILGenerator mgen = mb.GetILGenerator();
mgen.Emit(OpCodes.Ldarg_0);
//mgen.Emit(OpCodes.Castclass, tg.TypeBuilder);
mgen.Emit(OpCodes.Ldarg_1);
mgen.Emit(OpCodes.Stfld, fd.field);
mgen.Emit(OpCodes.Ldsfld, Compiler.Generator.Unspecified);
mgen.Emit(OpCodes.Ret);
fd.mutator = mb;
pi.SetSetMethod(mb);
}
rtd_fields.Add(fd);
}
rtd.fields = rtd_fields.ToArray();
}
public static RecordTypeDescriptor GenerateRecordTypeDescriptor(AssemblyGen ag, object name, object parent, object uid, object issealed, object isopaque, object fields, object fieldtypes)
{
string n = SymbolTable.IdToString(RequiresNotNull<SymbolId>(name));
string id = uid is SymbolId ? SymbolTable.IdToString(RequiresNotNull<SymbolId>(uid)): uid as string;
if (id != null)
{
RecordTypeDescriptor ngrtd;
if (nongenerative.TryGetValue(n + id, out ngrtd))
{
// this is all nice and well, but when the caller is from a disk assembly, after it has been compiled, there will be a mismatch
// this is bit hard to check...
return ngrtd;
}
var type = ClrGenerator.GetTypeFast("record." + id + "." + n.Replace("&", "$").Replace("*", "$")); // TODO: Make me better
if (type != null)
{
return RecordTypeDescriptor.Create(type, n, id, parent as RecordTypeDescriptor);
}
}
bool @sealed = RequiresNotNull<bool>(issealed);
bool opaque = RequiresNotNull<bool>(isopaque);
RecordTypeDescriptor prtd = parent as RecordTypeDescriptor; // can be #f
Type parenttype = typeof(object);
if (prtd != null)
{
parenttype = prtd.type;
}
else if (n == "&condition")
{
parenttype = typeof(Condition);
}
TypeAttributes attrs = TypeAttributes.Public | TypeAttributes.Serializable;
var rtd = new RecordTypeDescriptor
{
Name = n,
@sealed = @sealed,
opaque = opaque,
ag = ag,
Parent = prtd,
uid = uid,
generative = id == null || uid is string,
};
if (@sealed)
{
attrs |= TypeAttributes.Sealed;
}
object gid = (object)id ?? Guid.NewGuid();
var ns = "record." + gid;
var typename = ns + "." + n.Replace("&", "$").Replace("*", "$"); // TODO: Make me better
TypeGen tg = ag.DefinePublicType(typename, parenttype, attrs);
rtd.tg = tg;
rtd.type = tg.TypeBuilder;
if (id != null)
{
nongenerative[n + id] = rtd;
}
if (parenttype.IsSubclassOf(typeof(Condition)))
{
SetSymbolValueFast(SymbolTable.StringToObject(n + "-rtd"), rtd);
}
GeneratePredicate(n, rtd, tg);
GenerateFields(fields, n, rtd, tg, fieldtypes);
GenerateConstructor(rtd, tg, parenttype);
return rtd;
}
