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-98) unstable; urgency=low
 .
   * restore traditional make-sequence,make-array, and coerce, and
     optimize replace, as 2.6.8 compiler is still too weak re: inlines
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/lsp/sys-proclaim.lisp
+++ gcl-2.6.7/lsp/sys-proclaim.lisp
@@ -17,7 +17,7 @@
 (PROCLAIM '(FTYPE (FUNCTION (FIXNUM) FIXNUM) DBL-WHAT-FRAME)) 
 (PROCLAIM '(FTYPE (FUNCTION (STRING FIXNUM) FIXNUM) ATOI)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T *) *) SUBTYPEP TYPEP LISP::PARSE-BODY
+    '(FTYPE (FUNCTION (T T *) *) SUBTYPEP LISP::PARSE-BODY
             SLOOP::FIND-IN-ORDERED-LIST REDUCE SORT STABLE-SORT)) 
 (PROCLAIM
     '(FTYPE (FUNCTION (T T T) *) LISP::VERIFY-KEYWORDS
@@ -45,7 +45,7 @@
             ANSI-LOOP::LOOP-MAKE-ITERATION-VARIABLE DEFMACRO*
             ANSI-LOOP::LOOP-TRANSLATE)) 
 (PROCLAIM
-    '(FTYPE (FUNCTION (T T *) T) INTERNAL-COUNT-IF-NOT COUNT-IF SUBSETP
+    '(FTYPE (FUNCTION (T T *) T) TYPEP INTERNAL-COUNT-IF-NOT COUNT-IF SUBSETP
             SLOOP::IN-ARRAY-SLOOP-FOR COUNT-IF-NOT UNION DELETE
             DELETE-IF VECTOR-PUSH-EXTEND DELETE-IF-NOT EVERY FILL FIND
             FIND-IF FIND-IF-NOT INTERSECTION SLOOP::PARSE-LOOP-MACRO
--- gcl-2.6.7.orig/lsp/gcl_seq.lsp
+++ gcl-2.6.7/lsp/gcl_seq.lsp
@@ -32,65 +32,48 @@
 (proclaim '(optimize (safety 2) (space 3)))
 
 
-(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 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,109 +73,50 @@
 ;  )
 
 (defun make-array (dimensions
-		   &key element-type
-			initial-element
-			(initial-contents nil icsp)
+		   &key (element-type t)
+			(initial-element nil)
+			(initial-contents nil initial-contents-supplied-p)
 			adjustable fill-pointer
 			displaced-to (displaced-index-offset 0)
-			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))))
-
+			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))
+		      (lic (listp initial-contents) lic)
+		      (ic initial-contents (if lic (cdr ic) ic))
+		      (i 0 (1+ i)))
+		     ((>= i n))
+		   (declare (fixnum n i))
+		   (si:aset x i (if lic (car ic) (aref ic 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)
   (if (null cursor)
--- gcl-2.6.7.orig/lsp/gcl_predlib.lsp
+++ gcl-2.6.7/lsp/gcl_predlib.lsp
@@ -723,65 +723,43 @@
 (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))
+(defun coerce (object type &aux (ot type))
   (when (typep 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))))
+        ;; 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 (aref object i) l))
+          (i (1- (length object)) (1- i)))
+         ((< i 0) l)
+	 (declare (fixnum i))))
+    ((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 ot (length object)))
+          (i 0 (1+ i))
+	  (lo (listp object))
+	  (o object (if lo (cdr o) o))
+          (l (length object)))
+         ((>= i l) seq)
+	 (declare (fixnum i l))
+	 (setf (aref seq i) (if lo (car o) (aref o 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,24 +148,19 @@
 		     (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))
+  (declare (optimize (safety 1))(:dynamic-extent s3))
   (when (and (eq s1 s2) (> start1 start2))
     (setq s3 (make-list (length s2)) s2 (replace s3 s2)))
-  (let* ((lp1 (listp s1)) (lp2 (listp s2))
+  (let* ((lp1 (listp s1)) (lp2 (listp s2))(start1 start1)(start2 start2)
 	 (e1 (or end1 (if lp1 array-dimension-limit (length s1))))
 	 (e2 (or end2 (if lp2 array-dimension-limit (length s2)))))
+    (declare (fixnum start1 start2 e1 e2))
     (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)))
+	 (s1 (if (when lp1 (> start1 0)) (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1))
+	 (s2 (if (when lp2 (> start2 0)) (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2)))
 	((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1)
+	(declare (fixnum i1 i2))
 	(let ((e2 (if lp2 (car s2) (aref s2 i2))))
 	  (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2))))))
 
--- gcl-2.6.7.orig/cmpnew/gcl_cmpopt.lsp
+++ gcl-2.6.7/cmpnew/gcl_cmpopt.lsp
@@ -110,6 +110,8 @@
    (get 'system:aset 'inline-always))
 (push '((t t t) t #.(flags set)"aset1(#0,fix(#1),#2)")
    (get 'system:aset 'inline-unsafe))
+(push '((t fixnum t) t #.(flags set)"aset1(#0,#1,#2)")
+   (get 'system:aset 'inline-unsafe))
 (push '(((array t) fixnum t) t #.(flags set)"(#0)->v.v_self[#1]= (#2)")
    (get 'system:aset 'inline-unsafe))
 (push '(((array string-char) fixnum character) character #.(flags rfa set)"(#0)->ust.ust_self[#1]= (#2)")
@@ -167,6 +169,8 @@
    (get 'system:elt-set 'inline-always))
 (push '((t t t) t #.(flags set)"elt_set(#0,fix(#1),#2)")
    (get 'system:elt-set 'inline-unsafe))
+(push '((t fixnum t) t #.(flags set)"elt_set(#0,#1,#2)")
+   (get 'system:elt-set 'inline-unsafe))
 
 ;;SYSTEM:FILL-POINTER-SET
  (push '((t fixnum) fixnum #.(flags rfa set)"((#0)->st.st_fillp)=(#1)")
@@ -371,12 +375,14 @@
    (get 'append 'inline-always))
 
 ;;AREF
-;;  (push '((t t) t #.(flags ans)"aref1(#0,fixint(#1))")
-;;    (get 'aref 'inline-always))
-;; (push '((t fixnum) t #.(flags ans)"aref1(#0,#1)")
-;;    (get 'aref 'inline-always))
-;; (push '((t t) t #.(flags ans)"aref1(#0,fix(#1))")
-;;    (get 'aref 'inline-unsafe))
+(push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fixint(#1))")
+   (get 'aref 'inline-always))
+(push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)")
+   (get 'aref 'inline-always))
+(push '((t t) t #.(flags ans)"fLrow_major_aref(#0,fix(#1))")
+   (get 'aref 'inline-unsafe))
+(push '((t fixnum) t #.(flags ans)"fLrow_major_aref(#0,#1)")
+   (get 'aref 'inline-unsafe))
 (push '(((array t) fixnum) t #.(flags)"(#0)->v.v_self[#1]")
    (get 'aref 'inline-unsafe))
 (push '(((array string-char) fixnum) character #.(flags rfa)"(#0)->ust.ust_self[#1]")
@@ -698,6 +704,8 @@ type_of(#0)==t_bitvector")
    (get 'elt 'inline-always))
 (push '((t t) t #.(flags ans)"elt(#0,fix(#1))")
    (get 'elt 'inline-unsafe))
+(push '((t fixnum) t #.(flags ans)"elt(#0,#1)")
+   (get 'elt 'inline-unsafe))
 
 ;;ENDP
 ;;Must use endp_prop here as generic lisp code containing (endp 
