From: William H. N. <wn...@us...> - 2002-09-28 14:39:46
|
Update of /cvsroot/sbcl/sbcl/src/code In directory usw-pr-cvs1:/tmp/cvs-serv4515/src/code Modified Files: target-c-call.lisp Log Message: 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) Index: target-c-call.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/target-c-call.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- target-c-call.lisp 16 Jan 2002 23:54:29 -0000 1.7 +++ target-c-call.lisp 28 Sep 2002 14:39:43 -0000 1.8 @@ -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)))) |