From e70961b8cf5153a91b3f884523dadfc209ac4db2 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Wed, 30 Apr 2003 11:47:59 +0000
Subject: [PATCH] Allow structures to have :TYPE (VECTOR BIT), (VECTOR
 CHARACTER), etc, and make use of that sequence type instead of the general
 one (VECTOR T).

---
 src/CHANGELOG         |  9 +++++++++
 src/c/structure.d     |  2 ++
 src/cmp/sysfun.lsp    |  3 ++-
 src/lsp/defstruct.lsp | 17 +++++++++++------
 src/lsp/seq.lsp       |  1 -
 5 files changed, 24 insertions(+), 8 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index 2362e6029..ed507bac6 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -1414,6 +1414,15 @@ ECLS 0.9
   - In destructuring lambda lists, &WHOLE may be accompanied by a
     destructuring form.
 
+  - In DEF{CLASS,CONDITION}, arguments to the :INITFORM option, or to
+    the :DEFAULT-INITARGS option, are now properly evaluated in the
+    lexical environment corresponding to the DEF{CLASS,CONDITION} form.
+
+  - Structures may now have :TYPE (VECTOR BIT), (VECTOR CHARACTER),
+    etc. That sequence type is used, rather than the general one
+    (VECTOR T). (:TYPE option from slots is not used, though).
+
+
 TODO:
 =====
 
diff --git a/src/c/structure.d b/src/c/structure.d
index aae366c04..7e08887e9 100644
--- a/src/c/structure.d
+++ b/src/c/structure.d
@@ -119,6 +119,8 @@ cl_copy_structure(cl_object s)
 		s = ecl_copy_structure(s);
 		break;
 	case t_cons:
+	case t_string:
+	case t_bitvector:
 	case t_vector:
 		s = cl_copy_seq(s);
 		break;
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index c3c148653..99bcf1ef4 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -1086,4 +1086,5 @@ type_of(#0)==t_bitvector"))
 	    count count-if count-if-not substitute substitute-if substitute-if-not
 	    nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not
 	    position position-if position-if-not remove-duplicates
-	    delete-duplicates mismatch search sort stable-sort merge))
+	    delete-duplicates mismatch search sort stable-sort merge
+	    si::closest-vector-type))
diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp
index c2189ee1b..4a07f7f6a 100644
--- a/src/lsp/defstruct.lsp
+++ b/src/lsp/defstruct.lsp
@@ -27,9 +27,7 @@
            ;;  the slot is at the offset in the structure-body.
 	   (fset access-function #'(lambda (x)
 				     (sys:structure-ref x name offset))))
-          ((or (eq type 'VECTOR)
-               (and (consp type)
-                    (eq (car type) 'VECTOR)))
+          ((subtypep type 'VECTOR)
 	   ;; If TYPE is VECTOR or (VECTOR ... ), ELT is used.
            (fset access-function
 		 #'(lambda (x) (elt x offset))))
@@ -140,10 +138,14 @@
               (sys:make-structure ',name ,@slot-names)
 	      #+CLOS
 	      (sys:make-structure (find-class ',name) ,@slot-names)))
-          ((or (eq type 'VECTOR)
-               (and (consp type) (eq (car type) 'vector)))
+	  ((subtypep type '(VECTOR T))
+	   `(defun ,constructor ,keys
+	     (vector ,@slot-names)))
+          ((subtypep type 'VECTOR)
            `(defun ,constructor ,keys
-              (vector ,@slot-names)))
+              (make-array ',(list (length slot-names))
+			  :element-type ',(closest-vector-type type)
+	       		  :initial-contents (list ,@slot-names))))
           ((eq type 'LIST)
            `(defun ,constructor ,keys
               (list ,@slot-names)))
@@ -371,6 +373,9 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
     (when (and type initial-offset)
           (setq offset (+ offset initial-offset)))
     (when (and type named)
+	  (unless (or (subtypep '(vector symbol) type)
+		      (subtypep type 'list))
+	    (error "Structure cannot have type ~S and be :NAMED." type))
           (setq name-offset offset)
           (setq offset (1+ offset)))
 
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 148d97076..9b29a8d88 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -30,7 +30,6 @@
 	 :datum NIL))
 
 (defun closest-vector-type (type)
-  (declare (si::c-local))
   (let (elt-type length name args)
     (if (atom type)
 	(setq name type args nil)