From: Stephen Adams Date: Fri, 26 Jul 1996 23:39:26 +0000 (+0000) Subject: Fixed logic bug with +0 and +1 arity encodings. X-Git-Tag: 20090517-FFI~5421 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6a61b5f4c2c33caacda92bf6ce9608d1e394737d;p=mit-scheme.git Fixed logic bug with +0 and +1 arity encodings. Added a missing else to a case expression. --- diff --git a/v8/src/runtime/coerce.scm b/v8/src/runtime/coerce.scm index 7cd953f31..bcdb67df1 100644 --- a/v8/src/runtime/coerce.scm +++ b/v8/src/runtime/coerce.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: coerce.scm,v 1.4 1996/07/26 19:57:38 adams Exp $ +$Id: coerce.scm,v 1.5 1996/07/26 23:39:26 adams Exp $ Copyright (c) 1996 Massachusetts Institute of Technology @@ -68,8 +68,8 @@ MIT in each case. |# (define-integrable (entity-extra entity) (system-pair-cdr entity)) - (define-integrable (entity-procedure entity) - (system-pair-car entity)) + ;;(define-integrable (entity-procedure entity) + ;; (system-pair-car entity)) (define (try-arity-dispatched-procedure) (cond ((and (fix:> (vector-length (entity-extra object)) arity) @@ -90,87 +90,81 @@ MIT in each case. |# (else (default)))) - (define (mismatch) - (default)) - (define (make-compiled-coercion procedure arity min max) ;; Note that min and max are +1-encoded, arity is not. (define-macro (coerce args . exprs) - `(NAMED-LAMBDA (PROCEDURE-COERCION ,@args) + `(NAMED-LAMBDA (COERCED-PROCEDURE ,@args) (JUMP ,(+ (length exprs) 1) PROCEDURE ,@exprs))) - (cond - ((fix:= min max) - (mismatch)) - ((fix:<= arity min) - (mismatch)) - (else - (case arity - ((0) ; min = 1 - (case max - ((2) (coerce () xx)) - ((3) (coerce () xx xx)) - ((4) (coerce () xx xx xx)) - ((5) (coerce () xx xx xx xx)) - ((254) (coerce () '())) - ((253) (coerce () xx '())) - ((252) (coerce () xx xx '())) - ((251) (coerce () xx xx xx '())) - ((250) (coerce () xx xx xx xx '())) - (else (default)))) - ((1) ; min <= 2 - (case max - ((3) (coerce (a1) a1 xx)) - ((4) (coerce (a1) a1 xx xx)) - ((5) (coerce (a1) a1 xx xx xx)) - ((254) (coerce (a1) (list a1))) - ((253) (coerce (a1) a1 '())) - ((252) (coerce (a1) a1 xx '())) - ((251) (coerce (a1) a1 xx xx '())) - ((250) (coerce (a1) a1 xx xx xx '())) - (else (default)))) - ((2) ; min <= 3 - (case max - ((4) (coerce (a1 a2) a1 a2 xx)) - ((5) (coerce (a1 a2) a1 a2 xx xx)) - ((254) (coerce (a1 a2) (list a1 a2))) - ((253) (coerce (a1 a2) a1 (list a2))) - ((252) (coerce (a1 a2) a1 a2 '())) - ((251) (coerce (a1 a2) a1 a2 xx '())) - ((250) (coerce (a1 a2) a1 a2 xx xx '())) - (else (default)))) - ((3) ; min <= 4 - (case max - ((5) (coerce (a1 a2 a3) a1 a2 a3 xx)) - ((254) (coerce (a1 a2 a3) (list a1 a2 a3))) - ((253) (coerce (a1 a2 a3) a1 (list a2 a3))) - ((252) (coerce (a1 a2 a3) a1 a2 (list a3))) - ((251) (coerce (a1 a2 a3) a1 a2 a3 '())) - ((250) (coerce (a1 a2 a3) a1 a2 a3 xx '())) - (else (default)))) - ((4) ; min <= 5 - (case max - ((254) (coerce (a1 a2 a3 a4) (list a1 a2 a3 a4))) - ((253) (coerce (a1 a2 a3 a4) a1 (list a2 a3 a4))) - ((252) (coerce (a1 a2 a3 a4) a1 a2 (list a3 a4))) - ((251) (coerce (a1 a2 a3 a4) a1 a2 a3 (list a4))) - ((250) (coerce (a1 a2 a3 a4) a1 a2 a3 a4 '())))) - ((5) ; min <= 6 - (case max - ((254) (coerce (a1 a2 a3 a4 a5) (list a1 a2 a3 a4 a5))) - ((253) (coerce (a1 a2 a3 a4 a5) a1 (list a2 a3 a4 a5))) - ((252) (coerce (a1 a2 a3 a4 a5) a1 a2 (list a3 a4 a5))) - ((251) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 (list a4 a5))) - ((250) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 a4 (list a5))) - (else (default)))) - ((6) ; min <= 7 - (case max - ((254) (coerce (a1 a2 a3 a4 a5 a6) (list a1 a2 a3 a4 a5 a6))) - ((253) (coerce (a1 a2 a3 a4 a5 a6) a1 (list a2 a3 a4 a5 a6))) - ((252) (coerce (a1 a2 a3 a4 a5 a6) a1 a2 (list a3 a4 a5 a6))) - (else (default)))) - (else (default)))))) + (if (fix:< arity (fix:- min 1)) + (default) ; too few args + (case arity + ((0) + (case max + ((2) (coerce () xx)) + ((3) (coerce () xx xx)) + ((4) (coerce () xx xx xx)) + ((5) (coerce () xx xx xx xx)) + ((254) (coerce () '())) + ((253) (coerce () xx '())) + ((252) (coerce () xx xx '())) + ((251) (coerce () xx xx xx '())) + ((250) (coerce () xx xx xx xx '())) + (else (default)))) + ((1) + (case max + ((3) (coerce (a1) a1 xx)) + ((4) (coerce (a1) a1 xx xx)) + ((5) (coerce (a1) a1 xx xx xx)) + ((254) (coerce (a1) (list a1))) + ((253) (coerce (a1) a1 '())) + ((252) (coerce (a1) a1 xx '())) + ((251) (coerce (a1) a1 xx xx '())) + ((250) (coerce (a1) a1 xx xx xx '())) + (else (default)))) + ((2) + (case max + ((4) (coerce (a1 a2) a1 a2 xx)) + ((5) (coerce (a1 a2) a1 a2 xx xx)) + ((254) (coerce (a1 a2) (list a1 a2))) + ((253) (coerce (a1 a2) a1 (list a2))) + ((252) (coerce (a1 a2) a1 a2 '())) + ((251) (coerce (a1 a2) a1 a2 xx '())) + ((250) (coerce (a1 a2) a1 a2 xx xx '())) + (else (default)))) + ((3) + (case max + ((5) (coerce (a1 a2 a3) a1 a2 a3 xx)) + ((254) (coerce (a1 a2 a3) (list a1 a2 a3))) + ((253) (coerce (a1 a2 a3) a1 (list a2 a3))) + ((252) (coerce (a1 a2 a3) a1 a2 (list a3))) + ((251) (coerce (a1 a2 a3) a1 a2 a3 '())) + ((250) (coerce (a1 a2 a3) a1 a2 a3 xx '())) + (else (default)))) + ((4) + (case max + ((254) (coerce (a1 a2 a3 a4) (list a1 a2 a3 a4))) + ((253) (coerce (a1 a2 a3 a4) a1 (list a2 a3 a4))) + ((252) (coerce (a1 a2 a3 a4) a1 a2 (list a3 a4))) + ((251) (coerce (a1 a2 a3 a4) a1 a2 a3 (list a4))) + ((250) (coerce (a1 a2 a3 a4) a1 a2 a3 a4 '())) + (else (default)))) + ((5) + (case max + ((254) (coerce (a1 a2 a3 a4 a5) (list a1 a2 a3 a4 a5))) + ((253) (coerce (a1 a2 a3 a4 a5) a1 (list a2 a3 a4 a5))) + ((252) (coerce (a1 a2 a3 a4 a5) a1 a2 (list a3 a4 a5))) + ((251) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 (list a4 a5))) + ((250) (coerce (a1 a2 a3 a4 a5) a1 a2 a3 a4 (list a5))) + (else (default)))) + ((6) + (case max + ((254) (coerce (a1 a2 a3 a4 a5 a6) (list a1 a2 a3 a4 a5 a6))) + ((253) (coerce (a1 a2 a3 a4 a5 a6) a1 (list a2 a3 a4 a5 a6))) + ((252) (coerce (a1 a2 a3 a4 a5 a6) a1 a2 (list a3 a4 a5 a6))) + (else (default)))) + (else (default))))) (if (fixnum? arity) (if (object-type? (ucode-type compiled-entry) object) @@ -185,16 +179,11 @@ MIT in each case. |# (default)))) -(define (make-primitive-coercion primitive arity) - (cond ((and (eq? primitive (ucode-primitive car)) (eqv? arity 1)) - (named-lambda (car object) - (if (pair? object) - (car object) - (error:wrong-type-argument object "pair" 'CAR)))) - (else - ((ucode-primitive coerce-to-compiled-procedure 2) - primitive arity)))) +;; It is probably a better idea to bind CONS CAR CDR etc to compiled +;; procedures and be done with it. +(define (make-primitive-coercion primitive arity) + ((ucode-primitive coerce-to-compiled-procedure 2) primitive arity)) (define arity-dispatcher-tag