0.9.5.58:
[sbcl.git] / src / code / host-c-call.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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.
9
10 (in-package "SB!ALIEN")
11
12 (/show0 "host-c-call.lisp 12")
13
14 (define-alien-type-class (c-string :include pointer :include-args (to)))
15
16 (define-alien-type-translator c-string ()
17   (make-alien-c-string-type
18    :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
19
20 (define-alien-type-method (c-string :unparse) (type)
21   (declare (ignore type))
22   'c-string)
23
24 (define-alien-type-method (c-string :lisp-rep) (type)
25   (declare (ignore type))
26   '(or simple-string null (alien (* char))))
27
28 (define-alien-type-method (c-string :naturalize-gen) (type alien)
29   (declare (ignore type))
30   `(if (zerop (sap-int ,alien))
31        nil
32        (%naturalize-c-string ,alien)))
33
34 (define-alien-type-method (c-string :deport-gen) (type value)
35   (declare (ignore type))
36   `(etypecase ,value
37      (null (int-sap 0))
38      ((alien (* char)) (alien-sap ,value))
39      (simple-base-string (vector-sap ,value))
40      (simple-string (vector-sap (coerce ,value 'simple-base-string)))))
41
42 (/show0 "host-c-call.lisp 42")
43
44 (define-alien-type-class (utf8-string :include pointer :include-args (to)))
45
46 (define-alien-type-translator utf8-string ()
47   (make-alien-utf8-string-type
48    :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
49
50 (define-alien-type-method (utf8-string :unparse) (type)
51   (declare (ignore type))
52   'utf8-string)
53
54 (define-alien-type-method (utf8-string :lisp-rep) (type)
55   (declare (ignore type))
56   '(or simple-string null (alien (* char))))
57
58 (define-alien-type-method (utf8-string :naturalize-gen) (type alien)
59   (declare (ignore type))
60   `(if (zerop (sap-int ,alien))
61        nil
62        (%naturalize-utf8-string ,alien)))
63
64 (define-alien-type-method (utf8-string :deport-gen) (type value)
65   (declare (ignore type))
66   `(etypecase ,value
67      (null (int-sap 0))
68      ((alien (* char)) (alien-sap ,value))
69      (simple-base-string (vector-sap ,value))
70      (simple-string (vector-sap (%deport-utf8-string ,value)))))
71
72 (/show0 "host-c-call.lisp end of file")