X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-c-call.lisp;h=7a83d1021a80879036a93fc2ee5765291ff7c383;hb=55c7345f18c442abbbe46c66b51bcab612cae65f;hp=1d312c344308af4777c3b463be2b32542f5544bb;hpb=78fa16bf55be44cc16845be84d98023e83fb14bc;p=sbcl.git diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index 1d312c3..7a83d10 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -23,22 +23,40 @@ (define-alien-type short (integer 16)) (define-alien-type int (integer 32)) (define-alien-type long (integer #.sb!vm::n-machine-word-bits)) +(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 #.sb!vm::n-machine-word-bits)) +(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 +65,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))))