From 5abe4ece14005be5c30adda64e337913a803a6b5 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 22 Nov 1989 16:29:55 +0000 Subject: [PATCH] Fix a bug backing out of apply. The procedure and number of arguments were not being pused on the stack consistently, so there were some paths that could not restart on interrupt, for example. --- v7/src/microcode/cmpint.c | 24 ++++++++++++++++-------- v8/src/microcode/cmpint.c | 24 ++++++++++++++++-------- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 1a8b680a5..f837ade35 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.16 1989/11/21 23:31:05 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.17 1989/11/22 16:29:55 jinx Exp $ * * This file corresponds to * $COMPILER-Header: compiler.c,v 9.37 89/10/25 14:55:45 GMT jinx Exp $ @@ -429,8 +429,6 @@ apply_compiled_procedure() } else { - STACK_PUSH (procedure); - STACK_PUSH (nactuals); return (result); } } @@ -477,11 +475,15 @@ setup_compiled_invocation (nactuals, compiled_entry_address) if (nmin < 0) { /* Not a procedure. */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_INAPPLICABLE_OBJECT); } if (nactuals < nmin) { /* Too few arguments. */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_WRONG_NUMBER_OF_ARGUMENTS); } delta = (nactuals - nmax); @@ -497,12 +499,14 @@ setup_compiled_invocation (nactuals, compiled_entry_address) if (nmax > 0) { /* Too many arguments */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_WRONG_NUMBER_OF_ARGUMENTS); } /* The procedure can take arbitrarily many arguments, ie. it is a lexpr. */ - return (setup_lexpr_invocation (nactuals, nmax)); + return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address)); } /* Default some optional parameters, and return the location @@ -535,8 +539,9 @@ open_gap (nactuals, delta) /* Setup a rest argument as appropriate. */ static long -setup_lexpr_invocation (nactuals, nmax) +setup_lexpr_invocation (nactuals, nmax, entry_address) register long nactuals, nmax; + machine_word *entry_address; { register long delta; @@ -595,6 +600,8 @@ setup_lexpr_invocation (nactuals, nmax) if (GC_Check (list_size)) { Request_GC (list_size); + STACK_PUSH (ENTRY_TO_OBJECT (entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (PRIM_APPLY_INTERRUPT); } gap_location = &Free[list_size]; @@ -749,7 +756,7 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) long arity; - arity = PRIMITIVE_ARITY (procedure); + arity = (PRIMITIVE_ARITY (procedure)); if (arity == (nactuals - 1)) { return (comutil_primitive_apply (procedure, 0, 0, 0)); @@ -759,7 +766,7 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) { /* Wrong number of arguments. */ STACK_PUSH (procedure); - STACK_PUSH (nactuals); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS); } if (!(IMPLEMENTED_PRIMITIVE_P (procedure))) @@ -817,7 +824,8 @@ comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4) RETURN_UNLESS_EXCEPTION ((setup_lexpr_invocation ((nactuals + 1), - (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)))), + (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)), + ((machine_word *) entry_address))), entry_address); } diff --git a/v8/src/microcode/cmpint.c b/v8/src/microcode/cmpint.c index 181a37001..b27332d15 100644 --- a/v8/src/microcode/cmpint.c +++ b/v8/src/microcode/cmpint.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.16 1989/11/21 23:31:05 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.17 1989/11/22 16:29:55 jinx Exp $ * * This file corresponds to * $COMPILER-Header: compiler.c,v 9.37 89/10/25 14:55:45 GMT jinx Exp $ @@ -429,8 +429,6 @@ apply_compiled_procedure() } else { - STACK_PUSH (procedure); - STACK_PUSH (nactuals); return (result); } } @@ -477,11 +475,15 @@ setup_compiled_invocation (nactuals, compiled_entry_address) if (nmin < 0) { /* Not a procedure. */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_INAPPLICABLE_OBJECT); } if (nactuals < nmin) { /* Too few arguments. */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_WRONG_NUMBER_OF_ARGUMENTS); } delta = (nactuals - nmax); @@ -497,12 +499,14 @@ setup_compiled_invocation (nactuals, compiled_entry_address) if (nmax > 0) { /* Too many arguments */ + STACK_PUSH (ENTRY_TO_OBJECT (compiled_entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (ERR_WRONG_NUMBER_OF_ARGUMENTS); } /* The procedure can take arbitrarily many arguments, ie. it is a lexpr. */ - return (setup_lexpr_invocation (nactuals, nmax)); + return (setup_lexpr_invocation (nactuals, nmax, compiled_entry_address)); } /* Default some optional parameters, and return the location @@ -535,8 +539,9 @@ open_gap (nactuals, delta) /* Setup a rest argument as appropriate. */ static long -setup_lexpr_invocation (nactuals, nmax) +setup_lexpr_invocation (nactuals, nmax, entry_address) register long nactuals, nmax; + machine_word *entry_address; { register long delta; @@ -595,6 +600,8 @@ setup_lexpr_invocation (nactuals, nmax) if (GC_Check (list_size)) { Request_GC (list_size); + STACK_PUSH (ENTRY_TO_OBJECT (entry_address)); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); return (PRIM_APPLY_INTERRUPT); } gap_location = &Free[list_size]; @@ -749,7 +756,7 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) long arity; - arity = PRIMITIVE_ARITY (procedure); + arity = (PRIMITIVE_ARITY (procedure)); if (arity == (nactuals - 1)) { return (comutil_primitive_apply (procedure, 0, 0, 0)); @@ -759,7 +766,7 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) { /* Wrong number of arguments. */ STACK_PUSH (procedure); - STACK_PUSH (nactuals); + STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nactuals)); RETURN_TO_C (ERR_WRONG_NUMBER_OF_ARGUMENTS); } if (!(IMPLEMENTED_PRIMITIVE_P (procedure))) @@ -817,7 +824,8 @@ comutil_lexpr_apply (entry_address, nactuals, ignore_3, ignore_4) RETURN_UNLESS_EXCEPTION ((setup_lexpr_invocation ((nactuals + 1), - (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)))), + (COMPILED_ENTRY_MAXIMUM_ARITY (entry_address)), + ((machine_word *) entry_address))), entry_address); } -- 2.25.1