/[cmucl]/src/code/c-call.lisp
ViewVC logotype

Contents of /src/code/c-call.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (show annotations)
Fri Mar 19 15:18:58 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.18: +3 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Package: C-CALL -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/c-call.lisp,v 1.19 2010/03/19 15:18:58 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains some extensions to the Alien facility to simplify
13 ;;; importing C interfaces.
14 ;;;
15 (in-package "C-CALL")
16 (use-package "ALIEN")
17 (use-package "ALIEN-INTERNALS")
18 (use-package "SYSTEM")
19
20 (intl:textdomain "cmucl")
21
22 (export '(char short int long long-long unsigned-char unsigned-short unsigned-int
23 unsigned-long unsigned-long-long float double c-string void))
24
25
26 ;;;; Extra types.
27
28 (def-alien-type char (integer 8))
29 (def-alien-type short (integer 16))
30 (def-alien-type int (integer 32))
31 (def-alien-type long (integer #-alpha 32 #+alpha 64))
32 (def-alien-type long-long (integer 64))
33
34 (def-alien-type unsigned-char (unsigned 8))
35 (def-alien-type unsigned-short (unsigned 16))
36 (def-alien-type unsigned-int (unsigned 32))
37 (def-alien-type unsigned-long (unsigned #-alpha 32 #+alpha 64))
38 (def-alien-type unsigned-long-long (unsigned 64))
39
40 (def-alien-type float single-float)
41 (def-alien-type double double-float)
42
43 (def-alien-type-translator void ()
44 (parse-alien-type '(values)))
45
46
47
48 ;;;; C string support.
49
50 (def-alien-type-class (c-string :include pointer :include-args (to)))
51
52 (def-alien-type-translator c-string ()
53 (make-alien-c-string-type :to (parse-alien-type 'char)))
54
55 (def-alien-type-method (c-string :unparse) (type)
56 (declare (ignore type))
57 'c-string)
58
59 (def-alien-type-method (c-string :lisp-rep) (type)
60 (declare (ignore type))
61 '(or simple-base-string null (alien (* char))))
62
63 (def-alien-type-method (c-string :naturalize-gen) (type alien)
64 (declare (ignore type))
65 `(if (zerop (sap-int ,alien))
66 nil
67 (%naturalize-c-string ,alien)))
68
69 #-unicode
70 (def-alien-type-method (c-string :deport-gen) (type value)
71 (declare (ignore type))
72 `(etypecase ,value
73 (null (int-sap 0))
74 ((alien (* char)) (alien-sap ,value))
75 (simple-base-string (vector-sap ,value))))
76
77 #+unicode
78 (def-alien-type-method (c-string :deport-gen) (type value)
79 (declare (ignore type))
80 (let ((s (gensym "C-STRING-"))
81 (len (gensym "LEN-"))
82 (k (gensym "IDX-")))
83 `(etypecase ,value
84 (null (int-sap 0))
85 ((alien (* char)) (alien-sap ,value))
86 (simple-base-string
87 ;; FIXME: What should we do here? For now, we just create an
88 ;; 8-bit array and copy our characters (the low 8-bits of each
89 ;; character!) to the 8-bit array.
90 (let* ((,len (length ,value))
91 (,s (make-array (1+ ,len) :element-type '(unsigned-byte 8))))
92 (dotimes (,k ,len)
93 (setf (aref ,s ,k) (logand #xff (char-code (aref ,value ,k)))))
94 (setf (aref ,s ,len) 0)
95 (vector-sap ,s))))))
96
97 #-unicode
98 (defun %naturalize-c-string (sap)
99 (declare (type system-area-pointer sap))
100 (locally
101 (declare (optimize (speed 3) (safety 0)))
102 (let ((length (loop
103 for offset of-type fixnum upfrom 0
104 until (zerop (sap-ref-8 sap offset))
105 finally (return offset))))
106 (let ((result (make-string length)))
107 (kernel:copy-from-system-area sap 0
108 result (* vm:vector-data-offset
109 vm:word-bits)
110 (* length vm:byte-bits))
111 result))))
112
113 ;; FIXME: What should we do? For now, just take the 8-bit strings
114 ;; returned from C and create a new Lisp string containing those
115 ;; characters.
116 #+unicode
117 (defun %naturalize-c-string (sap)
118 (declare (type system-area-pointer sap))
119 (let ((length (loop
120 for offset of-type fixnum upfrom 0
121 until (zerop (sap-ref-8 sap offset))
122 finally (return offset))))
123
124 (let ((result (make-string length)))
125 (dotimes (k length)
126 (setf (aref result k) (code-char (sap-ref-8 sap k))))
127 result)))

  ViewVC Help
Powered by ViewVC 1.1.5