From f11f2e4297b96fa547c8432e491da17ac1074a27 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Sun, 13 Mar 2016 23:57:10 +0300 Subject: [PATCH] Clean up nested IFs. And other similar stuff. --- src/code/array.lisp | 58 +++++++++++++++++++++++++++----------------------- src/pcl/early-low.lisp | 1 + src/pcl/std-class.lisp | 36 +++++++++++++++---------------- tests/array.pure.lisp | 5 +++++ 4 files changed, 55 insertions(+), 45 deletions(-) diff --git a/src/code/array.lisp b/src/code/array.lisp index b9f880731..b0d15f649 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -1067,11 +1067,12 @@ of specialized arrays is supported." (declare (explicit-check)) (flet ((oops (x) (fill-pointer-error vector x))) - (if (array-has-fill-pointer-p vector) - (if (> new (%array-available-elements vector)) - (oops new) - (setf (%array-fill-pointer vector) new)) - (oops nil)))) + (cond ((not (array-has-fill-pointer-p vector)) + (oops nil)) + ((> new (%array-available-elements vector)) + (oops new)) + (t + (setf (%array-fill-pointer vector) new))))) ;;; FIXME: It'd probably make sense to use a MACROLET to share the ;;; guts of VECTOR-PUSH between VECTOR-PUSH-EXTEND. Such a macro @@ -1168,17 +1169,18 @@ of specialized arrays is supported." (array-data (data-vector-from-inits dimensions array-size element-type nil nil initialize initial-data))) - (if (adjustable-array-p array) - (set-array-header array array-data array-size - (get-new-fill-pointer array array-size - fill-pointer) - 0 dimensions nil nil) - (if (array-header-p array) - ;; simple multidimensional or single dimensional array + (cond ((adjustable-array-p array) + (set-array-header array array-data array-size + (get-new-fill-pointer array array-size + fill-pointer) + 0 dimensions nil nil)) + ((array-header-p array) + ;; simple multidimensional or single dimensional array (make-array dimensions :element-type element-type - :initial-contents initial-contents) - array-data)))) + :initial-contents initial-contents)) + (t + array-data)))) (displaced-to ;; We already established that no INITIAL-CONTENTS was supplied. (unless (or (eql element-type (array-element-type displaced-to)) @@ -1286,7 +1288,8 @@ of specialized arrays is supported." (when (> fill-pointer new-array-size) (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ than the new length of the vector (~S)" - fill-pointer new-array-size))))) + fill-pointer new-array-size)) + fill-pointer))) ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH, ;;; which must be less than or equal to its current length. This can @@ -1426,12 +1429,13 @@ function to be removed without further warning." ;; KLUDGE: Without TRULY-THE the system is not smart enough to figure out that ;; the return value is always of the known type. (truly-the (simple-array * (*)) - (if (array-header-p array) - (if (%array-displaced-p array) - (error "~S cannot be used with displaced arrays. Use ~S instead." - 'array-storage-vector 'array-displacement) - (%array-data-vector array)) - array))) + (cond ((not (array-header-p array)) + array) + ((%array-displaced-p array) + (error "~S cannot be used with displaced arrays. Use ~S instead." + 'array-storage-vector 'array-displacement)) + (t + (%array-data-vector array))))) ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY @@ -1454,12 +1458,12 @@ function to be removed without further warning." ;; INITIAL-ELEMENT-P are used when OLD-DATA and NEW-DATA are ;; EQ; in this case, a temporary must be used and filled ;; appropriately. specified initial-element. - (when initial-element-p - ;; FIXME: transforming this TYPEP to someting a bit faster - ;; would be a win... - (unless (typep initial-element element-type) - (error "~S can't be used to initialize an array of type ~S." - initial-element element-type))) + ;; FIXME: transforming this TYPEP to someting a bit faster + ;; would be a win... + (unless (or (not initial-element-p) + (typep initial-element element-type)) + (error "~S can't be used to initialize an array of type ~S." + initial-element element-type)) (let ((temp (if initial-element-p (make-array new-length :initial-element initial-element) (make-array new-length)))) diff --git a/src/pcl/early-low.lisp b/src/pcl/early-low.lisp index bce205e6a..bf4f74819 100644 --- a/src/pcl/early-low.lisp +++ b/src/pcl/early-low.lisp @@ -91,6 +91,7 @@ *the-class-slot-object* *the-class-structure-object* *the-class-standard-object* + *the-class-function* *the-class-funcallable-standard-object* *the-class-class* *the-class-generic-function* diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 858526120..dc42715c6 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -939,27 +939,27 @@ (not (find-in-superclasses (find-class 'function) (list class)))))))) (defun %update-cpl (class cpl) - (when (eq (class-of class) *the-class-standard-class*) - (when (find (find-class 'function) cpl) - (error 'cpl-protocol-violation :class class :cpl cpl))) - (when (eq (class-of class) *the-class-funcallable-standard-class*) - (unless (find (find-class 'function) cpl) - (error 'cpl-protocol-violation :class class :cpl cpl))) - (if (class-finalized-p class) - (unless (and (equal (class-precedence-list class) cpl) + (when (or (and + (eq (class-of class) *the-class-standard-class*) + (find *the-class-function* cpl)) + (and (eq (class-of class) *the-class-funcallable-standard-class*) + (not (and (find (find-class 'function) cpl))))) + (error 'cpl-protocol-violation :class class :cpl cpl)) + (cond ((not (class-finalized-p class)) + (setf (slot-value class '%class-precedence-list) cpl + (slot-value class 'cpl-available-p) t)) + ((not (and (equal (class-precedence-list class) cpl) (dolist (c cpl t) (when (position :class (class-direct-slots c) :key #'slot-definition-allocation) - (return nil)))) - ;; comment from the old CMU CL sources: - ;; Need to have the cpl setup before %update-lisp-class-layout - ;; is called on CMU CL. - (setf (slot-value class '%class-precedence-list) cpl) - (setf (slot-value class 'cpl-available-p) t) - (%force-cache-flushes class)) - (progn - (setf (slot-value class '%class-precedence-list) cpl) - (setf (slot-value class 'cpl-available-p) t))) + (return nil))))) + + ;; comment from the old CMU CL sources: + ;; Need to have the cpl setup before %update-lisp-class-layout + ;; is called on CMU CL. + (setf (slot-value class '%class-precedence-list) cpl + (slot-value class 'cpl-available-p) t) + (%force-cache-flushes class))) (update-class-can-precede-p cpl)) (defun update-class-can-precede-p (cpl) diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp index 71df8efcf..d3ffe4501 100644 --- a/tests/array.pure.lisp +++ b/tests/array.pure.lisp @@ -392,3 +392,8 @@ `(lambda () (adjust-array #(1 2 3) 3 :displaced-to #(4 5 6))))) #(4 5 6)))) + +(with-test (:name :adjust-array-fill-pointer) + (let ((array (make-array 10 :fill-pointer t))) + (assert (= (fill-pointer (adjust-array array 5 :fill-pointer 2)) + 2)))) -- 2.11.4.GIT