diff --git a/src/org/armedbear/lisp/MathFunctions.java b/src/org/armedbear/lisp/MathFunctions.java index ef06c30c..8df27805 100644 --- a/src/org/armedbear/lisp/MathFunctions.java +++ b/src/org/armedbear/lisp/MathFunctions.java @@ -613,7 +613,9 @@ public LispObject execute(LispObject base, LispObject power) return SingleFloat.ONE; } if (base.zerop()) - return base; + // Type contagion: (expt 0 y) must match the result type of + // (* 0 y) so that e.g. (expt 0 2.0f0) => 0.0f0, not 0. + return base.multiplyBy(power); if (base.isEqualTo(1)) return base; diff --git a/src/org/armedbear/lisp/compiler-pass2.lisp b/src/org/armedbear/lisp/compiler-pass2.lisp index 83e487de..5478a54f 100644 --- a/src/org/armedbear/lisp/compiler-pass2.lisp +++ b/src/org/armedbear/lisp/compiler-pass2.lisp @@ -4254,7 +4254,6 @@ given a specific common representation.") (emit-move-from-stack target)))) ((and (consp name) (eq (%car name) 'SETF)) (dformat t "p2-function case 2~%") - ;; FIXME Need to check for NOTINLINE declaration! (cond ((setf local-function (find-local-function name)) (dformat t "p2-function 1~%") @@ -4270,6 +4269,7 @@ given a specific common representation.") (declare-setf-function name) +lisp-object+) (emit-move-from-stack target)) ((and (null *file-compilation*) + (not (notinline-p name)) (fboundp name) (fdefinition name)) (emit-load-externalized-object (fdefinition name)) diff --git a/src/org/armedbear/lisp/make-sequence.lisp b/src/org/armedbear/lisp/make-sequence.lisp index 28e90dec..4be02d3e 100644 --- a/src/org/armedbear/lisp/make-sequence.lisp +++ b/src/org/armedbear/lisp/make-sequence.lisp @@ -38,9 +38,61 @@ :format-control "The requested length (~D) does not match the specified type ~A." :format-arguments (list size type))) +(defun %vector-type-element-type (type) + "Extract the element type from a vector type specifier, or return +:UNKNOWN if the type is not a recognized vector type." + (cond ((atom type) + (case type + ((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'character) + ((BIT-VECTOR SIMPLE-BIT-VECTOR) 'bit) + ((VECTOR SIMPLE-VECTOR) t) + (t :unknown))) + ((consp type) + (case (%car type) + ((STRING SIMPLE-STRING BASE-STRING SIMPLE-BASE-STRING) 'character) + ((BIT-VECTOR SIMPLE-BIT-VECTOR) 'bit) + ((VECTOR SIMPLE-VECTOR) (if (cdr type) (cadr type) t)) + ((ARRAY SIMPLE-ARRAY) (if (cdr type) (cadr type) t)) + (t :unknown))) + (t :unknown))) + (defun make-sequence (type size &key (initial-element nil iesp)) (let (element-type sequence class) (setf type (normalize-type type)) + (when (and (consp type) (eq (%car type) 'or)) + ;; For an OR type, only proceed if all branches share the same + ;; element type. Otherwise the result type is ambiguous and + ;; CLHS permits (and the ANSI suite requires) signaling an + ;; error. + (let ((branches (%cdr type)) + (common-et nil) + (first-p t)) + (dolist (branch branches) + (let ((et (%vector-type-element-type branch))) + (cond ((eq et :unknown) + (setf common-et :unknown) + (return)) + (first-p (setf common-et et first-p nil)) + ((equal common-et et) nil) + (t (setf common-et :conflict) (return))))) + (when (or (eq common-et :unknown) (eq common-et :conflict)) + (error 'simple-type-error + :format-control "~S is not a sequence type." + :format-arguments (list type))) + ;; All branches share a single element type; try each until + ;; one succeeds at the requested size. + (dolist (subtype branches) + (let ((result (handler-case + (if iesp + (make-sequence subtype size + :initial-element initial-element) + (make-sequence subtype size)) + (error () :make-sequence-or-branch-failed)))) + (unless (eq result :make-sequence-or-branch-failed) + (return-from make-sequence result)))) + (error 'simple-type-error + :format-control "~S is not a sequence type." + :format-arguments (list type)))) (cond ((atom type) (setf class (if (classp type) type (find-class type nil))) (when (classp type)