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)&&ic.c_cdr, i++) { *p = make_cons(car(s->c.c_car), Cnil); @s| for (i=0, n=def->length; !endp(s)&&ic.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; iv.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; istr.str_def,i,svalue);} for(i=0,slots_tail=slots; istr.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; iv.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] ==============================================================================