public static SObject findCode(string module, string ns, int id, int number)
{
// First look in programAssembly
CodeVector cv = findCodeInAssembly(Reg.programAssembly, ns, number);
if (cv != null)
{
return(cv);
}
// Then look in external Assembly via module in name
Assembly moduleAssembly;
try {
moduleAssembly = Assembly.LoadFrom(module + ".exe");
}
catch {
try {
moduleAssembly = Assembly.LoadFrom(module + ".dll");
}
catch {
Exn.error("code not found (no EXE or DLL file): " + module);
return(Factory.Impossible);
}
}
cv = findCodeInAssembly(moduleAssembly, ns, number);
if (cv != null)
{
return(cv);
}
Exn.error("code not found: " + module + " " + ns + " " + number);
return(Factory.False);
}
public static Procedure getSupportProcedure(int index)
{
SObject support = Reg.globalValue("millicode-support");
if (support is SVL)
{
SVL procedures = (SVL)support;
Procedure p = procedures.elementAt(index) as Procedure;
if (p != null)
{
return(p);
}
else
{
Exn.internalError("millicode support " + index + " not a procedure");
return(null);
}
}
else if (support == Factory.Undefined)
{
Exn.internalError("millicode-support is not defined (index: " + index + ")");
return(null);
}
else
{
Exn.internalError("millicode-support is not a vector");
return(null);
}
}
public static void op1_round(SObject arg)
{
if (arg is SFixnum)
{
return;
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
if (a.tag == Tags.RatnumTag)
{
Call.callMillicodeSupport1(Constants.MS_RATNUM_ROUND, arg);
return;
}
}
else if (arg is SByteVL)
{
SByteVL a = (SByteVL)arg;
if (a.tag == Tags.FlonumTag)
{
double d = a.unsafeAsDouble(0);
Reg.Result = Factory.makeFlonum(System.Math.Round(d));
return;
}
else if (a.tag == Tags.BignumTag)
{
return;
}
}
Exn.fault(Constants.EX_ROUND, "round: expected real number");
}
/* ===================================================== */
/* Utility */
/* ===================================================== */
public static void expect1(bool b, SObject arg, int blame)
{
if (!b)
{
Exn.fault(blame, "bad argument: " + arg, arg);
}
}
// return new stream position,
// -1 on error
public static long LSeek(int fd, long offset, int whence_code)
{
SeekOrigin whence = SeekOrigin.Begin;
if (whence_code == 0)
{
whence = SeekOrigin.Begin;
}
else if (whence_code == 1)
{
whence = SeekOrigin.Current;
}
else if (whence_code == 2)
{
whence = SeekOrigin.End;
}
else
{
Exn.fault(Constants.EX_ASSERT, "bad whence_code for lseek");
}
try {
return(fd2stream(fd).Seek(offset, whence));
} catch (Exception) {
return(-1);
}
}
public static SObject op2_procedure_ref(SObject arg1, SObject arg2)
{
expect2(arg1.isProcedure(), arg1, arg2.isFixnum(), arg2, Constants.EX_PROCEDURE_REF);
Procedure p = (Procedure)arg1;
int b = ((SFixnum)arg2).value;
if (b == 0)
{
// Code vector
return(p.getCode());
}
else if (b == 1)
{
// Constant vector
return(p.constantvector);
}
else if (b > 1)
{
b = b - 2;
if (b < p.rib.Length)
{
return(p.rib[b]);
}
}
Exn.fault(Constants.EX_PROCEDURE_REF, "procedure-ref: bad index", arg1, arg2);
return(null);
}
public static SObject op1_imag_part(SObject arg)
{
if (arg is SFixnum)
{
return(Factory.makeFixnum(0));
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
if (a.tag == Tags.BignumTag
| a.tag == Tags.RatnumTag)
{
return(Factory.makeFixnum(0));
}
else if (a.tag == Tags.RectnumTag)
{
return(Number.rectImagPart(a));
}
}
else if (arg is SByteVL)
{
SByteVL a = (SByteVL)arg;
if (a.tag == Tags.FlonumTag)
{
return(Factory.makeFixnum(0));
}
else if (a.tag == Tags.CompnumTag)
{
return(Number.compImagPart(a));
}
}
Exn.fault(Constants.EX_IMAGPART,
"not a number");
return(Factory.Unspecified);
}
public static CodeAddress fault(int blame, string m,
SObject arg1, SObject arg2, SObject arg3)
{
Reg.Result = arg1;
Reg.Second = arg2;
Reg.Third = arg3;
return(Exn.fault(blame, m));
}
public void checkPop(int lastslot, Procedure reg0)
{
if (this.lastslot != lastslot)
{
Exn.internalError("pop: wrong number of slots");
}
if (this.s0.entrypoint != reg0.entrypoint)
{
Exn.internalError("pop: can't pop someone else's frame!");
}
}
public static SObject op1_fxnegative(SObject arg)
{
expect1(arg.isFixnum(), arg, Constants.EX_FXNEG);
int a = ((SFixnum)arg).value;
if (!SFixnum.inFixnumRange(-a))
{
Exn.fault(Constants.EX_FXNEG, "result not a fixnum", arg);
}
return(Factory.makeNumber(-a));
}
public static void ffi_syscall()
{
try
{
SObject scode = Reg.Register2;
ffi_syscall_main(((SFixnum)scode).value);
}
catch (Exception e)
{
Exn.error("exception in ffi: " + e.ToString());
}
}
public static void op2_greater_or_equal(SObject arg1, SObject arg2)
{
if (arg1 is SFixnum & arg2 is SFixnum)
{
bool result =
((SFixnum)arg1).value >= ((SFixnum)arg2).value;
Reg.Result = Factory.makeBoolean(result);
return;
}
else if (arg1 is SVL & arg2 is SVL)
{
SVL a = (SVL)arg1;
SVL b = (SVL)arg2;
if (a.tag == Tags.RatnumTag & b.tag == Tags.RatnumTag)
{
Call.callMillicodeSupport2(Constants.MS_RATNUM_GREATEREQ, a, b);
return; // TAIL CALL
}
else if (a.tag == Tags.RectnumTag & b.tag == Tags.RectnumTag)
{
Exn.fault(Constants.EX_GREATEREQP, ">= cannot compare rectnums");
return; // TAIL CALL
}
}
else if (arg1 is SByteVL & arg2 is SByteVL)
{
SByteVL a = (SByteVL)arg1;
SByteVL b = (SByteVL)arg2;
if (a.tag == Tags.BignumTag & b.tag == Tags.BignumTag)
{
Call.callMillicodeSupport2(Constants.MS_BIGNUM_GREATEREQ, a, b);
return; // TAIL CALL
}
else if (a.tag == Tags.FlonumTag & b.tag == Tags.FlonumTag)
{
double av = a.unsafeAsDouble(0);
double bv = b.unsafeAsDouble(0);
Reg.Result = Factory.makeBoolean(av >= bv);
return;
}
else if (a.tag == Tags.CompnumTag & b.tag == Tags.CompnumTag)
{
Exn.fault(Constants.EX_GREATEREQP, ">= cannot compare compnums");
return;
}
}
Procedure generic
= Call.getSupportProcedure(Constants.MS_GENERIC_GREATEREQ);
Call.pcontagion(arg1, arg2, generic);
return; // TAIL CALL
}
public static void op1_disable_interrupts(SObject arg)
{
if (Reg.interruptsEnabled)
{
Reg.interruptsEnabled = false;
Reg.Result = Factory.makeFixnum((int)Reg.timer);
}
else
{
Reg.Result = Factory.makeBoolean(false);
}
Exn.checkSignals();
}
public static SObject op2_fxmul(SObject arg1, SObject arg2)
{
expect2(arg1.isFixnum(), arg1, arg2.isFixnum(), arg2, Constants.EX_FXMUL);
int a = ((SFixnum)arg1).value;
int b = ((SFixnum)arg2).value;
int c = a * b;
if (!SFixnum.inFixnumRange(c))
{
Exn.fault(Constants.EX_FXMUL, "result not a fixnum", arg1, arg2);
}
return(Factory.makeNumber(c));
}
public static void rangeCheckVL(SObject arg1, SObject arg2, SObject arg3, int blame)
{
SVL bv = (SVL)arg1;
int index = ((SFixnum)arg2).value;
if (index >= 0 && index < bv.elements.Length)
{
}
else
{
Exn.fault(blame, "index out of range", arg1, arg2, arg3);
}
}
public static void expect2(bool b1, SObject arg1,
bool b2, SObject arg2,
int blame)
{
if (!b1)
{
Exn.fault(blame, "bad argument 1: " + arg1, arg1, arg2);
}
if (!b2)
{
Exn.fault(blame, "bad argument 2: " + arg2, arg1, arg2);
}
}
private static Stream fd2output(int fd)
{
Stream s = fd2stream(fd);
if (s == null || !s.CanWrite)
{
Exn.internalError("file descriptor " + fd + " not open for output");
return(null);
}
else
{
return(s);
}
}
private static Stream fd2stream(int fd)
{
object s = open_files[fd];
if (s is Stream)
{
return((Stream)s);
}
else
{
Exn.internalError("fd " + fd + " is not a stream: " + s);
return(null);
}
}
private static object unwrapF(SObject s)
{
if (s is SFixnum)
{
return(((SFixnum)s).value);
}
else if (s is ForeignBox)
{
return(((ForeignBox)s).value);
}
else
{
Exn.error("cannot unwrap foreign argument");
return(Factory.Impossible);
}
}
// Combines the effect of checkpop and pop.
public void SafePop(int lastslot)
{
if (this.lastslot != lastslot)
{
Exn.internalError("pop: wrong number of slots. Expected "
+ lastslot.ToString()
+ ", got "
+ this.lastslot.ToString());
}
if (this.s0.entrypoint != Reg.ProcRegister0.entrypoint)
{
Exn.internalError("pop: can't pop someone else's frame!");
}
Cont.pop();
}
public static void op1_negative(SObject arg)
{
if (arg is SFixnum)
{
int a = ((SFixnum)arg).value;
Reg.Result = Factory.makeNumber(-a);
return;
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
if (a.tag == Tags.RatnumTag)
{
Call.callMillicodeSupport1(Constants.MS_RATNUM_NEGATE, a);
return; // TAIL CALL
}
else if (a.tag == Tags.RectnumTag)
{
Call.callMillicodeSupport1(Constants.MS_RECTNUM_NEGATE, a);
return;
}
}
else if (arg is SByteVL)
{
SByteVL a = (SByteVL)arg;
if (a.tag == Tags.BignumTag)
{
Call.callMillicodeSupport1(Constants.MS_BIGNUM_NEGATE, a);
return;
}
else if (a.tag == Tags.FlonumTag)
{
Reg.Result = Factory.makeFlonum(-a.unsafeAsDouble(0));
return;
}
else if (a.tag == Tags.CompnumTag)
{
double real = a.unsafeAsDouble(0);
double imag = a.unsafeAsDouble(1);
Reg.Result = Factory.makeCompnum(-real, -imag);
return;
}
}
Exn.fault(Constants.EX_NEG, "not a number");
return;
}
/* Misc */
/* ---- */
public static void op1_enable_interrupts(SObject arg)
{
Ops.expect1(arg.isFixnum(), arg, Constants.EX_EINTR);
int time = ((SFixnum)arg).value;
if (time > 0)
{
Reg.interruptsEnabled = true;
Reg.timer = time;
}
else
{
Exn.fault(Constants.EX_EINTR,
"enable-interrupts: expected positive value");
}
Reg.Result = Factory.Unspecified;
Exn.checkSignals();
}
public static void op2_quotient(SObject arg1, SObject arg2)
{
if (arg1 is SFixnum & arg2 is SFixnum)
{
int a = ((SFixnum)arg1).value;
int b = ((SFixnum)arg2).value;
if (b != 0)
{
int result = a / b;
Reg.Result = Factory.makeFixnum(result);
return;
}
else
{
Exn.fault(Constants.EX_QUOTIENT, "division by zero", arg1, arg2);
return;
}
}
else if (arg1 is SByteVL & arg2 is SFixnum)
{
SByteVL a = (SByteVL)arg1;
int b = ((SFixnum)arg2).value;
if (b == 0)
{
Exn.fault(Constants.EX_QUOTIENT, "division by zero", arg1, arg2);
return;
}
if (b > 0 &&
a.tag == Tags.BignumTag &&
Number.getBignumLength(a) == 1 &&
Number.getBignumSign(a) == Number.BIGNUM_POSITIVE)
{
// Exn.msg.WriteLine("++++ doing bignum quotient in millicode");
uint av = a.getUInt32(1);
uint result = av / (uint)b;
Reg.Result = Factory.makeNumber(result);
return;
}
}
Call.callMillicodeSupport2(Constants.MS_HEAVY_QUOTIENT, arg1, arg2);
return; // TAIL CALL
}
/* fillCache
*/
public static void fillCache()
{
#if HAS_PERFORMANCE_COUNTERS
if (stackReloadCounter != null)
{
stackReloadCounter.Increment();
}
#endif
cont = ROOT;
SVL h = heap as SVL;
if (h == null)
{
Exn.internalError("fillCache: Cont.heap is not a vector");
}
else
{
heap = h.elements[Cont.HC_DYNLINK];
cont.fillFromVector(h);
}
}
public static SObject op3_procedure_set(SObject arg1, SObject arg2, SObject arg3)
{
expect3(arg1.isProcedure(), arg1, arg2.isFixnum(), arg2, true, arg3,
Constants.EX_PROCEDURE_SET);
Procedure p = (Procedure)arg1;
int b = ((SFixnum)arg2).value;
// System.Console.WriteLine("** (procedure-set! {0} {1} {2})", arg1, arg2, arg3);
if (b == 0)
{
// "code vector"
p.setCode(arg3);
return(Factory.Unspecified);
}
else if (b == 1)
{
if (arg3.isVector())
{
p.setConstants((SVL)arg3);
return(Factory.Unspecified);
}
else
{
Exn.fault(Constants.EX_PROCEDURE_SET, "not a vector", arg1, arg2, arg3);
return(null);
}
}
else if (b > 1)
{
int bb = b - 2;
if (bb < p.rib.Length)
{
p.rib[bb] = arg3;
return(Factory.Unspecified);
}
}
Exn.fault(Constants.EX_PROCEDURE_SET, "procedure-set!: bad index " + b, arg1, arg2, arg3);
return(null);
}
public static void op1_truncate(SObject arg)
{
if (arg is SFixnum)
{
Reg.Result = arg;
return;
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
if (a.tag == Tags.RatnumTag)
{
Call.callMillicodeSupport1(Constants.MS_RATNUM_TRUNCATE, arg);
return;
}
}
else if (arg is SByteVL)
{
SByteVL a = (SByteVL)arg;
if (a.tag == Tags.FlonumTag)
{
double d = a.unsafeAsDouble(0);
if (d < 0)
{
Reg.Result = Factory.makeFlonum(System.Math.Ceiling(d));
return;
}
else
{
Reg.Result = Factory.makeFlonum(System.Math.Floor(d));
return;
}
}
else if (a.tag == Tags.BignumTag)
{
return;
}
}
Exn.fault(Constants.EX_TRUNC, "truncate: expected real number");
}
public static void op1_inexact2exact(SObject arg)
{
if (arg is SFixnum)
{
return;
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
}
else if (arg is SByteVL)
{
SByteVL a = (SByteVL)arg;
if (a.tag == Tags.FlonumTag
| a.tag == Tags.CompnumTag)
{
Call.callMillicodeSupport1(Constants.MS_GENERIC_INEXACT2EXACT, arg);
return;
}
else if (a.tag == Tags.BignumTag)
{
return;
}
}
else if (arg is SVL)
{
SVL a = (SVL)arg;
if (a.tag == Tags.RatnumTag)
{
return;
}
else if (a.tag == Tags.RectnumTag)
{
return;
}
}
Exn.fault(Constants.EX_I2E, "not a number");
return;
}
// file exists?
private static void access()
{
string file = ((SByteVL)Reg.Register2).asString();
int operation = ((SFixnum)Reg.Register3).value;
int result = 2; // WHY?
if (operation == 0x01) // FILE EXISTS?
{
if (File.Exists(file) || Directory.Exists(file))
{
result = 0;
}
else
{
result = -1;
}
}
else
{
Exn.internalError("access: read/write/execute checking not supported");
return;
}
Reg.Result = Factory.makeNumber(result);
}
public static bool handleProcedure(Procedure command, SObject[] args)
{
bool keepRunning = true;
bool errorOccurred = true;
try {
Reg.clearRegisters();
for (int i = 0; i < args.Length; ++i)
{
Reg.setRegister(i + 1, args[i]);
}
Call.trampoline(command, args.Length);
errorOccurred = false;
}
catch (SchemeExitException see) {
keepRunning = false;
errorOccurred = false;
if (see.returnCode != 0)
{
// Exn.msg.WriteLine ("Machine exited with error code "
// + see.returnCode);
Exn.fullCoreDump();
Environment.Exit(see.returnCode);
}
}
finally {
if (errorOccurred)
{
Exn.fullCoreDump();
}
}
// if (reportResult) {
// Exn.msg.WriteLine (" {0}", Reg.Result);
// }
return(keepRunning);
}
public static SObject op1_gc_counter(SObject arg)
{
Exn.fault(Constants.EX_UNSUPPORTED);
return(Factory.Unspecified);
}
