public override Expression Generate(object args, CodeBlock c)
{
var refs = ClrGenerator.SaveReferences();
object arg = Builtins.First(args);
object typespec = (Builtins.Second(args));
Cons body = Builtins.Cdr(Builtins.Cdr(args)) as Cons;
var returntype = ClrGenerator.ExtractTypeInfo(Builtins.List(quote, Builtins.Second(typespec)));
CodeBlock cb = Ast.CodeBlock(SpanHint, GetLambdaName(c), returntype);
NameHint = SymbolId.Empty;
cb.Filename = LocationHint;
cb.Parent = c;
bool isrest = AssignParameters(cb, arg, Builtins.Car(typespec));
List <Statement> stmts = new List <Statement>();
FillBody(cb, stmts, body, true);
Type dt = GetDelegateType(cb);
Type ct = GetClosureType(cb);
Expression ex = Ast.New(ct.GetConstructor(new Type[] { dt }), Ast.CodeBlockExpression(cb, true, dt));
ClrGenerator.ResetReferences(refs);
return(ex);
}
protected static bool AssignParameters(CodeBlock cb, object arg)
{
bool isrest = false;
Cons cargs = arg as Cons;
if (cargs != null)
{
while (cargs != null)
{
SymbolId an = (SymbolId)Builtins.First(cargs);
CreateParameter(an, cb, typeof(object));
Cons r = cargs.cdr as Cons;
if (r == null && cargs.cdr != null)
{
SymbolId ta = (SymbolId)cargs.cdr;
CreateParameter(ta, cb, typeof(object));
isrest = true;
break;
}
else
{
cargs = r;
}
}
}
else if (arg != null) // empty
{
SymbolId an = (SymbolId)arg;
isrest = true;
CreateParameter(an, cb, typeof(object));
}
return(isrest);
}
public override Expression Generate(object args, CodeBlock c)
{
var refs = ClrGenerator.SaveReferences();
CodeBlock cb = Ast.CodeBlock(SpanHint, GetLambdaName(c));
NameHint = SymbolId.Empty;
cb.Filename = LocationHint;
cb.Parent = c;
cb.Source = new Cons(SymbolTable.StringToObject("lambda"), args);
object arg = Builtins.First(args);
Cons body = Builtins.Cdr(args) as Cons;
bool isrest = AssignParameters(cb, arg);
cb.IsRest = isrest;
List <Statement> stmts = new List <Statement>();
FillBody(cb, stmts, body, true);
Expression ex = MakeClosure(cb, isrest);
ClrGenerator.ResetReferences(refs);
return(ex);
}
// (clr-field-set! type field-name obj value)
public override Expression Generate(object args, CodeBlock cb)
{
Type t = null;
string type = null;
bool inferred = false;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
string member = SymbolTable.IdToString((SymbolId)Builtins.Second(Builtins.Second(args)));
BindingFlags bf = BindingFlags.Instance;
Expression instance = GetAst(Builtins.Third(args), cb);
if (instance is ConstantExpression && ((ConstantExpression)instance).Value == null)
{
bf = BindingFlags.Static;
instance = null;
if (inferred)
{
ClrSyntaxError("clr-field-set!", "type inference not possible on static member", member);
}
}
else if (inferred)
{
if (instance is UnaryExpression && instance.Type == typeof(object))
{
var ue = (UnaryExpression)instance;
instance = ue.Operand;
}
t = instance.Type;
}
else
{
instance = ConvertToHelper(t, instance);
}
type = t.Name;
FieldInfo fi = t.GetField(member, BindingFlags.Public | bf | BindingFlags.FlattenHierarchy);
if (fi == null)
{
ClrSyntaxError("clr-field-set!", "field not found on type: " + type, args);
}
if (fi.IsLiteral)
{
ClrSyntaxError("clr-field-set!", "cannot set a constant field: " + type);
}
Expression value = GetAst(Builtins.Car(Builtins.LastPair(args)), cb);
return(Ast.Comma(Ast.AssignField(instance, fi, value), Ast.ReadField(null, Unspecified)));
}
public override Expression Generate(object args, CodeBlock cb)
{
SymbolId s = (SymbolId)Builtins.First(args);
assigns[s] = true;
if (libraryglobals.ContainsKey(s))
{
libraryglobals.Remove(s);
}
if (libraryglobalsN.ContainsKey(s))
{
libraryglobalsN.Remove(s);
}
if (libraryglobalsX.ContainsKey(s))
{
libraryglobalsX.Remove(s);
}
setstack.Push(s);
NameHint = Builtins.UnGenSymInternal(s);
var prevvh = VarHint;
VarHint = s;
Expression value = GetAst(Builtins.Second(args), cb);
VarHint = prevvh;
setstack.Pop();
NameHint = SymbolId.Invalid;
Variable v = cb.Lookup(s);
Statement r = null;
if (v == null)
{
r = Ast.Statement(Ast.SimpleCallHelper(SetSymbolValue, Ast.Constant(s), value));
}
else
{
//Trace.Assert(cb.Parent != null);
value = Ast.ConvertHelper(value, v.Type);
r = Ast.Write(v, value);
}
if (SpanHint != SourceSpan.Invalid || SpanHint != SourceSpan.None)
{
r.SetLoc(SpanHint);
}
return(Ast.Void(r));
}
public override Expression Generate(object args, CodeBlock cb)
{
var to = Builtins.First(args);
Type t = ExtractTypeInfo(to);
if (t == null)
{
ClrSyntaxError("clr-type-of", "type not found", to, Cons.FromList(namespaces.Keys));
}
return(Ast.Constant(t));
}
protected static bool AssignParameters(CodeBlock cb, object arg, object types)
{
bool isrest = false;
Cons cargs = arg as Cons;
Cons ctypes = types as Cons;
if (cargs != null)
{
while (cargs != null)
{
SymbolId an = (SymbolId)Builtins.First(cargs);
if (ctypes == null)
{
Builtins.SyntaxError("AssignParameters", "missing parameter type", Builtins.UnGenSymInternal(an), Builtins.FALSE);
}
object type = Builtins.First(ctypes);
Type clrtype = ClrGenerator.ExtractTypeInfo(Builtins.List(quote, type));
CreateParameter(an, cb, clrtype);
Cons r = cargs.cdr as Cons;
Cons rt = ctypes.cdr as Cons;
// not sure I can even handle this...
if (r == null && cargs.cdr != null)
{
SymbolId ta = (SymbolId)cargs.cdr;
CreateParameter(ta, cb, typeof(object));
isrest = true;
break;
}
else
{
cargs = r;
ctypes = rt;
}
}
if (ctypes != null)
{
Builtins.SyntaxError("AssignParameters", "extra parameter type(s)", ctypes, Builtins.FALSE);
}
}
else if (arg != null) // empty
{
SymbolId an = (SymbolId)arg;
isrest = true;
CreateParameter(an, cb, typeof(object));
}
// else both null, which is OK, no?
return(isrest);
}
// (clr-reference assname)
public override Expression Generate(object args, CodeBlock cb)
{
Assembly ass = null;
object name = Builtins.Second(Builtins.First(args));
string assname = null;
if (name is SymbolId)
{
assname = SymbolTable.IdToString((SymbolId)name);//.Replace(".dll", "");
}
else if (name is string)
{
assname = (string)name;
}
else
{
ClrSyntaxError("clr-reference", "reference is not a symbol or a string", name);
}
try
{
var aname = AssemblyName.GetAssemblyName(assname);
ass = Assembly.Load(aname);
}
catch (FileNotFoundException)
{
try
{
ass = Assembly.Load(assname);
}
catch (FileNotFoundException)
{
// final fail, after AssemblyResolve
}
}
if (ass == null)
{
// last chance
#pragma warning disable 0618
ass = Assembly.LoadWithPartialName(assname);
#pragma warning restore 0618
}
if (ass == null)
{
ClrSyntaxError("clr-reference", "assembly not found", args);
}
return(Ast.ReadField(null, Unspecified));
}
// (clr-is type arg)
public override Expression Generate(object args, CodeBlock cb)
{
Type t;
string type;
bool inferred;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
if (t == null)
{
ClrSyntaxError("clr-is", "type not found", type);
}
return(Ast.TypeIs(GetAst(Builtins.Second(args), cb), t));
}
// (clr-using namespace)
public override Expression Generate(object args, CodeBlock cb)
{
object name = Builtins.Second(Builtins.First(args));
string assname = null;
if (name is SymbolId)
{
assname = SymbolTable.IdToString((SymbolId)name);
namespaces[assname] = assname;
}
else
{
ClrSyntaxError("clr-using", "namespace is not a symbol", name);
}
return(Ast.ReadField(null, Unspecified));
}
protected static bool AssignParameters(CodeBlock cb, object arg, object types)
{
bool isrest = false;
Cons cargs = arg as Cons;
Cons ctypes = types as Cons;
if (cargs != null)
{
while (cargs != null)
{
SymbolId an = (SymbolId)Builtins.First(cargs);
object type = Builtins.First(ctypes);
Type clrtype = ClrGenerator.ExtractTypeInfo(Builtins.List(quote, type));
CreateParameter(an, cb, clrtype);
Cons r = cargs.cdr as Cons;
Cons rt = ctypes.cdr as Cons;
if (r == null && cargs.cdr != null)
{
SymbolId ta = (SymbolId)cargs.cdr;
CreateParameter(ta, cb, typeof(object));
isrest = true;
break;
}
else
{
cargs = r;
ctypes = rt;
}
}
}
else if (arg != null) // empty
{
SymbolId an = (SymbolId)arg;
isrest = true;
CreateParameter(an, cb, typeof(object));
}
return(isrest);
}
// (clr-cast type arg)
public override Expression Generate(object args, CodeBlock cb)
{
Type t;
string type;
bool inferred;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
if (t == null)
{
ClrSyntaxError("clr-cast", "type not found", type);
}
Expression obj = GetAst(Builtins.Second(args), cb);
if (obj.IsConstant(null))
{
if (t == typeof(int))
{
return(Ast.Convert(Ast.Constant(0), t));
}
if (t == typeof(double))
{
return(Ast.Convert(Ast.Constant(0.0), t));
}
if (t == typeof(char))
{
return(Ast.Convert(Ast.Constant((char)0), t));
}
if (t == typeof(bool))
{
return(Ast.Convert(Ast.Constant(false), t));
}
}
return(ConvertToHelper(t, obj));
}
// (clr-new-array type size )
public override Expression Generate(object args, CodeBlock cb)
{
Type t;
string type;
bool inferred;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
if (t == null)
{
ClrSyntaxError("clr-new-array", "type not found", type);
}
t = t.MakeArrayType();
Expression size = ConvertToHelper(typeof(int), GetAst(Builtins.Second(args), cb));
ConstructorInfo ci = t.GetConstructor(new Type[] { typeof(int) });
return(Ast.New(ci, size));
}
// (clr-call type member obj arg1 ... )
public override Expression Generate(object args, CodeBlock cb)
{
Type t = null;
string type = null;
bool inferred = false;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
string member = null;
var marg = Builtins.Second(args);
object memobj = null;
Type[] argtypes = null;
Type[] gentypes = null;
if (marg is SymbolId)
{
var mem = Builtins.SymbolValue(marg);
if (mem is Cons)
{
ExtractMethodInfo(mem as Cons, out member, ref argtypes, ref gentypes);
}
else
{
ClrSyntaxError("clr-call", "type member not supported", mem);
}
}
else
{
memobj = Builtins.Second(marg);
member = memobj is SymbolId?SymbolTable.IdToString((SymbolId)memobj) : "";
if (memobj is string)
{
string mems = memobj as string;
int bi = mems.IndexOf('(');
if (bi < 0)
{
member = mems;
}
else
{
member = mems.Substring(0, bi);
}
}
else if (memobj is Cons)
{
ExtractMethodInfo(memobj as Cons, out member, ref argtypes, ref gentypes);
}
}
Expression instance = GetAst(Builtins.Third(args), cb);
CallType ct = CallType.ImplicitInstance;
if (instance is ConstantExpression && ((ConstantExpression)instance).Value == null)
{
ct = CallType.None;
if (inferred)
{
ClrSyntaxError("clr-call", "type inference not possible on static member", member);
}
}
else if (inferred)
{
if (instance is UnaryExpression && instance.Type == typeof(object))
{
var ue = (UnaryExpression)instance;
instance = ue.Operand;
}
t = instance.Type;
}
else
{
instance = ConvertToHelper(t, instance);
}
type = t.Name;
Expression[] arguments = GetAstListNoCast(Cdddr(args) as Cons, cb);
if (member == "get_Item")
{
if (Attribute.IsDefined(t, typeof(DefaultMemberAttribute)))
{
var dma = Attribute.GetCustomAttribute(t, typeof(DefaultMemberAttribute)) as DefaultMemberAttribute;
member = "get_" + dma.MemberName;
}
else if (t.IsArray)
{
var index = arguments[0];
return(Ast.ArrayIndex(instance, Ast.ConvertHelper(index, typeof(int))));
}
}
else if (member == "set_Item")
{
if (Attribute.IsDefined(t, typeof(DefaultMemberAttribute)))
{
var dma = Attribute.GetCustomAttribute(t, typeof(DefaultMemberAttribute)) as DefaultMemberAttribute;
member = "set_" + dma.MemberName;
}
else if (t.IsArray)
{
var index = arguments[0];
var v = arguments[1];
return(Ast.Comma(Ast.AssignArrayIndex(instance, Ast.ConvertHelper(index, typeof(int)), v), Ast.ReadField(null, Unspecified)));
}
}
List <MethodBase> candidates = new List <MethodBase>();
BindingFlags bf = BindingFlags.Public | (ct == CallType.None ? BindingFlags.Static : BindingFlags.Instance) | BindingFlags.FlattenHierarchy;
foreach (MethodInfo mi in t.GetMember(member, MemberTypes.Method, bf))
{
if (PAL.ExcludeParamtypes(mi))
{
continue;
}
if (mi.ContainsGenericParameters)
{
if (gentypes != null && mi.GetGenericArguments().Length == gentypes.Length)
{
candidates.Add(mi.MakeGenericMethod(gentypes));
continue;
}
}
candidates.Add(mi);
}
Type[] types = new Type[arguments.Length];
for (int i = 0; i < types.Length; i++)
{
types[i] = arguments[i].Type;
}
if (memobj is string)
{
string mems = memobj as string;
int bi = mems.IndexOf('(');
if (bi < 0)
{
// do notthig
}
else
{
string[] typeargs = mems.Substring(bi + 1).TrimEnd(')').Split(',');
for (int i = 0; i < types.Length; i++)
{
if (typeargs[i].Length > 0)
{
types[i] = ScanForType(typeargs[i]);
}
}
}
}
else if (argtypes != null)
{
for (int i = 0; i < types.Length; i++)
{
types[i] = argtypes[i];
}
}
if (ct == CallType.ImplicitInstance)
{
types = ArrayUtils.Insert(t, types);
}
MethodBinder mb = MethodBinder.MakeBinder(Binder, member, candidates, BinderType.Normal);
MethodCandidate mc = mb.MakeBindingTarget(ct, types);
if (mc == null)
{
types = new Type[arguments.Length];
for (int i = 0; i < types.Length; i++)
{
types[i] = typeof(object);
}
if (ct == CallType.ImplicitInstance)
{
types = ArrayUtils.Insert(t, types);
}
mc = mb.MakeBindingTarget(ct, types);
}
if (mc != null)
{
MethodInfo meth = (MethodInfo)mc.Target.Method;
// do implicit cast
ParameterInfo[] pars = meth.GetParameters();
for (int i = 0; i < arguments.Length; i++)
{
Type tt = pars[i].ParameterType;
arguments[i] = ConvertToHelper(tt, arguments[i]);
}
Expression r = null;
// o god...
if (ct == CallType.ImplicitInstance)
{
r = Ast.ComplexCallHelper(instance, (MethodInfo)mc.Target.Method, arguments);
}
else
{
r = Ast.ComplexCallHelper((MethodInfo)mc.Target.Method, arguments);
}
return(ConvertFromHelper(meth.ReturnType, r));
}
ClrSyntaxError("clr-call", "member could not be resolved on type: " + type, args, member);
return(null);
}
public override Expression Generate(object args, CodeBlock c)
{
Cons lambdas = args as Cons;
int arlen = lambdas == null ? 0 : lambdas.Length;
if (arlen == 1)
{
if (lambdagen == null)
{
lambdagen = Context.Scope.LookupName(SymbolTable.StringToId("lambda")) as LambdaGenerator;
}
return(lambdagen.Generate(lambdas.car, c));
}
else
{
List <CodeBlockDescriptor> cbs = new List <CodeBlockDescriptor>();
Cons annotations = this.annotations;
this.annotations = null;
string lambdaname = GetLambdaName(c);
NameHint = SymbolId.Empty;
var sh = SpanHint;
var lh = LocationHint;
Annotation ann = null;
while (lambdas != null)
{
object actual = lambdas.car;
if (annotations != null)
{
ann = annotations.car as Annotation;
if (ann != null)
{
var h = (Cons)ann.source;
if (h.cdr is string)
{
sh = ExtractLocation(((Cons)ann.source).cdr as string);
}
else if (h.cdr is SourceSpan)
{
sh = (SourceSpan)h.cdr;
}
}
}
var refs = ClrGenerator.SaveReferences();
CodeBlock cb = Ast.CodeBlock(sh, lambdaname);
cb.Filename = lh;
cb.Parent = c;
object arg = Builtins.First(actual);
Cons body = Builtins.Cdr(actual) as Cons;
bool isrest = AssignParameters(cb, arg);
cb.IsRest = isrest;
List <Statement> stmts = new List <Statement>();
FillBody(cb, stmts, body, true);
CodeBlockDescriptor cbd = new CodeBlockDescriptor();
cbd.arity = isrest ? -cb.ParameterCount : cb.ParameterCount;
cbd.codeblock = Ast.CodeBlockExpression(cb, false);
cbd.varargs = isrest;
descriptorshack.Add(cbd.codeblock, cbd);
cbs.Add(cbd);
if (annotations != null)
{
annotations = annotations.cdr as Cons;
}
lambdas = lambdas.cdr as Cons;
ClrGenerator.ResetReferences(refs);
}
return(MakeCaseClosure(lambdaname, cbs));
}
}
// (clr-new type arg1 ... )
public override Expression Generate(object args, CodeBlock cb)
{
Type t;
string type;
bool inferred;
object rtype = Builtins.First(args);
ExtractTypeInfo(rtype, out t, out type, out inferred);
if (t == null)
{
ClrSyntaxError("clr-new", "type not found", type);
}
Expression[] arguments = GetAstListNoCast(Builtins.Cdr(args) as Cons, cb);
List <MethodBase> candidates = new List <MethodBase>();
foreach (ConstructorInfo c in t.GetConstructors())
{
bool add = true;
foreach (var pi in c.GetParameters())
{
if (pi.ParameterType.IsPointer)
{
add = false;
break;
}
}
if (add)
{
candidates.Add(c);
}
}
if (t.IsValueType && arguments.Length == 0)
{
// create default valuetype here
return(Ast.DefaultValueType(t));
}
Type[] types = new Type[arguments.Length];
for (int i = 0; i < types.Length; i++)
{
types[i] = arguments[i].Type;
}
CallType ct = CallType.None;
MethodBinder mb = MethodBinder.MakeBinder(Binder, "ctr", candidates, BinderType.Normal);
MethodCandidate mc = mb.MakeBindingTarget(ct, types);
if (mc == null)
{
types = new Type[arguments.Length];
for (int i = 0; i < types.Length; i++)
{
types[i] = typeof(object);
}
if (ct == CallType.ImplicitInstance)
{
types = ArrayUtils.Insert(t, types);
}
mc = mb.MakeBindingTarget(ct, types);
}
ConstructorInfo ci = null;
if (mc == null && candidates.Count > 0)
{
foreach (ConstructorInfo c in candidates)
{
if (c.GetParameters().Length == arguments.Length)
{
ci = c;
break; // tough luck for now
}
}
}
else
{
ci = mc.Target.Method as ConstructorInfo;
}
if (ci != null)
{
ParameterInfo[] pars = ci.GetParameters();
for (int i = 0; i < arguments.Length; i++)
{
Type tt = pars[i].ParameterType;
arguments[i] = ConvertToHelper(tt, arguments[i]);
}
Expression r = Ast.New(ci, arguments);
return(r);
}
ClrSyntaxError("clr-new", "constructor could not be resolved on type: " + type, args);
return(null);
}
public override Expression Generate(object args, CodeBlock c)
{
Cons lambdas = args as Cons;
int arlen = lambdas == null ? 0 : lambdas.Length;
if (arlen == 1)
{
if (lambdagen == null)
{
lambdagen = Context.Scope.LookupName(SymbolTable.StringToId("typed-lambda")) as TypedLambdaGenerator;
}
return(lambdagen.Generate(lambdas.car, c));
}
else
{
List <CodeBlockDescriptor> cbs = new List <CodeBlockDescriptor>();
string lambdaname = GetLambdaName(c);
NameHint = SymbolId.Empty;
var sh = SpanHint;
var lh = LocationHint;
while (lambdas != null)
{
var refs = ClrGenerator.SaveReferences();
object actual = lambdas.car;
object arg = Builtins.First(actual);
object typespec = (Builtins.Second(actual));
Cons body = Builtins.Cdr(Builtins.Cdr(actual)) as Cons;
var returntype = ClrGenerator.ExtractTypeInfo(Builtins.List(quote, Builtins.Second(typespec)));
CodeBlock cb = Ast.CodeBlock(SpanHint, lambdaname, returntype);
NameHint = SymbolId.Empty;
cb.Filename = lh;
cb.Parent = c;
bool isrest = AssignParameters(cb, arg, Builtins.Car(typespec));
List <Statement> stmts = new List <Statement>();
FillBody(cb, stmts, body, true);
Type dt = GetDelegateType(cb);
Type ct = GetClosureType(cb);
var cbe = Ast.CodeBlockExpression(cb, true, dt);
Expression ex = Ast.New(ct.GetConstructor(new Type[] { dt }), cbe);
CodeBlockDescriptor cbd = new CodeBlockDescriptor();
cbd.arity = isrest ? -cb.ParameterCount : cb.ParameterCount;
cbd.callable = ex;
cbd.codeblock = cbe;
cbd.varargs = isrest;
descriptorshack2.Add(cbd.callable, cbd);
cbs.Add(cbd);
lambdas = lambdas.cdr as Cons;
ClrGenerator.ResetReferences(refs);
}
return(MakeTypedCaseClosure(lambdaname, cbs));
}
}
public override Expression Generate(object args, CodeBlock cb)
{
Cons c = args as Cons;
int alen = c.Length;
if (alen < 2 || alen > 3)
{
Builtins.SyntaxError("if", "argument mismatch. expected: (if a b c?) got: " + new Cons("if", args), args, false);
}
object test = Builtins.First(args);
object trueexp = Builtins.Second(args);
object falseexp = alen == 3 ? Builtins.Third(args) : null;
// fast check for (if #f #f) == Unspecified or (if #t ...)
if (test is bool) // constant
{
bool tt = (bool)test;
if (tt)
{
return(GetAst(test, cb));
}
else
{
if (falseexp == null)
{
return(Ast.ReadField(null, Unspecified));
}
else
{
return(GetAst(falseexp, cb));
}
}
}
Expression e = null;
if (falseexp != null)
{
e = Unwrap(GetAst(falseexp, cb));
}
else
{
e = Ast.ReadField(null, Unspecified);
}
Expression t = Unwrap(GetAst(trueexp, cb));
if (e.Type != typeof(object) && e.Type != t.Type)
{
e = Ast.ConvertHelper(e, typeof(object));
}
if (t.Type != typeof(object) && e.Type != t.Type)
{
t = Ast.ConvertHelper(t, typeof(object));
}
Expression testexp = Unwrap(GetAst(test, cb));
if (testexp is ConstantExpression)
{
if (testexp.IsConstant(false))
{
return(e);
}
else
{
return(t);
}
}
if (testexp.Type != typeof(bool))
{
testexp = Ast.SimpleCallHelper(Builtins_IsTrue, testexp);
//testexp = Ast.NotEqual(Ast.Constant(false), testexp);
}
return(Ast.Condition(testexp, t, e));
}