diff --git a/src/cell.cpp b/src/cell.cpp index e63e787..38ff312 100644 --- a/src/cell.cpp +++ b/src/cell.cpp @@ -390,11 +390,15 @@ cellvector * Cell::CProcValue () const typecheck(Cproc); return cd.cv; } -Cell * Cell::PromiseValue () const - { - typecheck (Promise); - return cd.cv->get (0); - } +Cell* Cell::PromiseValue () const { + typecheck (Promise); + return cd.cv->get (0); +} + +Cell* Cell::CPromiseValue() const { + typecheck(Cpromise); + return cd.cv->get(0); +} psymbol Cell::BuiltinValue () const { diff --git a/src/io.cpp b/src/io.cpp index 2df7ac8..5a997eb 100644 --- a/src/io.cpp +++ b/src/io.cpp @@ -535,9 +535,10 @@ void Cell::write (sstring& ss) const { ss.append("#"); break; case Cpromise: - ss.append(flag(FORCED) - ? "#" - : "#"); + if (flag(FORCED)) + CPromiseValue()->write(ss); + else + ss.append("#"); break; case Insn: ss.append("#"); diff --git a/src/vm.cpp b/src/vm.cpp index 87e85dc..14f0f0e 100644 --- a/src/vm.cpp +++ b/src/vm.cpp @@ -290,7 +290,7 @@ Cell* Context::execute (Cell* proc, Cell* args) { break; case 2: // subr if (!insn->flag(Cell::QUICK)) { - Cell* subr = find_var(root_envt, insn->cd.y, 0); + Cell* const subr = find_var(root_envt, insn->cd.y, 0); if (!subr) error("missing primitive procedure"); Cell* proc = cdr(subr); type = proc->type(); @@ -303,12 +303,12 @@ Cell* Context::execute (Cell* proc, Cell* args) { // re-push the args, and dispatch to the procedure. n_args = INSN_COUNT(insn); cellvector cv; - for (int ix = 0; ix < n_args; ++ix) + for (unsigned int ix = 0; ix < n_args; ++ix) cv.push(m_stack.pop()); save(r_envt); save(r_cproc); save(pc+1); - for (int ix = 0; ix < n_args; ++ix) + for (unsigned int ix = 0; ix < n_args; ++ix) m_stack.push(cv.pop()); r_cproc = proc; goto PROC; diff --git a/src/vx-scheme.h b/src/vx-scheme.h index 5cf577a..850b95f 100644 --- a/src/vx-scheme.h +++ b/src/vx-scheme.h @@ -415,39 +415,39 @@ public: // preallocate the string space; freeing this object discards // both box and string. - struct StringBox - { - size_t length; - char s[1]; - }; + struct StringBox { + size_t length; + char s[1]; + }; // Value extractors - int IntValue () const; - char CharValue () const; - SubrBox * SubrValue () const; - char * StringValue () const; - size_t StringLength () const; - FILE * IportValue () const; - FILE * OportValue () const; - void * ContValue () const; - cellvector * VectorValue () const; - cellvector * CProcValue () const; - Cell * PromiseValue () const; - psymbol SymbolValue () const; - psymbol BuiltinValue () const; - Procedure LambdaValue () const; - double RealValue () const; - const char * name () const; + int IntValue() const; + char CharValue() const; + SubrBox* SubrValue() const; + char* StringValue() const; + size_t StringLength() const; + FILE* IportValue() const; + FILE* OportValue() const; + void* ContValue() const; + cellvector* VectorValue() const; + cellvector* CProcValue() const; + Cell* PromiseValue() const; + Cell* CPromiseValue() const; + psymbol SymbolValue() const; + psymbol BuiltinValue() const; + Procedure LambdaValue() const; + double RealValue() const; + const char* name() const; // unsafe accessors: use when you have prior knowledge that the // cell contains an atom of the proper type. - cellvector * unsafe_vector_value() const { + cellvector* unsafe_vector_value() const { return cd.cv; } - static void real_to_string (double, char *, int); + static void real_to_string (double, char *, int); double asReal () const { if (type () == Cell::Int) diff --git a/testcases/c-good/r4rstest.good b/testcases/c-good/r4rstest.good index e85ba9e..6d71eff 100644 --- a/testcases/c-good/r4rstest.good +++ b/testcases/c-good/r4rstest.good @@ -744,7 +744,7 @@ SECTION(6 9) (delay (3 3)) ==> (3 3) (delay 2) ==> 2 (# #) ==> 6 -(# #) ==> 6 +(# 6) ==> 6 (force 3) ==> 3 errors were: diff --git a/testcases/vx-test.scm b/testcases/vx-test.scm index ceb51fd..c729dfb 100644 --- a/testcases/vx-test.scm +++ b/testcases/vx-test.scm @@ -52,8 +52,7 @@ (display (cdr result)) (display " ") (set! total-time (+ total-time (cdr result)))) - (else - (display "FAIL: "))) + (display "FAIL: ")) (display testcase) (newline))) testcases)