Description: <short summary of the patch>
 TODO: Put a short summary on the line above and replace this paragraph
 with a longer explanation of this change. Complete the meta-information
 with other relevant fields (see below for details). To make it easier, the
 information below has been extracted from the changelog. Adjust it or drop
 it.
 .
 gcl (2.6.7-97) unstable; urgency=low
 .
   * evade __builtin___clear_cache on hppa
   * make-array;make-sequence;replace;coerce
Author: Camm Maguire <camm@debian.org>

---
The information above should follow the Patch Tagging Guidelines, please
checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here
are templates for supplementary fields that you might want to add:

Origin: <vendor|upstream|other>, <url of original patch>
Bug: <url in upstream bugtracker>
Bug-Debian: http://bugs.debian.org/<bugnumber>
Bug-Ubuntu: https://launchpad.net/bugs/<bugnumber>
Forwarded: <no|not-needed|url proving that it has been forwarded>
Reviewed-By: <name and email of someone who approved the patch>
Last-Update: <YYYY-MM-DD>

--- gcl-2.6.7.orig/configure
+++ gcl-2.6.7/configure
@@ -5825,6 +5825,7 @@ fi
 
 case $use in
      sh4*) ;; #FIXME
+     hppa*) ;; #FIXME
      *)
      { $as_echo "$as_me:${as_lineno-$LINENO}: checking __builtin___clear_cache" >&5
 $as_echo_n "checking __builtin___clear_cache... " >&6; }
--- gcl-2.6.7.orig/configure.in
+++ gcl-2.6.7/configure.in
@@ -1055,6 +1055,7 @@ fi
 
 case $use in
      sh4*) ;; #FIXME
+     hppa*) ;; #FIXME
      *) 
      AC_MSG_CHECKING(__builtin___clear_cache)
      		AC_TRY_COMPILE([],
--- gcl-2.6.7.orig/lsp/gcl_seq.lsp
+++ gcl-2.6.7/lsp/gcl_seq.lsp
@@ -32,48 +32,65 @@
 (proclaim '(optimize (safety 2) (space 3)))
 
 
-(defun make-sequence (type size	&key (initial-element nil iesp)
-                                &aux element-type sequence)
-  (setq element-type
-        (cond ((eq type 'list)
-               (return-from make-sequence
-                (if iesp
-                    (make-list size :initial-element initial-element)
-                    (make-list size))))
-              ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
-              ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
-              ((or (eq type 'simple-vector) (eq type 'vector)) t)
-              (t
-               (setq type (normalize-type type))
-               (when (subtypep (car type) 'list)
-		 (if (or (and (eq 'null (car type)) (not (equal size 0)))
-			 (and (eq 'cons (car type)) (equal size 0)))
-		     (specific-error :wrong-type-argument "~S is not of type ~S." 
-				     type (format nil "list (size ~S)" size)))
-                     (return-from make-sequence
-                      (if iesp
-                          (make-list size :initial-element initial-element)
-                          (make-list size))))
-               (unless (or (eq (car type) 'array)
-			   (eq (car type) 'simple-array))
-		 (specific-error :wrong-type-argument "~S is not of type ~S." 
-				 type 'sequence))
-	       (let ((ssize (caddr type)))
-		 (if (listp ssize) (setq ssize (car ssize)))
-		 (if (not (si::fixnump ssize)) (setq ssize size))
-		 (unless (equal ssize size)
-		 (specific-error :wrong-type-argument "~S is not of type ~S." 
-				 type (format nil "~S (size ~S)" type size))))
-               (or (cadr type) t))))
-  (setq element-type (si::best-array-element-type element-type))
-  (setq sequence (si:make-vector element-type size nil nil nil nil nil))
-  (when iesp
-        (do ((i 0 (1+ i))
-             (size size))
-            ((>= i size))
-          (declare (fixnum i size))
-          (setf (elt sequence i) initial-element)))
-  sequence)
+(defun make-sequence (type size &key initial-element
+			   &aux ntype (atp (listp type)) (ctp (if atp (car type) type)) (tp (when atp (cdr type))))
+  (declare (optimize (safety 1)))
+  (let ((res
+	 (case ctp
+	       ((list cons member) (make-list size :initial-element initial-element))
+	       ((vector array) (make-vector (upgraded-array-element-type (car tp)) size nil nil nil 0 nil initial-element))
+	       (otherwise 'none))))
+    (cond ((not (eq res 'none)) (check-type-eval res type) res)
+          ((classp ctp) (make-sequence (class-name ctp) size :initial-element initial-element))
+	  ((let ((tem (get ctp 'deftype-definition)))
+	     (when tem
+	       (setq ntype (apply tem tp))
+	       (not (eq ctp (if (listp ntype) (car ntype) ntype)))))
+	   (make-sequence ntype size :initial-element initial-element))
+	  ((check-type-eval type '(member list vector))))))
+
+;; (defun make-sequence (type size	&key (initial-element nil iesp)
+;;                                 &aux element-type sequence)
+;;   (setq element-type
+;;         (cond ((eq type 'list)
+;;                (return-from make-sequence
+;;                 (if iesp
+;;                     (make-list size :initial-element initial-element)
+;;                     (make-list size))))
+;;               ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
+;;               ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
+;;               ((or (eq type 'simple-vector) (eq type 'vector)) t)
+;;               (t
+;;                (setq type (normalize-type type))
+;;                (when (subtypep (car type) 'list)
+;; 		 (if (or (and (eq 'null (car type)) (not (equal size 0)))
+;; 			 (and (eq 'cons (car type)) (equal size 0)))
+;; 		     (specific-error :wrong-type-argument "~S is not of type ~S." 
+;; 				     type (format nil "list (size ~S)" size)))
+;;                      (return-from make-sequence
+;;                       (if iesp
+;;                           (make-list size :initial-element initial-element)
+;;                           (make-list size))))
+;;                (unless (or (eq (car type) 'array)
+;; 			   (eq (car type) 'simple-array))
+;; 		 (specific-error :wrong-type-argument "~S is not of type ~S." 
+;; 				 type 'sequence))
+;; 	       (let ((ssize (caddr type)))
+;; 		 (if (listp ssize) (setq ssize (car ssize)))
+;; 		 (if (not (si::fixnump ssize)) (setq ssize size))
+;; 		 (unless (equal ssize size)
+;; 		 (specific-error :wrong-type-argument "~S is not of type ~S." 
+;; 				 type (format nil "~S (size ~S)" type size))))
+;;                (or (cadr type) t))))
+;;   (setq element-type (si::best-array-element-type element-type))
+;;   (setq sequence (si:make-vector element-type size nil nil nil nil nil))
+;;   (when iesp
+;;         (do ((i 0 (1+ i))
+;;              (size size))
+;;             ((>= i size))
+;;           (declare (fixnum i size))
+;;           (setf (elt sequence i) initial-element)))
+;;   sequence)
 
 
 (defun concatenate (result-type &rest sequences)
--- gcl-2.6.7.orig/lsp/gcl_arraylib.lsp
+++ gcl-2.6.7/lsp/gcl_arraylib.lsp
@@ -73,48 +73,108 @@
 ;  )
 
 (defun make-array (dimensions
-		   &key (element-type t)
-			(initial-element nil)
-			(initial-contents nil initial-contents-supplied-p)
+		   &key element-type
+			initial-element
+			(initial-contents nil icsp)
 			adjustable fill-pointer
 			displaced-to (displaced-index-offset 0)
-			static)
-  (when (integerp dimensions) (setq dimensions (list dimensions)))
-  (setq element-type (best-array-element-type element-type))
-  (cond ((= (length dimensions) 1)
-	 (let ((x (si:make-vector element-type (car dimensions)
-	                          adjustable fill-pointer
-	                          displaced-to displaced-index-offset
-	                          static initial-element)))
-	   (when initial-contents-supplied-p
-		 (do ((n (car dimensions))
-		      (i 0 (1+ i)))
-		     ((>= i n))
-		   (declare (fixnum n i))
-		   (si:aset x i (elt initial-contents i))))
-	   x))
-        (t
-	 (let ((x
-		(make-array1
-		       (the fixnum(get-aelttype element-type))
-			static initial-element 
-		       displaced-to (the fixnum displaced-index-offset)
-		       dimensions)))
-	   (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
-           (unless (member 0 dimensions)
-	   (when initial-contents-supplied-p
-		 (do ((cursor
-		       (make-list (length dimensions)
-		                  :initial-element 0)))
-		     (nil)
-		     (declare (:dynamic-extent cursor))
-		   (aset-by-cursor x
-			           (sequence-cursor initial-contents
-			                            cursor)
-				   cursor)
-		   (when (increment-cursor cursor dimensions)
-                          (return nil)))))
-            x))))
+			static
+		   &aux
+			(dimensions (if (and (listp dimensions) (not (cdr dimensions))) (car dimensions) dimensions))
+			(element-type (upgraded-array-element-type element-type)))
+  (declare (optimize (safety 1)))
+  (check-type fill-pointer (or boolean integer))
+  (check-type displaced-to (or null array))
+  (check-type displaced-index-offset integer)
+  (etypecase 
+   dimensions
+   (list
+    (let ((dimensions (dolist (d dimensions dimensions) (check-type d integer)))
+	  (x (make-array1 (get-aelttype element-type) static initial-element displaced-to displaced-index-offset dimensions)))
+      (assert (not fill-pointer))
+      (unless (member 0 dimensions)
+	(when icsp
+	  (do ((j nil t)(cursor (make-list (length dimensions) :initial-element 0)))
+	      ((when j (increment-cursor cursor dimensions)))
+	      (declare (:dynamic-extent cursor))
+	      (aset-by-cursor x (sequence-cursor initial-contents cursor) cursor))))
+      x))
+    (integer
+     (let ((x (make-vector element-type dimensions adjustable (when fill-pointer dimensions)
+			   displaced-to displaced-index-offset static initial-element)))
+       (when icsp (replace x initial-contents))
+       (when (and fill-pointer (not (eq t fill-pointer))) (setf (fill-pointer x) fill-pointer))
+       x))))
+
+;; (defun make-array (dimensions
+;; 		   &key (element-type t)
+;; 			initial-element
+;; 			(initial-contents nil initial-contents-supplied-p)
+;; 			adjustable fill-pointer
+;; 			displaced-to (displaced-index-offset 0)
+;; 			static)
+;;   (when (integerp dimensions) (setq dimensions (list dimensions)))
+;;   (setq element-type (or (upgraded-array-element-type element-type) 'character))
+;;   (if (= (length dimensions) 1)
+;;       (let ((x (si:make-vector element-type (car dimensions) adjustable (when fill-pointer (car dimensions))
+;; 			       displaced-to displaced-index-offset static initial-element)))
+;; 	(when initial-contents-supplied-p
+;; 	  (replace x initial-contents))
+;; 	(when (and fill-pointer (not (eq t fill-pointer))) (setf (fill-pointer x) fill-pointer))
+;; 	x)
+;;     (let ((x (make-array1 (get-aelttype element-type) static initial-element displaced-to displaced-index-offset dimensions)))
+;;       (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
+;;       (unless (member 0 dimensions)
+;; 	(when initial-contents-supplied-p
+;; 	  (do ((j nil t)(cursor (make-list (length dimensions) :initial-element 0)))
+;; 	      ((when j (increment-cursor cursor dimensions)))
+;; 	      (declare (:dynamic-extent cursor))
+;; 	      (aset-by-cursor x (sequence-cursor initial-contents cursor) cursor))))
+;;       x)))
+
+;; (defun make-array (dimensions
+;; 		   &key (element-type t)
+;; 			(initial-element nil)
+;; 			(initial-contents nil initial-contents-supplied-p)
+;; 			adjustable fill-pointer
+;; 			displaced-to (displaced-index-offset 0)
+;; 			static)
+;;   (when (integerp dimensions) (setq dimensions (list dimensions)))
+;;   (setq element-type (best-array-element-type element-type))
+;;   (cond ((= (length dimensions) 1)
+;; 	 (let ((x (si:make-vector element-type (car dimensions)
+;; 	                          adjustable fill-pointer
+;; 	                          displaced-to displaced-index-offset
+;; 	                          static initial-element)))
+;; 	   (when initial-contents-supplied-p
+;; 		 (do ((n (car dimensions))
+;; 		      (i 0 (1+ i)))
+;; 		     ((>= i n))
+;; 		   (declare (fixnum n i))
+;; 		   (si:aset x i (elt initial-contents i))))
+;; 	   x))
+;;         (t
+;; 	 (let ((x
+;; 		(make-array1
+;; 		       (the fixnum(get-aelttype element-type))
+;; 			static initial-element 
+;; 		       displaced-to (the fixnum displaced-index-offset)
+;; 		       dimensions)))
+;; 	   (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
+;;            (unless (member 0 dimensions)
+;; 	   (when initial-contents-supplied-p
+;; 		 (do ((cursor
+;; 		       (make-list (length dimensions)
+;; 		                  :initial-element 0)))
+;; 		     (nil)
+;; 		     (declare (:dynamic-extent cursor))
+;; 		   (aset-by-cursor x
+;; 			           (sequence-cursor initial-contents
+;; 			                            cursor)
+;; 				   cursor)
+;; 		   (when (increment-cursor cursor dimensions)
+;;                           (return nil)))))
+;;             x))))
 
 
 (defun increment-cursor (cursor dimensions)
--- gcl-2.6.7.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.7/lsp/gcl_predlib.lsp
@@ -715,41 +715,73 @@
 	   (match-dimensions (cdr dim) (cdr pat)))))
 
 
+(defmacro check-type-eval (place type)
+  `(values (assert (typep ,place ,type) (,place) 'type-error :datum ,place :expected-type ,type)))
 
-;;; COERCE function.
-(defun coerce (object type)
+(deftype simple-array (&optional (et '*) (dims '*))  `(array ,et ,(if (not dims) 0 dims)))
+(deftype null nil `(member nil))
+(deftype single-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
+(deftype double-float (&optional (low '*) (high '*)) `(long-float ,low ,high))
+
+(defun coerce (object type &aux ntype (atp (listp type)) (ctp (if atp (car type) type)) (tp (when atp (cdr type))))
+  (declare (optimize (safety 2)))
+  (check-type type (or symbol class structure cons))
   (when (typep object type)
-        ;; Just return as it is.
-        (return-from coerce object))
-  (when (classp type)
-    (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S~%" object type))
-  (setq type (normalize-type type))
-  (case (car type)
-    (list
-     (do ((l nil (cons (elt object i) l))
-          (i (1- (length object)) (1- i)))
-         ((< i 0) l)))
-    ((array simple-array)
-     (unless (or (endp (cdr type))
-                 (endp (cddr type))
-                 (eq (caddr type) '*)
-                 (endp (cdr (caddr type))))
-             (error "Cannot coerce to an multi-dimensional array."))
-     (do ((seq (make-sequence type (length object)))
-          (i 0 (1+ i))
-          (l (length object)))
-         ((>= i l) seq)
-       (setf (elt seq i) (elt object i))))
-    (character (character object))
-    (float (float object))
-    ((short-float) (float object 0.0S0))
-    ((single-float double-float long-float) (float object 0.0L0))
-    (complex
-     (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
-         (complex (realpart object) (imagpart object))
-         (complex (coerce (realpart object) (cadr type))
-                  (coerce (imagpart object) (cadr type)))))
-    (t (error "Cannot coerce ~S to ~S." object type))))
+    (return-from coerce object))
+  (case ctp
+	(function (values (eval `(function ,object))));FIXME
+	((list cons vector array member) (replace (make-sequence type (length object)) object))
+	(character (character object))
+	(short-float (float object 0.0S0))
+	(long-float (float object 0.0L0))
+	(float (float object))
+	(complex
+	 (let ((rtp (or (car tp) t)))
+	   (complex (coerce (realpart object) rtp) (coerce (imagpart object) rtp))))
+	(otherwise 
+	 (cond ((classp ctp) (coerce object (class-name ctp)))
+	       ((let ((tem (get ctp 'deftype-definition)))
+		  (when tem
+		    (setq ntype (apply tem tp))
+		    (not (eq ctp (if (listp ntype) (car ntype) ntype)))))
+		(coerce object ntype))
+	       ((check-type-eval object type))))))
+
+
+;; ;;; COERCE function.
+;; (defun coerce (object type)
+;;   (when (typep object type)
+;;         ;; Just return as it is.
+;;         (return-from coerce object))
+;;   (when (classp type)
+;;     (specific-error :wrong-type-argument "Cannot coerce ~S to class ~S~%" object type))
+;;   (setq type (normalize-type type))
+;;   (case (car type)
+;;     (list
+;;      (do ((l nil (cons (elt object i) l))
+;;           (i (1- (length object)) (1- i)))
+;;          ((< i 0) l)))
+;;     ((array simple-array)
+;;      (unless (or (endp (cdr type))
+;;                  (endp (cddr type))
+;;                  (eq (caddr type) '*)
+;;                  (endp (cdr (caddr type))))
+;;              (error "Cannot coerce to an multi-dimensional array."))
+;;      (do ((seq (make-sequence type (length object)))
+;;           (i 0 (1+ i))
+;;           (l (length object)))
+;;          ((>= i l) seq)
+;;        (setf (elt seq i) (elt object i))))
+;;     (character (character object))
+;;     (float (float object))
+;;     ((short-float) (float object 0.0S0))
+;;     ((single-float double-float long-float) (float object 0.0L0))
+;;     (complex
+;;      (if (or (null (cdr type)) (null (cadr type)) (eq (cadr type) '*))
+;;          (complex (realpart object) (imagpart object))
+;;          (complex (coerce (realpart object) (cadr type))
+;;                   (coerce (imagpart object) (cadr type)))))
+;;     (t (error "Cannot coerce ~S to ~S." object type))))
 
 ;; set by unixport/init_kcl.lsp
 ;; warn if a file was comopiled in another version
--- gcl-2.6.7.orig/lsp/gcl_seqlib.lsp
+++ gcl-2.6.7/lsp/gcl_seqlib.lsp
@@ -148,34 +148,54 @@
 		     (declare (fixnum i))
 		     (setf (elt sequence i) item))))
 
+(deftype seqind nil `(integer 0 ,array-dimension-limit))
+(defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3)
+  (declare (optimize (safety 1))(notinline make-list)(:dynamic-extent s3))
+  (check-type s1 sequence)
+  (check-type s2 sequence)
+  (check-type start1 seqind)
+  (check-type start2 seqind)
+  (check-type end1 (or null seqind))
+  (check-type end2 (or null seqind))
+  (when (and (eq s1 s2) (> start1 start2))
+    (setq s3 (make-list (length s2)) s2 (replace s3 s2)))
+  (let* ((lp1 (listp s1)) (lp2 (listp s2))
+	 (e1 (or end1 (if lp1 array-dimension-limit (length s1))))
+	 (e2 (or end2 (if lp2 array-dimension-limit (length s2)))))
+    (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2))
+	 (s1 (if lp1 (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1))
+	 (s2 (if lp2 (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2)))
+	((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1)
+	(let ((e2 (if lp2 (car s2) (aref s2 i2))))
+	  (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2))))))
 
-(defun replace (sequence1 sequence2
-	        &key start1  end1
-		     start2 end2 )
-  (with-start-end start1 end1 sequence1
-     (with-start-end start2 end2 sequence2		  
-    (if (and (eq sequence1 sequence2)
-             (> start1 start2))
-        (do* ((i 0 (f+ 1 i))
-              (l (if (<  (f- end1 start1)
-                         (f- end2 start2))
-                      (f- end1 start1)
-                      (f- end2 start2)))
-              (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
-              (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
-            ((>= i l) sequence1)
-          (declare (fixnum i l s1 s2))
-          (setf (elt sequence1 s1) (elt sequence2 s2)))
-        (do ((i 0 (f+ 1 i))
-             (l (if (<  (f- end1 start1)
-                        (f- end2 start2))
-                    (f- end1 start1)
-                    (f- end2 start2)))
-             (s1 start1 (f+ 1 s1))
-             (s2 start2 (f+ 1 s2)))
-            ((>= i l) sequence1)
-          (declare (fixnum i l s1 s2))
-          (setf (elt sequence1 s1) (elt sequence2 s2)))))))
+;; (defun replace (sequence1 sequence2
+;; 	        &key start1  end1
+;; 		     start2 end2 )
+;;   (with-start-end start1 end1 sequence1
+;;      (with-start-end start2 end2 sequence2		  
+;;     (if (and (eq sequence1 sequence2)
+;;              (> start1 start2))
+;;         (do* ((i 0 (f+ 1 i))
+;;               (l (if (<  (f- end1 start1)
+;;                          (f- end2 start2))
+;;                       (f- end1 start1)
+;;                       (f- end2 start2)))
+;;               (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
+;;               (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
+;;             ((>= i l) sequence1)
+;;           (declare (fixnum i l s1 s2))
+;;           (setf (elt sequence1 s1) (elt sequence2 s2)))
+;;         (do ((i 0 (f+ 1 i))
+;;              (l (if (<  (f- end1 start1)
+;;                         (f- end2 start2))
+;;                     (f- end1 start1)
+;;                     (f- end2 start2)))
+;;              (s1 start1 (f+ 1 s1))
+;;              (s2 start2 (f+ 1 s2)))
+;;             ((>= i l) sequence1)
+;;           (declare (fixnum i l s1 s2))
+;;           (setf (elt sequence1 s1) (elt sequence2 s2)))))))
 
 
 ;;; DEFSEQ macro.
