Menu
▾
▴
clisp-cvs digest, Vol 1 #932 - 7 msgs
|
From: <cli...@li...> - 2005-01-28 22:06:58
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src stream.d,1.502,1.503 (Sam Steingold) 2. clisp/doc impnotes.dsl,1.10,1.11 common.xsl,1.11,1.12 (Sam Steingold) 3. clisp/src constobj.d,1.169,1.170 (Bruno Haible) 4. clisp/doc impissue.xml,1.19,1.20 (Sam Steingold) 5. clisp/src clos-class1.lisp,1.31,1.32 clos-class3.lisp,1.80,1.81 defstruct.lisp,1.70,1.71 clos-class4.lisp,1.17,1.18 clos-class6.lisp,1.35,1.36 exporting.lisp,1.6,1.7 ChangeLog,1.4159,1.4160 (Bruno Haible) 6. clisp/src makemake.in,1.508,1.509 ChangeLog,1.4160,1.4161 (Bruno Haible) 7. clisp/tests path.tst,1.40,1.41 ChangeLog,1.311,1.312 (Bruno Haible) --__--__-- Message: 1 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src stream.d,1.502,1.503 Date: Fri, 28 Jan 2005 15:07:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31798 Modified Files: stream.d Log Message: comment Index: stream.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/stream.d,v retrieving revision 1.502 retrieving revision 1.503 diff -u -d -r1.502 -r1.503 --- stream.d 27 Jan 2005 22:55:04 -0000 1.502 +++ stream.d 28 Jan 2005 15:07:43 -0000 1.503 @@ -16745,8 +16745,8 @@ return false; if (eq(arg,S(Kbig))) return true; - pushSTACK(arg); # TYPE-ERROR slot DATUM - pushSTACK(O(type_endianness)); # TYPE-ERROR slot EXPECTED-TYPE + pushSTACK(arg); /* TYPE-ERROR slot DATUM */ + pushSTACK(O(type_endianness)); /* TYPE-ERROR slot EXPECTED-TYPE */ pushSTACK(arg); pushSTACK(TheSubr(subr_self)->name); check_value(type_error,GETTEXT("~S: illegal endianness argument ~S")); arg = value1; --__--__-- Message: 2 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impnotes.dsl,1.10,1.11 common.xsl,1.11,1.12 Date: Fri, 28 Jan 2005 15:56:05 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10430/doc Modified Files: impnotes.dsl common.xsl Log Message: SF logo is now on sflogo.sourceforge.net Index: common.xsl =================================================================== RCS file: /cvsroot/clisp/clisp/doc/common.xsl,v retrieving revision 1.11 retrieving revision 1.12 diff -u -d -r1.11 -r1.12 --- common.xsl 24 Nov 2004 19:39:31 -0000 1.11 +++ common.xsl 28 Jan 2005 15:56:03 -0000 1.12 @@ -111,7 +111,7 @@ <img src="http://www.gnu.org/graphics/gnubanner.jpg" width="468" height="60" alt="[Come and see what GNU creates for YOU]"/></a></td> <td align="right"><a href="http://sourceforge.net"> - <img src="http://sourceforge.net/sflogo.php?group_id=1355&amp;type=2" + <img src="http://sflogo.sourceforge.net/sflogo.php?group_id=1355&amp;type=2" width="125" height="37" alt="[SourceForge]"/></a></td></tr> </table></div> </xsl:template> Index: impnotes.dsl =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impnotes.dsl,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- impnotes.dsl 5 Jun 2003 16:59:54 -0000 1.10 +++ impnotes.dsl 28 Jan 2005 15:56:03 -0000 1.11 @@ -128,7 +128,7 @@ (make element gi: "a" attributes: '(("href" "http://sourceforge.net")) (make empty-element gi: "img" attributes: - '(("src" "http://sourceforge.net/sflogo.php?group_id=1355&amp;type=2") + '(("src" "http://sflogo.sourceforge.net/sflogo.php?group_id=1355&amp;type=2") ("width" "125") ("height" "37") ("alt" "[SourceForge]"))))))))) --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src constobj.d,1.169,1.170 Date: Fri, 28 Jan 2005 16:39:57 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22427 Modified Files: constobj.d Log Message: Bump O(version). Index: constobj.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constobj.d,v retrieving revision 1.169 retrieving revision 1.170 diff -u -d -r1.169 -r1.170 --- constobj.d 26 Jan 2005 13:25:48 -0000 1.169 +++ constobj.d 28 Jan 2005 16:39:54 -0000 1.170 @@ -330,7 +330,7 @@ LISPOBJ(memory_image_host,"NIL") # the host on which this image was dumped /* The date of the last change of the bytecode interpreter or the arglist of any built-in function in FUNTAB */ - LISPOBJ(version,"(20050121)") + LISPOBJ(version,"(20050128)") #ifdef MACHINE_KNOWN LISPOBJ(machine_type_string,"NIL") LISPOBJ(machine_version_string,"NIL") --__--__-- Message: 4 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/doc impissue.xml,1.19,1.20 Date: Fri, 28 Jan 2005 13:48:03 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/doc In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv14277/doc Modified Files: impissue.xml Log Message: typo Index: impissue.xml =================================================================== RCS file: /cvsroot/clisp/clisp/doc/impissue.xml,v retrieving revision 1.19 retrieving revision 1.20 diff -u -d -r1.19 -r1.20 --- impissue.xml 27 Jan 2005 18:06:23 -0000 1.19 +++ impissue.xml 28 Jan 2005 13:48:01 -0000 1.20 @@ -383,7 +383,7 @@ <varlistentry id="iss349"><term>&iss349;</term>&yes;</varlistentry> <varlistentry id="iss350"><term>&iss350;</term>&no;</varlistentry> <varlistentry id="iss351"><term>&iss351;</term>&yes;</varlistentry> - <varlistentry id="iss352"><term>&iss352;</term>&yes</varlistentry> + <varlistentry id="iss352"><term>&iss352;</term>&yes;</varlistentry> <varlistentry id="iss353"><term>&iss353;</term>&yes;</varlistentry> <varlistentry id="iss354"><term>&iss354;</term>&yes;</varlistentry> <varlistentry id="iss355"><term>&iss355;</term>&yes;</varlistentry> --__--__-- Message: 5 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class1.lisp,1.31,1.32 clos-class3.lisp,1.80,1.81 defstruct.lisp,1.70,1.71 clos-class4.lisp,1.17,1.18 clos-class6.lisp,1.35,1.36 exporting.lisp,1.6,1.7 ChangeLog,1.4159,1.4160 Date: Fri, 28 Jan 2005 13:59:06 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16341/src Modified Files: clos-class1.lisp clos-class3.lisp defstruct.lisp clos-class4.lisp clos-class6.lisp exporting.lisp ChangeLog Log Message: Create a separate API for retrieving structure information by name. Don't overload the class-* API with unrelated functionality and different concepts. Index: clos-class6.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class6.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- clos-class6.lisp 25 Jan 2005 14:35:12 -0000 1.35 +++ clos-class6.lisp 28 Jan 2005 13:58:46 -0000 1.36 @@ -136,11 +136,6 @@ (:method ((class defined-class)) (check-class-initialized class 2) (sys::%record-ref class *<defined-class>-direct-slots-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-slots-location*) - (class-direct-slots (find-class class))))) (:method ((class forward-reference-to-class)) ;; Broken MOP. Any use of this method is a bug. (warn (TEXT "~S being called on ~S, but class ~S is not yet defined.") @@ -148,21 +143,9 @@ '())) (initialize-extended-method-check #'class-direct-slots) ;; Not in MOP. -(defgeneric (setf class-direct-slots) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'defined-class '(setf class-direct-slots)) - (setf (sys::%record-ref class *<defined-class>-direct-slots-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-slots-location*) - (class-direct-slots (find-class class))) - new-value))) - (:method (new-value (class forward-reference-to-class)) - ;; Broken MOP. Any use of this method is a bug. - (warn (TEXT "~S being called on (~S ~S), but class ~S is not yet defined.") - '(setf class-direct-slots) new-value class (class-name class)) - '())) +(defun (setf class-direct-slots) (new-value class) + (accessor-typecheck class 'defined-class '(setf class-direct-slots)) + (setf (sys::%record-ref class *<defined-class>-direct-slots-location*) new-value)) ;; MOP p. 77 (defgeneric class-slots (class) @@ -267,25 +250,12 @@ (setf (sys::%record-ref class *<slotted-class>-valid-initargs-from-slots-location*) new-value)) ;; Not in MOP. -(defgeneric class-instance-size (class) - (:method ((class defined-class)) - (accessor-typecheck class 'slotted-class 'class-instance-size) - (sys::%record-ref class *<slotted-class>-instance-size-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-size-location*) - (class-instance-size (find-class class)))))) -(defgeneric (setf class-instance-size) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'slotted-class '(setf class-instance-size)) - (setf (sys::%record-ref class *<slotted-class>-instance-size-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-size-location*) - (class-instance-size (find-class class))) - new-value)))) +(defun class-instance-size (class) + (accessor-typecheck class 'slotted-class 'class-instance-size) + (sys::%record-ref class *<slotted-class>-instance-size-location*)) +(defun (setf class-instance-size) (new-value class) + (accessor-typecheck class 'slotted-class '(setf class-instance-size)) + (setf (sys::%record-ref class *<slotted-class>-instance-size-location*) new-value)) ;; Not in MOP. (defun class-names (class) @@ -296,88 +266,36 @@ (setf (sys::%record-ref class *<structure-class>-names-location*) new-value)) ;; Not in MOP. -(defgeneric class-kconstructor (class) - (:method ((class defined-class)) - (accessor-typecheck class 'structure-class 'class-kconstructor) - (sys::%record-ref class *<structure-class>-kconstructor-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-kconstructor-location*) - (class-kconstructor (find-class class)))))) -(defgeneric (setf class-kconstructor) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'structure-class '(setf class-kconstructor)) - (setf (sys::%record-ref class *<structure-class>-kconstructor-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-kconstructor-location*) - (class-kconstructor (find-class class))) - new-value)))) +(defun class-kconstructor (class) + (accessor-typecheck class 'structure-class 'class-kconstructor) + (sys::%record-ref class *<structure-class>-kconstructor-location*)) +(defun (setf class-kconstructor) (new-value class) + (accessor-typecheck class 'structure-class '(setf class-kconstructor)) + (setf (sys::%record-ref class *<structure-class>-kconstructor-location*) new-value)) ;; Not in MOP. -(defgeneric class-boa-constructors (class) - (:method ((class defined-class)) - (accessor-typecheck class 'structure-class 'class-boa-constructors) - (sys::%record-ref class *<structure-class>-boa-constructors-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-boa-constructors-location*) - (class-boa-constructors (find-class class)))))) -(defgeneric (setf class-boa-constructors) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'structure-class '(setf class-boa-constructors)) - (setf (sys::%record-ref class *<structure-class>-boa-constructors-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-boa-constructors-location*) - (class-boa-constructors (find-class class))) - new-value)))) +(defun class-boa-constructors (class) + (accessor-typecheck class 'structure-class 'class-boa-constructors) + (sys::%record-ref class *<structure-class>-boa-constructors-location*)) +(defun (setf class-boa-constructors) (new-value class) + (accessor-typecheck class 'structure-class '(setf class-boa-constructors)) + (setf (sys::%record-ref class *<structure-class>-boa-constructors-location*) new-value)) ;; Not in MOP. -(defgeneric class-copier (class) - (:method ((class defined-class)) - (accessor-typecheck class 'structure-class 'class-copier) - (sys::%record-ref class *<structure-class>-copier-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-copier-location*) - (class-copier (find-class class)))))) -(defgeneric (setf class-copier) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'structure-class '(setf class-copier)) - (setf (sys::%record-ref class *<structure-class>-copier-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-copier-location*) - (class-copier (find-class class))) - new-value)))) +(defun class-copier (class) + (accessor-typecheck class 'structure-class 'class-copier) + (sys::%record-ref class *<structure-class>-copier-location*)) +(defun (setf class-copier) (new-value class) + (accessor-typecheck class 'structure-class '(setf class-copier)) + (setf (sys::%record-ref class *<structure-class>-copier-location*) new-value)) ;; Not in MOP. -(defgeneric class-predicate (class) - (:method ((class defined-class)) - (accessor-typecheck class 'structure-class 'class-predicate) - (sys::%record-ref class *<structure-class>-predicate-location*)) - (:method ((class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (if descriptor - (svref descriptor sys::*defstruct-description-predicate-location*) - (class-predicate (find-class class)))))) -(defgeneric (setf class-predicate) (new-value class) - (:method (new-value (class defined-class)) - (accessor-typecheck class 'structure-class '(setf class-predicate)) - (setf (sys::%record-ref class *<structure-class>-predicate-location*) new-value)) - (:method (new-value (class symbol)) - (let ((descriptor (get class 'SYS::DEFSTRUCT-DESCRIPTION))) - (setf (if descriptor - (svref descriptor sys::*defstruct-description-predicate-location*) - (class-predicate (find-class class))) - new-value)))) +(defun class-predicate (class) + (accessor-typecheck class 'structure-class 'class-predicate) + (sys::%record-ref class *<structure-class>-predicate-location*)) +(defun (setf class-predicate) (new-value class) + (accessor-typecheck class 'structure-class '(setf class-predicate)) + (setf (sys::%record-ref class *<structure-class>-predicate-location*) new-value)) ;; Not in MOP. (defun class-current-version (class) Index: exporting.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/exporting.lisp,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- exporting.lisp 24 Jan 2005 10:32:13 -0000 1.6 +++ exporting.lisp 28 Jan 2005 13:58:46 -0000 1.7 @@ -107,17 +107,17 @@ (cl:defun class-accessor-symbols (class) ; ABI (all-accessor-symbols (clos:class-direct-slots class))) -(cl:defun export-accessories (name) +(cl:defun export-structure-accessories (name) ; ABI (export name) - (export (clos::class-kconstructor name)) - (export (clos::class-boa-constructors name)) - (export (clos::class-copier name)) - (export (clos::class-predicate name)) - (export (class-accessor-symbols name))) + (export (sys::structure-kconstructor name)) + (export (sys::structure-boa-constructors name)) + (export (sys::structure-copier name)) + (export (sys::structure-predicate name)) + (export (all-accessor-symbols (sys::structure-slots name)))) (cl:defmacro defstruct (name+options &rest slots) `(LET ((NAME (CL:DEFSTRUCT ,name+options ,@slots))) - (EXPORT-ACCESSORIES NAME) + (EXPORT-STRUCTURE-ACCESSORIES NAME) NAME)) (cl:defmacro defclass (name superclasses slot-specs &rest options) @@ -168,7 +168,7 @@ #+FFI (cl:defmacro def-c-struct (name+options &rest slots) `(LET ((NAME (FFI:DEF-C-STRUCT ,name+options ,@slots))) - (EXPORT-ACCESSORIES NAME) + (EXPORT-STRUCTURE-ACCESSORIES NAME) NAME)) #+FFI Index: clos-class4.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class4.lisp,v retrieving revision 1.17 retrieving revision 1.18 diff -u -d -r1.17 -r1.18 --- clos-class4.lisp 25 Jan 2005 14:35:12 -0000 1.17 +++ clos-class4.lisp 28 Jan 2005 13:58:46 -0000 1.18 @@ -44,7 +44,7 @@ ((direct-slots direct-slots-as-metaobjects) '()) ((names names) nil) ((kconstructor kconstructor) nil) - ((boa-constructors boa-constructors) nil) + ((boa-constructors boa-constructors) '()) ((copier copier) nil) ((predicate predicate) nil) ((slots slots) '()) ((size size) 1)) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4159 retrieving revision 1.4160 diff -u -d -r1.4159 -r1.4160 --- ChangeLog 27 Jan 2005 22:55:11 -0000 1.4159 +++ ChangeLog 28 Jan 2005 13:58:46 -0000 1.4160 @@ -1,3 +1,29 @@ +2005-01-27 Bruno Haible <br...@cl...> + + * clos-class3.lisp (structure-undefine-accessories): Remove function, + moved to defstruct.lisp. + * defstruct.lisp (structure-undefine-accessories): Remove preliminary + definition. + (defstruct): Update. + (structure-slots, structure-instance-size, structure-kconstructor, + structure-boa-constructors, structure-copier, structure-predicate): New + functions. + (structure-undefine-accessories): Moved here from clos-class3.lisp. + Do nothing if name is not currently defined as a structure type. + * clos-class6.lisp (class-direct-slots@symbol): Remove method. + ((setf class-direct-slots)): Back to a plain function expecting a + <defined-class> instance. + (class-instance-size, (setf class-instance-size)): Likewise. + (class-kconstructor, (setf class-kconstructor)): Turn into a plain + function expecting a <structure-class> instance. + (class-boa-constructors, (setf class-boa-constructors)): Likewise. + (class-copier, (setf class-copier)): Likewise. + (class-predicate, (setf class-predicate)): Likewise. + * exporting.lisp (export-structure-accessories): Renamed from + export-accessories. Use the list of effective slot names, not the + list of direct slot names. + (defstruct, def-c-struct): Update. + 2005-01-27 Sam Steingold <sd...@gn...> * stream.d (check_endianness_arg): renamed from test_endianness_arg() Index: defstruct.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defstruct.lisp,v retrieving revision 1.70 retrieving revision 1.71 diff -u -d -r1.70 -r1.71 --- defstruct.lisp 25 Jan 2005 14:35:11 -0000 1.70 +++ defstruct.lisp 28 Jan 2005 13:58:46 -0000 1.71 @@ -21,9 +21,9 @@ size is the list length / vector length. keyword-constructor = NIL or the name of the keyword-constructor - boa-constructors = list of BOA constructors - copier = NIL or the copier - predicate = NIL or the predicate + boa-constructors = list of names of BOA constructors + copier = NIL or the name of the copier function + predicate = NIL or the name of the predicate function slotlist is a packed description of the slots of a structure: slotlist = ({slot}*) @@ -66,6 +66,7 @@ ALLOCATE-INSTANCE, without need for corresponding effective-slot-definition. |# +;; Indices of the fixed elements of a defstruct-description: (defconstant *defstruct-description-type-location* 0) (defconstant *defstruct-description-size-location* 1) (defconstant *defstruct-description-kconstructor-location* 2) @@ -74,12 +75,12 @@ (defconstant *defstruct-description-copier-location* 5) (defconstant *defstruct-description-predicate-location* 6) (proclaim '(constant-inline *defstruct-description-type-location* - *defstruct-description-size-location* - *defstruct-description-kconstructor-location* - *defstruct-description-slots-location* - *defstruct-description-boa-constructors-location* - *defstruct-description-copier-location* - *defstruct-description-predicate-location*)) + *defstruct-description-size-location* + *defstruct-description-kconstructor-location* + *defstruct-description-slots-location* + *defstruct-description-boa-constructors-location* + *defstruct-description-copier-location* + *defstruct-description-predicate-location*)) (defun make-ds-slot (name initargs offset initer type readonly) (clos::make-instance-<structure-effective-slot-definition> @@ -567,10 +568,6 @@ (declare (ignore name)) nil) -(predefun clos::structure-undefine-accessories (name) ; preliminary - (declare (ignore name)) - nil) - (defmacro defstruct (&whole whole-form name-and-options . docstring-and-slotargs) (let ((name name-and-options) @@ -1073,11 +1070,17 @@ `(EVAL-WHEN (LOAD COMPILE EVAL) (LET () (LET ,(append namesbinding (mapcar #'list slotdefaultvars slotdefaultfuns)) - (CLOS::STRUCTURE-UNDEFINE-ACCESSORIES ',name) + ;; ANSI CL doesn't specify what happens when a structure is + ;; redefined with different specification. We do here what DEFCLASS + ;; also does: remove the accessory functions defined by the previous + ;; specification. + (STRUCTURE-UNDEFINE-ACCESSORIES ',name) ,(if (eq type-option 'T) `(REMPROP ',name 'DEFSTRUCT-DESCRIPTION) `(%PUT ',name 'DEFSTRUCT-DESCRIPTION - (VECTOR ',type-option ,size ',keyword-constructor + (VECTOR ',type-option + ,size + ',keyword-constructor (LIST ,@(mapcar #'(lambda (slot+initff) (let ((slot (car slot+initff))) @@ -1086,12 +1089,16 @@ (let ((i (position slot+initff slotdefaultslots))) (if i (nth i slotdefaultvars) (cdr slot+initff)))))) slotlist)) - ',boa-constructors ',copier-option + ',boa-constructors + ',copier-option ',predicate-option))) ,(if (eq type-option 'T) `(CLOS::DEFINE-STRUCTURE-CLASS ',name - ,namesform ',keyword-constructor ',boa-constructors - ',copier-option ',predicate-option + ,namesform + ',keyword-constructor + ',boa-constructors + ',copier-option + ',predicate-option (LIST ,@(mapcar #'(lambda (slot+initff) (let ((slot (car slot+initff))) @@ -1127,3 +1134,111 @@ (PROGN ,print-object-option)) `(CLOS::DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD ',name)))) ',name)))) + + +;; A kind of Meta-Object Protocol for structures. +;; These function apply to structures of any representation +;; (structure classes as well as subtypes of LIST or VECTOR). +;; This differs from the CLOS MOP +;; 1. in the use of a structure name (symbol) instead of a class, +;; 2. in the different set of available operations: classes in general +;; don't have kconstructors, boa-constructors, copier, predicate, +;; whereas on the other hand structures in general don't have a prototype +;; and finalization. + +(defun structure-slots (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-slots-location*) + (let ((class (find-class name))) + (clos::accessor-typecheck class 'structure-class 'structure-slots) + (clos::class-slots class))))) +#| +(defun (setf structure-slots) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-slots-location*) new-value) + (let ((class (find-class name))) + (clos::accessor-typecheck class 'structure-class '(setf structure-slots)) + (setf (clos::class-slots class) new-value))))) +|# + +(defun structure-instance-size (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-size-location*) + (let ((class (find-class name))) + (clos::accessor-typecheck class 'structure-class 'structure-instance-size) + (clos::class-instance-size class))))) +#| +(defun (setf structure-instance-size) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-size-location*) new-value) + (let ((class (find-class name))) + (clos::accessor-typecheck class 'structure-class '(setf structure-instance-size)) + (setf (clos::class-instance-size class) new-value))))) +|# + +(defun structure-kconstructor (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-kconstructor-location*) + (clos::class-kconstructor (find-class name))))) +#| +(defun (setf structure-kconstructor) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-kconstructor-location*) new-value) + (setf (clos::class-kconstructor (find-class name)) new-value)))) +|# + +(defun structure-boa-constructors (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-boa-constructors-location*) + (clos::class-boa-constructors (find-class name))))) +#| +(defun (setf structure-boa-constructors) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-boa-constructors-location*) new-value) + (setf (clos::class-boa-constructors (find-class name)) new-value)))) +|# + +(defun structure-copier (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-copier-location*) + (clos::class-copier (find-class name))))) +#| +(defun (setf structure-copier) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-copier-location*) new-value) + (setf (clos::class-copier (find-class name)) new-value)))) +|# + +(defun structure-predicate (name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (svref desc *defstruct-description-predicate-location*) + (clos::class-predicate (find-class name))))) +#| +(defun (setf structure-predicate) (new-value name) + (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) + (if desc + (setf (svref desc *defstruct-description-predicate-location*) new-value) + (setf (clos::class-predicate (find-class name)) new-value)))) +|# + +(defun structure-undefine-accessories (name) ; ABI + (when (or (get name 'DEFSTRUCT-DESCRIPTION) + (clos::structure-class-p (find-class name nil))) + (macrolet ((fmakunbound-if-present (symbol-form) + `(let ((symbol ,symbol-form)) + (when symbol (fmakunbound symbol))))) + (fmakunbound-if-present (structure-kconstructor name)) + (mapc #'fmakunbound (structure-boa-constructors name)) + (fmakunbound-if-present (structure-copier name)) + (fmakunbound-if-present (structure-predicate name))))) Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.80 retrieving revision 1.81 diff -u -d -r1.80 -r1.81 --- clos-class3.lisp 21 Jan 2005 17:42:27 -0000 1.80 +++ clos-class3.lisp 28 Jan 2005 13:58:46 -0000 1.81 @@ -1850,14 +1850,6 @@ :generic-accessors nil))) (defun undefine-structure-class (name) ; ABI (setf (find-class name) nil)) -(defun structure-undefine-accessories (name) ; ABI - (macrolet ((undef (accessor) - `(let ((symbol (,accessor name))) - (when symbol (fmakunbound symbol))))) - (undef class-kconstructor) - (mapc #'fmakunbound (class-boa-constructors name)) - (undef class-copier) - (undef class-predicate))) ;; ------------- Creation of an instance of <semi-standard-class> ------------- Index: clos-class1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class1.lisp,v retrieving revision 1.31 retrieving revision 1.32 diff -u -d -r1.31 -r1.32 --- clos-class1.lisp 25 Jan 2005 14:35:12 -0000 1.31 +++ clos-class1.lisp 28 Jan 2005 13:58:45 -0000 1.32 @@ -483,11 +483,11 @@ :type cons) ; name_1 contains name_2, ..., name_i-1 contains name_i. ($kconstructor ; name of keyword constructor function :type symbol) - ($boa-constructors ; list of all BOA constructor functions + ($boa-constructors ; list of all BOA constructor function names :type list) - ($copier ; name of the copier + ($copier ; name of the copier function :type symbol) - ($predicate ; name of the predicate + ($predicate ; name of the predicate function :type symbol)) (:fixed-slot-locations t))) (defvar *<structure-class>-class-version* (make-class-version)) --__--__-- Message: 6 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src makemake.in,1.508,1.509 ChangeLog,1.4160,1.4161 Date: Fri, 28 Jan 2005 14:00:33 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16617/src Modified Files: makemake.in ChangeLog Log Message: Detect errors that occur while constructing a mem file. Index: makemake.in =================================================================== RCS file: /cvsroot/clisp/clisp/src/makemake.in,v retrieving revision 1.508 retrieving revision 1.509 diff -u -d -r1.508 -r1.509 --- makemake.in 26 Jan 2005 13:35:18 -0000 1.508 +++ makemake.in 28 Jan 2005 14:00:25 -0000 1.509 @@ -2930,7 +2930,7 @@ fi # The strict minimum needed for building interpreted.mem is between 1100KW # and 1200KW. To reduce GCs, we spend 20% more than this. - echotab '$(RUN) -m 1400KW -x "(and (load \"init.lisp\") (sys::%saveinitmem) (ext::exit))"' + echotab '$(RUN) -m 1400KW -x "(and (load \"init.lisp\") (sys::%saveinitmem) (ext::exit)) (ext::exit t)"' echotab "\$(MV) lispimag.mem interpreted.mem" echol @@ -2972,7 +2972,7 @@ echotab "cp -p lisp${LEXE} lisp.tmp" echotab "mv lisp.tmp lisp${LEXE}" fi - echotab '$(RUN) -m 1400KW -x "(and (load \"init.lisp\") (sys::%saveinitmem) (ext::exit))"' + echotab '$(RUN) -m 1400KW -x "(and (load \"init.lisp\") (sys::%saveinitmem) (ext::exit)) (ext::exit t)"' echotab "\$(MV) lispimag.mem halfcompiled.mem" echol @@ -2985,7 +2985,7 @@ echotab "cp -p lisp${LEXE} lisp.tmp" echotab "mv lisp.tmp lisp${LEXE}" fi - echotab '$(RUN) -x "(and (load \"init.fas\") (ext::saveinitmem) (ext::exit))"' + echotab '$(RUN) -x "(and (load \"init.fas\") (ext::saveinitmem) (ext::exit)) (ext::exit t)"' echol fi @@ -3083,7 +3083,7 @@ echotab "cp -p lisp${LEXE} lisp.tmp" echotab "mv lisp.tmp lisp${LEXE}" fi - echotab '$(RUN) -x "(and (cd \"'"${RECOMPILEDIR}${NEXT}"'\") (load \"init.fas\") (cd \"'"${PARENT}"'\") (sys::%saveinitmem) (ext::exit))"' + echotab '$(RUN) -x "(and (cd \"'"${RECOMPILEDIR}${NEXT}"'\") (load \"init.fas\") (cd \"'"${PARENT}"'\") (sys::%saveinitmem) (ext::exit)) (ext::exit t)"' echotab "-\$(RM) lispinit2.mem" echotab "\$(MV) lispimag.mem lispinit2.mem" echol Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.4160 retrieving revision 1.4161 diff -u -d -r1.4160 -r1.4161 --- ChangeLog 28 Jan 2005 13:58:46 -0000 1.4160 +++ ChangeLog 28 Jan 2005 14:00:27 -0000 1.4161 @@ -1,5 +1,10 @@ 2005-01-27 Bruno Haible <br...@cl...> + * makemake.in (interpreted.mem, halfcompiled.mem, lispinit.mem, + lispinit2.mem): Exit with error code if an error occurs. + +2005-01-27 Bruno Haible <br...@cl...> + * clos-class3.lisp (structure-undefine-accessories): Remove function, moved to defstruct.lisp. * defstruct.lisp (structure-undefine-accessories): Remove preliminary --__--__-- Message: 7 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/tests path.tst,1.40,1.41 ChangeLog,1.311,1.312 Date: Fri, 28 Jan 2005 14:01:58 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17023/tests Modified Files: path.tst ChangeLog Log Message: Fix (logical-pathname ":"). Index: path.tst =================================================================== RCS file: /cvsroot/clisp/clisp/tests/path.tst,v retrieving revision 1.40 retrieving revision 1.41 diff -u -d -r1.40 -r1.41 --- path.tst 19 Dec 2004 18:44:56 -0000 1.40 +++ path.tst 28 Jan 2005 14:01:56 -0000 1.41 @@ -578,6 +578,13 @@ #-CLISP FIXME +(logical-pathname ":") +#+CLISP +#S(LOGICAL-PATHNAME :HOST "" :DEVICE NIL :DIRECTORY (:ABSOLUTE) + :NAME NIL :TYPE NIL :VERSION NIL) +#-CLISP +FIXME + (merge-pathnames (logical-pathname "cl-systems:") "metering.system") #+CLISP #S(LOGICAL-PATHNAME :HOST "CL-SYSTEMS" :DEVICE NIL :DIRECTORY (:ABSOLUTE) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v retrieving revision 1.311 retrieving revision 1.312 diff -u -d -r1.311 -r1.312 --- ChangeLog 26 Jan 2005 13:02:41 -0000 1.311 +++ ChangeLog 28 Jan 2005 14:01:56 -0000 1.312 @@ -1,3 +1,7 @@ +2005-01-27 Bruno Haible <br...@cl...> + + * path.tst: Add test for (logical-pathname ":"). + 2005-01-26 Bruno Haible <br...@cl...> * setf.tst: Add a test for SETF VALUES-LIST. --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |
![http://www.gnu.org/graphics/gnubanner.jpg"](http://www.gnu.org/graphics/gnubanner.jpg"){kind=link}