/[cparse]/cparse/cmu-alien.lisp
ViewVC logotype

Contents of /cparse/cmu-alien.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri May 14 21:44:22 2004 UTC (9 years, 11 months ago) by clynbech
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +2 -0 lines
<comment>
1 ;;;
2 ;;; Copyright (c) 2001 Timothy Moore
3 ;;; All rights reserved.
4 ;;;
5 ;;; Modified 2004 by Christian Lynbech
6 ;;;
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
9 ;;; are met:
10 ;;; 1. Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;; 2. Redistributions in binary form must reproduce the above copyright
13 ;;; notice, this list of conditions and the following disclaimer in the
14 ;;; documentation and/or other materials provided with the distribution.
15 ;;; 3. The name of the author may not be used to endorse or promote products
16 ;;; derived from this software without specific prior written permission.
17 ;;;
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
19 ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
20 ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
22 ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
24 ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
25 ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26 ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
27 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
28 ;;; SUCH DAMAGE.
29
30 (in-package "CMU-ALIEN")
31
32 (defmacro with-temp-file ((file-name &optional (base "/tmp/tmp~D~C"))
33 &body body)
34 "Creates a temporary file and binds the name to FILE-NAME. BASE is a format
35 string template for the temporary filename; it needs to accept a ~D and a ~C
36 argument."
37 `(let ((,file-name (system::pick-temporary-file-name ,base)))
38 (unwind-protect
39 (progn
40 ,@body)
41 (delete-file ,file-name))))
42
43 (eval-when (compile load eval)
44 (defun c-name-to-lisp-name (str)
45 (let ((lisp-name (string-upcase str)))
46 (nsubstitute #\- #\_ lisp-name)))
47
48 (defgeneric intern-as-lisp (csym &optional package))
49
50 (defmethod intern-as-lisp ((csym symbol) &optional (package *package*))
51 (intern (c-name-to-lisp-name (symbol-name csym)) package))
52
53 (defmethod intern-as-lisp ((csym string) &optional (package *package*))
54 (intern (c-name-to-lisp-name csym) package))
55 )
56
57 (define-condition alien-not-implemented (cparse-error)
58 (format-string &rest format-args))
59
60 (defvar *struct-tags*)
61
62 (defun make-alien-defs (files &key cpp-args extra-cpp-lines)
63 "Returns a form that declares, via def-alien-type, def-alien-routine
64 and def-alien-variable the types, functions and variables found in
65 FILES.
66
67 :CPP-ARGS is a list of command-line arguments for the C
68 preprocessor (for example, '(\"-I/usr/X11R6/include\").
69
70 :EXTRA-CPP-LINES are added to the file passed to the C preprocessor
71 and can be used for extra macro definitions, #includes, etc."
72 (with-temp-file (cpp-file "/tmp/tmp~D~C.c")
73 (let ((cpp-file-stream (open cpp-file
74 :direction :output :if-exists :overwrite))
75 (default-dir (namestring (ext:default-directory)))
76 (files (if (listp files)
77 files
78 (list files))))
79 (dolist (line extra-cpp-lines)
80 (write-line line cpp-file-stream))
81 (dolist (file files)
82 (format cpp-file-stream
83 "#include \"~A\"~%"
84 (if (eql (cl:schar file 0) #\/)
85 file
86 (concatenate 'string default-dir file))))
87 (close cpp-file-stream))
88 (with-open-stream
89 (cpp-stream (ext:process-output
90 (ext:run-program "gcc"
91 (append cpp-args (list "-E" cpp-file))
92 :output :stream
93 :input t :wait nil)))
94 (let ((defs nil)
95 (*struct-tags* (make-hash-table)))
96 (flet ((stmt-fun (decls scope stream)
97 (declare (ignore scope stream))
98 (handler-case (setf defs (nconc (do-decls decls) defs))
99 (alien-not-implemented (condition)
100 (format *error-output* "~A~%Ignoring and moving on.~%"
101 condition)))))
102 (cparse-stream cpp-stream :stmt-fun #'stmt-fun)
103 `(progn ,@(nreverse defs)))))))
104
105 (defun do-decls (decls)
106 (loop
107 for (type-decl name) in decls
108 collect (do-decl type-decl name)))
109
110 (defgeneric do-decl (type-decl name))
111
112 (defmethod do-decl ((type-decl t) name)
113 (declare (ignore name))
114 (error 'alien-not-implemented
115 :format-string "cmu-alien can't handle ~S yet (if ever)"
116 :format-arguments (list type-decl)))
117
118 (defmethod do-decl ((type-decl typedef-type) name)
119 (let ((def-type (do-type-declarator (defined-type type-decl))))
120 (unless (eq def-type 'c-call:void)
121 `(def-alien-type ,(intern-as-lisp name) ,def-type))))
122
123 (defgeneric do-type-declarator (type-decl))
124
125 (defmethod do-type-declarator ((type-decl t))
126 (error 'alien-not-implemented
127 :format-string "cmu-alien can't handle ~S yet (if ever)"
128 :format-arguments (list type-decl)))
129
130 (defmethod do-type-declarator ((type-decl enum-type))
131 (let ((key-package (find-package "KEYWORD"))
132 (tag (intern-as-lisp (tag type-decl))))
133 (loop
134 for (id . val) in (enumerators type-decl)
135 collect (list (intern-as-lisp id key-package)
136 val)
137 into enums
138 finally (return `(enum ,tag ,@enums)))))
139
140 (macrolet ((frob-prim-type
141 (cparse-type
142 &optional (c-call-type (intern-as-lisp
143 (symbol-name cparse-type)
144 (find-package "C-CALL"))))
145 `(defmethod do-type-declarator ((type-decl ,cparse-type))
146 ',c-call-type)))
147 (frob-prim-type void)
148 (frob-prim-type char)
149 (frob-prim-type unsigned-char)
150 (frob-prim-type signed-char c-call:char)
151 (frob-prim-type short)
152 (frob-prim-type unsigned-short)
153 (frob-prim-type int)
154 (frob-prim-type unsigned-int)
155 (frob-prim-type long)
156 (frob-prim-type unsigned-long)
157 (frob-prim-type cfloat c-call:float)
158 (frob-prim-type double))
159
160 (defun do-func-args-result (func-decl)
161 (values (loop for (type arg) in (args func-decl)
162 collect (list (intern-as-lisp arg)
163 (do-type-declarator type)))
164 (do-type-declarator (return-type func-decl))))
165
166 (defmethod do-decl ((type-decl func-type) name)
167 (let ((lisp-name (intern-as-lisp name)))
168 (multiple-value-bind (fun-args result)
169 (do-func-args-result type-decl)
170 `(progn
171 (declaim (inline ,lisp-name))
172 (def-alien-routine ,lisp-name
173 ,result
174 ,@fun-args)))))
175
176 ;;; func-type when seen in typedefs, pointers and stuff
177 (defmethod do-type-declarator ((type-decl func-type))
178 (multiple-value-bind (fun-args result)
179 (do-func-args-result type-decl)
180 `(function ,result ,@fun-args)))
181
182
183 (defmethod do-type-declarator ((type-decl pointer-type))
184 (let ((to-type (do-type-declarator (to type-decl))))
185 (if (eq to-type 'c-call:void)
186 '(* t)
187 `(* ,to-type))))
188
189 (defmethod do-decl ((type-decl compound-type) name)
190 (unless name
191 `(def-alien-type nil ,(do-type-declarator type-decl))))
192
193 (defgeneric compound-kind (type-decl))
194 (defmethod compound-kind ((type-decl struct-type))
195 'struct)
196 (defmethod compound-kind ((type-decl union-type))
197 'union)
198
199 (defmethod do-type-declarator ((type-decl compound-type))
200 (let ((tag (intern-as-lisp (tag type-decl)))
201 (kind (compound-kind type-decl)))
202 (if (gethash tag *struct-tags*)
203 `(,kind ,tag)
204 (progn
205 (setf (gethash tag *struct-tags*) t)
206 (loop for mem in (and (slot-boundp type-decl 'members)
207 (members type-decl))
208 collect (list (intern-as-lisp (cadr mem))
209 (do-type-declarator (car mem)))
210 into struct-members
211 finally (return `(,kind ,(intern-as-lisp (tag type-decl))
212 ,@struct-members)))))))
213
214 ;;; Anything other than a function declaration, structure or union or
215 ;;; enum, or typedef is a variable declaration.
216
217 (defmethod do-decl ((type-decl c-type) name)
218 `(def-alien-variable ,(intern-as-lisp name) ,(do-type-declarator type-decl)))
219
220 (defmethod do-type-declarator ((type-decl array-type))
221 (let ((dimension (when (len type-decl)
222 (value (len type-decl)))))
223 `(array ,(do-type-declarator (of type-decl)) ,dimension)))
224

  ViewVC Help
Powered by ViewVC 1.1.5