Made code 64-bit clean. Enabled use of 64-bit arithmetic for integers.

git-svn-id: svn://localhost/root/svnrepo/trunk@13 bee25f81-8ba7-4b93-944d-dfac3d1a11cc
This commit is contained in:
colin.smith 2008-06-17 23:00:34 +00:00
parent 30a867f44b
commit 420e9ec1b3
10 changed files with 152 additions and 152 deletions

View File

@ -11,7 +11,7 @@ VM_COMP_OBJ = $(VM_OBJ) _compiler.o
UNIX_OBJ = u-main.o
PROGRAM = vx-scheme
DEFVER = -DVERSION=$(VERSION)
CFLAGS = -ansi -g -O2 -fno-exceptions -fno-rtti -Wall $(DEFVER)
CFLAGS = -m64 -ansi -g -O2 -fno-exceptions -fno-rtti -Wall $(DEFVER)
CC = gcc
TC = ../testcases
@ -37,7 +37,7 @@ scheme-compiler: $(VM_COMP_OBJ) $(UNIX_OBJ) compile-file.scm vx-scheme
./vx-scheme ./compile-file.scm < compile-file.scm \
> _compile-file.cpp
$(CC) $(CFLAGS) -c _compile-file.cpp
$(CC) -o $@ $(VM_COMP_OBJ) $(UNIX_OBJ) \
$(CC) $(CFLAGS) -o $@ $(VM_COMP_OBJ) $(UNIX_OBJ) \
_compile-file.o -lstdc++ -lm
# Precompiled objects! Run the scheme-compiler to produce bytecode in

View File

@ -18,7 +18,7 @@ Cell * Context::make ()
return c;
}
Cell * Context::make_int (int i)
Cell * Context::make_int (intptr_t i)
{
// SHORT INTEGER support: if the integer fits in 24 bits,
// then return a phony pointer with the short flag set and
@ -199,9 +199,6 @@ void Cell::sanity_check ()
{
int bad = 0;
printf ("size = %Zu, typebits = %d, typemask = %x, numtypes = %d\n",
sizeof (Cell), TYPEBITS, TYPEMASK, NUM_TYPES);
// Make sure that there are enough typebits to contain
// all the types we know about.
@ -333,10 +330,10 @@ void Cell::stats ()
//
//======================================================================
int Cell::IntValue () const
intptr_t Cell::IntValue () const
{
if (short_atom (this))
return reinterpret_cast <int> (this) >> 8;
return reinterpret_cast <intptr_t> (this) >> 8;
typecheck (Int); return cd.i;
}
@ -424,11 +421,10 @@ const char * Cell::name () const
void Cell::typefail (Type t1, Type t2) const
{
static char buf [128]; // XXX not reentrant, and fixed buffer dangerous
sprintf (buf, "type check failure: wanted %s, got %s",
sprintf (OS::errbuf, "type check failure: wanted %s, got %s",
typeName [t2], typeName [t1]); /* XXX sprintf into fixed buf */
OS::exception (buf);
OS::exception();
}
void Cell::dump (FILE * out)
@ -441,13 +437,13 @@ void Cell::dump (FILE * out)
if (ca.i & MARK) fputs ("mark ", out);
if (short_atom (ca.p))
{
printf ("short %d ", ca.p->IntValue ());
printf ("short %" PRIdPTR " ", ca.p->IntValue ());
}
else
{
if (ca.i & ATOM)
{
printf ("atom %04x ", ca.i);
printf ("atom %04" PRIxPTR " ", ca.i);
if (ca.i & FORCED) fputs ("forced ", out);
if (ca.i & QUICK) fputs ("quick ", out);
if (ca.i & MACRO) fputs ("macro ", out);
@ -471,7 +467,7 @@ void Cell::dump (FILE * out)
fprintf (out, "%p", cd.p);
break;
case Int: fprintf (out, " %d", cd.i); break;
case Int: fprintf (out, " %" PRIdPTR, cd.i); break;
case Real: fprintf (out, " %g", RealValue ()); break;
case Unique: fprintf (out, " %s", cd.u); break;
case Symbol: fprintf (out, " %s", SymbolValue ()->key);
@ -676,13 +672,13 @@ class Slab
// Supposedly the ANSI library guarantees that storage
// is 4-aligned!
if (((int) storage) & 3)
if ((reinterpret_cast<intptr_t>(storage)) & 3)
abort ();
// But if it's not 8-aligned we can fix that using the
// extra 4 bytes we allocated.
if (((int) storage) & 7)
if ((reinterpret_cast<intptr_t>(storage)) & 7)
start = reinterpret_cast <Cell *> (storage + 4);
else
start = reinterpret_cast <Cell *> (storage);
@ -783,11 +779,12 @@ TOP:
//
inline Cell * Cell::untagged (Cell * c)
{
return reinterpret_cast <Cell *>
(reinterpret_cast <int> (c) & ~Cell::TAGMASK);
}
inline Cell * Cell::untagged (Cell * c) {
static const uintptr_t not_tagmask = ~Cell::TAGMASK;
return reinterpret_cast <Cell *>
(reinterpret_cast <uintptr_t> (c) & not_tagmask);
}
inline void Cell::gc_set_car (Cell * src)
{
@ -967,7 +964,7 @@ E6: if (T == nil)
// can contain integer VM codes as well as cell pointers.
// These latter are marked with the ATOM flag.
if (reinterpret_cast <int> (P) & Cell::ATOM)
if (reinterpret_cast <intptr_t> (P) & Cell::ATOM)
goto next_element;
// Otherwise we mark, if not marked already.
@ -1145,7 +1142,7 @@ void Context::gc ()
// marked with the ATOM flag.
for (int ix = 0; ix < m_stack.size (); ++ix)
if ((reinterpret_cast <int> ((p = m_stack [ix])) & Cell::ATOM) == 0)
if ((reinterpret_cast <intptr_t> ((p = m_stack [ix])) & Cell::ATOM) == 0)
mark (p);
// Mark the I/O ports referenced in this environment stack.

View File

@ -91,6 +91,8 @@ void Context::init_machine ()
clear (r_varl);
}
char OS::errbuf [ebufsize];
// Context::using_vm - return true if we are using the bytecode vm.
bool Context::using_vm() const {
@ -110,24 +112,22 @@ Cell* Context::eval(Cell* form) {
void error (const char * message, const char * m2 /* = 0 */)
{
static const int ebufsize = 256;
static char errbuf [ebufsize];
int ix = 0;
const char *p;
char *q;
// Concatenate the two strings into a static buffer.
for (p = message, ix = 0, q = errbuf; *p && ix < ebufsize-1; ++ix)
for (p = message, ix = 0, q = OS::errbuf; *p && ix < OS::ebufsize-1; ++ix)
*q++ = *p++;
if (m2)
for (p = m2; *p && ix < ebufsize-1; ++ix)
for (p = m2; *p && ix < OS::ebufsize-1; ++ix)
*q++ = *p++;
*q = '\0';
OS::exception (errbuf);
OS::exception();
}
Cell * Context::extend (Cell * env)

View File

@ -245,7 +245,7 @@ Cell* Context::interp_evaluator(Cell * form)
psymbol s;
Cell::Type t;
Cell::Procedure lambda;
int flag = 0;
intptr_t flag = 0;
double t1;
bool trace;
psymbol p;
@ -280,7 +280,7 @@ Cell* Context::interp_evaluator(Cell * form)
#define RETURN_VALUE(v) do { \
r_val = (v); \
restore (r_cont); \
restore_i (r_cont); \
GOTO (r_cont); \
} while (0)
@ -344,7 +344,7 @@ TOP:
return r_val;
case ev_application:
save (r_cont);
save_i (r_cont);
r_unev = cdr (r_exp);
r_exp = car (r_exp);
CALL_EVAL (ev_application2);
@ -459,7 +459,7 @@ TOP:
r_env = extend (lambda.envt);
bind_arguments (r_env, lambda.arglist, r_unev);
save (macro_subst); // continuation
save_i (macro_subst); // continuation
}
else
{
@ -489,7 +489,7 @@ TOP:
error ("can't dispatch one of those.");
}
restore (r_cont);
restore_i (r_cont);
GOTO (r_cont);
case ev_eval:
@ -512,7 +512,7 @@ TOP:
clear(r_argl);
save(make_real(OS::get_time()));
save(ev_time1); // cont
save_i(ev_time1); // cont
GOTO(apply_dispatch2);
case ev_time1:
@ -530,7 +530,7 @@ TOP:
if (cdr (r_unev) == nil)
{
restore (r_cont);
restore_i(r_cont);
EVAL_DISPATCH ();
}
@ -557,7 +557,7 @@ TOP:
r_unev = cdr (r_unev);
CALL_EVAL (ev_if_decide);
restore (r_cont);
restore_i(r_cont);
if (r_val->istrue ())
{
@ -612,7 +612,7 @@ TOP:
case ev_or:
if (r_unev == nil || r_val->istrue ())
{
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
}
@ -624,7 +624,7 @@ TOP:
case ev_and:
if (r_unev == nil || !r_val->istrue ())
{
restore (r_cont);
restore_i (r_cont);
GOTO (r_cont);
}
@ -639,7 +639,7 @@ TOP:
// eval, please.
restore (r_env);
restore (r_cont);
restore_i (r_cont);
r_exp = r_val;
EVAL_DISPATCH ();
@ -844,7 +844,7 @@ TOP:
save (r_unev);
save (r_env);
r_unev = cddr (r_unev);
save (ev_do_step);
save_i (ev_do_step);
GOTO (ev_sequence);
case ev_do_step:
@ -962,13 +962,13 @@ TOP:
if (t == Cell::Vec)
{
save (1);
save_i (1);
r_unev = vector_to_list (this, cons (r_unev, nil)); // yyy
}
else
save (0);
save_i (0);
save (ev_qq_finish);
save_i (ev_qq_finish);
r_val = nil;
case ev_qq0:
@ -1001,7 +1001,7 @@ TOP:
else if (p == s_quasiquote) // increase QQ level.
{
r_unev = cdr (r_unev);
save (ev_qq1);
save_i (ev_qq1);
GOTO (ev_quasiquote);
case ev_qq1:
r_tmp = make_symbol (s_quasiquote);
@ -1036,7 +1036,7 @@ TOP:
save (r_argl);
r_exp = r_unev;
save (ev_unq_spl2);
save_i (ev_unq_spl2);
GOTO (ev_qq0);
}
else
@ -1057,13 +1057,13 @@ TOP:
{
QQCONS: // "move quasiquotation inward"
save (cdr (r_unev)); // cons (qq (car), qq (cdr))
save (ev_qq2); // new continuation
save_i (ev_qq2); // new continuation
r_unev = r_exp;
GOTO (ev_qq0);
case ev_qq2:
restore (r_unev);
save (r_val);
save (ev_qq3);
save_i (ev_qq3);
GOTO (ev_qq0);
case ev_qq3:
restore (r_exp);
@ -1073,15 +1073,15 @@ TOP:
else
r_val = r_unev; // atoms are self-evaluating
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
case ev_qq_finish: // finished. reconvert to
restore (flag); // vector form if necessary.
restore_i(flag); // vector form if necessary.
if (flag)
r_val = vector_from_list (this, r_val);
--r_qq;
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
case ev_qq_decrease:
@ -1092,7 +1092,7 @@ TOP:
--r_qq;
r_unev = cdr (r_unev);
save (ev_qqd_1);
save_i (ev_qqd_1);
GOTO (ev_qq0);
case ev_qqd_1:
restore (r_exp); // recover head symbol
@ -1146,7 +1146,7 @@ TOP:
save (r_unev);
save (r_proc);
save (ev_foreach2);
save_i(ev_foreach2);
GOTO (apply_dispatch2);
case ev_foreach2:
restore (r_proc);
@ -1173,7 +1173,7 @@ TOP:
save (r_varl);
save (r_unev);
save (r_proc);
save (ev_map2);
save_i(ev_map2);
GOTO (apply_dispatch2);
case ev_map2:
restore (r_proc);
@ -1199,7 +1199,7 @@ TOP:
clear (r_argl);
r_proc = r_exp->cd.cv->get (0);
save (r_exp);
save (ev_force2);
save_i(ev_force2);
GOTO (apply_dispatch2);
case ev_force2:
// Now, it can happen that the procedure we're
@ -1220,7 +1220,7 @@ TOP:
}
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
case ev_withinput:
@ -1229,24 +1229,24 @@ TOP:
with_input (Cell::caar (&r_argl)->StringValue ());
r_proc = Cell::cadar (&r_argl);
clear (r_argl);
save (ev_withinput2); // continuation
save_i(ev_withinput2); // continuation
GOTO (apply_dispatch2);
case ev_withinput2:
without_input ();
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
case ev_withoutput:
with_output (Cell::caar (&r_argl)->StringValue ());
r_proc = Cell::cadar (&r_argl);
clear (r_argl);
save (ev_withoutput2); // continuation
save_i(ev_withoutput2); // continuation
GOTO (apply_dispatch2);
case ev_withoutput2:
without_output ();
restore (r_cont);
restore_i(r_cont);
GOTO (r_cont);
case ev_load:
@ -1274,7 +1274,7 @@ TOP:
r_unev = make_oport (Cell::caar (&r_argl)->StringValue ());
Cell::setcar (&r_argl, cons (r_unev, nil));
save (r_unev);
save (ev_callwof2); // cont
save_i(ev_callwof2); // cont
GOTO (apply_dispatch2);
case ev_callwof2:

View File

@ -233,7 +233,7 @@ TOP:
// hex constant. Drop the 'x' and convert with strtoul.
char * endptr;
unsigned long ul = strtoul (lexeme.str () + 1, &endptr, 16);
uintptr_t ul = strtoul (lexeme.str () + 1, &endptr, 16);
if (*endptr == '\0')
READ_RETURN (make_int (ul));
@ -425,7 +425,7 @@ void Cell::write (sstring& ss) const {
switch(t) {
case Int: {
char buf[40];
sprintf(buf, "%d", IntValue());
sprintf(buf, "%" PRIdPTR, IntValue());
ss.append(buf);
break;
}

View File

@ -51,7 +51,7 @@ static bool exact_list (Cell * arglist)
{
case Cell::Int: continue;
case Cell::Real: return false;
default: error ("non-numeric type encountered");
default: return false;
}
return true;
@ -78,7 +78,7 @@ Cell * skplus (Context * ctx, Cell * arglist)
{
if (exact_list (arglist))
{
int result = 0;
intptr_t result = 0;
FOR_EACH (p, arglist)
result += car (p)->IntValue ();
@ -100,7 +100,7 @@ Cell * skminus (Context * ctx, Cell * arglist)
{
if (exact_list (arglist))
{
int result = car (arglist)->IntValue ();
intptr_t result = car (arglist)->IntValue ();
arglist = cdr (arglist);
if (arglist == nil)
@ -154,7 +154,7 @@ Cell * times (Context * ctx, Cell * arglist)
{
if (exact_list (arglist))
{
int result = 1;
intptr_t result = 1;
FOR_EACH (p, arglist)
result *= Cell::car (p)->IntValue ();
@ -176,8 +176,8 @@ Cell * skmax (Context * ctx, Cell * arglist)
{
if (exact_list (arglist))
{
int m = INT_MIN;
int z;
intptr_t m = numeric_limits<intptr_t>::min();
intptr_t z;
FOR_EACH (a, arglist)
if ((z = Cell::car (a)->IntValue ()) > m)
@ -202,8 +202,8 @@ Cell * skmin (Context * ctx, Cell * arglist)
{
if (exact_list (arglist))
{
int m = INT_MAX;
int z;
intptr_t m = numeric_limits<intptr_t>::max();
intptr_t z;
FOR_EACH (a, arglist)
if ((z = car (a)->IntValue ()) < m)
@ -323,8 +323,8 @@ BINOP (char_gt_ci, chrGTci, char, Char)
if (cdr (a) != nil) \
if (exact) \
{ \
int ia = car (a)->IntValue (); \
int ib = cadr (a)->IntValue (); \
intptr_t ia = car (a)->IntValue (); \
intptr_t ib = cadr (a)->IntValue (); \
if (! OP (ia, ib)) \
return &Cell::Bool_F; \
} \
@ -435,7 +435,7 @@ Cell * write_char (Context * ctx, Cell * arglist)
Cell * skmake_vector (Context * ctx, Cell * arglist)
{
int n = car (arglist)->IntValue ();
intptr_t n = car (arglist)->IntValue ();
if (cdr (arglist) != nil)
return ctx->make_vector (n, cadr (arglist));
@ -1183,7 +1183,7 @@ Cell * set_cdr (Context * ctx, Cell * arglist)
return unspecified;
}
Cell * set_car (Context * ctx, Cell * arglist)
Cell* set_car(Context * ctx, Cell * arglist)
{
Cell::setcar (car (arglist), cadr (arglist));
return unspecified;
@ -1218,7 +1218,7 @@ Cell * integer_to_char (Context * ctx, Cell * arglist)
Cell * char_to_integer (Context * ctx, Cell * arglist)
{
return ctx->make_int ((int) car (arglist)->CharValue ());
return ctx->make_int (static_cast<intptr_t>(car (arglist)->CharValue ()));
}
Cell * open_input_file (Context * ctx, Cell * arglist)
@ -1290,7 +1290,7 @@ Cell * inexact_to_exact (Context * ctx, Cell * arglist)
if (a->type () == Cell::Int)
return ctx->make_int (a->IntValue ());
else
return ctx->make_int ((int) a->RealValue ());
return ctx->make_int (static_cast<intptr_t>(a->RealValue ()));
}
// Round to nearest int... which would be easy except that the Scheme

View File

@ -74,9 +74,9 @@ Cell * OS::undef (Context * ctx, const char * name)
return 0;
}
void OS::exception (const char * s) {
if (jmpbuf_set) longjmp (jb, reinterpret_cast <int> (s));
fputs(s, stderr);
void OS::exception() {
if (jmpbuf_set) longjmp (jb, 1);
fputs(errbuf, stderr);
fputs("\n", stderr);
exit(1);
}
@ -98,7 +98,6 @@ void interact (Context * ctx)
}
int main (int argc, char **argv) {
const char *jv;
Context ctx;
Cell* scheme_argv = ctx.gc_protect(ctx.make_vector(0));
cellvector* argvec = scheme_argv->VectorValue();
@ -126,11 +125,11 @@ int main (int argc, char **argv) {
// Interact
while (1) {
if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0) {
if (setjmp (jb) == 0) {
jmpbuf_set = true;
interact (&ctx);
} else {
fprintf (stderr, "caught: %s\n", jv);
fprintf (stderr, "caught: %s\n", OS::errbuf);
}
}
}

View File

@ -105,7 +105,7 @@ static bool exact_top_n (cellvector * cv, int n) {
switch (cv->get_unchecked(ix)->type()) {
case Cell::Int: continue;
case Cell::Real: return false;
default: error ("non-numeric type encountered");
default: return false;
}
return true;
}
@ -176,19 +176,19 @@ void Context::print_insn(int addr, Cell* insn) {
printf ("%4d:\t%s\t", addr, op->opcode->key);
switch (op->opnd_type) {
case OP_INT:
printf ("%d", insn->cd.i);
printf ("%" PRIdPTR, insn->cd.i);
break;
case OP_SYMBOL:
printf ("%s", insn->cd.y->key);
break;
case OP_SUBR: printf ("%d,%s", INSN_COUNT (insn),
case OP_SUBR: printf ("%" PRIdPTR ",%s", INSN_COUNT (insn),
insn->flag(Cell::QUICK)
? insn->cd.f->name
: insn->cd.y->key);
// XXX comment
break;
case OP_LEXADDR:
printf ("%d,%d", LEXA_ESKIP(insn), LEXA_BSKIP(insn));
printf ("%" PRIdPTR ",%" PRIdPTR, LEXA_ESKIP(insn), LEXA_BSKIP(insn));
break;
case OP_NONE:
;
@ -221,9 +221,9 @@ Cell* Context::vm_evaluator(Cell* form) {
Cell* Context::execute (Cell* proc, Cell* args) {
cellvector *insns, *literals;
int pc;
intptr_t pc;
int type;
int start;
intptr_t start;
unsigned int count;
unsigned int n_args = 0;
unsigned int b_skip = 0;
@ -232,7 +232,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
// Note the initial stack size.
int initial_stackdepth = m_stack.size();
save (-1);
save_i (-1);
// Push any arguments we received onto the stack.
@ -270,10 +270,10 @@ Cell* Context::execute (Cell* proc, Cell* args) {
printf ("\t");
for (int ix = m_stack.size() - 1; ix >= 0; --ix) {
Cell * c = m_stack.get_unchecked(ix);
if (!(((int)c)&1)) {
if (!((reinterpret_cast<intptr_t>(c))&1)) {
if (c == root_envt) printf("#<root-envt> ");
else c->write (stdout);
} else printf ("%d", ((int)c)>>1);
} else printf ("%" PRIdPTR, (reinterpret_cast<intptr_t>(c))>>1);
fputc (' ', stdout);
}
printf("\n");
@ -283,14 +283,14 @@ Cell* Context::execute (Cell* proc, Cell* args) {
switch (opcode)
{
case 0: // consti
save (insn->cd.i);
save_i (insn->cd.i);
break;
case 1: // nil
m_stack.push (nil);
break;
case 2: // subr
if (!insn->flag(Cell::QUICK)) {
Cell* const subr = find_var(root_envt, insn->cd.y, 0);
Cell* subr = find_var(root_envt, insn->cd.y, 0);
if (!subr) error("missing primitive procedure");
Cell* proc = cdr(subr);
type = proc->type();
@ -307,7 +307,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
cv.push(m_stack.pop());
save(r_envt);
save(r_cproc);
save(pc+1);
save_i(pc+1);
for (unsigned int ix = 0; ix < n_args; ++ix)
m_stack.push(cv.pop());
r_cproc = proc;
@ -396,7 +396,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
case 12: // proc
// pop the starting instruction from the stack and compose it
// with the current environment.
restore (start);
restore_i (start);
m_stack.push (make_compiled_procedure (r_cproc->cd.cv->get_unchecked (0),
r_cproc->cd.cv->get_unchecked (1),
r_envt,
@ -426,12 +426,12 @@ Cell* Context::execute (Cell* proc, Cell* args) {
// instruction slot in this segment.
save (r_envt);
save (r_cproc);
save (insn->cd.i);
save_i (insn->cd.i);
break;
case 17: // return
r_val = m_stack.pop (); // value
RETURN:
restore (pc);
restore_i (pc);
if (pc < 0)
goto FINISH;
restore (r_cproc);
@ -451,7 +451,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
// (We count from zero). 'take 0' would be a no-op; 'take 1'
// would swap the top two elements. We use an unchecked get
// because we "trust the compiler."
int target = insn->cd.i;
intptr_t target = insn->cd.i;
int last = m_stack.size() - 1;
r_tmp = m_stack.get_unchecked(last-target);
for (int ix = last-target; ix < last; ++ix)
@ -541,7 +541,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
n_args = insn->cd.i;
if (n_args != 2)
error ("bad arguments to vector-ref!");
int ix = m_stack.pop()->IntValue();
intptr_t ix = m_stack.pop()->IntValue();
cellvector * cv = m_stack.pop()->VectorValue();
m_stack.push(cv->get(ix));
break;
@ -570,7 +570,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
n_args = insn->cd.i;
int sz = m_stack.size ();
if (exact_top_n (&m_stack, n_args)) {
int sum = 0;
intptr_t sum = 0;
for (int ix = sz - n_args; ix < sz; ++ix)
sum += m_stack.get (ix)->IntValue(); // exact_top_n guarantees this is OK
m_stack.discard (n_args);
@ -589,7 +589,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
n_args = insn->cd.i;
int sz = m_stack.size ();
if (exact_top_n (&m_stack, n_args)) {
int product = 1;
intptr_t product = 1;
for (int ix = sz - n_args; ix < sz; ++ix)
product *= m_stack.get (ix)->IntValue(); // exact_top_n says this is OK
m_stack.discard (n_args);
@ -606,8 +606,8 @@ Cell* Context::execute (Cell* proc, Cell* args) {
case 35: { // quotient
if (insn->cd.i != 2)
error ("wrong # args");
int d = m_stack.pop()->IntValue();
int n = m_stack.pop()->IntValue();
intptr_t d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue();
if (d == 0)
error ("/0");
m_stack.push (make_int (n/d));
@ -616,8 +616,8 @@ Cell* Context::execute (Cell* proc, Cell* args) {
case 36: { // remainder
if (insn->cd.i != 2)
error ("wrong # args");
int d = m_stack.pop()->IntValue();
int n = m_stack.pop()->IntValue();
intptr_t d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue();
if (d == 0)
error ("/0");
m_stack.push (make_int (n%d));
@ -633,7 +633,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
if (n_args == 1) {
m_stack.push(make_int(-m_stack.pop()->IntValue()));
} else {
int difference = m_stack.get(sz-n_args)->IntValue();
intptr_t difference = m_stack.get(sz-n_args)->IntValue();
for (int ix = sz - n_args + 1; ix < sz; ++ix)
difference -= m_stack.get (ix)->IntValue();
m_stack.discard (n_args);
@ -687,7 +687,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
m_stack.push(make_int(insn->cd.i));
break;
case 47: // promise
restore(start);
restore_i(start);
r_tmp = make_compiled_procedure(r_cproc->cd.cv->get(0),
r_cproc->cd.cv->get(1),
r_envt,
@ -895,7 +895,7 @@ Cell* Context::load_instructions(vm_cproc* cp) {
Cell::setcar(a1, zero);
switch(optab[opcode].opnd_type) {
case OP_INT:
Cell::setcar(a0, make_int(reinterpret_cast<int>(insn->operand)));
Cell::setcar(a0, make_int(reinterpret_cast<intptr_t>(insn->operand)));
break;
case OP_SYMBOL:
Cell::setcar(a0,
@ -903,7 +903,7 @@ Cell* Context::load_instructions(vm_cproc* cp) {
intern(static_cast<const char*>(insn->operand))));
break;
case OP_LEXADDR: {
int la = reinterpret_cast<int>(insn->operand);
int la = reinterpret_cast<intptr_t>(insn->operand);
Cell::setcar(a0, make_int(la >> 16));
Cell::setcar(a1, make_int(la & 0xffff));
break;
@ -974,18 +974,18 @@ Cell* Context::write_compiled_procedure(Cell* arglist) {
fprintf(output, " { %2d,", opcode); // XXX magic number
switch(op->opnd_type) {
case OP_NONE: fprintf(output, "0,0"); break;
case OP_INT: fprintf(output, "0,(void*)%d", insn->cd.i); break;
case OP_INT: fprintf(output, "0,(void*)%" PRIdPTR, insn->cd.i); break;
case OP_SYMBOL: fprintf(output, "0,");
write_escaped_string(output, insn->cd.y->key); break;
case OP_SUBR:
// XXX write a comment
fprintf(output, "%d,", INSN_COUNT(insn));
fprintf(output, "%" PRIdPTR ",", INSN_COUNT(insn));
if (insn->flag(Cell::QUICK))
write_escaped_string(output, insn->cd.f->name);
else
write_escaped_string(output, insn->cd.y->key);
break;
case OP_LEXADDR: fprintf(output, "0,(void*)%#x", insn->cd.i); break;
case OP_LEXADDR: fprintf(output, "0,(void*)%#" PRIxPTR, insn->cd.i); break;
}
}
fprintf(output, " },\n");

View File

@ -173,7 +173,7 @@ Cell * vx_invoke (Context * ctx, Cell * arglist)
void OS::exception (const char * s)
{
longjmp (jb, reinterpret_cast <int> (s));
longjmp (jb, 1);
}
void interact (Context * ctx)
@ -191,7 +191,6 @@ void interact (Context * ctx)
extern "C" int scheme (char * a0)
{
const char * jv;
Context ctx;
// Sanity check: we need to make sure that the "unique cells"
@ -203,7 +202,7 @@ extern "C" int scheme (char * a0)
// worked out ok. The garbage collector will be very unhappy if
// any cells are not 8-aligned.
if (((int) nil) & 7)
if ((reinterpret_cast<intptr_t>(nil)) & 7)
{
printf ("code module error: standard cells not 8-aligned\n");
exit (1);
@ -228,10 +227,10 @@ extern "C" int scheme (char * a0)
}
else while (1)
{
if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0)
if (setjmp (jb) == 0)
interact (&ctx);
else
fprintf (stderr, "caught: %s\n", jv);
fprintf (stderr, "caught: %s\n", OS::errbuf);
}
}

View File

@ -12,6 +12,9 @@
#include <stdio.h>
#include <ctype.h>
#include <limits.h>
#define __STDC_FORMAT_MACROS
#include <inttypes.h>
#ifndef WIN32
#include <unistd.h>
#else
@ -56,11 +59,16 @@ class OS
// supply value for undef symbol
static Cell * undef (Context *, const char *);
// report exception and restart
static void exception (const char *);
static void exception();
// manage debug flags
static unsigned int flags ();
static bool flag (int bit)
{ return (flags () & bit) != 0; }
// XXX global error buffer, set just before a longjmp to the
// REPL. This should be made context local.
static const int ebufsize = 256;
static char errbuf [ebufsize];
};
typedef Cell * (* subr_f) (Context * ctx, Cell * arglist);
@ -300,8 +308,6 @@ class Cell
public:
typedef Cell * ptr;
void display (FILE *);
void write(FILE *) const;
void write(sstring&) const;
@ -422,7 +428,7 @@ public:
// Value extractors
int IntValue() const;
intptr_t IntValue() const;
char CharValue() const;
SubrBox* SubrValue() const;
char* StringValue() const;
@ -589,10 +595,10 @@ public:
private:
static inline bool short_atom (const Cell * c)
{ return (reinterpret_cast <unsigned int> (c) & (ATOM|SHORT))
{ return (reinterpret_cast <uintptr_t> (c) & (ATOM|SHORT))
== (ATOM|SHORT); }
static inline bool long_atom (const Cell* c)
{ return (reinterpret_cast <unsigned int> (c) & (ATOM|SHORT)) == ATOM; }
{ return (reinterpret_cast <uintptr_t> (c) & (ATOM|SHORT)) == ATOM; }
static inline bool atomic (const Cell * c)
{ return short_atom (c) || ((c->ca.i & (ATOM|SHORT)) == ATOM); }
@ -619,23 +625,23 @@ public:
// consists of two words, each at least 32 bits, with the
// natural alignment (8 bytes for a 32-bit machine).
static const unsigned int TAGBITS = 3;
static const unsigned int ATOM = 0x1;
static const unsigned int MARK = 0x2;
static const unsigned int SHORT = 0x4;
static const uintptr_t TAGBITS = 3;
static const uintptr_t ATOM = 0x1;
static const uintptr_t MARK = 0x2;
static const uintptr_t SHORT = 0x4;
static const unsigned int TYPEBITS = 5;
static const unsigned int TYPEMASK = (1 << TYPEBITS) - 1;
static const unsigned int TAGMASK = (1 << TAGBITS) - 1;
static const uintptr_t TYPEBITS = 5;
static const uintptr_t TYPEMASK = (1 << TYPEBITS) - 1;
static const uintptr_t TAGMASK = (1 << TAGBITS) - 1;
// Make sure flag bits are disjoint from TYPE and TAG bits.
static const unsigned int FLAGBASE = 1 << (TYPEBITS + TAGBITS);
static const unsigned int FORCED = FLAGBASE;
static const unsigned int QUICK = FLAGBASE << 1;
static const unsigned int GLOBAL = FLAGBASE << 2;
static const unsigned int MACRO = FLAGBASE << 3;
static const unsigned int VREF = FLAGBASE << 4;
static const unsigned int FREE = FLAGBASE << 5;
static const unsigned int FLAGBITS = 6;
static const uintptr_t FLAGBASE = 1 << (TYPEBITS + TAGBITS);
static const uintptr_t FORCED = FLAGBASE;
static const uintptr_t QUICK = FLAGBASE << 1;
static const uintptr_t GLOBAL = FLAGBASE << 2;
static const uintptr_t MACRO = FLAGBASE << 3;
static const uintptr_t VREF = FLAGBASE << 4;
static const uintptr_t FREE = FLAGBASE << 5;
static const uintptr_t FLAGBITS = 6;
static const int GLOBAL_ENV = -1;
@ -647,26 +653,26 @@ public:
#error too many atom bits used
#endif
inline int e_skip () {
inline intptr_t e_skip () {
// If global symbol, return -1. Else number of environments
// to skip is in highest-order byte
return (ca.i & GLOBAL) ? GLOBAL_ENV
: (int)((ca.i >> (8*(sizeof(ca.i)-1))) & 0xff);
}
inline int b_skip () {
inline intptr_t b_skip () {
// If global symbol, number of bindings to skip is in upper 16
// bits; else, it's in 2nd-highest-order byte
return (ca.i & GLOBAL) ? (ca.i >> (8*(sizeof(ca.i)-2)) & 0xffff)
: ((ca.i >> (8*(sizeof(ca.i)-2))) & 0xff);
}
void set_lexaddr (int e_skip, int b_skip) {
void set_lexaddr (intptr_t e_skip, intptr_t b_skip) {
// If global, set flag and store b_skip in upper 16 bits.
// Else set e_skip in upper 8 bits, and set b_skip in
// next 8 bits.
const int start_bit = 8*(sizeof(ca.i)-2);
const int two_bytes = (1 << 16) - 1;
const intptr_t start_bit = 8*(sizeof(ca.i)-2);
const intptr_t two_bytes = (1 << 16) - 1;
ca.i &= ~(two_bytes << start_bit);
if (e_skip == -1)
ca.i |= (b_skip << start_bit) | GLOBAL | QUICK;
@ -710,12 +716,12 @@ public:
union _car
{
unsigned int i;
uintptr_t i;
Cell * p;
} ca;
union _cdr
{
unsigned int i;
uintptr_t i;
double * d;
Cell * p;
const char * u;
@ -871,7 +877,7 @@ class Context
// Manufacture Cells and Atoms
Cell * make ();
Cell * make_int (int i);
Cell * make_int (intptr_t i);
Cell * make_char (char ch);
Cell * make_real (double d);
Cell * make_string (size_t len);
@ -952,7 +958,6 @@ class Context
Cell* RunMain();
private:
Cell * alloc (Cell::Type t);
@ -977,14 +982,14 @@ class Context
void save (Cell * c) { m_stack.push (c); }
void save (Cell & rc) { m_stack.push (rc.ca.p);
m_stack.push (rc.cd.p); }
void save (int i)
void save_i (intptr_t i)
{ m_stack.push (reinterpret_cast <Cell *> ((i << 1) | Cell::ATOM)); }
void restore (Cell *& c) { c = m_stack.pop (); }
void restore (Cell & rc) { rc.cd.p = m_stack.pop ();
rc.ca.p = m_stack.pop (); }
void restore (int & i)
{ i = (reinterpret_cast <int> (m_stack.pop ()) &
static_cast<int>(~Cell::ATOM)) >> 1; }
void restore_i (intptr_t & i)
{ i = (reinterpret_cast <intptr_t> (m_stack.pop ()) &
static_cast<intptr_t>(~Cell::ATOM)) >> 1; }
// ===========================
// REGISTER MACHINE
@ -1002,7 +1007,7 @@ class Context
Cell * r_nu; // reference to objects being created
int r_qq; // quasiquotation depth
cellvector r_gcp; // extra cells protected from GC
int r_cont; // current continuation
intptr_t r_cont; // current continuation
cellvector m_stack; // recursion/evaluation stack
int state; // current machine state