conservatory
/
vx-scheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Makefile
View File

@ -11,7 +11,7 @@ VM_COMP_OBJ = $(VM_OBJ) _compiler.o
UNIX_OBJ = u-main.o UNIX_OBJ = u-main.o
PROGRAM = vx-scheme PROGRAM = vx-scheme
DEFVER = -DVERSION=$(VERSION) 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 CC = gcc
TC = ../testcases 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 \ ./vx-scheme ./compile-file.scm < compile-file.scm \
> _compile-file.cpp > _compile-file.cpp
$(CC) $(CFLAGS) -c _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 _compile-file.o -lstdc++ -lm
# Precompiled objects! Run the scheme-compiler to produce bytecode in # Precompiled objects! Run the scheme-compiler to produce bytecode in

39
src/cell.cpp
View File

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

10
src/ctx.cpp
View File

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

64
src/interp.cpp
View File

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

4
src/io.cpp
View File

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

28
src/subr.cpp
View File

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

11
src/u-main.cpp
View File

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

60
src/vm.cpp
View File

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

9
src/vx-main.cpp
View File

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

75
src/vx-scheme.h
View File

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