1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (in-package "SB!ALIEN")
12 (/show0
"host-c-call.lisp 12")
14 (define-alien-type-class (c-string :include pointer
:include-args
(to))
15 (external-format :default
:type keyword
)
16 (element-type 'character
:type
(member character base-char
))
17 (not-null nil
:type boolean
))
19 (define-alien-type-translator c-string
20 (&key
(external-format :default
)
21 (element-type 'character
)
23 (make-alien-c-string-type
24 :to
(parse-alien-type 'char
(sb!kernel
:make-null-lexenv
))
25 :element-type element-type
26 :external-format external-format
29 (defun c-string-external-format (type)
30 (let ((external-format (alien-c-string-type-external-format type
)))
31 (if (eq external-format
:default
)
32 #+sb-xc-host
(bug "No default c-string-external-format")
33 #-sb-xc-host
(default-c-string-external-format)
36 (define-alien-type-method (c-string :unparse
) (type)
37 (let* ((external-format (alien-c-string-type-external-format type
))
38 (element-type (alien-c-string-type-element-type type
))
39 (not-null (alien-c-string-type-not-null type
))
41 (append (unless (eq :default external-format
)
42 (list :external-format external-format
))
43 (unless (eq 'character element-type
)
44 (list :element-type element-type
))
46 (list :not-null t
)))))
51 (define-alien-type-method (c-string :lisp-rep
) (type)
52 (let ((possibilities '(simple-string (alien (* char
)) (simple-array (unsigned-byte 8)))))
53 (if (alien-c-string-type-not-null type
)
55 `(or null
,@possibilities
))))
57 (define-alien-type-method (c-string :deport-pin-p
) (type)
58 (declare (ignore type
))
61 (defun c-string-needs-conversion-p (type)
63 (declare (ignore type
))
67 (let ((external-format (sb!impl
::get-external-format
68 ;; Can't use C-STRING-EXTERNAL-FORMAT here,
69 ;; since the meaning of :DEFAULT can change
70 ;; when *DEFAULT-C-STRING-EXTERNAL-FORMAT*
72 (alien-c-string-type-external-format type
))))
73 (not (and external-format
74 (or (eq (first (sb!impl
::ef-names external-format
)) :ascii
)
75 ;; On non-SB-UNICODE all latin-1 codepoints will fit
76 ;; into a base-char, on SB-UNICODE they won't.
78 (eq (first (sb!impl
::ef-names external-format
)) :latin-1
))))))
80 (declaim (ftype (sfunction (t) nil
) null-error
))
81 (defun null-error (type)
82 #-sb-xc-host
(declare (optimize sb
!kernel
:allow-non-returning-tail-call
))
83 (aver (alien-c-string-type-not-null type
))
85 :expected-type
`(alien ,(unparse-alien-type type
))
88 (define-alien-type-method (c-string :naturalize-gen
) (type alien
)
89 `(if (zerop (sap-int ,alien
))
90 ,(if (alien-c-string-type-not-null type
)
93 ;; Check whether we need to do a full external-format
94 ;; conversion, or whether we can just do a cheap byte-by-byte
95 ;; copy of the c-string data.
97 ;; On SB-UNICODE we can never do the cheap copy, even if the
98 ;; external format and element-type are suitable, since
99 ;; simple-base-strings may not contain ISO-8859-1 characters.
100 ;; If we need to check for non-ascii data in the input, we
101 ;; might as well go through the usual external-format machinery
102 ;; instead of rewriting another version of it.
104 #!-sb-unicode
(c-string-needs-conversion-p type
)
105 `(c-string-to-string ,alien
106 (c-string-external-format ,type
)
107 (alien-c-string-type-element-type
109 `(%naturalize-c-string
,alien
))))
111 (define-alien-type-method (c-string :deport-gen
) (type value
)
112 ;; This SAP taking is safe as DEPORT callers pin the VALUE when
116 ,(if (alien-c-string-type-not-null type
)
119 ((alien (* char
)) (alien-sap ,value
))
120 (vector (vector-sap ,value
))))
122 (define-alien-type-method (c-string :deport-alloc-gen
) (type value
)
125 ,(if (alien-c-string-type-not-null type
)
128 ((alien (* char
)) ,value
)
130 ,(if (c-string-needs-conversion-p type
)
131 ;; If the alien type is not ascii-compatible (+SB-UNICODE)
132 ;; or latin-1-compatible (-SB-UNICODE), we need to do
133 ;; external format conversion.
134 `(string-to-c-string ,value
135 (c-string-external-format ,type
))
136 ;; Otherwise we can just pass it uncopied.
139 (string-to-c-string ,value
140 (c-string-external-format ,type
)))))
142 (/show0
"host-c-call.lisp end of file")