The new-kcl-wrapper modifications make the storage of standard-objects
and structure objects much more similar than before.  These changes should 
greatly speed up WRAPPER-OF for structure objects and should speed up
WRAPPER-OF for standard-instances also (but not funcallable instances).

Look first at the defstructs defined here (scan this file for "(defstruct (").
Then look at cache.lisp, at the "#+structure-wrapper" for the new definition of
the wrapper structure.  Finally, look in low.lisp, at the 
"#+new-structure-wrapper" for the definition of %allocate-instance--class.

You need to have akcl-1-615 to use this file.

This file contains new versions of the files V/c/structure.c and 
V/lsp/defstruct.lsp, as well as small changes to the files c/gbc.c, c/sgbc.c, 
cmpnew/cmpinit.lsp, lsp/cmpinit.lsp, and lsp/describe.lsp.

-- The gbc changes allow the garbage collector to work correctly even when
structures which define other structures (ones which can be the value of 
STRUCTURE-DEF) are not allocated in static storage. 


c/gbc.c
*** c/gbc.c       Tue Jun 30 04:11:00 1992
--- ../akcl-1-615/c/gbc.c Tue Jun 30 02:48:04 1992
***************
*** 427,453 ****
                          break;
                  goto COPY_STRING;
  
          case t_structure:
                  mark_object(x->str.str_def);
                  p = x->str.str_self;
                  if (p == NULL)
!                         break;
!                 {object def=x->str.str_def;
!                  unsigned char * s_type = &SLOT_TYPE(def,0);
!                  unsigned short *s_pos= & SLOT_POS(def,0);
!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
                   if ((int)what_to_collect >= (int)t_contiguous) {
                       if (inheap(x->str.str_self)) {
                         if (what_to_collect == t_contiguous)
                           mark_contblock((char *)p,
!                                         S_DATA(def)->size);
  
                       } else
!                        x->str.str_self = (object *)
!                          copy_relblock((char *)p, S_DATA(def)->size);
                     }}
                  break;
  
          case t_stream:
                  switch (x->sm.sm_mode) {
--- 427,461 ----
                          break;
                  goto COPY_STRING;
  
          case t_structure:
+                 x->d.m = 2; 
                  mark_object(x->str.str_def);
                  p = x->str.str_self;
                  if (p == NULL)
!                         {x->d.m = TRUE; break;}
!                 {object def=x->str.str_def;
!                  struct s_data *sdef=S_DATA(def);
!                  unsigned char *s_type;
!                  unsigned short *s_pos;
!                  if((int)what_to_collect >= (int)t_contiguous &&
!                     !inheap(sdef) && def->d.m==TRUE)
!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
!                  s_type = sdef->raw->ust.ust_self;
!                  s_pos = &USHORT(sdef->slot_position,0);
!                  for (i = 0, j = sdef->length;  i < j;  i++)
                     if (s_type[i]==0) mark_object(STREF(object,x,s_pos[i]));
                   if ((int)what_to_collect >= (int)t_contiguous) {
                       if (inheap(x->str.str_self)) {
                         if (what_to_collect == t_contiguous)
                           mark_contblock((char *)p,
!                                         sdef->size);
  
                       } else
!                         x->str.str_self = (object *)
!                          copy_relblock((char *)p, sdef->size);
                     }}
+                 x->d.m = TRUE; 
                  break;
  
          case t_stream:
                  switch (x->sm.sm_mode) {
*** c/sgbc.c      Mon Jun 15 21:16:01 1992
--- akcl-1-615/c/sgbc.c   Wed Jul  1 18:37:24 1992
***************
*** 355,386 ****
                  if (cp == NULL)
                          break;
                  goto COPY_STRING;
  
          case t_structure:
                  sgc_mark_object(x->str.str_def);
                  p = x->str.str_self;
                  if (p == NULL)
!                         break;
!                 {object def=x->str.str_def;
!                  unsigned char * s_type = &SLOT_TYPE(def,0);
!                  unsigned short *s_pos= & SLOT_POS(def,0);
!                  for (i = 0, j = S_DATA(def)->length;  i < j;  i++)
                     if (s_type[i]==0 &&
                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
                         )
                       sgc_mark_object(STREF(object,x,s_pos[i]));
                   if ((int)what_to_collect >= (int)t_contiguous) {
                       if (inheap(x->str.str_self)) {
                         if (what_to_collect == t_contiguous)
                           mark_contblock((char *)p,
!                                         S_DATA(def)->size);
  
                       } else if(SGC_RELBLOCK_P(p))
                         x->str.str_self = (object *)
!                          copy_relblock((char *)p, S_DATA(def)->size);
                     }}
                  break;
  
          case t_stream:
                  switch (x->sm.sm_mode) {
                  case smm_input:
--- 355,394 ----
                  if (cp == NULL)
                          break;
                  goto COPY_STRING;
  
          case t_structure:
+                 x->d.m = 2;
                  sgc_mark_object(x->str.str_def);
                  p = x->str.str_self;
                  if (p == NULL)
!                         {x->d.m = TRUE; break;}
!                 {object def=x->str.str_def;
!                  struct s_data *sdef=S_DATA(def);
!                  unsigned char *s_type;
!                  unsigned short *s_pos;
!                  if((int)what_to_collect >= (int)t_contiguous &&
!                     !inheap(sdef) && def->d.m==TRUE)
!                    sdef=(struct s_data *)(((char *)sdef)+(rb_start1-rb_start));
!                  s_type = sdef->raw->ust.ust_self;
!                  s_pos = &USHORT(sdef->slot_position,0);
!                  for (i = 0, j = sdef->length;  i < j;  i++)
                     if (s_type[i]==0 &&
                         ON_WRITABLE_PAGE(& STREF(object,x,s_pos[i]))
                         )
                       sgc_mark_object(STREF(object,x,s_pos[i]));
                   if ((int)what_to_collect >= (int)t_contiguous) {
                       if (inheap(x->str.str_self)) {
                         if (what_to_collect == t_contiguous)
                           mark_contblock((char *)p,
!                                         sdef->size);
  
                       } else if(SGC_RELBLOCK_P(p))
                         x->str.str_self = (object *)
!                          copy_relblock((char *)p, sdef->size);
                     }}
+                 x->d.m = TRUE; 
                  break;
  
          case t_stream:
                  switch (x->sm.sm_mode) {
                  case smm_input:
cmpnew/cmpinit.lsp
*** cmpnew/cmpinit.lsp    Tue Jun 30 04:11:13 1992
--- ../akcl-1-615/cmpnew/cmpinit.lsp      Mon Jun 22 18:41:51 1992
***************
*** 4,7 ****
--- 4,10 ----
  (load "sys-proclaim.lisp")
  (setq compiler::*eval-when-defaults* '(compile eval load))
  
  ;(dolist (v '( cmpeval cmpopt cmptype cmpbind cmpinline cmploc cmpvar cmptop cmplet cmpcall cmpmulti cmplam cmplabel          cmpeval))   (load (format nil "~(~a~).lsp" v)))
+ (unless (get 'si::basic-wrapper 'si::s-data)
+   (setf (get 'si::s-data 'si::s-data) nil)
+   (load "../lsp/defstruct.lsp"))
lsp/cmpinit.lsp
*** lsp/cmpinit.lsp       Tue Jun 30 04:11:26 1992
--- ../akcl-1-615/lsp/cmpinit.lsp Mon Jun 22 17:11:11 1992
***************
*** 5,12 ****
  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
  ;(or (get 'si::s-data 'si::s-data)
  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
! 
! 
  
  ;;;;;
--- 5,13 ----
  (or (fboundp 'si::get-&environment) (load "defmacro.lsp"))
  ;(or (get 'si::s-data 'si::s-data)
  ;    (progn (load "../lsp/setf.lsp") (load "../lsp/defstruct.lsp")))
  (if (probe-file "sys-proclaim.lisp")(load "sys-proclaim.lisp"))
! (unless (get 'si::basic-wrapper 'si::s-data)
!   (setf (get 'si::s-data 'si::s-data) nil)
!   (load "../lsp/defstruct.lsp"))
  
  ;;;;;
lsp/describe.lsp
*** lsp/describe.lsp      Tue Jun 30 04:11:27 1992
--- ../akcl-1-615/lsp/describe.lsp        Tue Jun 23 16:39:07 1992
***************
*** 266,282 ****
  
  (defun inspect-structure (x &aux name)
    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
            (setq name (type-of x)))
!   (let* ((sd (get name 'si::s-data))
           (spos (s-data-slot-position sd)))
      (dolist (v (s-data-slot-descriptions sd))
              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
!                     (aref spos (nth 4 v))
!                     (let ((type (nth 2 v)))
                        (if (eq t type) nil type))
!                     (car v)
!                     (structure-ref1 x (nth 4 v))))))
      
    
  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
    (inspect-indent)
--- 266,282 ----
  
  (defun inspect-structure (x &aux name)
    (format t "Structure of type ~a ~%Byte:[Slot Type]Slot Name   :Slot Value"
            (setq name (type-of x)))
!   (let* ((sd (structure-def x))
           (spos (s-data-slot-position sd)))
      (dolist (v (s-data-slot-descriptions sd))
              (format t "~%~4d:~@[[~s] ~]~20a:~s"   
!                     (aref spos (slot-offset v))
!                     (let ((type (slot-type v)))
                        (if (eq t type) nil type))
!                     (slot-name v)
!                     (structure-ref1 x (slot-offset v))))))
      
    
  (defun inspect-object (object &aux (*inspect-level* *inspect-level*))
    (inspect-indent)
==============================================================================
=============================== c/structure.c ================================
Changes file for /kcl/c/structure.c
Usage \n@s[Original text\n@s|Replacement Text\n@s]
See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
for a program to merge change files.  Anything not between
 "\n@s[" and  "\n@s]" is a simply a comment.
This file was constructed using emacs and  merge.el
 by (Bill Schelter)  wfs@carl.ma.utexas.edu 


****Change:(orig (15 17 d))
@s[object siSstructure_print_function;
object siSstructure_slot_descriptions;
object siSstructure_include;

@s|
@s]


****Change:(orig (18 18 a))
@s[

@s|
#define COERCE_DEF(x) if (type_of(x)==t_symbol) \
  x=getf(x->s.s_plist,siLs_data,Cnil)

#define check_type_structure(x) \
  if(type_of((x))!=t_structure) \
    FEwrong_type_argument(Sstructure,(x)) 



@s]


****Change:(orig (22 31 c))
@s[{
	do {
		if (type_of(x) != t_symbol)
		        return(FALSE);

@s,       } while (x != Cnil);
	return(FALSE);
}

@s|{ if (x==y) return 1;
  if (type_of(x)!= t_structure
      || type_of(y)!=t_structure)
    FEerror("bad call to structure_subtypep",0);
  {if (S_DATA(y)->included == Cnil) return 0;
   while ((x=S_DATA(x)->includes) != Cnil)
     { if (x==y) return 1;}
   return 0;
 }}

@s]


****Change:(orig (32 32 a))
@s[

@s|
static
bad_raw_type()
{           FEerror("Bad raw struct type",0);}



@s]


****Change:(orig (34 34 c))
@s[structure_ref(x, name, n)

@s|structure_ref(x, name, i)

@s]


****Change:(orig (36 38 c))
@s[object x, name;
int n;
{
	int i;

@s|object x, name;
int i;
{unsigned short *s_pos;
 COERCE_DEF(name);
 if (type_of(x) != t_structure ||
     (type_of(name)!=t_structure) ||
     !structure_subtypep(x->str.str_def, name))
   FEwrong_type_argument((type_of(name)==t_structure ?
		          S_DATA(name)->name : name),
		         x);
 s_pos = &SLOT_POS(x->str.str_def,0);
 switch((SLOT_TYPE(x->str.str_def,i)))
   {
   case aet_object: return(STREF(object,x,s_pos[i]));
   case aet_fix:  return(make_fixnum((STREF(int,x,s_pos[i]))));
   case aet_ch:  return(code_char(STREF(char,x,s_pos[i])));
   case aet_bit:
   case aet_char: return(make_fixnum(STREF(char,x,s_pos[i])));
   case aet_sf: return(make_shortfloat(STREF(shortfloat,x,s_pos[i])));
   case aet_lf: return(make_longfloat(STREF(longfloat,x,s_pos[i])));
   case aet_uchar: return(make_fixnum(STREF(unsigned char,x,s_pos[i])));
   case aet_ushort: return(make_fixnum(STREF(unsigned short,x,s_pos[i])));
   case aet_short: return(make_fixnum(STREF(short,x,s_pos[i])));
   default:
     bad_raw_type();
     return 0;
   }}

@s]


****Change:(orig (40 43 c))
@s[       if (type_of(x) != t_structure ||
	    !structure_subtypep(x->str.str_name, name))
		FEwrong_type_argument(name, x);
	return(x->str.str_self[n]);

@s|
void
siLstructure_ref1()
{object x=vs_base[0];
 int n=fix(vs_base[1]);
 object def;
 check_type_structure(x);
 def=x->str.str_def;
 if(n>= S_DATA(def)->length)
   FEerror("Structure ref out of bounds",0);
 vs_base[0]=structure_ref(x,x->str.str_def,n);
 vs_top=vs_base+1;

@s]


****Change:(orig (45 45 a))
@s[}


@s|}

void
siLstructure_set1()
{object x=vs_base[0];
 int n=fix(vs_base[1]);
 object v=vs_base[2];
 object def;
 check_type_structure(x);
 def=x->str.str_def;
 if(n>= S_DATA(def)->length)
   FEerror("Structure ref out of bounds",0);
 vs_base[0]=structure_set(x,x->str.str_def,n,v);
 vs_top=vs_base+1;
}  



@s]


****Change:(orig (47 47 c))
@s[structure_set(x, name, n, v)

@s|structure_set(x, name, i, v)

@s]


****Change:(orig (49 51 c))
@s[object x, name, v;
int n;
{
	int i;

@s|object x, name, v;
int i;
{unsigned short *s_pos;
 
 COERCE_DEF(name);
 if (type_of(x) != t_structure ||
     type_of(name) != t_structure ||
     !structure_subtypep(x->str.str_def, name))
   FEwrong_type_argument((type_of(name)==t_structure ?
		          S_DATA(name)->name : name)
		         , x);

@s]


****Change:(orig (53 57 c))
@s[       if (type_of(x) != t_structure ||
	    !structure_subtypep(x->str.str_name, name))
		FEwrong_type_argument(name, x);
	x->str.str_self[n] = v;

@s,       return(v);

@s|#ifdef SGC
 /* make sure the structure header is on a writable page */
 if (x->d.m) FEerror("bad gc field",0); else  x->d.m = 0;
#endif   
 
 s_pos= & SLOT_POS(x->str.str_def,0);
 switch(SLOT_TYPE(x->str.str_def,i)){
   
   case aet_object: STREF(object,x,s_pos[i])=v; break;
   case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
   case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
   case aet_bit:
   case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
   case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
   case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
   case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
   case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
   case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
 default:
   bad_raw_type();

   }
 return(v);

@s]


****Change:(orig (59 59 a))
@s[}


@s|}

void
siLstructure_subtype_p()
{object x,y;
 check_arg(2);
 x=vs_base[0];
 y=vs_base[1];
 if (type_of(x)!=t_structure)
   {vs_base[0]=Cnil; goto BOTTOM;}
 x=x->str.str_def;
 COERCE_DEF(y);
 if (structure_subtypep(x,y)) vs_base[0]=Ct;
 else vs_base[0]=Cnil;
 BOTTOM:
 vs_top=vs_base+1;
}
 
static object
slot_name(x)
     object x;
{
  if(type_of(x)==t_cons)
    return car(x);
  if(type_of(x)==t_structure)
    return x->str.str_self[0];
  return Cnil;
}


@s]


****Change:(orig (64 64 a))
@s[object x;
{
	object *p, s;

@s|object x;
{
	object *p, s;
	struct s_data *def=S_DATA(x->str.str_def);

@s]


****Change:(orig (66 69 c))
@s[
	s = getf(x->str.str_name->s.s_plist,
	         siSstructure_slot_descriptions, Cnil);
	vs_push(x->str.str_name);

@s|       
	s = def->slot_descriptions;
	vs_push(def->name);

@s]


****Change:(orig (72 73 c))
@s[       for (i=0, n=x->str.str_length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
		*p = make_cons(car(s->c.c_car), Cnil);

@s|       for (i=0, n=def->length;  !endp(s)&&i<n;  s=s->c.c_cdr, i++) {
		*p = make_cons(slot_name(s->c.c_car), Cnil);

@s]


****Change:(orig (75 75 c))
@s[               *p = make_cons(x->str.str_self[i], Cnil);

@s|               *p = make_cons(structure_ref(x,x->str.str_def,i), Cnil);

@s]


****Change:(orig (81 81 a))
@s[       stack_cons();
	return(vs_pop);
}


@s|       stack_cons();
	return(vs_pop);
}

void

@s]


****Change:(orig (84 85 c))
@s[       object x;
	int narg, i;

@s|  object x,name,*base;
  struct s_data *def;
  int narg, i,size;
  base=vs_base;
  if ((narg = vs_top - base) == 0)
    too_few_arguments();
  x = alloc_object(t_structure);
  name=base[0];
  COERCE_DEF(name);
  if (type_of(name)!=t_structure  ||
      (def=S_DATA(name))->length != --narg)
    FEerror("Bad make_structure args for type ~a",1,
	    base[0]);
  x->str.str_def = name;
  x->str.str_self = NULL;
  size=S_DATA(name)->size;
  base[0] = x;
  x->str.str_self = (object *)
    (def->staticp == Cnil ? alloc_relblock(size)
     : alloc_contblock(size));
  /* There may be holes in the structure.
     We want them zero, so that equal can work better.
     */
  if (S_DATA(name)->has_holes != Cnil)
    bzero(x->str.str_self,size);
  {unsigned char *s_type;
   unsigned short *s_pos;
   s_pos= (&SLOT_POS(x->str.str_def,0));
   s_type = (&(SLOT_TYPE(x->str.str_def,0)));
   base=base+1;
   for (i = 0;  i < narg;  i++)
     {object v=base[i];
      switch(s_type[i]){
	     
      case aet_object: STREF(object,x,s_pos[i])=v; break;
      case aet_fix:  (STREF(int,x,s_pos[i]))=fix(v); break;
      case aet_ch:  STREF(char,x,s_pos[i])=char_code(v); break;
      case aet_bit:
      case aet_char: STREF(char,x,s_pos[i])=fix(v); break;
      case aet_sf: STREF(shortfloat,x,s_pos[i])=sf(v); break;
      case aet_lf: STREF(longfloat,x,s_pos[i])=lf(v); break;
      case aet_uchar: STREF(unsigned char,x,s_pos[i])=fix(v); break;
      case aet_ushort: STREF(unsigned short,x,s_pos[i])=fix(v); break;
      case aet_short: STREF(short,x,s_pos[i])=fix(v); break;
      default:
	bad_raw_type();

@s]


****Change:(orig (87 97 c))
@s[       if ((narg = vs_top - vs_base) == 0)
		too_few_arguments();
	x = alloc_object(t_structure);
	x->str.str_name = vs_base[0];

@s,               x->str.str_self[i] = vs_top[i];

@s|      }}
   vs_top = base;
   vs_base=base-1;

 }

@s]


****Change:(orig (99 99 a))
@s[}


@s|}

void

@s]


****Change:(orig (103 103 c))
@s[       object x, y;
	int i, j;

@s|       object x, y;
	struct s_data *def;

@s]


****Change:(orig (105 105 c))
@s[
	check_arg(2);

@s|
	if (vs_top-vs_base < 1) too_few_arguments();

@s]


****Change:(orig (107 110 c))
@s[       if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
		FEwrong_type_argument(vs_base[1], x);
	vs_base[1] = y = alloc_object(t_structure);
	y->str.str_name = x->str.str_name;

@s|       check_type_structure(x);
	vs_base[0] = y = alloc_object(t_structure);
	def=S_DATA(y->str.str_def = x->str.str_def);

@s]


****Change:(orig (112 116 c))
@s[       y->str.str_length = j = x->str.str_length;
	y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
	for (i = 0;  i < j;  i++)
		y->str.str_self[i] = x->str.str_self[i];

@s,       vs_base++;

@s|       y->str.str_self = (object *)alloc_relblock(def->size);
	bcopy(x->str.str_self,y->str.str_self,def->size);
	vs_top=vs_base+1;

@s]


****Change:(orig (118 118 a))
@s[}


@s|}

void
siLcopy_structure_header()
{
	object x, y;

	if (vs_top-vs_base < 1) too_few_arguments();
	x = vs_base[0];
	check_type_structure(x);
	vs_base[0] = y = alloc_object(t_structure);
	y->str.str_def = x->str.str_def;
	y->str.str_self = x->str.str_self;
	vs_top=vs_base+1;
}


void

@s]


****Change:(orig (122 124 c))
@s[       if (type_of(vs_base[0]) != t_structure)
		FEwrong_type_argument(Sstructure, vs_base[0]);
	vs_base[0] = vs_base[0]->str.str_name;

@s|       check_type_structure(vs_base[0]);
	vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;

@s]


****Change:(orig (127 127 c))
@s[}

siLstructure_ref()

@s|}

#define FIND_SLOT(str,name) ((type_of(name)==t_fixnum)?fix(name): \
		             structure_slot_position(str,name))

object
structure_ref_new(x, name, i)
     object x,name,i;

@s]


****Change:(orig (129 131 c))
@s[       object x;
	int i;
	check_arg(3);

@s|  return structure_ref(x,name,FIND_SLOT(x,i));
}

@s]


****Change:(orig (133 144 c))
@s[       x = vs_base[0];
	if (type_of(x) != t_structure ||
	    !structure_subtypep(x->str.str_name, vs_base[1]))
		FEwrong_type_argument(vs_base[1], x);

@s,       vs_base[0] = x->str.str_self[i];
	vs_top = vs_base+1;

@s|object
structure_set_new(x, name, i, v)
     object x,name,i,v;
{
  return structure_set(x,name,FIND_SLOT(x,i),v);

@s]


****Change:(orig (146 146 a))
@s[}


@s|}

void
siLstructure_ref()
{
  check_arg(3);
  vs_base[0]=structure_ref_new(vs_base[0],vs_base[1],vs_base[2]);
  vs_top=vs_base+1;
}

void

@s]


****Change:(orig (149 150 d))
@s[siLstructure_set()
{
	object x;
	int i;

@s|siLstructure_set()
{

@s]


****Change:(orig (152 163 c))
@s[
	x = vs_base[0];
	if (type_of(x) != t_structure ||
	    !structure_subtypep(x->str.str_name, vs_base[1]))

@s,       x->str.str_self[i] = vs_base[3];

@s|       structure_set_new(vs_base[0],vs_base[1],vs_base[2],vs_base[3]);

@s]


****Change:(orig (166 166 a))
@s[       vs_base = vs_top-1;
}


@s|       vs_base = vs_top-1;
}

void

@s]


****Change:(orig (228 228 c))
@s[init_structure_function()

@s|void
siLmake_s_data_structure()
{object x,y,raw,*base;
 int i;
 check_arg(5);
 x=vs_base[0];
 base=vs_base;
 raw=vs_base[1];
 y=alloc_object(t_structure);
 y->str.str_def=y;
 y->str.str_self = (object *)( x->v.v_self);
 S_DATA(y)->name  =siLs_data;
 S_DATA(y)->length=(raw->v.v_dim);
 S_DATA(y)->raw   =raw;
 for(i=3; i<raw->v.v_dim; i++)
   y->str.str_self[i]=Cnil;
 S_DATA(y)->slot_position=base[2];
 S_DATA(y)->slot_descriptions=base[3];
 S_DATA(y)->staticp=base[4];
 S_DATA(y)->size = (raw->v.v_dim)*sizeof(object);
 vs_base[0]=y;
 vs_top=vs_base+1;
}

object siSstructure_init,siSstructure_init_named;
object siSname,siSdefault_init;
object siSraw,siSslot_position,siSsize,siSstaticp,siSslot_descriptions;

static object
slot_value(str,name)
     object str,name;

@s]


****Change:(orig (230 237 c))
@s[       siSstructure_print_function
	= make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
	enter_mark_origin(&siSstructure_print_function);
	siSstructure_slot_descriptions

@s,       enter_mark_origin(&siSstructure_include);

@s| top:
  if(type_of(str)==t_structure)
    return structure_ref_new(str,str->str.str_def,name);
  if(str->c.c_car==siSstructure_init_named)
    {object new=get(str->c.c_cdr,siLs_data);
     str->c.c_car=siSstructure_init;
     str->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
  if(siSstructure_init!=car(str))
    FEerror("Illegal call to SI:MAKE-STRUCTURES 1",0);
  {object key=intern(coerce_to_string(name),keyword_package);
   object value=getf(cdddr(str),key,NULL);
   if(value!=NULL)
     return value;
   else
     {object slots;
      if(str==caddr(str)&&name==siSslot_descriptions)
	FEerror("Illegal call to SI:MAKE-STRUCTURES 2",0);
      slots=slot_value(caddr(str),siSslot_descriptions);
      for(;!endp(slots);slots=cdr(slots))
	if(name==slot_value(car(slots),siSname))
	  {object result,form=slot_value(car(slots),siSdefault_init);
	   object *old_vs_base=vs_base,*old_vs_top=vs_top;
	   vs_base=vs_top;vs_push(form);Leval();result=vs_base[0];
	   vs_base=old_vs_base; vs_top=old_vs_top;
	   return result;}
      FEerror("Illegal call to SI:MAKE-STRUCTURES 3",0);}}
  return Cnil;
}

@s]


****Change:(orig (238 238 a))
@s[

@s|
int 
structure_slot_position(str,name)
     object str,name;
{
  if(type_of(name)==t_fixnum)
    return fix(name);
  else
    {object slotd_list;
     int pos;
     check_type_structure(str);
     slotd_list=S_DATA(str->str.str_def)->slot_descriptions;
     for(pos=0; type_of(slotd_list)==t_cons; pos++,slotd_list=cdr(slotd_list))
       {object slotd=car(slotd_list);
	if(name==((type_of(slotd)==t_structure)?
		  slotd->str.str_self[0]:slot_value(slotd,siSname)))
	  return pos;}
     FEerror("Slot ~S not found in structure ~S",2,name,str);
     return 0;}  
}

static object
make_structures_internal(value)
     object value;
{
  object str,def;
  int def_index,i,ind;

  switch(type_of(value))
    {case t_cons:
       if(value->c.c_car==siSstructure_init_named)
	 {object new=get(value->c.c_cdr,siLs_data);
	  value->c.c_car=siSstructure_init;
	  value->c.c_cdr=(type_of(new)==t_structure)?new:cdr(new);}
       if(car(value)!=siSstructure_init)
	 {value->c.c_car=make_structures_internal(value->c.c_car);
	  value->c.c_cdr=make_structures_internal(value->c.c_cdr);
	  break;}
       if(type_of(cadr(value))==t_structure)
	 {value=value->c.c_cdr->c.c_car;
	  break;}
       {object def=caddr(value),plist=cdddr(value),result;
	object slots,slots_tail;
	int size,staticp,len,i;
	if(def!=value)def=make_structures_internal(def);
	result=alloc_object(t_structure);
	result->str.str_def=(def==value)?result:def;
	result->str.str_self=NULL;
	value->c.c_cdr->c.c_car=result;
	size=fixint(slot_value(def,siSsize));
	staticp=Cnil!=slot_value(def,siSstaticp);
	slots=slot_value(def,siSslot_descriptions);
	len=length(slots);
	result->str.str_self=(object *)(staticp?alloc_contblock(size):
		                                alloc_relblock(size));
	bzero(result->str.str_self,size);
	if(def==value)
	  {S_DATA(result)->raw=slot_value(def,siSraw);
	   S_DATA(result)->slot_position=slot_value(def,siSslot_position);}
	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
	  {object svalue=slot_value(value,slot_value(car(slots_tail),siSname));
	   structure_set(result,result->str.str_def,i,svalue);}
	for(i=0,slots_tail=slots; i<len; i++,slots_tail=cdr(slots_tail))
	  {object svalue=structure_ref(result,result->str.str_def,i);
	   svalue=make_structures_internal(svalue);
	   structure_set(result,result->str.str_def,i,svalue);}
	value=result;
	break;}
     case t_vector:
       if ((enum aelttype)value->v.v_elttype == aet_object)
	 {int i,len=value->v.v_dim;
	  for(i=0; i<len; i++)
	    value->v.v_self[i]=make_structures_internal(value->v.v_self[i]);}
       break;
     case t_symbol:
       {object plist=value->s.s_plist,next;
	for(;!endp(plist);plist=cddr(plist))
	  {next=plist->c.c_cdr;
	   if(plist->c.c_car==siLs_data&&
	      type_of(next->c.c_car)==t_cons)
	     next->c.c_car=make_structures_internal(next->c.c_car);}
	break;}}
  return value;   
}

void
siLmake_structures()
{
  check_arg(1);
  vs_base[0]=make_structures_internal(vs_base[0]);
}

void
siLstructure_def()
{check_arg(1);
 check_type_structure(vs_base[0]);
  vs_base[0]=vs_base[0]->str.str_def;
}

short aet_sizes [] = {
sizeof(object),  /* aet_object  t  */
sizeof(char),  /* aet_ch  string-char  */
sizeof(char),  /* aet_bit  bit  */
sizeof(fixnum),  /* aet_fix  fixnum  */
sizeof(float),  /* aet_sf  short-float  */
sizeof(double),  /* aet_lf  long-float  */
sizeof(char),  /* aet_char  signed char */
sizeof(char),  /* aet_uchar  unsigned char */
sizeof(short),  /* aet_short  signed short */
sizeof(short)  /* aet_ushort  unsigned short   */
};

  



void
siLsize_of() 
{ object x= vs_base[0];
  int i;
  i= aet_sizes[get_aelttype(x)];
  vs_base[0]=make_fixnum(i);
}
  
void
siLaet_type()
{vs_base[0]=make_fixnum(get_aelttype(vs_base[0]));}


/* Return N such that something of type ARG can be aligned on
   an address which is a multiple of N */


void
siLalignment()
{struct {double x; int y; double z;
	 float x1; int y1; float z1;}
 joe;
 joe.z=3.0;
 
 if (vs_base[0]==Slong_float)
   {vs_base[0]=make_fixnum((int)&joe.z- (int)&joe.y); return;}
 else
   if (vs_base[0]==Sshort_float)
     {vs_base[0]=make_fixnum((int)&(joe.z1)-(int)&(joe.y1)); return;}
   else
     {siLsize_of();}
}
   
void
swap_structure_contents(str1,str2)
   object str1,str2;
{
  object def1,*self1;
  check_type_structure(str1);
  check_type_structure(str2);
  def1=str1->str.str_def;
  self1=str1->str.str_self;
  str1->str.str_def=str2->str.str_def;
  str1->str.str_self=str2->str.str_self;
  str2->str.str_def=def1;
  str2->str.str_self=self1;
}

void
siLswap_structure_contents()
{
  check_arg(2);
  swap_structure_contents(vs_base[0],vs_base[1]);
  vs_base[0]=Cnil;
  vs_top=vs_base+1;
}

void
siLset_structure_def()
{check_arg(2);
 check_type_structure(vs_base[0]);
 check_type_structure(vs_base[1]);
 vs_base[0]->str.str_def=vs_base[1];
 vs_base[0]=vs_base[1];
 vs_top=vs_base+1;
}

init_structure_function()
{
        siLs_data=make_si_ordinary("S-DATA");
	siSstructure_init=make_si_ordinary("STRUCTURE-INIT");
	siSstructure_init_named=make_si_ordinary("STRUCTURE-INIT-NAMED");
	siSname=make_si_ordinary("NAME");
	siSdefault_init=make_si_ordinary("DEFAULT-INIT");
	siSraw=make_si_ordinary("RAW");
	siSslot_position=make_si_ordinary("SLOT-POSITION");
	siSsize=make_si_ordinary("SIZE");
	siSstaticp=make_si_ordinary("STATICP");
	siSslot_descriptions=make_si_ordinary("SLOT-DESCRIPTIONS");

@s]


****Change:(orig (239 239 a))
@s[       make_si_function("MAKE-STRUCTURE", siLmake_structure);

@s|       make_si_function("MAKE-STRUCTURE", siLmake_structure);
	make_si_function("MAKE-S-DATA-STRUCTURE",siLmake_s_data_structure);

@s]


****Change:(orig (240 240 a))
@s[       make_si_function("COPY-STRUCTURE", siLcopy_structure);

@s|       make_si_function("COPY-STRUCTURE", siLcopy_structure);
	make_si_function("COPY-STRUCTURE-HEADER", siLcopy_structure_header);

@s]


****Change:(orig (242 242 a))
@s[       make_si_function("STRUCTURE-REF", siLstructure_ref);

@s|       make_si_function("STRUCTURE-REF", siLstructure_ref);
	make_si_function("STRUCTURE-DEF", siLstructure_def);
	make_si_function("STRUCTURE-REF1", siLstructure_ref1);
	make_si_function("STRUCTURE-SET1", siLstructure_set1);

@s]


****Change:(orig (245 245 c))
@s[       make_si_function("STRUCTUREP", siLstructurep);


@s|       make_si_function("STRUCTUREP", siLstructurep);
	make_si_function("SIZE-OF", siLsize_of);
	make_si_function("ALIGNMENT",siLalignment);
	make_si_function("STRUCTURE-SUBTYPE-P",siLstructure_subtype_p);

@s]


****Change:(orig (247 247 a))
@s[       make_si_function("LIST-NTH", siLlist_nth);

@s|       make_si_function("LIST-NTH", siLlist_nth);
	make_si_function("AET-TYPE",siLaet_type);
	make_si_function("SWAP-STRUCTURE-CONTENTS",siLswap_structure_contents);
	make_si_function("SET-STRUCTURE-DEF", siLset_structure_def);
	make_si_function("MAKE-STRUCTURES", siLmake_structures);


@s]

==============================================================================
============================== V/lsp/defstruct.lsp =============================
Changes file for /kcl/lsp/defstruct.lsp
Usage \n@s[Original text\n@s|Replacement Text\n@s]
See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
for a program to merge change files.  Anything not between
 "\n@s[" and  "\n@s]" is a simply a comment.
This file was constructed using emacs and  merge.el
 by (Bill Schelter)  wfs@carl.ma.utexas.edu 


****Change:(orig (20 71 c))
@s[(defun make-access-function (name conc-name type named
                             slot-name default-init slot-type read-only
                             offset)
  (declare (ignore named default-init slot-type))

@s,          ((error "~S is an illegal structure type." type)))))

@s|(defvar *accessors* (make-array 10 :adjustable t))
(defvar *list-accessors* (make-array 2 :adjustable t))
(defvar *vector-accessors* (make-array 2 :adjustable t))

@s]


****Change:(orig (72 72 a))
@s[

@s|
(or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
		               #'(lambda (&rest l) l nil)))

@s]


****Change:(orig (73 73 a))
@s[

@s|
(defun boot-slot-value (str name)
  (if (structurep str)
      (structure-ref str (structure-def str) name)
      (getf (cdddr str) (intern (string name) :keyword))))

(defun boot-set-slot-value (str name new-value)
  (if (structurep str)
      (structure-set str (structure-def str) name new-value)
      (setf (getf (cdddr str) (intern (string name) :keyword)) new-value)))

(defun boot-subtypep (type1 type2)
  (or (eq type1 type2)
      (let* ((s-data (get type1 's-data))
	     (include (boot-s-data-name (boot-slot-value s-data 'includes))))
	(boot-subtypep include type2))))

(defun make-slot-boot (&rest args)
  (if (get 's-data 's-data)
      (apply #'make-slot args)
      (list* 'structure-init
	     nil
	     '(structure-init-named . slot)
	     args)))

(defun make-s-data-boot (&rest args)
  (if (get 's-data 's-data)
      (apply #'make-s-data args)
      (list* 'structure-init
	     nil
	     '(structure-init-named . s-data)
	     args)))

(defun make-boot-accessor (slot accessor)
  (setf (symbol-function accessor) 
	#'(lambda (object)
	    (boot-slot-value object slot)))
  (let ((writer (intern (format nil "SET ~A" accessor))))
    (setf (symbol-function writer)
	  #'(lambda (object value)
	      (boot-set-slot-value object slot value)))
    (eval `(defsetf ,accessor ,writer))))

(defmacro defstructboot (name &rest slots)
  (let ((conc-name (if (listp name)
		       (string (second (assoc :conc-name (cdr name))))
		       (format nil "~A-" name))))
    `(progn
       ,@(mapcar #'(lambda (slot)
		     (let ((fname (intern (format nil "~A~A" conc-name slot))))
		       `(make-boot-accessor ',slot ',fname)))
	         slots))))

(defstructboot (slot (:conc-name boot-slot-))
  name default-init type read-only offset accessor-name type-changed)

(defstructboot (s-data-internal (:conc-name boot-s-data-))
  name length raw included includes staticp print-function
  slot-descriptions slot-position size has-holes)

(defstructboot (basic-wrapper (:conc-name boot-wrapper-))
  cache-number-vector state class)

(defstructboot (s-data (:conc-name boot-s-data-))
  frozen documentation constructors offset
  named type conc-name)

(defun make-access-function (name conc-name type named include no-fun slot)
  (declare (ignore named))
  
  (let* ((slot-name (boot-slot-name slot))
	 (slot-type (boot-slot-type slot))
	 (read-only (boot-slot-read-only slot))
	 (offset (boot-slot-offset slot))
	 (access-function
	  (intern (si:string-concatenate (string conc-name)
		                         (string slot-name))))
	accsrs dont-overwrite)
    (unless (boot-slot-accessor-name slot)
      (setf (boot-slot-accessor-name slot) access-function))
    (ecase type
      ((nil)
       (setf accsrs *accessors*))
      (list
	(setf accsrs *list-accessors*))
      (vector
	(setf accsrs *vector-accessors*)))
    (or (> (length  accsrs) offset)
	(adjust-array accsrs (+ offset 10)))
    (unless
     dont-overwrite
     (record-fn access-function 'defun '(t) slot-type)
     (or no-fun
	 (and (fboundp access-function)
	      (eq (aref accsrs offset) (symbol-function access-function)))
	 (setf (symbol-function access-function)
	   (or (aref accsrs offset)
	       (setf (aref accsrs offset)
		     (cond  ((eq accsrs *accessors*)
		                #'(lambda (x)
		                    (or (structurep x)
		                        (error "~a is not a structure" x))
		                    (structure-ref1 x offset)))
		               ((eq accsrs *list-accessors*)
		                #'(lambda(x)
		                    (si:list-nth offset x)))
		               ((eq accsrs *vector-accessors*)
		                #'(lambda(x)
		                    (aref x offset)))))))))
    (cond (read-only
	    (remprop access-function 'structure-access)
	    (setf (get access-function 'struct-read-only) t))
	  (t (remprop access-function 'setf-update-fn)
	     (remprop access-function 'setf-lambda)
	     (remprop access-function 'setf-documentation)
	     (let ((tem (get access-function 'structure-access)))
	       (cond ((and (consp tem) include
		           (if (consp (get include 's-data))
		               (boot-subtypep include (car tem))
		               (subtypep include (car tem)))
		           (eql (cdr tem) offset))
		      ;; don't change overwrite accessor of subtype.
		      (setq dont-overwrite t)
		      )
		     (t  (setf (get access-function 'structure-access)
		               (cons (if type type name) offset)))))))
    nil))


@s]


****Change:(orig (80 89 c))
@s[                     (cond ((null x)
                            ;; If the slot-description is NIL,
                            ;;  it is in the padding of initial-offset.
                            nil)

@s,                           (t (car x))))

@s|                    (or (boot-slot-name x)
		         (and (boot-slot-default-init x)
		              ;; If the slot name is NIL,
		              ;;  it is the structure name.
		              ;;  This is for typed structures with names.
		              (list 'quote (boot-slot-default-init x)))))

@s]


****Change:(orig (94 97 c))
@s[                     (cond ((null x) nil)
                           ((null (car x)) nil)
                           ((null (cadr x)) (list (car x)))
                           (t (list (list  (car x) (cadr x))))))

@s|                    (when (boot-slot-name x)
		       (if (boot-slot-default-init x)
		           (list (list (boot-slot-name x) (boot-slot-default-init x)))
		           (list (boot-slot-name x)))))

@s]


****Change:(orig (248 248 d))
@s[          ((error "~S is an illegal structure type" type)))))



@s|          ((error "~S is an illegal structure type" type)))))


@s]


****Change:(orig (252 265 d))
@s[
(defun make-copier (name copier type named)
  (declare (ignore named))
  (cond ((null type)

@s,        ((error "~S is an illegal structure type." type))))



@s|
@s]


****Change:(orig (267 275 c))
@s[  (cond ((null type)
         ;; If TYPE is NIL, the predicate searches the link
         ;;  of structure-include, until there is no included structure.
         `(defun ,predicate (x)

@s,                   (setq n (get n 'structure-include))))))

@s|  (cond ((null type))
	 ; done in define-structure

@s]


****Change:(orig (282 283 c))
@s[                 (> (length x) ,name-offset)
                 (eq (elt x ,name-offset) ',name))))

@s|                 (> (the fixnum (length x)) ,name-offset)
                 (eq (aref (the (vector t) x) ,name-offset) ',name))))

@s]


****Change:(orig (294 294 a))
@s[                         ((= i 0) (and (consp y) (eq (car y) ',name)))

@s|                         ((= i 0) (and (consp y) (eq (car y) ',name)))
		         (declare (fixnum i))

@s]


****Change:(orig (300 301 c))
@s[;;;  and returns a list of the form:
;;;        (slot-name default-init slot-type read-only offset)

@s|;;;  and returns a slot.

@s]


****Change:(orig (325 325 c))
@s[    (list slot-name default-init slot-type read-only offset)))

@s|    (make-slot-boot :name slot-name
		    :default-init default-init
		    :type slot-type
		    :read-only read-only
		    :offset offset)))

@s]


****Change:(orig (335 335 c))
@s[      (let ((sds (member (caar olds) news :key #'car)))

@s|      (let* ((old (car olds))
	     (sds (member (boot-slot-name old) news :key #'slot-name))
	     (new (car sds)))

@s]


****Change:(orig (337 348 c))
@s[               (when (and (null (cadddr (car sds)))
                          (cadddr (car olds)))
                     ;; If read-only is true in the old
                     ;;  and false in the new, signal an error.

@s,                           (car (cddddr (car olds))))

@s|               (when (and (null (boot-slot-read-only new))
                          (boot-slot-read-only old))
		 ;; If read-only is true in the old
		 ;;  and false in the new, signal an error.
		 (error "~S is an illegal include slot-description."
		        new))
	       ;; If
	       (setf (boot-slot-type new)
		     (best-array-element-type (boot-slot-type new)))
	       (when (not (equal (normalize-type (or (boot-slot-type new) t))
		                 (normalize-type (or (boot-slot-type old) t))))
		 (error "Type mismmatch for included slot ~a" new))
	       (cons (make-slot :name (boot-slot-name new)
		                :default-init (boot-slot-default-init new)
		                :type (boot-slot-type new)
		                :read-only (boot-slot-read-only new)
		                :offset (boot-slot-offset old))

@s]


****Change:(orig (353 353 a))
@s[                     (overwrite-slot-descriptions news (cdr olds))))))))


@s|                     (overwrite-slot-descriptions news (cdr olds))))))))

(defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))

@s]


****Change:(orig (355 355 c))
@s[;;; The DEFSTRUCT macro.

@s|(defun make-t-type (n include slot-descriptions &aux i)
  (let ((res  (make-array n :element-type 'unsigned-char :static t)))
    (when include
      (let ((tem (get include 's-data))raw)
	(or tem (error "Included structure undefined ~a" include))
	(setq raw (boot-s-data-raw tem))
	(dotimes (i (min n (length raw)))
	  (setf (aref res i) (aref raw i)))))
    (dolist (v slot-descriptions)
      (setq i (boot-slot-offset v))
      (let ((type (boot-slot-type v)))
	(cond ((<= (the fixnum (alignment type)) #. (alignment t))
	       (setf (aref res i) (aet-type type))))))
    (cond ((< n (length *all-t-s-type*))
	   (dotimes (i n)
	     (cond ((not (eql (the fixnum (aref res i)) 0))
		    (return-from make-t-type res))))
	   *all-t-s-type*)
	  (t res))))

@s]


****Change:(orig (356 356 a))
@s[

@s|
(defvar *standard-slot-positions*
  (let ((ar (make-array 50 :element-type 'unsigned-short
		        :static t))) 
    (dotimes (i 50)
	     (declare (fixnum i))
	     (setf (aref ar i)(* #. (size-of t) i)))
    ar))

(eval-when (compile )
(proclaim '(function round-up (fixnum fixnum ) fixnum))
)

(defun round-up (a b)
  (declare (fixnum a b))
  (setq a (ceiling a b))
  (the fixnum (* a b)))


(defun get-slot-pos (leng include slot-descriptions &aux type small-types
		          has-holes) 
  (declare (special *standard-slot-positions*)) include
  (dolist (v slot-descriptions)
    (when (boot-slot-name v)
      (setf type (best-array-element-type (boot-slot-type v))
	    (boot-slot-type v) type)
      (let ((val (boot-slot-default-init v)))
	(unless (typep val type)
	  (if (and (symbolp val)
		   (constantp val))
	      (setf val (symbol-value val)))
	  (and (constantp val)
	       (setf (boot-slot-default-init v) (coerce val type)))))
      (cond ((memq type '(signed-char unsigned-char
		          short unsigned-short
		          long-float
		          bit))
	     (setq small-types t)))))
  (cond ((and (null small-types)
	      (< leng (length *standard-slot-positions*))
	      (list  *standard-slot-positions* (* leng #. (size-of t)) nil)))
	(t (let ((ar (make-array leng :element-type 'unsigned-short
		                 :static t))
		 (pos 0)(i 0)(align 0)type (next-pos 0))
	     (declare (fixnum pos i align next-pos))
	     ;; A default array.
		   
	     (dolist (v slot-descriptions)
	       (setq type (boot-slot-type v))
	       (setq align (alignment type))
	       (unless (<= align #. (alignment t))
		 (setq type t)
		 (setf (boot-slot-type v) t)
		 (setq align #. (alignment t))
		 (setf (boot-slot-type-changed v) t))
	       (setq next-pos (round-up pos align))      
	       (or (eql pos next-pos) (setq has-holes t))
	       (setq pos next-pos)
	       (setf (aref ar i) pos)
	       (incf pos (size-of type))
	       (incf i))
	     (list ar (round-up pos (size-of t)) has-holes)
	     ))))


(defun define-structure (name conc-name type named slot-descriptions copier
		              static include print-function constructors
		              offset predicate &optional documentation no-funs
		              &aux leng)
  (and (consp type) (eq (car type) 'vector)(setq type 'vector))
  (setq leng (length slot-descriptions))
  (setq slot-descriptions 
	(mapcar #'(lambda (info)
		    (make-slot-boot :name (first info)
		                    :default-init (second info)
		                    :type (third info)
		                    :read-only (fourth info)
		                    :offset (fifth info)
		                    :accessor-name (sixth info)
		                    :type-changed (seventh info)))
		slot-descriptions))
  (dolist (x slot-descriptions)
    (when (boot-slot-name x)
      (make-access-function name conc-name type named include no-funs x)))
  (when (and copier (not no-funs))
    (setf (symbol-function copier)
	  (ecase type
	    ((nil) #'si::copy-structure)
	    (list #'copy-list)
	    (vector #'copy-seq))))
  (let ((include-str (and include (get include 's-data))))
    (when (and (eq include 's-data-internal)
	       (not (eq name 'basic-wrapper)))
      (error "only ~s can include ~s" 'basic-wrapper 's-data-internal))
    (when include-str
      (cond ((and (not (consp include-str))
		  (s-data-frozen include-str)
		  (or (not (s-data-included include-str))
		      (not (let ((te (get name 's-data)))
		             (and te
		                  (eq (s-data-includes te)
		                      include-str))))))
	     (warn " ~a was frozen but now included"
		   include)))
      (let ((old-included (boot-slot-value include-str 'included)))
	(unless (member name old-included)
	  (boot-set-slot-value include-str 'included (cons name old-included)))))
    (let* ((tem (get name 's-data))
	   (g-s-p (and (null type)
		       (get-slot-pos leng include slot-descriptions)))
	   (slot-position (car g-s-p))
	   (size (if g-s-p (cadr g-s-p) 0))
	   (has-holes (caddr g-s-p))
	   (def (make-s-data-boot :name name
		                  :length leng
		                  :raw
		                  (and (null type)
		                       (make-t-type leng include 
		                                    slot-descriptions))
		                  :slot-position slot-position
		                  :size size
		                  :has-holes has-holes
		                  :staticp static
		                  :includes include-str
		                  :print-function print-function
		                  :slot-descriptions slot-descriptions
		                  :constructors constructors
		                  :offset offset
		                  :type type
		                  :named named
		                  :documentation documentation
		                  :conc-name conc-name)))
      (check-s-data tem def name)
      (when (and (consp def) (eq name 's-data))
	(make-structures def))))
  (when documentation
    (setf (get name 'structure-documentation)
	  documentation))
  (when (and  (null type)  predicate)
    (record-fn predicate 'defun '(t) t)
    (or no-funs
	(setf (symbol-function predicate)
	      #'(lambda (x)
		  (si::structure-subtype-p x name))))
    (setf (get predicate 'compiler::co1)
	  'compiler::co1structure-predicate)
    (setf (get predicate 'struct-predicate) name))
  nil)

(defun check-s-data (old new name)
  (unless (and old (member name '(slot s-data-internal basic-wrapper s-data)))
    (when (and old (eq (structure-def old) (get 's-data 's-data)))
      (boot-set-slot-value new 'included (boot-slot-value old 'included))
      (boot-set-slot-value new 'frozen (boot-slot-value old 'frozen)))
    (unless (and old
		 (eq (structure-def old) (get 's-data 's-data))
		 (let ((new-cnv (boot-slot-value new 'cache-number-vector))
		       (old-cnv (boot-slot-value old 'cache-number-vector)))
		   (boot-set-slot-value new 'cache-number-vector old-cnv)
		   (prog1 (equalp new old)
		     (boot-set-slot-value new 'cache-number-vector new-cnv))))
      (when old
	(warn "structure ~a is changing" name)
	(when (eq (structure-def old) (get 's-data 's-data))
	  (boot-set-slot-value old 'state (list ':obsolete new))))
      (setf (get name 's-data) new))))


@s]


****Change:(orig (364 364 c))
@s[        predicate predicate-specified
        include

@s|        predicate predicate-specified
        include include-s-data

@s]


****Change:(orig (367 367 c))
@s[        offset name-offset
        documentation)

@s|        offset name-offset
        documentation
	static)

@s]


****Change:(orig (370 370 c))
@s[          ;; The defstruct options are supplied.

@s|         ;; The defstruct options are supplied.

@s]


****Change:(orig (390 425 c))
@s[      (cond ((and (consp (car os)) (not (endp (cdar os))))
             (setq o (caar os) v (cadar os))
             (case o
               (:conc-name

@s,               (t (error "~S is an illegal defstruct option." o))))))

@s|       (cond ((and (consp (car os)) (not (endp (cdar os))))
	       (setq o (caar os) v (cadar os))
	       (case o
		 (:conc-name
		   (if (null v)
		       (setq conc-name "")
		     (setq conc-name v)))
		 (:constructor
		   (if (null v)
		       (setq no-constructor t)
		     (if (endp (cddar os))
		         (setq constructors (cons v constructors))
		       (setq constructors (cons (cdar os) constructors)))))
		 (:copier (setq copier v))
		 (:static (setq static v))
		 (:predicate
		   (setq predicate v)
		   (setq predicate-specified t))
		 (:include
		   (setq include (cdar os))
		   (unless (setq include-s-data (get v 's-data))
		           (error "~S is an illegal included structure." v)))
		 (:print-function
		  (and (consp v) (eq (car v) 'function)
		       (setq v (second v)))
		  (setq print-function v))
		 (:type (setq type v))
		 (:initial-offset (setq initial-offset v))
		 (t (error "~S is an illegal defstruct option." o))))
	      (t
		(if (consp (car os))
		    (setq o (caar os))
		  (setq o (car os)))
		(case o
		  (:constructor
		    (setq constructors
		          (cons default-constructor constructors)))
		  ((:conc-name :copier :predicate :print-function))
		  (:named (setq named t))
		  (t (error "~S is an illegal defstruct option." o))))))

@s]


****Change:(orig (426 426 a))
@s[

@s|
    (setq conc-name (intern (string conc-name)))

    (and include-s-data (not print-function)
	 (setq print-function (boot-s-data-print-function include-s-data)))


@s]


****Change:(orig (434 435 c))
@s[    (when include
          (unless (equal type (get (car include) 'structure-type))

@s|    (when include-s-data
          (unless (equal type (boot-s-data-type include-s-data))

@s]


****Change:(orig (442 443 c))
@s[          (t
           (setq offset (get (car include) 'structure-offset))))

@s|          (t 
	    (setq offset (boot-s-data-offset include-s-data))))

@s]


****Change:(orig (457 458 c))
@s[      (setq sds (cons (parse-slot-description (car ds) offset) sds))
      (setq offset (1+ offset)))

@s|       (setq sds (cons (parse-slot-description (car ds) offset) sds))
	(setq offset (1+ offset)))

@s]


****Change:(orig (464 464 c))
@s[                (cons (list nil name) slot-descriptions)))

@s|                (cons (make-slot :default-init name) slot-descriptions)))

@s]


****Change:(orig (469 469 c))
@s[                (append (make-list initial-offset) slot-descriptions)))

@s|                (append (mapcar #'make-named-slot (make-list initial-offset))
		        slot-descriptions)))

@s]


****Change:(orig (473 486 c))
@s[    (cond ((null include))
          ((endp (cdr include))
           (setq slot-descriptions
                 (append (get (car include) 'structure-slot-descriptions)

@s,                         slot-descriptions))))

@s|    (let ((include-slot-descriptions 
	   (and include
		(boot-s-data-slot-descriptions include-s-data))))
      (cond ((null include))
	    ((endp (cdr include))
	     (setq slot-descriptions
		   (append include-slot-descriptions
		           slot-descriptions)))
	    (t
	     (setq slot-descriptions
		   (append (overwrite-slot-descriptions
		            (mapcar #'(lambda (sd)
		                        (parse-slot-description sd 0))
		                    (cdr include))
		            include-slot-descriptions)
		           slot-descriptions)))))

@s]


****Change:(orig (489 492 c))
@s[           ;; If a constructor option is NIL,
           ;;  no constructor should have been specified.
           (when constructors
                 (error "Contradictory constructor options.")))

@s|           ;; If a constructor option is NIL,
	    ;;  no constructor should have been specified.
	    (when constructors
		  (error "Contradictory constructor options.")))

@s]


****Change:(orig (494 495 c))
@s[           ;; If no constructor is specified,
           ;;  the default-constructor is made.

@s|          ;; If no constructor is specified,
	   ;;  the default-constructor is made.

@s]


****Change:(orig (497 497 a))
@s[           (setq constructors (list default-constructor))))


@s|           (setq constructors (list default-constructor))))

    ;; We need a default constructor for the sharp-s-reader
    (or (member t (mapcar 'symbolp  constructors))
	(push (intern (string-concatenate "__si::" default-constructor))
		      constructors))


@s]


****Change:(orig (509 509 c))
@s[          (error "An print function is supplied to a typed structure."))

@s|          (error "A print function is supplied to a typed structure."))
    
    `(progn
       (define-structure ',name  ',conc-name ',type ',named
		         ',(mapcar #'(lambda (slotd)
		                       (list (boot-slot-name slotd)
		                             (boot-slot-default-init slotd)
		                             (boot-slot-type slotd)
		                             (boot-slot-read-only slotd)
		                             (boot-slot-offset slotd)
		                             (boot-slot-accessor-name slotd)
		                             (boot-slot-type-changed slotd)))
		                   slot-descriptions)
		         ',copier ',static ',include ',print-function ',constructors 
		         ',offset ',predicate ',documentation)

@s]


****Change:(orig (511 542 c))
@s[    `(progn (si:putprop ',name
                        '(defstruct ,name ,@slots)
                        'defstruct-form)
            (si:putprop ',name t 'is-a-structure)

@s,            (si:putprop ',name ,documentation 'structure-documentation)
            ',name)))

@s|       ,@(mapcar #'(lambda (constructor)
		     (make-constructor name constructor type named
		                       slot-descriptions))
		 constructors)
       ,@(if (and type predicate)
	     (list (make-predicate name predicate type named
		                   name-offset)))
       ',name
       )))

@s]


****Change:(orig (544 544 a))
@s[


@s|

(eval-when (compile load eval)

(defconstant wrapper-cache-number-adds-ok 4)

(defconstant wrapper-cache-number-length
	     (- (integer-length most-positive-fixnum)
		wrapper-cache-number-adds-ok))

(defconstant wrapper-cache-number-mask
	     (1- (expt 2 wrapper-cache-number-length)))


(defvar *get-wrapper-cache-number* (make-random-state))

(defun get-wrapper-cache-number ()
  (let ((n 0))
    (declare (fixnum n))
    (loop
      (setq n
	    (logand wrapper-cache-number-mask
		    (random most-positive-fixnum *get-wrapper-cache-number*)))
      (unless (zerop n) (return n)))))

)

(eval-when (compile load eval)

(defconstant wrapper-cache-number-vector-length 8)

(deftype cache-number-vector ()
  `(simple-array fixnum (8)))

(defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
		                       :initial-element 'number))

)

(defun make-wrapper-cache-number-vector ()
  (let ((cnv (make-array #.wrapper-cache-number-vector-length
		         :element-type 'fixnum)))
    (dotimes (i #.wrapper-cache-number-vector-length)
      (setf (aref cnv i) (get-wrapper-cache-number)))
    cnv))

(defstruct (slot
	     (:static t)
	     (:constructor make-slot)
	     (:constructor make-named-slot (name)))
  name
  default-init
  (type t)
  read-only
  offset
  accessor-name
  type-changed)

;; All of the fields of s-data-internal must coincide with 
;; the C structure s_data (see object.h).
(defstruct (s-data-internal
	     (:conc-name s-data-)
	     (:constructor nil)
	     (:static t))
  ;; all of these slots are used by c code
  name                    ; a symbol
  (length 0 :type fixnum) ; length of slot-descriptions
  raw                     ; a static array of unsigned-short (enum aelttype)
  included                ; a list of the names of structures including this one
  includes                ; nil or a s-data structure
  staticp         ; t or nil
  print-function  ; nil, a symbol, or a lambda expression
  slot-descriptions       ; a list of slots
  slot-position           ; a static array of unsigned-short
  (size 0 :type fixnum) ; total size to allocate
  has-holes)              ; t or nil

(defstruct (basic-wrapper (:include s-data-internal)
		          (:conc-name wrapper-)
		          (:constructor nil)
		          (:static t))
  (cache-number-vector (make-wrapper-cache-number-vector))
  (state t) ;  either t or a list (state-sym new-wrapper)
  ;;           where state-sym is either :flush or :obsolete
  (class nil))

;(get name 'si::s-data) ;returns one of these:
(defstruct (s-data (:include basic-wrapper)
		   (:static t))
  ;; these slots are used only from lisp
  frozen          ; t or nil ; t means won't include this
  documentation 
  constructors            ; a list of either a symbol or a list symbol, arglist
  offset          ; the total number of slots and placeholders
  named                   ; t or nil
  type                    ; one of: nil, list, or vector
  conc-name)              ; an interned symbol

#|| 
(import '(si::wrapper-state si::wrapper-class si::basic-wrapper))

(defstruct (wrapper (:include basic-wrapper)
		    (:print-function print-wrapper)
		    (:constructor make-wrapper-internal)
		    (:predicate wrapper-p)
		    (:conc-name wrapper-))
  (class-slots nil :type list))

(defun print-wrapper (instance stream depth)
  (printing-random-thing (wrapper stream)
    (format stream "Wrapper ~S" (wrapper-class wrapper))))
||#

(defun update-wrapper-state (old new same-p)
  (unless (consp old)
    (setf (wrapper-state old) 
	  (list (if same-p ':flush ':obsolete) new))))

(defun freeze-defstruct (name)
  (let ((tem (and (symbolp name) (get name 's-data))))
    (if tem (setf (s-data-frozen tem) t))))



@s]


****Change:(orig (551 553 c))
@s[  (let ((l (read stream)))
    (unless (get (car l) 'is-a-structure)
            (error "~S is not a structure." (car l)))

@s|  (let* ((l (prog1 (read stream t nil t)
	      (if *read-suppress*
		  (return-from sharp-s-reader nil))))
	 (sd
	   (or (get (car l) 's-data)
	       
	       (error "~S is not a structure." (car l)))))
    

@s]


****Change:(orig (558 558 c))
@s[         (do ((cs (get (car l) 'structure-constructors) (cdr cs)))

@s|         (do ((cs (s-data-constructors sd) (cdr cs)))

@s]


****Change:(orig (571 571 d))
@s[(set-dispatch-macro-character #\# #\S 'sharp-s-reader)



@s|(set-dispatch-macro-character #\# #\S 'sharp-s-reader)


@s]


****Change:(orig (582 582 c))
@s[(defstruct person name age sex)

@s|(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
		                                        sex)
(defstruct person name (age 20 :type signed-char) (eyes 2 :type signed-char)
		                                        sex)
(defstruct person1 name (age 20 :type fixnum)
		                                        sex)

@s]


****Change:(orig (584 584 c))
@s[(defstruct (astronaut (:include person (age 45))

@s|(defstruct joe a (a1 0 :type (mod  30)) (a2 0 :type (mod  30))
  (a3 0 :type (mod  30)) (a4 0 :type (mod 30)) )

;(defstruct person name age sex)

(defstruct (astronaut (:include person (age 45 :type fixnum))

@s]


****Change:(orig (605 605 a))
@s[  associative
  identity)

@s|  associative
  identity)


@s]

==============================================================================
