From 789a365f2d49a2d2774797dec5759a6e9c7e0d5a Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 18 Oct 2002 14:06:51 +0000 Subject: [PATCH] 0.7.8.46: Continue maintenance work on LIST-like type specifiers ... fix COERCE and MERGE analogously to MAKE-SEQUENCE ... note, but don't worry too much yet, about circular list arguments to COERCE and MERGE --- src/code/coerce.lisp | 15 ++++++++++++++- src/code/sort.lisp | 29 ++++++++++++++++++++++++----- tests/seq.impure.lisp | 14 +++++++++++++- version.lisp-expr | 2 +- 4 files changed, 52 insertions(+), 8 deletions(-) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index dfd208d..576aba5 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -192,10 +192,23 @@ res)) ((csubtypep type (specifier-type 'list)) (if (vectorp object) - (vector-to-list* object) + (cond ((type= type (specifier-type 'list)) + (vector-to-list* object)) + ((type= type (specifier-type 'null)) + (if (= (length object) 0) + 'nil + (sequence-type-length-mismatch-error type + (length object)))) + ((csubtypep (specifier-type '(cons nil t)) type) + (if (> (length object) 0) + (vector-to-list* object) + (sequence-type-length-mismatch-error type 0))) + (t (sequence-type-too-hairy (type-specifier type)))) (coerce-error))) ((csubtypep type (specifier-type 'vector)) (typecase object + ;; FOO-TO-VECTOR* go through MAKE-SEQUENCE, so length + ;; errors are caught there. -- CSR, 2002-10-18 (list (list-to-vector* object output-type-spec)) (vector (vector-to-vector* object output-type-spec)) (t diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 4b6c02e..78c291d 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -235,7 +235,7 @@ drag)))) ; and return pointer to last element. (cond ((apply-pred (car list-2) (car list-1) pred key) (rplacd p list-2) ; Append the lesser list to last cell of - (setq p (cdr p)) ; result. Note: test must bo done for + (setq p (cdr p)) ; result. Note: test must be done for (pop list-2)) ; LIST-2 < LIST-1 so merge will be (T (rplacd p list-1) ; stable for LIST-1. (setq p (cdr p)) @@ -425,10 +425,29 @@ (let ((type (specifier-type result-type))) (cond ((csubtypep type (specifier-type 'list)) - (let ((result (merge-lists* (coerce sequence1 'list) - (coerce sequence2 'list) - predicate key))) - result)) + ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so + ;; benefits from the error checking there. Short of + ;; reimplementing everything, we can't do the same for the LIST + ;; case, so do relevant length checking here: + (let ((s1 (coerce sequence1 'list)) + (s2 (coerce sequence2 'list))) + (when (type= type (specifier-type 'list)) + (return-from merge (values (merge-lists* s1 s2 predicate key)))) + (when (eq type *empty-type*) + (bad-sequence-type-error nil)) + (when (type= type (specifier-type 'null)) + (if (and (null s1) (null s2)) + (return-from merge 'nil) + ;; FIXME: This will break on circular lists (as, + ;; indeed, will the whole MERGE function). + (sequence-type-length-mismatch-error type + (+ (length s1) + (length s2))))) + (if (csubtypep (specifier-type '(cons nil t)) type) + (if (and (null s1) (null s2)) + (sequence-type-length-mismatch-error type 0) + (values (merge-lists* s1 s2 predicate key))) + (sequence-type-too-hairy result-type)))) ((csubtypep type (specifier-type 'vector)) (let* ((vector-1 (coerce sequence1 'vector)) (vector-2 (coerce sequence2 'vector)) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index 5aea01c..ec6e74f 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -300,7 +300,19 @@ (assert (= (length (make-sequence 'cons 3)) 3)) ;; and NIL is not a valid type for MAKE-SEQUENCE (assert-type-error (make-sequence 'nil 0)) - ;; tests for MAP/MERGE/CONCATENATE/COERCE to come. + ;; COERCE + (assert-type-error (coerce #(1) 'null)) + (assert-type-error (coerce #() 'cons)) + (assert (null (coerce #() 'null))) + (assert (= (length (coerce #(1) 'cons)) 1)) + (assert-type-error (coerce #() 'nil)) + ;; MERGE + (assert-type-error (merge 'null '(1 3) '(2 4) '<)) + (assert-type-error (merge 'cons () () '<)) + (assert (null (merge 'null () () '<))) + (assert (= (length (merge 'cons '(1 3) '(2 4) '<)) 4)) + (assert-type-error (merge 'nil () () '<)) + ;; tests for MAP/CONCATENATE to come. )) diff --git a/version.lisp-expr b/version.lisp-expr index 64b4fcf..5f9e608 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.8.45" +"0.7.8.46" -- 1.7.10.4