From 420e9ec1b3f27f39c142655a8fd091972f8ad5cb Mon Sep 17 00:00:00 2001 From: "colin.smith" Date: Tue, 17 Jun 2008 23:00:34 +0000 Subject: [PATCH] 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 --- src/Makefile | 4 +-- src/cell.cpp | 39 ++++++++++++------------- src/ctx.cpp | 10 +++---- src/interp.cpp | 64 ++++++++++++++++++++--------------------- src/io.cpp | 4 +-- src/subr.cpp | 28 +++++++++--------- src/u-main.cpp | 11 ++++---- src/vm.cpp | 60 +++++++++++++++++++-------------------- src/vx-main.cpp | 9 +++--- src/vx-scheme.h | 75 ++++++++++++++++++++++++++----------------------- 10 files changed, 152 insertions(+), 152 deletions(-) diff --git a/src/Makefile b/src/Makefile index 6bcd611..13c2ab5 100755 --- a/src/Makefile +++ b/src/Makefile @@ -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 diff --git a/src/cell.cpp b/src/cell.cpp index 38ff312..c9abb84 100644 --- a/src/cell.cpp +++ b/src/cell.cpp @@ -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 (this) >> 8; + return reinterpret_cast (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(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(storage)) & 7) start = reinterpret_cast (storage + 4); else start = reinterpret_cast (storage); @@ -783,11 +779,12 @@ TOP: // -inline Cell * Cell::untagged (Cell * c) - { - return reinterpret_cast - (reinterpret_cast (c) & ~Cell::TAGMASK); - } +inline Cell * Cell::untagged (Cell * c) { + static const uintptr_t not_tagmask = ~Cell::TAGMASK; + + return reinterpret_cast + (reinterpret_cast (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 (P) & Cell::ATOM) + if (reinterpret_cast (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 ((p = m_stack [ix])) & Cell::ATOM) == 0) + if ((reinterpret_cast ((p = m_stack [ix])) & Cell::ATOM) == 0) mark (p); // Mark the I/O ports referenced in this environment stack. diff --git a/src/ctx.cpp b/src/ctx.cpp index 7a50516..a5dd41c 100644 --- a/src/ctx.cpp +++ b/src/ctx.cpp @@ -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) diff --git a/src/interp.cpp b/src/interp.cpp index 19b1d70..8f22de3 100644 --- a/src/interp.cpp +++ b/src/interp.cpp @@ -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: diff --git a/src/io.cpp b/src/io.cpp index 7969489..475b6ee 100644 --- a/src/io.cpp +++ b/src/io.cpp @@ -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; } diff --git a/src/subr.cpp b/src/subr.cpp index a307430..97d2dcd 100644 --- a/src/subr.cpp +++ b/src/subr.cpp @@ -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::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::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(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(a->RealValue ())); } // Round to nearest int... which would be easy except that the Scheme diff --git a/src/u-main.cpp b/src/u-main.cpp index fb8ae38..a6bc761 100644 --- a/src/u-main.cpp +++ b/src/u-main.cpp @@ -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 (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 (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); } } } diff --git a/src/vm.cpp b/src/vm.cpp index 14f0f0e..b38d671 100644 --- a/src/vm.cpp +++ b/src/vm.cpp @@ -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(c))&1)) { if (c == root_envt) printf("# "); else c->write (stdout); - } else printf ("%d", ((int)c)>>1); + } else printf ("%" PRIdPTR, (reinterpret_cast(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(insn->operand))); + Cell::setcar(a0, make_int(reinterpret_cast(insn->operand))); break; case OP_SYMBOL: Cell::setcar(a0, @@ -903,7 +903,7 @@ Cell* Context::load_instructions(vm_cproc* cp) { intern(static_cast(insn->operand)))); break; case OP_LEXADDR: { - int la = reinterpret_cast(insn->operand); + int la = reinterpret_cast(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"); diff --git a/src/vx-main.cpp b/src/vx-main.cpp index a593f7e..c937670 100644 --- a/src/vx-main.cpp +++ b/src/vx-main.cpp @@ -173,7 +173,7 @@ Cell * vx_invoke (Context * ctx, Cell * arglist) void OS::exception (const char * s) { - longjmp (jb, reinterpret_cast (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(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 (setjmp (jb))) == 0) + if (setjmp (jb) == 0) interact (&ctx); else - fprintf (stderr, "caught: %s\n", jv); + fprintf (stderr, "caught: %s\n", OS::errbuf); } } diff --git a/src/vx-scheme.h b/src/vx-scheme.h index 850b95f..8cc1af5 100644 --- a/src/vx-scheme.h +++ b/src/vx-scheme.h @@ -12,6 +12,9 @@ #include #include #include +#define __STDC_FORMAT_MACROS +#include + #ifndef WIN32 #include #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 (c) & (ATOM|SHORT)) + { return (reinterpret_cast (c) & (ATOM|SHORT)) == (ATOM|SHORT); } static inline bool long_atom (const Cell* c) - { return (reinterpret_cast (c) & (ATOM|SHORT)) == ATOM; } + { return (reinterpret_cast (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 ((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 (m_stack.pop ()) & - static_cast(~Cell::ATOM)) >> 1; } + void restore_i (intptr_t & i) + { i = (reinterpret_cast (m_stack.pop ()) & + static_cast(~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