From: <cli...@li...> - 2004-07-23 22:13:06
|
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 clos-class3.lisp,1.22,1.23 ChangeLog,1.3319,1.3320 (Bruno Haible) 2. clisp/src defs1.lisp,1.35,1.36 clos-class3.lisp,1.23,1.24 ChangeLog,1.3320,1.3321 (Bruno Haible) 3. clisp/src type.lisp,1.60,1.61 subtypep.lisp,1.6,1.7 compiler.lisp,1.202,1.203 ChangeLog,1.3321,1.3322 (Bruno Haible) 4. clisp/src clos-class3.lisp,1.24,1.25 clos-slotdef2.lisp,1.3,1.4 clos-specializer2.lisp,1.3,1.4 ChangeLog,1.3322,1.3323 (Bruno Haible) 5. clisp/src genclisph.d,1.138,1.139 ChangeLog,1.3323,1.3324 (Sam Steingold) 6. clisp/utils modprep.lisp,1.10,1.11 (Sam Steingold) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class3.lisp,1.22,1.23 ChangeLog,1.3319,1.3320 Date: Fri, 23 Jul 2004 10:50:14 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15894/src Modified Files: clos-class3.lisp ChangeLog Log Message: More efficient slot accessors for slots at fixed slot locations. Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.22 retrieving revision 1.23 diff -u -d -r1.22 -r1.23 --- clos-class3.lisp 22 Jul 2004 10:32:30 -0000 1.22 +++ clos-class3.lisp 23 Jul 2004 10:50:11 -0000 1.23 @@ -1201,79 +1201,93 @@ (dolist (slot (class-direct-slots class)) (let ((slot-name (slot-definition-name slot)) (readers (slot-definition-readers slot)) - (writers (slot-definition-writers slot)) - (generic-p (class-generic-accessors class))) - ; Generic accessors are defined as methods and listed in the - ; direct-accessors list, so they can be removed upon class redefinition. - ; Non-generic accessors are defined as plain functions. - (dolist (funname readers) - (if generic-p - (setf (class-direct-accessors class) - (list* funname - (do-defmethod funname - (let* ((args - (list - :initfunction - (eval - `#'(LAMBDA (#:SELF) - (DECLARE (COMPILE)) - (%OPTIMIZE-FUNCTION-LAMBDA (T) (#:CONTINUATION OBJECT) - (DECLARE (COMPILE)) - (SLOT-VALUE OBJECT ',slot-name)))) - :wants-next-method-p t - :parameter-specializers (list class) - :qualifiers nil - :signature (make-signature :req-num 1) - :slot-definition slot)) - (method-class - (apply #'reader-method-class class slot args))) - (unless (and (class-p method-class) - (subclassp method-class <standard-reader-method>)) - (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") - 'reader-method-class (class-name class) 'standard-reader-method method-class)) - (apply #'make-instance method-class args))) - (class-direct-accessors class))) - (setf (fdefinition funname) - (eval `(FUNCTION ,funname - (LAMBDA (OBJECT) - ,@(if *compile-accessor-functions* '((DECLARE (COMPILE)))) - (UNLESS (TYPEP OBJECT ',class) - (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) - (SLOT-VALUE OBJECT ',slot-name))))))) - (dolist (funname writers) - (if generic-p - (setf (class-direct-accessors class) - (list* funname - (do-defmethod funname - (let* ((args - (list - :initfunction - (eval - `#'(LAMBDA (#:SELF) - (DECLARE (COMPILE)) - (%OPTIMIZE-FUNCTION-LAMBDA (T) (#:CONTINUATION NEW-VALUE OBJECT) - (DECLARE (COMPILE)) - (SETF (SLOT-VALUE OBJECT ',slot-name) NEW-VALUE)))) - :wants-next-method-p t - :parameter-specializers (list <t> class) - :qualifiers nil - :signature (make-signature :req-num 2) - :slot-definition slot)) - (method-class - (apply #'writer-method-class class slot args))) - (unless (and (class-p method-class) - (subclassp method-class <standard-writer-method>)) - (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") - 'writer-method-class (class-name class) 'standard-writer-method method-class)) - (apply #'make-instance method-class args))) - (class-direct-accessors class))) - (setf (fdefinition funname) - (eval `(FUNCTION ,funname - (LAMBDA (NEW-VALUE OBJECT) - ,@(if *compile-accessor-functions* '((DECLARE (COMPILE)))) - (UNLESS (TYPEP OBJECT ',class) - (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) - (SETF (SLOT-VALUE OBJECT ',slot-name) NEW-VALUE)))))))))) + (writers (slot-definition-writers slot))) + (when (or readers writers) + (let ((generic-p (class-generic-accessors class)) + (access-place + (let (effective-slot) + (if (and (standard-class-p class) + (class-fixed-slot-locations class) + (setq effective-slot + (find slot-name (class-slots class) + :key #'slot-definition-name)) + (eq (slot-definition-allocation effective-slot) + ':instance)) + (progn + (assert (typep (slot-definition-location effective-slot) 'integer)) + `(SYS::%RECORD-REF OBJECT ,(slot-definition-location effective-slot))) + `(SLOT-VALUE OBJECT ',slot-name))))) + ; Generic accessors are defined as methods and listed in the + ; direct-accessors list, so they can be removed upon class redefinition. + ; Non-generic accessors are defined as plain functions. + (dolist (funname readers) + (if generic-p + (setf (class-direct-accessors class) + (list* funname + (do-defmethod funname + (let* ((args + (list + :initfunction + (eval + `#'(LAMBDA (#:SELF) + (DECLARE (COMPILE)) + (%OPTIMIZE-FUNCTION-LAMBDA (T) (#:CONTINUATION OBJECT) + (DECLARE (COMPILE)) + ,access-place))) + :wants-next-method-p t + :parameter-specializers (list class) + :qualifiers nil + :signature (make-signature :req-num 1) + :slot-definition slot)) + (method-class + (apply #'reader-method-class class slot args))) + (unless (and (class-p method-class) + (subclassp method-class <standard-reader-method>)) + (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") + 'reader-method-class (class-name class) 'standard-reader-method method-class)) + (apply #'make-instance method-class args))) + (class-direct-accessors class))) + (setf (fdefinition funname) + (eval `(FUNCTION ,funname + (LAMBDA (OBJECT) + ,@(if *compile-accessor-functions* '((DECLARE (COMPILE)))) + (UNLESS (TYPEP OBJECT ',class) + (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) + ,access-place)))))) + (dolist (funname writers) + (if generic-p + (setf (class-direct-accessors class) + (list* funname + (do-defmethod funname + (let* ((args + (list + :initfunction + (eval + `#'(LAMBDA (#:SELF) + (DECLARE (COMPILE)) + (%OPTIMIZE-FUNCTION-LAMBDA (T) (#:CONTINUATION NEW-VALUE OBJECT) + (DECLARE (COMPILE)) + (SETF ,access-place NEW-VALUE)))) + :wants-next-method-p t + :parameter-specializers (list <t> class) + :qualifiers nil + :signature (make-signature :req-num 2) + :slot-definition slot)) + (method-class + (apply #'writer-method-class class slot args))) + (unless (and (class-p method-class) + (subclassp method-class <standard-writer-method>)) + (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S") + 'writer-method-class (class-name class) 'standard-writer-method method-class)) + (apply #'make-instance method-class args))) + (class-direct-accessors class))) + (setf (fdefinition funname) + (eval `(FUNCTION ,funname + (LAMBDA (NEW-VALUE OBJECT) + ,@(if *compile-accessor-functions* '((DECLARE (COMPILE)))) + (UNLESS (TYPEP OBJECT ',class) + (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class)) + (SETF ,access-place NEW-VALUE)))))))))))) ;; Remove a set of accessor methods given as a plist. (defun remove-accessor-methods (plist) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3319 retrieving revision 1.3320 diff -u -d -r1.3319 -r1.3320 --- ChangeLog 22 Jul 2004 17:27:46 -0000 1.3319 +++ ChangeLog 23 Jul 2004 10:50:11 -0000 1.3320 @@ -1,7 +1,13 @@ +2004-06-01 Bruno Haible <br...@cl...> + + * clos-class3.lisp (install-class-direct-accessors): For slots at + fixed slot locations, generate more efficient accessors that use + SYS::%RECORD-REF instead of SLOT-VALUE. + 2004-07-22 Sam Steingold <sd...@gn...> * stream.d (bitbuff_ixs_sub): fixed bitbufferptr initialization - Reported by "Randolph Udodenko" <udo...@us...> + Reported by Randolph Udodenko <udo...@us...> 2004-06-01 Bruno Haible <br...@cl...> @@ -7449,7 +7455,7 @@ 2003-09-04 Sam Steingold <sd...@gn...> * describe.lisp (describe-object) [SOCKETS]: handle SOCKET-SERVER - Reported by "John K. Hinsdale" <hi...@al...> + Reported by John K. Hinsdale <hi...@al...> * genclisph.d (Atype_32Bit): export for gdi (Dan Stanger) 2003-09-03 Sam Steingold <sd...@gn...> @@ -11825,7 +11831,7 @@ * io.d (multi_line_sub_block_out): fixed a crash when block contains several indentations - Reported by "Ribeiro, Glauber" <gla...@ex...> + Reported by Glauber Ribeiro <gla...@ex...> 2002-08-14 Sam Steingold <sd...@gn...> --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src defs1.lisp,1.35,1.36 clos-class3.lisp,1.23,1.24 ChangeLog,1.3320,1.3321 Date: Fri, 23 Jul 2004 10:51:49 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16115/src Modified Files: defs1.lisp clos-class3.lisp ChangeLog Log Message: Don't create a new signature object for each new accessor. Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.23 retrieving revision 1.24 diff -u -d -r1.23 -r1.24 --- clos-class3.lisp 23 Jul 2004 10:50:11 -0000 1.23 +++ clos-class3.lisp 23 Jul 2004 10:51:45 -0000 1.24 @@ -1237,7 +1237,7 @@ :wants-next-method-p t :parameter-specializers (list class) :qualifiers nil - :signature (make-signature :req-num 1) + :signature (sys::memoized (make-signature :req-num 1)) :slot-definition slot)) (method-class (apply #'reader-method-class class slot args))) @@ -1271,7 +1271,7 @@ :wants-next-method-p t :parameter-specializers (list <t> class) :qualifiers nil - :signature (make-signature :req-num 2) + :signature (sys::memoized (make-signature :req-num 2)) :slot-definition slot)) (method-class (apply #'writer-method-class class slot args))) Index: defs1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defs1.lisp,v retrieving revision 1.35 retrieving revision 1.36 diff -u -d -r1.35 -r1.36 --- defs1.lisp 9 Jun 2004 11:17:21 -0000 1.35 +++ defs1.lisp 23 Jul 2004 10:51:45 -0000 1.36 @@ -782,6 +782,21 @@ (write-to-string object :level level :length length) ) ) ) ) +;; (MEMOIZED form) memoizes the result of form from its first evaluation. +(defmacro memoized (form) + `(LET ((MEMORY + (IF (EVAL-WHEN (EVAL) T) + ',(cons nil nil) + ;; Careful: Different expansions of MEMOIZED forms must yield + ;; LOAD-TIME-VALUE forms that are not EQ, otherwise compile-file + ;; will coalesce these LOAD-TIME-VALUE forms. Therefore here we + ;; explicitly cons up the list and don't use backquote. + ,(list 'LOAD-TIME-VALUE '(CONS NIL NIL))))) + (UNLESS (CAR MEMORY) + (SETF (CDR MEMORY) ,form) + (SETF (CAR MEMORY) T)) + (CDR MEMORY))) + ;; *ERROR-HANDLER* should be NIL or a function which accepts the following ;; arguments: ;; - NIL (in case of ERROR) or a continue-format-string (in case of CERROR), Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3320 retrieving revision 1.3321 diff -u -d -r1.3320 -r1.3321 --- ChangeLog 23 Jul 2004 10:50:11 -0000 1.3320 +++ ChangeLog 23 Jul 2004 10:51:46 -0000 1.3321 @@ -1,3 +1,8 @@ +2004-06-04 Bruno Haible <br...@cl...> + + * defs1.lisp (memoized): New macro. + * clos-class3.lisp (install-class-direct-accessors): Use it. + 2004-06-01 Bruno Haible <br...@cl...> * clos-class3.lisp (install-class-direct-accessors): For slots at --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src type.lisp,1.60,1.61 subtypep.lisp,1.6,1.7 compiler.lisp,1.202,1.203 ChangeLog,1.3321,1.3322 Date: Fri, 23 Jul 2004 10:53:17 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16273/src Modified Files: type.lisp subtypep.lisp compiler.lisp ChangeLog Log Message: All specializers must be types. Index: subtypep.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/subtypep.lisp,v retrieving revision 1.6 retrieving revision 1.7 diff -u -d -r1.6 -r1.7 --- subtypep.lisp 15 Jun 2004 10:23:20 -0000 1.6 +++ subtypep.lisp 23 Jul 2004 10:53:13 -0000 1.7 @@ -1657,6 +1657,8 @@ (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type)) (canonicalize-type (clos:class-name type)) type)) + ((clos::eql-specializer-p type) + `(MEMBER ,(clos::eql-specializer-singleton type))) ((encodingp type) #+UNICODE type #-UNICODE 'CHARACTER) Index: type.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/type.lisp,v retrieving revision 1.60 retrieving revision 1.61 diff -u -d -r1.60 -r1.61 --- type.lisp 24 Jun 2004 10:50:40 -0000 1.60 +++ type.lisp 23 Jul 2004 10:53:13 -0000 1.61 @@ -83,6 +83,7 @@ (t (typespec-error 'typep y)) ) ) ((clos::class-p y) (clos::typep-class x y)) + ((clos::eql-specializer-p y) (eql x (clos::eql-specializer-singleton y))) ((encodingp y) (charset-typep x y)) (t (typespec-error 'typep y)) ) ) @@ -965,6 +966,11 @@ (return-from subtype-integer (subtype-integer (clos:class-name type))) (no))) + ((clos::eql-specializer-p type) + (let ((x (clos::eql-specializer-singleton type))) + (if (typep x 'INTEGER) + (let ((low (min 0 x)) (high (max 0 x))) (yes)) + (no)))) ((encodingp type) (no)) (t (typespec-error 'subtypep type))))) Index: compiler.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v retrieving revision 1.202 retrieving revision 1.203 diff -u -d -r1.202 -r1.203 --- compiler.lisp 20 Jul 2004 11:26:55 -0000 1.202 +++ compiler.lisp 23 Jul 2004 10:53:13 -0000 1.203 @@ -6755,6 +6755,10 @@ ,(if (eq (get (clos:class-name type) 'CLOS::CLOSCLASS) type) `(LOAD-TIME-VALUE (CLOS:FIND-CLASS ',(clos:class-name type))) typeform))))) + ((clos::eql-specializer-p type) + (return-from c-TYPEP + (let ((*form* `(EQL ,objform ',(clos::eql-specializer-singleton type)))) + (c-EQL)))) ;; ((sys::encodingp type) ...) ; not worth optimizing ))) (c-GLOBAL-FUNCTION-CALL-form Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3321 retrieving revision 1.3322 diff -u -d -r1.3321 -r1.3322 --- ChangeLog 23 Jul 2004 10:51:46 -0000 1.3321 +++ ChangeLog 23 Jul 2004 10:53:14 -0000 1.3322 @@ -1,3 +1,11 @@ +2004-06-05 Bruno Haible <br...@cl...> + + All specializers must be types. + * type.lisp (typep, subtype-integer): Treat EQL-specializers like + EQL forms. + * subtypep.lisp (canonicalize-type): Likewise. + * compiler.lisp (c-TYPEP): Likewise. + 2004-06-04 Bruno Haible <br...@cl...> * defs1.lisp (memoized): New macro. --__--__-- Message: 4 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src clos-class3.lisp,1.24,1.25 clos-slotdef2.lisp,1.3,1.4 clos-specializer2.lisp,1.3,1.4 ChangeLog,1.3322,1.3323 Date: Fri, 23 Jul 2004 10:56:12 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv16475/src Modified Files: clos-class3.lisp clos-slotdef2.lisp clos-specializer2.lisp ChangeLog Log Message: Make <slot-definition> and its subclasses and <eql-specializer> available as early as possible. Index: clos-slotdef2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-slotdef2.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-slotdef2.lisp 22 Jul 2004 10:30:56 -0000 1.3 +++ clos-slotdef2.lisp 23 Jul 2004 10:56:09 -0000 1.4 @@ -7,19 +7,6 @@ ;;; =========================================================================== -;; Define the class <slot-definition>. -(macrolet ((form () *<slot-definition>-defclass*)) - (form)) - -;; Define the class <direct-slot-definition>. -(macrolet ((form () *<direct-slot-definition>-defclass*)) - (form)) - -;; Define the class <effective-slot-definition>. -(macrolet ((form () *<effective-slot-definition>-defclass*)) - (form)) - - ;;; Lift the initialization protocol. (defmethod initialize-instance ((slotdef slot-definition) &rest args @@ -63,51 +50,21 @@ ;;; --------------------------------------------------------------------------- -;; Define the class <standard-slot-definition>. -(macrolet ((form () *<standard-slot-definition>-defclass*)) - (form)) - -;;; --------------------------------------------------------------------------- - -;; Define the class <standard-direct-slot-definition>. -(defparameter <standard-direct-slot-definition> - (macrolet ((form () *<standard-direct-slot-definition>-defclass*)) - (form))) -(replace-class-version (find-class 'standard-direct-slot-definition) - *<standard-direct-slot-definition>-class-version*) (defmethod initialize-instance ((slotdef standard-direct-slot-definition) &rest args) (apply #'initialize-instance-<standard-direct-slot-definition> slotdef args)) ;;; --------------------------------------------------------------------------- -;; Define the class <standard-effective-slot-definition>. -(defparameter <standard-effective-slot-definition> - (macrolet ((form () *<standard-effective-slot-definition>-defclass*)) - (form))) -(replace-class-version (find-class 'standard-effective-slot-definition) - *<standard-effective-slot-definition>-class-version*) (defmethod initialize-instance ((slotdef standard-effective-slot-definition) &rest args) (apply #'initialize-instance-<standard-effective-slot-definition> slotdef args)) ;;; --------------------------------------------------------------------------- -;; Define the class <structure-direct-slot-definition>. -(defparameter <structure-direct-slot-definition> - (macrolet ((form () *<structure-direct-slot-definition>-defclass*)) - (form))) -(replace-class-version (find-class 'structure-direct-slot-definition) - *<structure-direct-slot-definition>-class-version*) (defmethod initialize-instance ((slotdef structure-direct-slot-definition) &rest args) (apply #'initialize-instance-<structure-direct-slot-definition> slotdef args)) ;;; --------------------------------------------------------------------------- -;; Define the class <structure-effective-slot-definition>. -(defparameter <structure-effective-slot-definition> - (macrolet ((form () *<structure-effective-slot-definition>-defclass*)) - (form))) -(replace-class-version (find-class 'structure-effective-slot-definition) - *<structure-effective-slot-definition>-class-version*) (defun structure-effective-slot-definition-initff (slotdef) (slot-value slotdef 'initff)) (defun (setf structure-effective-slot-definition-initff) (new-value slotdef) Index: clos-specializer2.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-specializer2.lisp,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- clos-specializer2.lisp 18 Jul 2004 11:56:04 -0000 1.3 +++ clos-specializer2.lisp 23 Jul 2004 10:56:10 -0000 1.4 @@ -17,13 +17,6 @@ ;;; =========================================================================== -;; Define the class <eql-specializer>. -(defparameter <eql-specializer> - (macrolet ((form () *<eql-specializer>-defclass*)) - (form))) -(replace-class-version (find-class 'eql-specializer) - *<eql-specializer>-class-version*) - (defmethod shared-initialize ((specializer eql-specializer) situation &rest args &key ((singleton singleton) nil) &allow-other-keys) Index: clos-class3.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- clos-class3.lisp 23 Jul 2004 10:51:45 -0000 1.24 +++ clos-class3.lisp 23 Jul 2004 10:56:09 -0000 1.25 @@ -1895,6 +1895,59 @@ '() '())) + ;; 10. Define other classes whose definition was delayed. + + ;; Define the class <slot-definition>. + (macrolet ((form () *<slot-definition>-defclass*)) + (form)) + + ;; Define the class <direct-slot-definition>. + (macrolet ((form () *<direct-slot-definition>-defclass*)) + (form)) + + ;; Define the class <effective-slot-definition>. + (macrolet ((form () *<effective-slot-definition>-defclass*)) + (form)) + + ;; Define the class <standard-slot-definition>. + (macrolet ((form () *<standard-slot-definition>-defclass*)) + (form)) + + ;; Define the class <standard-direct-slot-definition>. + (setq <standard-direct-slot-definition> + (macrolet ((form () *<standard-direct-slot-definition>-defclass*)) + (form))) + (replace-class-version (find-class 'standard-direct-slot-definition) + *<standard-direct-slot-definition>-class-version*) + + ;; Define the class <standard-effective-slot-definition>. + (setq <standard-effective-slot-definition> + (macrolet ((form () *<standard-effective-slot-definition>-defclass*)) + (form))) + (replace-class-version (find-class 'standard-effective-slot-definition) + *<standard-effective-slot-definition>-class-version*) + + ;; Define the class <structure-direct-slot-definition>. + (setq <structure-direct-slot-definition> + (macrolet ((form () *<structure-direct-slot-definition>-defclass*)) + (form))) + (replace-class-version (find-class 'structure-direct-slot-definition) + *<structure-direct-slot-definition>-class-version*) + + ;; Define the class <structure-effective-slot-definition>. + (setq <structure-effective-slot-definition> + (macrolet ((form () *<structure-effective-slot-definition>-defclass*)) + (form))) + (replace-class-version (find-class 'structure-effective-slot-definition) + *<structure-effective-slot-definition>-class-version*) + + ;; Define the class <eql-specializer>. + (setq <eql-specializer> + (macrolet ((form () *<eql-specializer>-defclass*)) + (form))) + (replace-class-version (find-class 'eql-specializer) + *<eql-specializer>-class-version*) + );progn ;;; Install built-in classes: Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3322 retrieving revision 1.3323 diff -u -d -r1.3322 -r1.3323 --- ChangeLog 23 Jul 2004 10:53:14 -0000 1.3322 +++ ChangeLog 23 Jul 2004 10:56:10 -0000 1.3323 @@ -1,5 +1,13 @@ 2004-06-05 Bruno Haible <br...@cl...> + * clos-class3.lisp: Define <slot-definition> and its subclasses and + <eql-specializer> here. + * clos-slotdef2.lisp: Move the class definition forms to + clos-class3.lisp. + * clos-specializer2.lisp: Likewise. + +2004-06-05 Bruno Haible <br...@cl...> + All specializers must be types. * type.lisp (typep, subtype-integer): Treat EQL-specializers like EQL forms. --__--__-- Message: 5 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/src genclisph.d,1.138,1.139 ChangeLog,1.3323,1.3324 Date: Fri, 23 Jul 2004 22:08:25 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3757/src Modified Files: genclisph.d ChangeLog Log Message: (main): export CLSTEXT Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.138 retrieving revision 1.139 diff -u -d -r1.138 -r1.139 --- genclisph.d 21 Jul 2004 23:41:35 -0000 1.138 +++ genclisph.d 23 Jul 2004 22:08:20 -0000 1.139 @@ -1471,9 +1471,11 @@ #ifndef LANGUAGE_STATIC #ifndef GNU_GETTEXT printf("#define GETTEXT(english) english\n"); + printf("#define CLSTEXT ascii_to_string\n"); #else printf("extern const char * clgettext (const char * msgid);\n"); printf("#define GETTEXT clgettext\n"); + printf("extern object CLSTEXT (const char* asciz);\n"); #endif #endif printf("extern object allocate_cons (void);\n"); Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3323 retrieving revision 1.3324 diff -u -d -r1.3323 -r1.3324 --- ChangeLog 23 Jul 2004 10:56:10 -0000 1.3323 +++ ChangeLog 23 Jul 2004 22:08:21 -0000 1.3324 @@ -1,3 +1,7 @@ +2004-07-22 Sam Steingold <sd...@gn...> + + * genclisph.d (main): export CLSTEXT + 2004-06-05 Bruno Haible <br...@cl...> * clos-class3.lisp: Define <slot-definition> and its subclasses and --__--__-- Message: 6 From: Sam Steingold <sd...@us...> To: cli...@li... Subject: clisp/utils modprep.lisp,1.10,1.11 Date: Fri, 23 Jul 2004 22:11:08 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/utils In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4263/utils Modified Files: modprep.lisp Log Message: DEFCHECKER can now handle constants that come from "enum" and therefore not available to CPP Index: modprep.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/utils/modprep.lisp,v retrieving revision 1.10 retrieving revision 1.11 diff -u -d -r1.10 -r1.11 --- modprep.lisp 24 Jun 2004 20:01:49 -0000 1.10 +++ modprep.lisp 23 Jul 2004 22:11:05 -0000 1.11 @@ -50,17 +50,18 @@ return ret; }} it is convenient for parsing flag arguments to DEFUNs -- DEFCHECKER(c_name,C_CONST1 C_CONST2 C_CONST3) +- DEFCHECKER(c_name,C_CONST1 C_CONST2 C_CONST3) or + DEFCHECKER(c_name,enum_type, C_CONST1 C_CONST2 C_CONST3) is converted to - static uint32 c_name (object arg) { + static struct { int c_const, gcv_object_t *l_const; } c_name_table[] = ... + static enum_type c_name (object arg) { restart_c_name: if (posfixnump(arg)) return posfixnum_to_L(arg); else if (missingp(arg)) return 0; - #ifdef C_CONST1 - else if (eq(arg,`:C_CONST1`)) return C_CONST1; - #end - ... else { + for (index = 0; index < c_name_table_size; index++) + if (eq(a,*c_name_table[index].l_const)) + return c-name_table[index].c_const; pushSTACK(NIL); pushSTACK(arg); pushSTACK(the_appropriate_error_type); pushSTACK(the_appropriate_error_type); pushSTACK(arg); @@ -70,6 +71,14 @@ goto restart_c_name; } } + static object c_name_reverse (enum_type a) { + int index; + for (index = 0; index < c_name_table_size; index++) + if (a == c_name_table[index].c_const) + return *c_name_table[index].l_const; + if (a == 0) return NIL; + NOTREACHED; + } Restrictions and caveats: - A module should consist of a single file. @@ -553,27 +562,45 @@ (stack-push-optimize (flag-set-cond-stack fs) condition) fs)) -(defstruct (checker (:include cpp-helper)) cpp-odefs type-odef) +;; type is the enum type name (if it is an enum typedef) and NIL otherwise +;; since enum constants cannot be checked by CPP, we do not ifdef them +(defstruct (checker (:include cpp-helper)) type cpp-odefs type-odef) (defvar *checkers* (make-array 5 :adjustable t :fill-pointer 0)) -(defun new-checker (name cpp-names &optional (condition (current-condition))) +(defun new-checker (name cpp-names &optional type + (condition (current-condition))) (setq cpp-names (nreverse cpp-names)) - (let ((ch (make-checker :name name :cpp-names cpp-names)) - (type-odef (list "(OR NULL (INTEGER 0) (MEMBER")) cpp-odefs) + (let ((ch (make-checker :type type :name name :cpp-names cpp-names)) + (type-odef "(OR NULL (INTEGER 0) (MEMBER") cpp-odefs) (vector-push-extend ch *checkers*) (stack-push-optimize (checker-cond-stack ch) condition) - (dolist (name cpp-names) - (let ((co (ext:string-concat "defined(" name ")"))) - (push (init-to-objdef (ext:string-concat ":" name) - (concatenate 'vector condition (list co))) - cpp-odefs) - (push (cons co (ext:string-concat " :" name)) type-odef))) - (setf (checker-cpp-odefs ch) (nreverse cpp-odefs) - (checker-type-odef ch) - (init-to-objdef (nreconc type-odef (list "))")))) + (cond (type + (dolist (name cpp-names) + (push (init-to-objdef (ext:string-concat ":" name) condition) + cpp-odefs) + (setq type-odef (ext:string-concat type-odef " :" name))) + (setf (checker-type-odef ch) + (init-to-objdef (ext:string-concat type-odef "))")))) + (t + (setq type-odef (list type-odef)) + (dolist (name cpp-names) + (let ((co (ext:string-concat "defined(" name ")"))) + (push (init-to-objdef (ext:string-concat ":" name) + (concatenate 'vector condition (list co))) + cpp-odefs) + (push (cons co (ext:string-concat " :" name)) type-odef))) + (setf (checker-type-odef ch) + (init-to-objdef (nreconc type-odef (list "))")))))) + (setf (checker-cpp-odefs ch) (nreverse cpp-odefs)) ch)) +(defun word-list (line start end) + (loop :with l :and pos2 = start + :for pos1 = (next-non-blank line (1+ pos2)) + :while (and pos1 (< pos1 end)) + :do (setq pos2 (min end (or (next-blank line pos1) end))) + (push (subseq line pos1 pos2) l) :finally (return l))) (defun def-something-p (line command constructor) - "Parse a COMMAND(c_name,CPP_CONST...) line." + "Parse a COMMAND(c_name,[type,]CPP_CONST...) line." (let* ((pos (next-non-blank line 0)) (len (length line)) cc comma fname (end (and pos (+ pos (length command))))) (when (and pos (< end len) @@ -582,12 +609,12 @@ (#\( t) (t (sys::whitespacep cc)))) (multiple-value-setq (comma end fname) (parse-name line end command)) - (funcall constructor fname - (loop :with l :and pos2 = comma - :for pos1 = (next-non-blank line (1+ pos2)) - :while (and pos1 (< pos1 end)) - :do (setq pos2 (min end (or (next-blank line pos1) end))) - (push (subseq line pos1 pos2) l) :finally (return l))) + (setq cc (position #\, line :start (1+ comma))) + (if cc + (funcall constructor fname (word-list line cc end) + (let ((beg (next-non-blank line (1+ comma)))) + (subseq line beg (min cc (next-blank line beg))))) + (funcall constructor fname (word-list line comma end))) (ext:string-concat (subseq line 0 pos) (subseq line (1+ end)))))) (defstruct vardef @@ -877,7 +904,7 @@ :do (with-conditional (out (flag-set-cond-stack fs)) (format out "static uintL ~A (void) {" (flag-set-name fs)) (newline out) - (format out " {uintL flags = 0") (newline out) + (format out " uintL flags = 0") (newline out) (loop :for cpp-name :in (flag-set-cpp-names fs) :for nn :upfrom 0 :do (format out "# ifdef ~A" cpp-name) (newline out) (format out " | (missingp(STACK_(~D)) ? 0 : ~A)" @@ -886,24 +913,39 @@ :finally (progn (format out " ;") (newline out) (format out " skipSTACK(~D);" nn))) (newline out) (format out " return flags;") (newline out) - (format out "}}") (newline out))) + (format out "}") (newline out))) (newline out) - (loop :for ch :across *checkers* + (loop :with table-struct-printed-p = nil :for ch :across *checkers* :for type-tag = (objdef-tag (checker-type-odef ch)) - :for c-name = (checker-name ch) + :for c-name = (checker-name ch) :for c-type = (checker-type ch) :do (with-conditional (out (checker-cond-stack ch)) - (format out "static uintL ~A (object a) {" c-name) - (newline out) (format out " restart_~A:" c-name) (newline out) - (format out " if (missingp(a)) return 0;") (newline out) - (format out " else if (posfixnump(a)) return posfixnum_to_L(a);") + (unless table-struct-printed-p + (setq table-struct-printed-p t) + (format out "struct c_lisp_pair {int c_const; gcv_object_t *l_const;};") + (newline out) (newline out)) + (format out "static struct c_lisp_pair ~A_table[] = {" c-name) (newline out) (loop :for name :in (checker-cpp-names ch) :for odef :in (checker-cpp-odefs ch) - :do (format out " #ifdef ~A" name) (newline out) - (format out " else if (eq(a,O(~A))) return ~A;" - (objdef-tag odef) name) (newline out) - (format out " #endif") (newline out)) - (format out " else {") (newline out) + :do (unless c-type (format out " #ifdef ~A" name) (newline out)) + (format out " { ~A, &(O(~A)) }," name (objdef-tag odef)) + (newline out) + (unless c-type (format out " #endif") (newline out))) + (format out " { 0, NULL }") (newline out) + (format out "};") (newline out) + (format out "const uintL ~A_table_size = ((sizeof(~A_table)-1)/sizeof(struct c_lisp_pair));" c-name c-name) (newline out) + (format out "static ~A ~A (object a) {" (or c-type "int") c-name) + (newline out) (format out " int index;") (newline out) + (format out " restart_~A:" c-name) (newline out) + (format out " if (missingp(a)) return 0;") (newline out) + (format out " else if (integerp(a)) return I_to_L(a);") + (newline out) (format out " else {") (newline out) + (format out " for (index = 0; index < ~A_table_size; index++)" + c-name) (newline out) + (format out " if (eq(a,*~A_table[index].l_const))" c-name) + (newline out) + (format out " return ~A_table[index].c_const;" c-name) + (newline out) (format out " pushSTACK(NIL); pushSTACK(a);") (newline out) (format out " pushSTACK(O(~A));" type-tag) (newline out) (format out " pushSTACK(O(~A));" type-tag) (newline out) @@ -911,6 +953,18 @@ (newline out) (format out " check_value(type_error,GETTEXT(\"~~S: ~~S is not of type ~~S\"));") (newline out) (format out " a = value1; goto restart_~A;" c-name) (newline out) (format out " }") (newline out) + (format out "}") (newline out) + (format out "static object ~A_reverse (~A a) {" + c-name (or c-type "int")) + (newline out) (format out " int index;") (newline out) + (format out " for (index = 0; index < ~A_table_size; index++)" + c-name) (newline out) + (format out " if (a == ~A_table[index].c_const)" c-name) + (newline out) + (format out " return *~A_table[index].l_const;" c-name) + (newline out) + (format out " if (a == 0) return NIL;") (newline out) + (format out " NOTREACHED;") (newline out) (format out "}") (newline out))) (newline out))) --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |