X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-c-call.lisp;h=c978ac88e8da84b0ded01841abcb49e8a44ce0d6;hb=54da325f13fb41669869aea688ae195426c0e231;hp=e35489e1c139d8cb66b0ec119c5689537ed1e45f;hpb=d1355f6b79af346f05cf21c18637e269e0b499a1;p=sbcl.git diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index e35489e..c978ac8 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -22,23 +22,48 @@ (define-alien-type char (integer 8)) (define-alien-type short (integer 16)) (define-alien-type int (integer 32)) -(define-alien-type long (integer #!-alpha 32 #!+alpha 64)) +#!-(and win32 x86-64) +(define-alien-type long (integer #.sb!vm::n-machine-word-bits)) +#!+(and win32 x86-64) +(define-alien-type long (integer 32)) + +(define-alien-type long-long (integer 64)) (define-alien-type unsigned-char (unsigned 8)) (define-alien-type unsigned-short (unsigned 16)) (define-alien-type unsigned-int (unsigned 32)) -(define-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64)) +#!-(and win32 x86-64) +(define-alien-type unsigned-long (unsigned #.sb!vm::n-machine-word-bits)) +#!+(and win32 x86-64) +(define-alien-type unsigned-long (unsigned 32)) +(define-alien-type unsigned-long-long (unsigned 64)) (define-alien-type float single-float) (define-alien-type double double-float) +(define-alien-type utf8-string (c-string :external-format :utf8)) + (define-alien-type-translator void () (parse-alien-type '(values) (sb!kernel:make-null-lexenv))) + +(defun default-c-string-external-format () + #!+sb-xc + :latin-1 + #!-sb-xc + (or *default-c-string-external-format* + (setf *default-c-string-external-format* + (sb!impl::default-external-format)))) + ;;; FIXME: %NATURALIZE-C-STRING (and the UTF8 siblings below) would ;;; appear to be vulnerable to the lisp string moving from underneath ;;; them if the world undergoes a GC, possibly triggered by another ;;; thread. Ugh. +;;; +;;; Actually the above shouldn't happen; x86 and x86-64 use GENCGC, +;;; so the string can't move by virtue of pointers to it from +;;; outside the heap. Other platforms will access the lisp string +;;; through the GC-safe interior pointer. -- JES, 2006-01-13 (defun %naturalize-c-string (sap) (declare (type system-area-pointer sap)) (locally @@ -47,103 +72,19 @@ until (zerop (sap-ref-8 sap offset)) finally (return offset)))) (let ((result (make-string length :element-type 'base-char))) - (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)))) + (sb!kernel:copy-ub8-from-system-area sap 0 result 0 length) + result)))) -(defun %naturalize-utf8-string (sap) - (declare (type system-area-pointer sap)) +(defun string-to-c-string (string external-format) + (declare (type simple-string string)) (locally - (declare (optimize (speed 3) (safety 0))) - (let ((length (do* ((offset 0) - (byte (sap-ref-8 sap offset) (sap-ref-8 sap offset)) - (index 0 (1+ index))) - ((zerop byte) index) - (declare (type fixnum offset index)) - (cond - ;; FIXME: Here, and below, we don't defend - ;; against malformed utf-8 with any degree of - ;; rigour. - ((< byte #x80) (incf offset)) - ((< byte #xe0) (incf offset 2)) - ((< byte #xf0) (incf offset 3)) - (t (incf offset 4)))))) - (let ((result (make-string length :element-type 'character))) - (do* ((offset 0) - (byte (sap-ref-8 sap offset) (sap-ref-8 sap offset)) - (index 0 (1+ index))) - ((>= index length) result) - (declare (type fixnum offset index)) - (setf (char result index) - (cond - ((< byte #x80) - (prog1 (code-char byte) (incf offset))) - ((< byte #xe0) - (prog1 (code-char (dpb byte (byte 5 6) - (sap-ref-8 sap (1+ offset)))) - (incf offset 2))) - ((< byte #xf0) - (prog1 (code-char - (dpb byte (byte 4 12) - (dpb (sap-ref-8 sap (1+ offset)) (byte 6 6) - (sap-ref-8 sap (+ 2 offset))))) - (incf offset 3))) - (t - (prog1 - (code-char - (dpb byte (byte 3 18) - (dpb (sap-ref-8 sap (1+ offset)) (byte 6 12) - (dpb (sap-ref-8 sap (+ 2 offset)) (byte 6 6) - (sap-ref-8 sap (+ 3 offset)))))) - (incf offset 4)))))))))) + (declare (optimize (speed 3) (safety 0))) + (let ((external-format (sb!impl::get-external-format-or-lose external-format))) + (funcall (sb!impl::ef-write-c-string-fun external-format) string)))) -(defun %deport-utf8-string (string) - (declare (type simple-string string)) +(defun c-string-to-string (sap external-format element-type) + (declare (type system-area-pointer sap)) (locally - (declare (optimize (speed 3) (safety 0))) - (let ((length (1+ (do* ((offset 0) - (length (length string)) - (index 0 (1+ index))) - ((= index length) offset) - (declare (type fixnum offset)) - (let ((bits (char-code (char string index)))) - (cond - ((< bits #x80) (incf offset 1)) - ((< bits #x800) (incf offset 2)) - ((< bits #x10000) (incf offset 3)) - (t (incf offset 4)))))))) - (let ((vector (make-array length :element-type '(unsigned-byte 8) - :initial-element 0))) - (do* ((offset 0) - (length (length string)) - (index 0 (1+ index))) - ((= index length) vector) - (declare (type fixnum offset)) - (let ((bits (char-code (char string index)))) - (cond - ((< bits #x80) - (setf (aref vector offset) bits) - (incf offset)) - ((< bits #x800) - (setf (aref vector offset) (logior #xc0 (ldb (byte 5 6) bits))) - (setf (aref vector (1+ offset)) - (logior #x80 (ldb (byte 6 0) bits))) - (incf offset 2)) - ((< bits #x10000) - (setf (aref vector offset) (logior #xe0 (ldb (byte 4 12) bits))) - (setf (aref vector (1+ offset)) - (logior #x80 (ldb (byte 6 6) bits))) - (setf (aref vector (+ offset 2)) - (logior #x80 (ldb (byte 6 0) bits))) - (incf offset 3)) - (t - (setf (aref vector offset) (logior #xf0 (ldb (byte 3 18) bits))) - (setf (aref vector (1+ offset)) - (logior #x80 (ldb (byte 6 12) bits))) - (setf (aref vector (+ offset 2)) - (logior #x80 (ldb (byte 6 6) bits))) - (setf (aref vector (+ offset 3)) - (logior #x80 (ldb (byte 6 0) bits))) - (incf offset 4))))))))) + (declare (optimize (speed 3) (safety 0))) + (let ((external-format (sb!impl::get-external-format-or-lose external-format))) + (funcall (sb!impl::ef-read-c-string-fun external-format) sap element-type))))