From 1c5322a8614d45e9e791e4cdeb701bb39afcee06 Mon Sep 17 00:00:00 2001 From: toy <toy> Date: Tue, 19 Nov 2002 14:41:14 +0000 Subject: [PATCH] MERGE checks the length of the result is compatible for the result type. Based on the version in SBCL. --- code/sort.lisp | 62 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 41 insertions(+), 21 deletions(-) diff --git a/code/sort.lisp b/code/sort.lisp index 88d85dd0d..a7754b58f 100644 --- a/code/sort.lisp +++ b/code/sort.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.9 2002/10/02 17:29:14 toy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sort.lisp,v 1.10 2002/11/19 14:41:14 toy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -425,23 +425,43 @@ (defun merge (result-type sequence1 sequence2 predicate &key key) "The sequences Sequence1 and Sequence2 are destructively merged into a sequence of type Result-Type using the Predicate to order the elements." - (if (or (eq result-type 'list) - (subtypep result-type 'list)) - (let ((result (merge-lists* (coerce sequence1 'list) - (coerce sequence2 'list) - predicate key))) - result) - (let* ((vector-1 (coerce sequence1 'vector)) - (vector-2 (coerce sequence2 'vector)) - (length-1 (length vector-1)) - (length-2 (length vector-2)) - (result (make-sequence result-type (+ length-1 length-2)))) - (declare (vector vector-1 vector-2) - (fixnum length-1 length-2)) - (if (and (simple-vector-p result) - (simple-vector-p vector-1) - (simple-vector-p vector-2)) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key svref) - (merge-vectors vector-1 length-1 vector-2 length-2 - result predicate key aref))))) + (cond ((or (eq result-type 'list) + (subtypep result-type 'list)) + ;; Check the length of result-type and the sequence for + ;; consistency + (let ((s1 (coerce sequence1 'list)) + (s2 (coerce sequence2 'list)) + (type (specifier-type result-type))) + (cond ((type= type (specifier-type 'list)) + (values (merge-lists* s1 s2 predicate key))) + ((eq type *empty-type*) + (bad-sequence-type-error nil)) + ((type= type (specifier-type 'null)) + (if (and (null s1) (null s2)) + nil + (sequence-length-error type + (+ (length s1) (length s2))))) + ((csubtypep (specifier-type '(cons nil t)) type) + (if (and (null s1) (null s2)) + (sequence-length-error type 0) + (values (merge-lists* s1 s2 predicate key)))) + (t + (values (merge-lists* s1 s2 predicate key)))))) + + ((subtypep result-type 'vector) + (let* ((vector-1 (coerce sequence1 'vector)) + (vector-2 (coerce sequence2 'vector)) + (length-1 (length vector-1)) + (length-2 (length vector-2)) + (result (make-sequence result-type (+ length-1 length-2)))) + (declare (vector vector-1 vector-2) + (fixnum length-1 length-2)) + (if (and (simple-vector-p result) + (simple-vector-p vector-1) + (simple-vector-p vector-2)) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key svref) + (merge-vectors vector-1 length-1 vector-2 length-2 + result predicate key aref)))) + (t + (bad-sequence-type-error result-type)))) -- GitLab