0.9.12.3:
[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      ;; FIXME: GC safety alert! These SAPs are not safe, since the
40      ;; Lisp string can move. This is not hard to arrange, for example
41      ;; the following will fail very quickly on a SB-UNICODE build:
42      ;;
43      ;;   (setf (bytes-consed-between-gcs) 4096)
44      ;;   (define-alien-routine "strcmp" int (s1 c-string) (s2 c-string))
45      ;;
46      ;;   (loop
47      ;;     (let ((string "hello, world"))
48      ;;       (assert (zerop (strcmp string string)))))
49      ;;
50      ;; (This will appear to work on post-0.9.8.19 GENCGC, since
51      ;;  the GC no longer zeroes memory immediately after releasing
52      ;;  it after a minor GC. Either enabling the READ_PROTECT_FREE_PAGES
53      ;;  #define in gencgc.c or modifying the example so that a major
54      ;;  GC will occasionally be triggered would unmask the bug).
55      ;;
56      ;; The SIMPLE-BASE-STRING case will generally be very hard to
57      ;; trigger on GENCGC (even when threaded) thanks to GC
58      ;; conservativeness. It's mostly a problem on cheneygc.
59      ;; -- JES, 2006-01-13
60      (simple-base-string (vector-sap ,value))
61      ;; This case, on the other hand, will cause trouble on GENCGC, since
62      ;; we're taking the SAP of a immediately discarded temporary -> the
63      ;; conservativeness doesn't protect us.
64      ;; -- JES, 2006-01-13
65      (simple-string (vector-sap (coerce ,value 'simple-base-string)))))
66
67 (/show0 "host-c-call.lisp 42")
68
69 (define-alien-type-class (utf8-string :include pointer :include-args (to)))
70
71 (define-alien-type-translator utf8-string ()
72   (make-alien-utf8-string-type
73    :to (parse-alien-type 'char (sb!kernel:make-null-lexenv))))
74
75 (define-alien-type-method (utf8-string :unparse) (type)
76   (declare (ignore type))
77   'utf8-string)
78
79 (define-alien-type-method (utf8-string :lisp-rep) (type)
80   (declare (ignore type))
81   '(or simple-string null (alien (* char))))
82
83 (define-alien-type-method (utf8-string :naturalize-gen) (type alien)
84   (declare (ignore type))
85   `(if (zerop (sap-int ,alien))
86        nil
87        (%naturalize-utf8-string ,alien)))
88
89 (define-alien-type-method (utf8-string :deport-gen) (type value)
90   (declare (ignore type))
91   `(etypecase ,value
92      (null (int-sap 0))
93      ((alien (* char)) (alien-sap ,value))
94      ;; See the C-STRING :DEPORT-GEN comments for GC safety issues.
95      (simple-base-string (vector-sap ,value))
96      (simple-string (vector-sap (%deport-utf8-string ,value)))))
97
98 (/show0 "host-c-call.lisp end of file")