From: William Harold Newman Date: Sat, 28 Sep 2002 14:39:43 +0000 (+0000) Subject: 0.7.8.4: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9d67a20f91f72ec73847e283bcf9b2b4f74b1d25;p=sbcl.git 0.7.8.4: merged NJF ports of CMU CL patches... ...fixing bug 142 (%NATURALIZE-C-STRING consing, fixed in CMU CL by rtoy) ...improving MOP conformance (SLOT-DEFINITION-ALLOCATION returning :CLASS not the class itself, fixed by Gerd Moellman cmucl-imp 2002-09-17) --- diff --git a/BUGS b/BUGS index b7c3b53..33b9fee 100644 --- a/BUGS +++ b/BUGS @@ -776,7 +776,7 @@ WORKAROUND: This bug was fixed in sbcl-0.7.4.1 by invalidating the PCL wrapper class upon redefinition. Unfortunately, doing so causes bug #176 to - appear. Pending further investication, one or other of these bugs + appear. Pending further investigation, one or other of these bugs might be present at any given time. 141: @@ -787,12 +787,6 @@ WORKAROUND: * (lisp-implementation-version) "0.pre7.129" -142: - (as reported by Lynn Quam on cmucl-imp ca. 2002-01-16) - %NATURALIZE-C-STRING conses a lot, like 16 bytes per byte - of the naturalized string. We could probably port the patches - from the cmucl-imp mailing list. - 143: (reported by Jesse Bouwman 2001-10-24 through the unfortunately prominent SourceForge web/db bug tracking system, which is diff --git a/NEWS b/NEWS index 6bacac8..5c4a21c 100644 --- a/NEWS +++ b/NEWS @@ -1299,6 +1299,11 @@ changes in sbcl-0.7.8 relative to sbcl-0.7.7: changes in sbcl-0.7.9 relative to sbcl-0.7.8: * fixed bug: VALUES-LIST is no longer optimized away + * fixed bug 142: The FFI conversion of C string values to Lisp + string values no longer conses excessively. (thanks to Nathan + Froyd porting Raymond Toy's fix to CMU CL) + * improved MOP conformance in PCL (thanks to Nathan Froyd porting + Gerd Moellman's work in CMU CL) planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index d9575b8..5d3efec 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -37,11 +37,14 @@ (defun %naturalize-c-string (sap) (declare (type system-area-pointer sap)) - (with-alien ((ptr (* char) sap)) - (let* ((length (alien-funcall (extern-alien "strlen" - (function integer (* char))) - ptr)) - (result (make-string length))) + (locally (declare (optimize (speed 3) (safety 0))) - (sb!kernel:%byte-blt sap 0 result 0 length) - result))) + (let ((length (loop for offset of-type fixnum upfrom 0 + until (zerop (sap-ref-8 sap offset)) + finally (return offset)))) + (let ((result (make-string length))) + (sb!kernel:copy-from-system-area sap 0 + result (* sb!vm:vector-data-offset + sb!vm:n-word-bits) + (* length sb!vm:n-byte-bits)) + result)))) diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp index 9d84f31..cce5b7f 100644 --- a/src/pcl/init.lisp +++ b/src/pcl/init.lisp @@ -109,7 +109,7 @@ (class-slots (class-of previous))))) (dolist (slotd current-slotds) (if (and (not (memq (slot-definition-name slotd) previous-slot-names)) - (eq (slot-definition-allocation slotd) ':instance)) + (eq (slot-definition-allocation slotd) :instance)) (push (slot-definition-name slotd) added-slots))) (check-initargs-1 (class-of current) initargs @@ -131,61 +131,55 @@ (defmethod shared-initialize ((instance slot-object) slot-names &rest initargs) - (when (eq slot-names t) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-t-fun - (initialize-info (class-of instance) initargs)) - instance initargs))) - (when (eq slot-names nil) - (return-from shared-initialize - (call-initialize-function - (initialize-info-shared-initialize-nil-fun - (initialize-info (class-of instance) initargs)) - instance initargs))) - ;; Initialize the instance's slots in a two step process: - ;; (1) A slot for which one of the initargs in initargs can set - ;; the slot, should be set by that initarg. If more than - ;; one initarg in initargs can set the slot, the leftmost - ;; one should set it. - ;; (2) Any slot not set by step 1, may be set from its initform - ;; by step 2. Only those slots specified by the slot-names - ;; argument are set. If slot-names is: - ;; T - ;; then any slot not set in step 1 is set from its - ;; initform. - ;; - ;; then any slot in the list, and not set in step 1 - ;; is set from its initform. - ;; () - ;; then no slots are set from initforms. - (let* ((class (class-of instance)) - (slotds (class-slots class)) - (std-p (pcl-instance-p instance))) - (dolist (slotd slotds) - (let ((slot-name (slot-definition-name slotd)) - (slot-initargs (slot-definition-initargs slotd))) - (unless (progn - ;; Try to initialize the slot from one of the initargs. - ;; If we succeed return T, otherwise return nil. - (doplist (initarg val) initargs - (when (memq initarg slot-initargs) - (setf (slot-value-using-class class - instance - slotd) - val) - (return t)))) - ;; Try to initialize the slot from its initform. - (if (and slot-names - (or (eq slot-names t) - (memq slot-name slot-names)) - (or (and (not std-p) (eq slot-names t)) - (not (slot-boundp-using-class class instance slotd)))) - (let ((initfunction (slot-definition-initfunction slotd))) - (when initfunction - (setf (slot-value-using-class class instance slotd) - (funcall initfunction)))))))) - instance)) + (cond + ((eq slot-names t) + (call-initialize-function + (initialize-info-shared-initialize-t-fun + (initialize-info (class-of instance) initargs)) + instance initargs)) + ((eq slot-names nil) + (call-initialize-function + (initialize-info-shared-initialize-nil-fun + (initialize-info (class-of instance) initargs)) + instance initargs)) + (t + ;; Initialize the instance's slots in a two step process: + ;; (1) A slot for which one of the initargs in initargs can set + ;; the slot, should be set by that initarg. If more than + ;; one initarg in initargs can set the slot, the leftmost + ;; one should set it. + ;; (2) Any slot not set by step 1, may be set from its initform + ;; by step 2. Only those slots specified by the slot-names + ;; argument are set. If slot-names is: + ;; T + ;; then any slot not set in step 1 is set from its + ;; initform. + ;; + ;; then any slot in the list, and not set in step 1 + ;; is set from its initform. + ;; () + ;; then no slots are set from initforms. + (flet ((initialize-slot-from-initarg (class instance slotd) + (let ((slot-initargs (slot-definition-initargs slotd))) + (doplist (initarg value) initargs + (when (memq initarg slot-initargs) + (setf (slot-value-using-class class instance slotd) + value) + (return t))))) + (initialize-slot-from-initfunction (class instance slotd) + (unless (or (slot-boundp-using-class class instance slotd) + (null (slot-definition-initfunction slotd))) + (setf (slot-value-using-class class instance slotd) + (funcall (slot-definition-initfunction slotd))))) + (class-slot-p (slotd) + (eq :class (slot-definition-allocation slotd)))) + (loop with class = (class-of instance) + for slotd in (class-slots class) + unless (or (class-slot-p slotd) + (initialize-slot-from-initarg class instance slotd)) + when (memq (slot-definition-name slotd) slot-names) do + (initialize-slot-from-initfunction class instance slotd)) + instance)))) ;;; If initargs are valid return nil, otherwise signal an error. (defun check-initargs-1 (class initargs call-list diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index f79a78c..ed9995e 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -460,7 +460,7 @@ (setf (plist-value class 'class-slot-cells) (let (collect) (dolist (dslotd direct-slots) - (when (eq (slot-definition-allocation dslotd) class) + (when (eq :class (slot-definition-allocation dslotd)) (let ((initfunction (slot-definition-initfunction dslotd))) (push (cons (slot-definition-name dslotd) (if initfunction @@ -499,13 +499,6 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) -(defmethod shared-initialize :after ((slotd standard-slot-definition) - slot-names &key) - (declare (ignore slot-names)) - (with-slots (allocation class) - slotd - (setq allocation (if (eq allocation :class) class allocation)))) - (defmethod shared-initialize :after ((slotd structure-slot-definition) slot-names &key (allocation :instance)) @@ -719,8 +712,9 @@ (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) - (cond ((eq alloc :instance) (push eslotd instance-slots)) - ((classp alloc) (push eslotd class-slots))))) + (case alloc + (:instance (push eslotd instance-slots)) + (:class (push eslotd class-slots))))) ;; If there is a change in the shape of the instances then the ;; old class is now obsolete. @@ -765,7 +759,7 @@ (let (collect) (dolist (eslotd eslotds) (push (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))) + (class-slot-cells (slot-definition-class eslotd))) collect)) (nreverse collect))) @@ -862,8 +856,9 @@ (class-slots ())) (dolist (eslotd eslotds) (let ((alloc (slot-definition-allocation eslotd))) - (cond ((eq alloc :instance) (push eslotd instance-slots)) - ((classp alloc) (push eslotd class-slots))))) + (case alloc + (:instance (push eslotd instance-slots)) + (:class (push eslotd class-slots))))) (let ((nlayout (compute-layout cpl instance-slots))) (dolist (eslotd instance-slots) (setf (slot-definition-location eslotd) @@ -871,7 +866,7 @@ (dolist (eslotd class-slots) (setf (slot-definition-location eslotd) (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-allocation eslotd))))) + (class-slot-cells (slot-definition-class eslotd))))) (mapc #'initialize-internal-slot-functions eslotds) eslotds)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index fdd43e6..c4d7eba 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -638,7 +638,7 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (classp (slot-definition-allocation slotd))))))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) diff --git a/version.lisp-expr b/version.lisp-expr index 5a2e3aa..429947e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; internal versions off the main CVS branch, it gets hairier, e.g. ;;; "0.pre7.14.flaky4.13".) -"0.7.8.3" +"0.7.8.4"