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

Compare commits

base: conservatory:ac83d6e7b42d734eb6c8f36d75789c348f814f38
Branches Tags
conservatory:master
..
compare: conservatory:e0f1e47b53dcfb22e5d0fe716699f182e71243d1
Branches Tags
conservatory:master

No commits in common. "ac83d6e7b42d734eb6c8f36d75789c348f814f38" and "e0f1e47b53dcfb22e5d0fe716699f182e71243d1" have entirely different histories.
ac83d6e7b4 ... e0f1e47b53

13 changed files with 205 additions and 206 deletions
Show Stats Expand all files Collapse all files

2
lib/vx-scheme.init
View File

@ -48,7 +48,7 @@
; (else ""))))) ; (else "")))))
; (lambda () library-path))) ; (lambda () library-path)))
;(define (library-vicinity) "/usr/local/lib/slib/") ;(define (library-vicinity) "/usr/local/lib/slib/")
(define (library-vicinity) "/usr/share/slib/") (define (library-vicinity) "/usr/share/guile/slib/")
;;; (home-vicinity) should return the vicinity of the user's HOME ;;; (home-vicinity) should return the vicinity of the user's HOME
;;; directory, the directory which typically contains files which ;;; directory, the directory which typically contains files which

2
src/Makefile
View File

@ -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) $(CFLAGS) -o $@ $(VM_COMP_OBJ) $(UNIX_OBJ) \ $(CC) -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

47
src/cell.cpp
View File

@ -18,7 +18,7 @@ Cell * Context::make ()
return c; return c;
} }
Cell * Context::make_int (intptr_t i) Cell * Context::make_int (int 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,6 +199,9 @@ 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.
@ -330,10 +333,10 @@ void Cell::stats ()
// //
//====================================================================== //======================================================================
intptr_t Cell::IntValue () const int Cell::IntValue () const
{ {
if (short_atom (this)) if (short_atom (this))
return reinterpret_cast <intptr_t> (this) >> 8; return reinterpret_cast <int> (this) >> 8;
typecheck (Int); return cd.i; typecheck (Int); return cd.i;
} }
@ -387,15 +390,11 @@ cellvector * Cell::CProcValue () const
typecheck(Cproc); return cd.cv; typecheck(Cproc); return cd.cv;
} }
Cell* Cell::PromiseValue () const { Cell * Cell::PromiseValue () const
{
typecheck (Promise); typecheck (Promise);
return cd.cv->get (0); return cd.cv->get (0);
} }
Cell* Cell::CPromiseValue() const {
typecheck(Cpromise);
return cd.cv->get(0);
}
psymbol Cell::BuiltinValue () const psymbol Cell::BuiltinValue () const
{ {
@ -421,10 +420,11 @@ const char * Cell::name () const
void Cell::typefail (Type t1, Type t2) const void Cell::typefail (Type t1, Type t2) const
{ {
sprintf (OS::errbuf, "type check failure: wanted %s, got %s", static char buf [128]; // XXX not reentrant, and fixed buffer dangerous
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(); OS::exception (buf);
} }
void Cell::dump (FILE * out) void Cell::dump (FILE * out)
@ -437,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 %" PRIdPTR " ", ca.p->IntValue ()); printf ("short %d ", ca.p->IntValue ());
} }
else else
{ {
if (ca.i & ATOM) if (ca.i & ATOM)
{ {
printf ("atom %04" PRIxPTR " ", ca.i); printf ("atom %04x ", 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);
@ -467,7 +467,7 @@ void Cell::dump (FILE * out)
fprintf (out, "%p", cd.p); fprintf (out, "%p", cd.p);
break; break;
case Int: fprintf (out, " %" PRIdPTR, cd.i); break; case Int: fprintf (out, " %d", 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);
@ -672,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 ((reinterpret_cast<intptr_t>(storage)) & 3) if (((int) 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 ((reinterpret_cast<intptr_t>(storage)) & 7) if (((int) 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);
@ -779,12 +779,11 @@ 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 *> return reinterpret_cast <Cell *>
(reinterpret_cast <uintptr_t> (c) & not_tagmask); (reinterpret_cast <int> (c) & ~Cell::TAGMASK);
} }
inline void Cell::gc_set_car (Cell * src) inline void Cell::gc_set_car (Cell * src)
{ {
@ -964,7 +963,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 <intptr_t> (P) & Cell::ATOM) if (reinterpret_cast <int> (P) & Cell::ATOM)
goto next_element; goto next_element;
// Otherwise we mark, if not marked already. // Otherwise we mark, if not marked already.
@ -1142,7 +1141,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 <intptr_t> ((p = m_stack [ix])) & Cell::ATOM) == 0) if ((reinterpret_cast <int> ((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,8 +91,6 @@ 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 {
@ -112,22 +110,24 @@ 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 = OS::errbuf; *p && ix < OS::ebufsize-1; ++ix) for (p = message, ix = 0, q = errbuf; *p && ix < ebufsize-1; ++ix)
*q++ = *p++; *q++ = *p++;
if (m2) if (m2)
for (p = m2; *p && ix < OS::ebufsize-1; ++ix) for (p = m2; *p && ix < ebufsize-1; ++ix)
*q++ = *p++; *q++ = *p++;
*q = '\0'; *q = '\0';
OS::exception(); OS::exception (errbuf);
} }
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;
intptr_t flag = 0; int 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_i (r_cont); \ restore (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_i (r_cont); save (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_i (macro_subst); // continuation save (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_i (r_cont); restore (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_i(ev_time1); // cont save(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_i(r_cont); restore (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_i(r_cont); restore (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_i(r_cont); restore (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_i (r_cont); restore (r_cont);
GOTO (r_cont); GOTO (r_cont);
} }
@ -639,7 +639,7 @@ TOP:
// eval, please. // eval, please.
restore (r_env); restore (r_env);
restore_i (r_cont); restore (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_i (ev_do_step); save (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_i (1); save (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_i (0); save (0);
save_i (ev_qq_finish); save (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_i (ev_qq1); save (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_i (ev_unq_spl2); save (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_i (ev_qq2); // new continuation save (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_i (ev_qq3); save (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_i(r_cont); restore (r_cont);
GOTO (r_cont); GOTO (r_cont);
case ev_qq_finish: // finished. reconvert to case ev_qq_finish: // finished. reconvert to
restore_i(flag); // vector form if necessary. restore (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_i(r_cont); restore (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_i (ev_qqd_1); save (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_i(ev_foreach2); save (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_i(ev_map2); save (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_i(ev_force2); save (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_i(r_cont); restore (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_i(ev_withinput2); // continuation save (ev_withinput2); // continuation
GOTO (apply_dispatch2); GOTO (apply_dispatch2);
case ev_withinput2: case ev_withinput2:
without_input (); without_input ();
restore_i(r_cont); restore (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_i(ev_withoutput2); // continuation save (ev_withoutput2); // continuation
GOTO (apply_dispatch2); GOTO (apply_dispatch2);
case ev_withoutput2: case ev_withoutput2:
without_output (); without_output ();
restore_i(r_cont); restore (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_i(ev_callwof2); // cont save (ev_callwof2); // cont
GOTO (apply_dispatch2); GOTO (apply_dispatch2);
case ev_callwof2: case ev_callwof2:

13
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;
uintptr_t ul = strtoul (lexeme.str () + 1, &endptr, 16); unsigned long ul = strtoul (lexeme.str () + 1, &endptr, 16);
if (*endptr == '\0') if (*endptr == '\0')
READ_RETURN (make_int (ul)); READ_RETURN (make_int (ul));
@ -254,7 +254,7 @@ TOP:
error ("indecipherable #o constant"); error ("indecipherable #o constant");
} }
error ("indecipherable #constant:", lexeme.str()); error ("indecipherable #constant");
} }
else if (c == '"') else if (c == '"')
{ {
@ -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, "%" PRIdPTR, IntValue()); sprintf(buf, "%d", IntValue());
ss.append(buf); ss.append(buf);
break; break;
} }
@ -535,10 +535,9 @@ void Cell::write (sstring& ss) const {
ss.append("#<compiled-procedure>"); ss.append("#<compiled-procedure>");
break; break;
case Cpromise: case Cpromise:
if (flag(FORCED)) ss.append(flag(FORCED)
CPromiseValue()->write(ss); ? "#<forced-compiled-promise>"
else : "#<compiled-promise>");
ss.append("#<compiled-promise>");
break; break;
case Insn: case Insn:
ss.append("#<vm-instruction>"); ss.append("#<vm-instruction>");

45
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: return false; default: error ("non-numeric type encountered");
} }
return true; return true;
@ -78,7 +78,7 @@ Cell * skplus (Context * ctx, Cell * arglist)
{ {
if (exact_list (arglist)) if (exact_list (arglist))
{ {
intptr_t result = 0; int 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))
{ {
intptr_t result = car (arglist)->IntValue (); int 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))
{ {
intptr_t result = 1; int 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))
{ {
intptr_t m = numeric_limits<intptr_t>::min(); int m = INT_MIN;
intptr_t z; int 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))
{ {
intptr_t m = numeric_limits<intptr_t>::max(); int m = INT_MAX;
intptr_t z; int 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) \
{ \ { \
intptr_t ia = car (a)->IntValue (); \ int ia = car (a)->IntValue (); \
intptr_t ib = cadr (a)->IntValue (); \ int 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)
{ {
intptr_t n = car (arglist)->IntValue (); int 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 (static_cast<intptr_t>(car (arglist)->CharValue ())); return ctx->make_int ((int) 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 (static_cast<intptr_t>(a->RealValue ())); return ctx->make_int ((int) 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
@ -1570,19 +1570,21 @@ static Cell* put_property (Context * ctx, Cell * arglist)
return unspecified; return unspecified;
} }
static Cell* get_property (Context * ctx, Cell * arglist) { static Cell* get_property (Context * ctx, Cell * arglist)
psymbol const p = car (arglist)->SymbolValue (); {
psymbol const q = cadr (arglist)->SymbolValue (); psymbol p = car (arglist)->SymbolValue ();
psymbol q = cadr (arglist)->SymbolValue ();
if (p->plist) if (p->plist)
for (int ix = 0; ix < p->plist->size (); ++ix) { for (int ix = 0; ix < p->plist->size (); ++ix)
{
Cell * elt = p->plist->get (ix); Cell * elt = p->plist->get (ix);
if (car (elt)->SymbolValue () == q) if (car (elt)->SymbolValue () == q)
return cdr (elt); return cdr (elt);
} }
return ctx->make_boolean (false); return ctx->make_boolean (false);
} }
// Imported from Common Lisp. Returns #t if the given symbol is // Imported from Common Lisp. Returns #t if the given symbol is
// bound in the global environment (lexical bindings are not consulted), // bound in the global environment (lexical bindings are not consulted),
@ -1866,10 +1868,11 @@ void Context::provision ()
SchemeExtension::RunInstall (this, envt); SchemeExtension::RunInstall (this, envt);
} }
void Context::bind_subr (const char * name, subr_f subr) { void Context::bind_subr (const char * name, subr_f subr)
{
psymbol s = intern (name); psymbol s = intern (name);
set_var (envt, s, make_subr (subr, name)); set_var (envt, s, make_subr (subr, name));
} }
cellvector* SchemeExtension::extensions = 0; cellvector* SchemeExtension::extensions = 0;
SchemeExtension* SchemeExtension::main = 0; SchemeExtension* SchemeExtension::main = 0;

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() { void OS::exception (const char * s) {
if (jmpbuf_set) longjmp (jb, 1); if (jmpbuf_set) longjmp (jb, reinterpret_cast <int> (s));
fputs(errbuf, stderr); fputs(s, stderr);
fputs("\n", stderr); fputs("\n", stderr);
exit(1); exit(1);
} }
@ -98,6 +98,7 @@ 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();
@ -125,11 +126,11 @@ int main (int argc, char **argv) {
// Interact // Interact
while (1) { while (1) {
if (setjmp (jb) == 0) { if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0) {
jmpbuf_set = true; jmpbuf_set = true;
interact (&ctx); interact (&ctx);
} else { } else {
fprintf (stderr, "caught: %s\n", OS::errbuf); fprintf (stderr, "caught: %s\n", jv);
} }
} }
} }

62
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: return false; default: error ("non-numeric type encountered");
} }
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 ("%" PRIdPTR, insn->cd.i); printf ("%d", 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 ("%" PRIdPTR ",%s", INSN_COUNT (insn), case OP_SUBR: printf ("%d,%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 ("%" PRIdPTR ",%" PRIdPTR, LEXA_ESKIP(insn), LEXA_BSKIP(insn)); printf ("%d,%d", 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;
intptr_t pc; int pc;
int type; int type;
intptr_t start; int 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_i (-1); save (-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 (!((reinterpret_cast<intptr_t>(c))&1)) { if (!(((int)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 ("%" PRIdPTR, (reinterpret_cast<intptr_t>(c))>>1); } else printf ("%d", ((int)c)>>1);
fputc (' ', stdout); fputc (' ', stdout);
} }
printf("\n"); printf("\n");
@ -283,7 +283,7 @@ Cell* Context::execute (Cell* proc, Cell* args) {
switch (opcode) switch (opcode)
{ {
case 0: // consti case 0: // consti
save_i (insn->cd.i); save (insn->cd.i);
break; break;
case 1: // nil case 1: // nil
m_stack.push (nil); m_stack.push (nil);
@ -303,12 +303,12 @@ Cell* Context::execute (Cell* proc, Cell* args) {
// re-push the args, and dispatch to the procedure. // re-push the args, and dispatch to the procedure.
n_args = INSN_COUNT(insn); n_args = INSN_COUNT(insn);
cellvector cv; cellvector cv;
for (unsigned int ix = 0; ix < n_args; ++ix) for (int ix = 0; ix < n_args; ++ix)
cv.push(m_stack.pop()); cv.push(m_stack.pop());
save(r_envt); save(r_envt);
save(r_cproc); save(r_cproc);
save_i(pc+1); save(pc+1);
for (unsigned int ix = 0; ix < n_args; ++ix) for (int ix = 0; ix < n_args; ++ix)
m_stack.push(cv.pop()); m_stack.push(cv.pop());
r_cproc = proc; r_cproc = proc;
goto PROC; goto 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_i (start); restore (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_i (insn->cd.i); save (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_i (pc); restore (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."
intptr_t target = insn->cd.i; int 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!");
intptr_t ix = m_stack.pop()->IntValue(); int 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)) {
intptr_t sum = 0; int 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)) {
intptr_t product = 1; int 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");
intptr_t d = m_stack.pop()->IntValue(); int d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue(); int 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");
intptr_t d = m_stack.pop()->IntValue(); int d = m_stack.pop()->IntValue();
intptr_t n = m_stack.pop()->IntValue(); int 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 {
intptr_t difference = m_stack.get(sz-n_args)->IntValue(); int 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_i(start); restore(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<intptr_t>(insn->operand))); Cell::setcar(a0, make_int(reinterpret_cast<int>(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<intptr_t>(insn->operand); int la = reinterpret_cast<int>(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*)%" PRIdPTR, insn->cd.i); break; case OP_INT: fprintf(output, "0,(void*)%d", 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, "%" PRIdPTR ",", INSN_COUNT(insn)); fprintf(output, "%d,", 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*)%#" PRIxPTR, insn->cd.i); break; case OP_LEXADDR: fprintf(output, "0,(void*)%#x", 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, 1); longjmp (jb, reinterpret_cast <int> (s));
} }
void interact (Context * ctx) void interact (Context * ctx)
@ -191,6 +191,7 @@ 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"
@ -202,7 +203,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 ((reinterpret_cast<intptr_t>(nil)) & 7) if (((int) 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);
@ -227,10 +228,10 @@ extern "C" int scheme (char * a0)
} }
else while (1) else while (1)
{ {
if (setjmp (jb) == 0) if ((jv = reinterpret_cast <const char *> (setjmp (jb))) == 0)
interact (&ctx); interact (&ctx);
else else
fprintf (stderr, "caught: %s\n", OS::errbuf); fprintf (stderr, "caught: %s\n", jv);
} }
} }

111
src/vx-scheme.h
View File

@ -12,9 +12,6 @@
#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
@ -59,16 +56,11 @@ 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(); static void exception (const char *);
// 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);
@ -308,6 +300,8 @@ 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;
@ -421,35 +415,35 @@ public:
// preallocate the string space; freeing this object discards // preallocate the string space; freeing this object discards
// both box and string. // both box and string.
struct StringBox { struct StringBox
{
size_t length; size_t length;
char s[1]; char s[1];
}; };
// Value extractors // Value extractors
intptr_t IntValue() const; int IntValue () const;
char CharValue() const; char CharValue () const;
SubrBox* SubrValue() const; SubrBox * SubrValue () const;
char* StringValue() const; char * StringValue () const;
size_t StringLength() const; size_t StringLength () const;
FILE* IportValue() const; FILE * IportValue () const;
FILE* OportValue() const; FILE * OportValue () const;
void* ContValue() const; void * ContValue () const;
cellvector* VectorValue() const; cellvector * VectorValue () const;
cellvector* CProcValue() const; cellvector * CProcValue () const;
Cell* PromiseValue() const; Cell * PromiseValue () const;
Cell* CPromiseValue() const; psymbol SymbolValue () const;
psymbol SymbolValue() const; psymbol BuiltinValue () const;
psymbol BuiltinValue() const; Procedure LambdaValue () const;
Procedure LambdaValue() const; double RealValue () const;
double RealValue() const; const char * name () const;
const char* name() const;
// unsafe accessors: use when you have prior knowledge that the // unsafe accessors: use when you have prior knowledge that the
// cell contains an atom of the proper type. // cell contains an atom of the proper type.
cellvector* unsafe_vector_value() const { cellvector * unsafe_vector_value() const {
return cd.cv; return cd.cv;
} }
@ -595,10 +589,10 @@ public:
private: private:
static inline bool short_atom (const Cell * c) static inline bool short_atom (const Cell * c)
{ return (reinterpret_cast <uintptr_t> (c) & (ATOM|SHORT)) { return (reinterpret_cast <unsigned int> (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 <uintptr_t> (c) & (ATOM|SHORT)) == ATOM; } { return (reinterpret_cast <unsigned int> (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); }
@ -625,23 +619,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 uintptr_t TAGBITS = 3; static const unsigned int TAGBITS = 3;
static const uintptr_t ATOM = 0x1; static const unsigned int ATOM = 0x1;
static const uintptr_t MARK = 0x2; static const unsigned int MARK = 0x2;
static const uintptr_t SHORT = 0x4; static const unsigned int SHORT = 0x4;
static const uintptr_t TYPEBITS = 5; static const unsigned int TYPEBITS = 5;
static const uintptr_t TYPEMASK = (1 << TYPEBITS) - 1; static const unsigned int TYPEMASK = (1 << TYPEBITS) - 1;
static const uintptr_t TAGMASK = (1 << TAGBITS) - 1; static const unsigned int 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 uintptr_t FLAGBASE = 1 << (TYPEBITS + TAGBITS); static const unsigned int FLAGBASE = 1 << (TYPEBITS + TAGBITS);
static const uintptr_t FORCED = FLAGBASE; static const unsigned int FORCED = FLAGBASE;
static const uintptr_t QUICK = FLAGBASE << 1; static const unsigned int QUICK = FLAGBASE << 1;
static const uintptr_t GLOBAL = FLAGBASE << 2; static const unsigned int GLOBAL = FLAGBASE << 2;
static const uintptr_t MACRO = FLAGBASE << 3; static const unsigned int MACRO = FLAGBASE << 3;
static const uintptr_t VREF = FLAGBASE << 4; static const unsigned int VREF = FLAGBASE << 4;
static const uintptr_t FREE = FLAGBASE << 5; static const unsigned int FREE = FLAGBASE << 5;
static const uintptr_t FLAGBITS = 6; static const unsigned int FLAGBITS = 6;
static const int GLOBAL_ENV = -1; static const int GLOBAL_ENV = -1;
@ -653,26 +647,26 @@ public:
#error too many atom bits used #error too many atom bits used
#endif #endif
inline intptr_t e_skip () { inline int 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 intptr_t b_skip () { inline int 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 (intptr_t e_skip, intptr_t b_skip) { void set_lexaddr (int e_skip, int 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 intptr_t start_bit = 8*(sizeof(ca.i)-2); const int start_bit = 8*(sizeof(ca.i)-2);
const intptr_t two_bytes = (1 << 16) - 1; const int 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;
@ -716,12 +710,12 @@ public:
union _car union _car
{ {
uintptr_t i; unsigned int i;
Cell * p; Cell * p;
} ca; } ca;
union _cdr union _cdr
{ {
uintptr_t i; unsigned int i;
double * d; double * d;
Cell * p; Cell * p;
const char * u; const char * u;
@ -877,7 +871,7 @@ class Context
// Manufacture Cells and Atoms // Manufacture Cells and Atoms
Cell * make (); Cell * make ();
Cell * make_int (intptr_t i); Cell * make_int (int 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);
@ -958,6 +952,7 @@ class Context
Cell* RunMain(); Cell* RunMain();
private: private:
Cell * alloc (Cell::Type t); Cell * alloc (Cell::Type t);
@ -982,14 +977,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_i (intptr_t i) void save (int 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_i (intptr_t & i) void restore (int & i)
{ i = (reinterpret_cast <intptr_t> (m_stack.pop ()) & { i = (reinterpret_cast <int> (m_stack.pop ()) &
static_cast<intptr_t>(~Cell::ATOM)) >> 1; } static_cast<int>(~Cell::ATOM)) >> 1; }
// =========================== // ===========================
// REGISTER MACHINE // REGISTER MACHINE
@ -1007,7 +1002,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
intptr_t r_cont; // current continuation int 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

2
testcases/c-good/r4rstest.good
View File

@ -744,7 +744,7 @@ SECTION(6 9)
(delay (3 3)) ==> (3 3) (delay (3 3)) ==> (3 3)
(delay 2) ==> 2 (delay 2) ==> 2
(#<subr force> #<compiled-promise>) ==> 6 (#<subr force> #<compiled-promise>) ==> 6
(#<subr force> 6) ==> 6 (#<subr force> #<forced-compiled-promise>) ==> 6
(force 3) ==> 3 (force 3) ==> 3
errors were: errors were:

3
testcases/vx-test.scm
View File

@ -52,7 +52,8 @@
(display (cdr result)) (display (cdr result))
(display " ") (display " ")
(set! total-time (+ total-time (cdr result)))) (set! total-time (+ total-time (cdr result))))
(display "FAIL: ")) (else
(display "FAIL: ")))
(display testcase) (display testcase)
(newline))) (newline)))
testcases) testcases)