source: branches/objc-gf/ccl/lib/foreign-types.lisp @ 6052

Last change on this file since 6052 was 6052, checked in by gb, 13 years ago

Revert out of some of the changes that led to Trac bug #2.

Try hard to preserve identity of named foreign-record-types; check for field
redefinition earlier.

Use PARSE-FOREIGN-TYPE in load form for FOREIGN-RECORD-TYPE, so that we
go through the same interning (of named types) and field compatibility
checking. Move some of the FOREIGN-RECORD-TYPE definitions later in
the load order, since it's never really worked (doesn't enhance cross-compilation
to define them inside INSTALL-STANDARD-FOREIGN-TYPES, and since we now need
to be able to call PARSE-FOREIGN-TYPE, which can't work that early.
(Actually, it might work to call PARSE-FOREIGN-TYPE to define structure types
at load time, rather than dealing with the strange type constants introduced
in the expansion of DEF-FOREIGN-TYPE.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 64.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2001 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;;; This is a slightly-watered-down version of CMUCL's ALIEN-TYPE system.
18
19(in-package "CCL")
20
21(defstruct (interface-dir
22             (:include dll-node)
23            )
24  (name)
25  (subdir)
26  (constants-interface-db-file)
27  (functions-interface-db-file)
28  (records-interface-db-file)
29  (types-interface-db-file)
30  (vars-interface-db-file)
31  (objc-classes-interface-db-file)
32  (objc-methods-interface-db-file))
33
34(defmethod print-object ((d interface-dir) stream)
35  (print-unreadable-object (d stream :type t :identity t)
36    (format stream "~s ~s"
37            (interface-dir-name d)
38            (interface-dir-subdir d))))
39
40;;; We can't reference foreign types early in the cold load,
41;;; but we want things like RLET to be able to set a pointer's
42;;; type based on the foreign-type's "ordinal".  We therefore
43;;; seem to have to arrange that certain types have fixed,
44;;; "canonical" ordinals.  I doubt if we need more than a handful
45;;; of these, but let's burn 100
46
47(defconstant max-canonical-foreign-type-ordinal 100)
48
49;;; This is intended to try to encapsulate foreign type stuff, to
50;;; ease cross-compilation (among other things.)
51
52(defstruct (foreign-type-data (:conc-name ftd-)
53                              (:constructor make-ftd))
54  (translators (make-hash-table :test #'eq))
55  (kind-info (make-hash-table :test #'eq))
56  (definitions (make-hash-table :test #'eq))
57  (struct-definitions (make-hash-table :test #'eq))
58  (union-definitions (make-hash-table :test #'eq))
59  ;; Do we even use this ?
60  (enum-definitions (make-hash-table :test #'eq))
61  (interface-db-directory ())
62  (interface-package-name ())
63  (external-function-definitions (make-hash-table :test #'eq))
64  (dirlist (make-dll-header))
65  (attributes ())
66  (ff-call-expand-function ())
67  (ff-call-struct-return-by-implicit-arg-function ())
68  (callback-bindings-function ())
69  (callback-return-value-function ())
70  (ordinal max-canonical-foreign-type-ordinal)
71  (ordinal-lock (make-lock))
72  (ordinal-types (make-hash-table :test #'eq :weak :value))
73  (pointer-types (make-hash-table :test #'eq))
74  (array-types (make-hash-table :test #'equal)))
75
76
77
78
79(defvar *host-ftd* (make-ftd
80                    :interface-db-directory
81                    #.(ftd-interface-db-directory *target-ftd*)
82
83                    :interface-package-name
84                    #.(ftd-interface-package-name *target-ftd*)
85                    :attributes
86                    '(:bits-per-word #+64-bit-target 64 #+32-bit-target 32
87                      :signed-char #+darwinppc-target t #-darwinppc-target nil
88                      :struct-by-value #+darwinppc-target t #-darwinppc-target nil
89                      :struct-return-in-registers #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil
90                      :struct-return-explicit  #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil
91                      :struct-by-value-by-field  #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil
92                   
93                      :prepend-underscores #+darwinppc-target t #-darwinppc-target nil)
94                    :ff-call-expand-function
95                    'os::expand-ff-call
96                    :ff-call-struct-return-by-implicit-arg-function
97                    'os::record-type-returns-structure-as-first-arg
98                    :callback-bindings-function
99                    'os::generate-callback-bindings
100                    :callback-return-value-function
101                    'os::generate-callback-return-value
102                    ))
103                   
104(defvar *target-ftd* *host-ftd*)
105(setf (backend-target-foreign-type-data *host-backend*)
106      *host-ftd*)
107
108(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*))
109  (with-lock-grabbed ((ftd-ordinal-lock ftd))
110    (incf (ftd-ordinal ftd))))
111
112
113(defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body)
114  `(do-dll-nodes  (,dir (ftd-dirlist ,ftd))
115    ,@body))
116
117(defun find-interface-dir (name &optional (ftd *target-ftd*))
118  (do-interface-dirs (d ftd)
119    (when (eq name (interface-dir-name d))
120      (return d))))
121
122(defun require-interface-dir (name &optional (ftd *target-ftd*))
123  (or (find-interface-dir name ftd)
124      (error "Interface directory ~s not found" name)))
125
126(defun ensure-interface-dir (name &optional (ftd *target-ftd*))
127  (or (find-interface-dir name ftd)
128      (let* ((d (make-interface-dir
129                 :name name
130                 :subdir (make-pathname
131                          :directory
132                          `(:relative ,(string-downcase name))))))
133        (append-dll-node d (ftd-dirlist ftd)))))
134
135(defun use-interface-dir (name &optional (ftd *target-ftd*))
136  "Tell OpenMCL to add the interface directory denoted by dir-id to the
137list of interface directories which it consults for foreign type and
138function information. Arrange that that directory is searched before any
139others.
140
141Note that use-interface-dir merely adds an entry to a search list. If the
142named directory doesn't exist in the file system or doesn't contain a set
143of database files, a runtime error may occur when OpenMCL tries to open some
144database file in that directory, and it will try to open such a database
145file whenever it needs to find any foreign type or function information.
146unuse-interface-dir may come in handy in that case."
147  (let* ((d (ensure-interface-dir name ftd)))
148    (move-dll-nodes d (ftd-dirlist ftd))
149    d))
150
151(defun unuse-interface-dir (name &optional (ftd *target-ftd*))
152  "Tell OpenMCL to remove the interface directory denoted by dir-id from
153the list of interface directories which are consulted for foreign type
154and function information. Returns T if the directory was on the search
155list, NIL otherwise."
156  (let* ((d (find-interface-dir name ftd)))
157    (when d
158      (remove-dll-node d)
159      t)))
160
161
162(use-interface-dir :libc)
163
164
165;;;; Utility functions.
166
167(eval-when (:compile-toplevel :load-toplevel :execute)
168  (defun align-offset (offset alignment)
169    (let ((extra (rem offset alignment)))
170      (if (zerop extra) offset (+ offset (- alignment extra)))))
171
172  (defun guess-alignment (bits)
173    (cond ((null bits) nil)
174          ((> bits 32) 64)
175          ((> bits 16) 32)
176          ((> bits 8) 16)
177          ((= bits 8) 8)
178          (t 1)))
179
180  (defstruct foreign-type-class
181    (name nil :type symbol)
182    (include nil :type (or null foreign-type-class))
183    (unparse nil :type (or null function))
184    (type= nil :type (or null function))
185    (lisp-rep nil :type (or null function))
186    (foreign-rep nil :type (or null function))
187    (extract-gen nil :type (or null function))
188    (deposit-gen nil :type (or null function))
189    (naturalize-gen nil :type (or null function))
190    (deport-gen nil :type (or null function))
191    ;; Cast?
192    (arg-tn nil :type (or null function))
193    (result-tn nil :type (or null function))
194    (subtypep nil :type (or null function)))
195
196
197  (defvar *foreign-type-classes* (make-hash-table :test #'eq))
198
199  (defun info-foreign-type-translator (x &optional (ftd *target-ftd*))
200    (gethash (make-keyword x) (ftd-translators ftd)))
201  (defun (setf info-foreign-type-translator) (val x &optional (ftd *target-ftd*))
202    (setf (gethash (make-keyword x) (ftd-translators ftd)) val))
203
204  (defun note-foreign-type-ordinal (type ftd)
205    (let* ((ordinal (and type (foreign-type-ordinal type))))
206      (when (and ordinal (not (eql 0 ordinal)))
207        (with-lock-grabbed ((ftd-ordinal-lock ftd))
208          (setf (gethash ordinal (ftd-ordinal-types ftd)) type)))))
209 
210  (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
211    (if (info-foreign-type-translator x ftd)
212      :primitive
213      (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown)))
214  (defun (setf info-foreign-type-kind) (val x &optional (ftd *target-ftd*))
215    (setf (gethash (make-keyword x) (ftd-kind-info ftd)) val))
216                   
217  (defun info-foreign-type-definition (x &optional (ftd *target-ftd*))
218    (gethash (make-keyword x) (ftd-definitions ftd)))
219  (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*))
220    (note-foreign-type-ordinal val ftd)
221    (setf (gethash (make-keyword x) (ftd-definitions ftd)) val))
222  (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*))
223    (remhash (make-keyword x) (ftd-definitions ftd)))
224
225  (defun info-foreign-type-struct (x &optional (ftd *target-ftd*))
226    (gethash (make-keyword x) (ftd-struct-definitions ftd)))
227  (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*))
228    (note-foreign-type-ordinal val ftd)
229    (setf (gethash (make-keyword x) (ftd-struct-definitions ftd)) val))
230
231  (defun info-foreign-type-union (x &optional (ftd *target-ftd*))
232    (gethash (make-keyword x) (ftd-union-definitions ftd)))
233  (defun (setf info-foreign-type-union) (val x  &optional (ftd *target-ftd*))
234    (note-foreign-type-ordinal val ftd)
235    (setf (gethash (make-keyword x) (ftd-union-definitions ftd)) val))
236
237  (defun info-foreign-type-enum (x  &optional (ftd *target-ftd*))
238    (gethash (make-keyword x) (ftd-enum-definitions ftd)))
239  (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*))
240    (note-foreign-type-ordinal val ftd)
241    (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val))
242
243  (defun require-foreign-type-class (name)
244    (or (gethash name  *foreign-type-classes*)
245        (error "Unknown foreign type class ~s" name)))
246
247  (defun find-or-create-foreign-type-class (name include)
248    (let* ((old (gethash name *foreign-type-classes*))
249           (include-class (if include (require-foreign-type-class include))))
250      (if old
251        (setf (foreign-type-class-name old) include-class)
252        (setf (gethash name *foreign-type-classes*)
253              (make-foreign-type-class :name name :include include-class)))))
254
255
256  (defconstant method-slot-alist
257    '((:unparse . foreign-type-class-unparse)
258      (:type= . foreign-type-class-type=)
259      (:subtypep . foreign-type-class-subtypep)
260      (:lisp-rep . foreign-type-class-lisp-rep)
261      (:foreign-rep . foreign-type-class-foreign-rep)
262      (:extract-gen . foreign-type-class-extract-gen)
263      (:deposit-gen . foreign-type-class-deposit-gen)
264      (:naturalize-gen . foreign-type-class-naturalize-gen)
265      (:deport-gen . foreign-type-class-deport-gen)
266      ;; Cast?
267      (:arg-tn . foreign-type-class-arg-tn)
268      (:result-tn . foreign-type-class-result-tn)))
269
270  (defun method-slot (method)
271    (cdr (or (assoc method method-slot-alist)
272             (error "No method ~S" method))))
273  )
274
275(defmethod print-object ((f foreign-type-class) out)
276  (print-unreadable-object (f out :type t :identity t)
277    (prin1 (foreign-type-class-name f) out)))
278
279
280;;; We define a keyword "BOA" constructor so that we can reference the slots
281;;; names in init forms.
282;;;
283(defmacro def-foreign-type-class ((name &key include include-args) &rest slots)
284  (let ((defstruct-name
285         (intern (concatenate 'string "FOREIGN-" (symbol-name name) "-TYPE"))))
286    (multiple-value-bind
287        (include include-defstruct overrides)
288        (etypecase include
289          (null
290           (values nil 'foreign-type nil))
291          (symbol
292           (values
293            include
294            (intern (concatenate 'string
295                                 "FOREIGN-" (symbol-name include) "-TYPE"))
296            nil))
297          (list
298           (values
299            (car include)
300            (intern (concatenate 'string
301                                 "FOREIGN-" (symbol-name (car include)) "-TYPE"))
302            (cdr include))))
303      `(progn
304         (eval-when (:compile-toplevel :load-toplevel :execute)
305           (find-or-create-foreign-type-class ',name ',(or include 'root)))
306         (defstruct (,defstruct-name
307                        (:include ,include-defstruct
308                                  (class ',name)
309                                  ,@overrides)
310                        (:constructor
311                         ,(intern (concatenate 'string "MAKE-"
312                                               (string defstruct-name)))
313                         (&key class bits alignment
314                               ,@(mapcar #'(lambda (x)
315                                             (if (atom x) x (car x)))
316                                         slots)
317                               ,@include-args)))
318           ,@slots)))))
319
320(defmacro def-foreign-type-method ((class method) lambda-list &rest body)
321  (let ((defun-name (intern (concatenate 'string
322                                         (symbol-name class)
323                                         "-"
324                                         (symbol-name method)
325                                         "-METHOD"))))
326    `(progn
327       (defun ,defun-name ,lambda-list
328         ,@body)
329       (setf (,(method-slot method) (require-foreign-type-class ',class))
330             #',defun-name))))
331
332(defmacro invoke-foreign-type-method (method type &rest args)
333  (let ((slot (method-slot method)))
334    (once-only ((type type))
335      `(funcall (do ((class (require-foreign-type-class (foreign-type-class ,type))
336                            (foreign-type-class-include class)))
337                    ((null class)
338                     (error "Method ~S not defined for ~S"
339                            ',method (foreign-type-class ,type)))
340                  (let ((fn (,slot class)))
341                    (when fn
342                      (return fn))))
343                ,type ,@args))))
344
345
346;;;; Foreign-type defstruct.
347
348(eval-when (:compile-toplevel :load-toplevel :execute)
349  (find-or-create-foreign-type-class 'root nil))
350
351(defstruct (foreign-type
352            (:constructor make-foreign-type (&key class bits alignment ordinal))
353            (:print-object
354             (lambda (s out)
355               (print-unreadable-object (s out :type t :identity t)
356                 (prin1 (unparse-foreign-type s) out)))))
357  (class 'root :type symbol)
358  (bits nil :type (or null unsigned-byte))
359  (alignment (guess-alignment bits) :type (or null unsigned-byte))
360  (ordinal (next-foreign-type-ordinal)))
361
362
363
364(defmethod make-load-form ((s foreign-type) &optional env)
365  (if (eq s *void-foreign-type*)
366    '*void-foreign-type*
367    (make-load-form-saving-slots s :environment env)))
368
369
370
371
372;;;; Type parsing and unparsing.
373
374(defvar *auxiliary-type-definitions* nil)
375(defvar *new-auxiliary-types*)
376
377;;; WITH-AUXILIARY-FOREIGN-TYPES -- internal.
378;;;
379;;; Process stuff in a new scope.
380;;;
381(defmacro with-auxiliary-foreign-types (&body body)
382  `(let ((*auxiliary-type-definitions*
383          (if (boundp '*new-auxiliary-types*)
384              (append *new-auxiliary-types* *auxiliary-type-definitions*)
385              *auxiliary-type-definitions*))
386         (*new-auxiliary-types* nil))
387     ,@body))
388
389;;; PARSE-FOREIGN-TYPE -- public
390;;;
391(defun parse-foreign-type (type &optional (ftd *target-ftd*))
392  "Parse the list structure TYPE as a foreign type specifier and return
393   the resultant foreign-type structure."
394  (if (boundp '*new-auxiliary-types*)
395    (%parse-foreign-type type ftd)
396    (let ((*new-auxiliary-types* nil))
397      (%parse-foreign-type type ftd))))
398
399(defun %parse-foreign-type (type &optional (ftd *target-ftd*))
400  (if (consp type)
401    (let ((translator (info-foreign-type-translator (car type) ftd)))
402      (unless translator
403        (error "Unknown foreign type: ~S" type))
404      (funcall translator type nil))
405    (case (info-foreign-type-kind type)
406      (:primitive
407       (let ((translator (info-foreign-type-translator type ftd)))
408         (unless translator
409           (error "No translator for primitive foreign type ~S?" type))
410      (funcall translator (list type) nil)))
411      (:defined
412          (or (info-foreign-type-definition type ftd)
413              (error "Definition missing for foreign type ~S?" type)))
414      (:unknown
415       (let* ((loaded (load-foreign-type type ftd)))
416         (if loaded
417           (setq type loaded)))
418       (or (info-foreign-type-definition type ftd)
419           (error "Unknown foreign type: ~S" type))))))
420
421(defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*))
422  (declare (ignore ftd))
423  (flet ((aux-defn-matches (x)
424           (and (eq (first x) kind) (eq (second x) name))))
425    (let ((in-auxiliaries
426           (or (find-if #'aux-defn-matches *new-auxiliary-types*)
427               (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
428      (if in-auxiliaries
429        (values (third in-auxiliaries) t)))))
430
431(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*))
432  (declare (ignore ftd))
433  (flet ((aux-defn-matches (x)
434           (and (eq (first x) kind) (eq (second x) name))))
435    (when (find-if #'aux-defn-matches *new-auxiliary-types*)
436      (error "Attempt to multiple define ~A ~S." kind name))
437    (when (find-if #'aux-defn-matches *auxiliary-type-definitions*)
438      (error "Attempt to shadow definition of ~A ~S." kind name)))
439  (push (list kind name defn) *new-auxiliary-types*)
440  defn)
441
442(defsetf auxiliary-foreign-type %set-auxiliary-foreign-type)
443
444
445;;; *record-type-already-unparsed* -- internal
446;;;
447;;; Holds the list of record types that have already been unparsed.  This is
448;;; used to keep from outputing the slots again if the same structure shows
449;;; up twice.
450;;;
451(defvar *record-types-already-unparsed*)
452
453;;; UNPARSE-FOREIGN-TYPE -- public.
454;;;
455(defun unparse-foreign-type (type)
456  "Convert the foreign-type structure TYPE back into a list specification of
457   the type."
458  (declare (type foreign-type type))
459  (let ((*record-types-already-unparsed* nil))
460    (%unparse-foreign-type type)))
461
462;;; %UNPARSE-FOREIGN-TYPE -- internal.
463;;;
464;;; Does all the work of UNPARSE-FOREIGN-TYPE.  It's seperate because we need
465;;; to recurse inside the binding of *record-types-already-unparsed*.
466;;;
467(defun %unparse-foreign-type (type)
468  (invoke-foreign-type-method :unparse type))
469
470
471
472
473;;;; Foreign type defining stuff.
474
475(defmacro def-foreign-type-translator (name lambda-list &body body &environment env)
476  (expand-type-macro '%def-foreign-type-translator name lambda-list body env))
477
478
479(defun %def-foreign-type-translator (name translator docs)
480  (declare (ignore docs))
481  (setf (info-foreign-type-translator name) translator)
482  (clear-info-foreign-type-definition name)
483  #+nil
484  (setf (documentation name 'foreign-type) docs)
485  name)
486
487
488(defmacro def-foreign-type (name type)
489  "If name is non-NIL, define name to be an alias for the foreign type
490specified by foreign-type-spec. If foreign-type-spec is a named structure
491or union type, additionally defines that structure or union type.
492
493If name is NIL, foreign-type-spec must be a named foreign struct or union
494definition, in which case the foreign structure or union definition is put
495in effect.
496
497Note that there are two separate namespaces for foreign type names, one for
498the names of ordinary types and one for the names of structs and unions.
499Which one name refers to depends on foreign-type-spec in the obvious manner."
500  (with-auxiliary-foreign-types
501    (let ((foreign-type (parse-foreign-type type)))
502      `(eval-when (:compile-toplevel :load-toplevel :execute)
503         ,@(when *new-auxiliary-types*
504             `((%def-auxiliary-foreign-types ',*new-auxiliary-types*)))
505         ,@(when name
506             `((%def-foreign-type ',name ',foreign-type)))))))
507
508(defun %def-auxiliary-foreign-types (types)
509  (dolist (info types)
510    (destructuring-bind (kind name defn) info
511      (macrolet ((frob (accessor)
512                   `(let ((old (,accessor name)))
513                      (unless (or (null old) (foreign-type-= old defn))
514                        (warn "Redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
515                              kind name defn old))
516                      (setf (,accessor name) defn))))
517        (ecase kind
518          (:struct (frob info-foreign-type-struct))
519          (:union (frob info-foreign-type-union))
520          (:enum (frob info-foreign-type-enum)))))))
521
522(defun %def-foreign-type (name new &optional (ftd *target-ftd*))
523  (ecase (info-foreign-type-kind name ftd)
524    (:primitive
525     (error "~S is a built-in foreign type." name))
526    (:defined
527     (let ((old (info-foreign-type-definition name ftd)))
528       (unless (or (null old) (foreign-type-= new old))
529         (warn "Redefining ~S to be:~%  ~S,~%was~%  ~S" name
530               (unparse-foreign-type new) (unparse-foreign-type old)))))
531    (:unknown))
532  (setf (info-foreign-type-definition name ftd) new)
533  (setf (info-foreign-type-kind name ftd) :defined)
534  name)
535
536
537
538;;;; Interfaces to the different methods
539
540(defun foreign-type-= (type1 type2)
541  "Return T iff TYPE1 and TYPE2 describe equivalent foreign types."
542  (or (eq type1 type2)
543      (and (eq (foreign-type-class type1)
544               (foreign-type-class type2))
545           (invoke-foreign-type-method :type= type1 type2))))
546
547(defun foreign-subtype-p (type1 type2)
548  "Return T iff the foreign type TYPE1 is a subtype of TYPE2.  Currently, the
549   only supported subtype relationships are is that any pointer type is a
550   subtype of (* t), and any array type first dimension will match
551   (array <eltype> nil ...).  Otherwise, the two types have to be
552   FOREIGN-TYPE-=."
553  (or (eq type1 type2)
554      (invoke-foreign-type-method :subtypep type1 type2)))
555
556(defun foreign-typep (object type)
557  "Return T iff OBJECT is a foreign of type TYPE."
558  (let ((lisp-rep-type (compute-lisp-rep-type type)))
559    (if lisp-rep-type
560        (typep object lisp-rep-type))))
561
562
563(defun compute-naturalize-lambda (type)
564  `(lambda (foreign ignore)
565     (declare (ignore ignore))
566     ,(invoke-foreign-type-method :naturalize-gen type 'foreign)))
567
568(defun compute-deport-lambda (type)
569  (declare (type foreign-type type))
570  (multiple-value-bind
571      (form value-type)
572      (invoke-foreign-type-method :deport-gen type 'value)
573    `(lambda (value ignore)
574       (declare (type ,(or value-type
575                           (compute-lisp-rep-type type)
576                           `(foreign ,type))
577                      value)
578                (ignore ignore))
579       ,form)))
580
581(defun compute-extract-lambda (type)
582  `(lambda (sap offset ignore)
583     (declare (type system-area-pointer sap)
584              (type unsigned-byte offset)
585              (ignore ignore))
586     (naturalize ,(invoke-foreign-type-method :extract-gen type 'sap 'offset)
587                 ',type)))
588
589(defun compute-deposit-lambda (type)
590  (declare (type foreign-type type))
591  `(lambda (sap offset ignore value)
592     (declare (type system-area-pointer sap)
593              (type unsigned-byte offset)
594              (ignore ignore))
595     (let ((value (deport value ',type)))
596       ,(invoke-foreign-type-method :deposit-gen type 'sap 'offset 'value)
597       ;; Note: the reason we don't just return the pre-deported value
598       ;; is because that would inhibit any (deport (naturalize ...))
599       ;; optimizations that might have otherwise happen.  Re-naturalizing
600       ;; the value might cause extra consing, but is flushable, so probably
601       ;; results in better code.
602       (naturalize value ',type))))
603
604(defun compute-lisp-rep-type (type)
605  (invoke-foreign-type-method :lisp-rep type))
606
607(defun compute-foreign-rep-type (type)
608  (invoke-foreign-type-method :foreign-rep type))
609
610
611
612
613
614;;;; Default methods.
615
616(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0))
617
618(def-foreign-type-method (root :unparse) (type)
619  (if (eq type *void-foreign-type*)
620    :void
621    `(!!unknown-foreign-type!! ,(type-of type))))
622
623(def-foreign-type-method (root :type=) (type1 type2)
624  (declare (ignore type1 type2))
625  t)
626
627(def-foreign-type-method (root :subtypep) (type1 type2)
628  (foreign-type-= type1 type2))
629
630(def-foreign-type-method (root :lisp-rep) (type)
631  (declare (ignore type))
632  nil)
633
634(def-foreign-type-method (root :foreign-rep) (type)
635  (declare (ignore type))
636  '*)
637
638(def-foreign-type-method (root :naturalize-gen) (type foreign)
639  (declare (ignore foreign))
640  (error "Cannot represent ~S typed foreigns." type))
641
642(def-foreign-type-method (root :deport-gen) (type object)
643  (declare (ignore object))
644  (error "Cannot represent ~S typed foreigns." type))
645
646(def-foreign-type-method (root :extract-gen) (type sap offset)
647  (declare (ignore sap offset))
648  (error "Cannot represent ~S typed foreigns." type))
649
650(def-foreign-type-method (root :deposit-gen) (type sap offset value)
651  `(setf ,(invoke-foreign-type-method :extract-gen type sap offset) ,value))
652
653(def-foreign-type-method (root :arg-tn) (type state)
654  (declare (ignore state))
655  (error "Cannot pass foreigns of type ~S as arguments to call-out"
656         (unparse-foreign-type type)))
657
658(def-foreign-type-method (root :result-tn) (type state)
659  (declare (ignore state))
660  (error "Cannot return foreigns of type ~S from call-out"
661         (unparse-foreign-type type)))
662
663
664
665;;;; The INTEGER type.
666
667(def-foreign-type-class (integer)
668  (signed t :type (member t nil)))
669
670(defvar *unsigned-integer-types*
671  (let* ((a (make-array 65)))
672    (dotimes (i 65 a)
673      (setf (svref a i) (make-foreign-integer-type :signed nil
674                                                   :bits i
675                                                   :alignment
676                                                   (if (= 1 (logcount i))
677                                                     i
678                                                     1))))))
679
680(defvar *signed-integer-types*
681  (let* ((a (make-array 65)))
682    (dotimes (i 65 a)
683      (setf (svref a i) (make-foreign-integer-type :signed t
684                                                   :bits i
685                                                   :alignment
686                                                   (if (= 1 (logcount i))
687                                                     i
688                                                     1))))))
689         
690
691(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil))
692
693                                                 
694
695(def-foreign-type-method (integer :unparse) (type)
696  (if (eq type *bool-type*)
697    :<BOOL>
698    (let* ((bits (foreign-integer-type-bits type))
699           (signed (foreign-integer-type-signed type))
700           (alignment (foreign-integer-type-alignment type)))
701      (if (eql alignment 1)
702        (if (eql bits 1)
703          :bit
704          `(:bitfield ,bits))
705        (list (if signed :signed :unsigned) bits)))))
706 
707(def-foreign-type-method (integer :type=) (type1 type2)
708  (and (eq (foreign-integer-type-signed type1)
709           (foreign-integer-type-signed type2))
710       (= (foreign-integer-type-bits type1)
711          (foreign-integer-type-bits type2))))
712
713(def-foreign-type-method (integer :lisp-rep) (type)
714  (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte)
715        (foreign-integer-type-bits type)))
716
717(def-foreign-type-method (integer :foreign-rep) (type)
718  (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte)
719        (foreign-integer-type-bits type)))
720
721(def-foreign-type-method (integer :naturalize-gen) (type foreign)
722  (declare (ignore type))
723  foreign)
724
725(def-foreign-type-method (integer :deport-gen) (type value)
726  (declare (ignore type))
727  value)
728
729(def-foreign-type-method (integer :extract-gen) (type sap offset)
730  (declare (type foreign-integer-type type))
731  (let ((ref-form
732         (if (foreign-integer-type-signed type)
733          (case (foreign-integer-type-bits type)
734            (8 `(%get-signed-byte ,sap (/ ,offset 8)))
735            (16 `(%get-signed-word ,sap (/ ,offset 8)))
736            (32 `(%get-signed-long ,sap (/ ,offset 8)))
737            (64 `(%%get-signed-longlong ,sap (/ ,offset 8))))
738          (case (foreign-integer-type-bits type)
739            (1 `(%get-bit ,sap ,offset))
740            (8 `(%get-unsigned-byte ,sap (/ ,offset 8)))
741            (16 `(%get-unsigned-word ,sap (/ ,offset 8)))
742            (32 `(%get-unsigned-long ,sap (/ ,offset 8)))
743            (64 `(%%get-unsigned-longlong ,sap (/ ,offset 8)))
744            (t  `(%get-bitfield ,sap ,offset ,(foreign-integer-type-bits type)))))))
745    (or ref-form
746        (error "Cannot extract ~D bit integers."
747               (foreign-integer-type-bits type)))))
748
749
750
751;;;; The BOOLEAN type.
752
753(def-foreign-type-class (boolean :include integer :include-args (signed)))
754
755
756
757(def-foreign-type-method (boolean :lisp-rep) (type)
758  (declare (ignore type))
759  `(member t nil))
760
761(def-foreign-type-method (boolean :naturalize-gen) (type foreign)
762  (declare (ignore type))
763  `(not (zerop ,foreign)))
764
765(def-foreign-type-method (boolean :deport-gen) (type value)
766  (declare (ignore type))
767  `(if ,value 1 0))
768
769
770(def-foreign-type-method (boolean :unparse) (type)
771  `(boolean ,(foreign-boolean-type-bits type)))
772
773
774;;;; the FLOAT types.
775
776(def-foreign-type-class (float)
777  (type () :type symbol))
778
779(def-foreign-type-method (float :unparse) (type)
780  (foreign-float-type-type type))
781
782(def-foreign-type-method (float :lisp-rep) (type)
783  (foreign-float-type-type type))
784
785(def-foreign-type-method (float :foreign-rep) (type)
786  (foreign-float-type-type type))
787
788(def-foreign-type-method (float :naturalize-gen) (type foreign)
789  (declare (ignore type))
790  foreign)
791
792(def-foreign-type-method (float :deport-gen) (type value)
793  (declare (ignore type))
794  value)
795
796
797(def-foreign-type-class (single-float :include (float (bits 32))
798                                    :include-args (type)))
799
800
801(def-foreign-type-method (single-float :extract-gen) (type sap offset)
802  (declare (ignore type))
803  `(%get-single-float ,sap (/ ,offset 8)))
804
805
806(def-foreign-type-class (double-float :include (float (bits 64))
807                                    :include-args (type)))
808
809
810(def-foreign-type-method (double-float :extract-gen) (type sap offset)
811  (declare (ignore type))
812  `(%get-double-float ,sap (/ ,offset 8)))
813
814
815
816;;;; The MACPTR type
817
818(def-foreign-type-class (macptr))
819
820
821(def-foreign-type-method (macptr :unparse) (type)
822  (declare (ignore type))
823  'macptr)
824
825(def-foreign-type-method (macptr :lisp-rep) (type)
826  (declare (ignore type))
827  'macptr)
828
829(def-foreign-type-method (macptr :foreign-rep) (type)
830  (declare (ignore type))
831  'macptr)
832
833(def-foreign-type-method (macptr :naturalize-gen) (type foreign)
834  (declare (ignore type))
835  foreign)
836
837(def-foreign-type-method (macptr :deport-gen) (type object)
838  (declare (ignore type))
839  object)
840
841(def-foreign-type-method (macptr :extract-gen) (type sap offset)
842  (declare (ignore type))
843  `(%get-ptr ,sap (/ ,offset 8)))
844
845
846;;;; the FOREIGN-VALUE type.
847
848(def-foreign-type-class (foreign-value :include macptr))
849
850(def-foreign-type-method (foreign-value :lisp-rep) (type)
851  (declare (ignore type))
852  nil)
853
854(def-foreign-type-method (foreign-value :naturalize-gen) (type foreign)
855  `(%macptr-foreign ,foreign ',type))
856
857(def-foreign-type-method (foreign-value :deport-gen) (type value)
858  (declare (ignore type))
859  `(foreign-macptr ,value))
860
861
862
863;;;; The POINTER type.
864
865(def-foreign-type-class (pointer :include (foreign-value))
866  (to *void-foreign-type* :type foreign-type))
867
868
869
870(def-foreign-type-method (pointer :unparse) (type)
871  (let ((to (foreign-pointer-type-to type)))
872    `(:* ,(if to
873             (%unparse-foreign-type to)
874             :void))))
875
876(def-foreign-type-method (pointer :type=) (type1 type2)
877  (let ((to1 (foreign-pointer-type-to type1))
878        (to2 (foreign-pointer-type-to type2)))
879    (if to1
880        (if to2
881            (foreign-type-= to1 to2)
882            nil)
883        (null to2))))
884
885(def-foreign-type-method (pointer :subtypep) (type1 type2)
886  (and (foreign-pointer-type-p type2)
887       (let ((to1 (foreign-pointer-type-to type1))
888             (to2 (foreign-pointer-type-to type2)))
889         (if to1
890             (if to2
891                 (foreign-subtype-p to1 to2)
892                 t)
893             (null to2)))))
894
895(def-foreign-type-method (pointer :deport-gen) (type value)
896  (values
897   `(etypecase ,value
898      (null
899       (%int-to-ptr 0))
900      (macptr
901       ,value)
902      ((foreign ,type)
903       (foreign-sap ,value)))
904   `(or null macptr (foreign ,type))))
905
906
907;;;; The MEM-BLOCK type.
908
909
910(def-foreign-type-class (mem-block :include foreign-value))
911
912(def-foreign-type-method (mem-block :extract-gen) (type sap offset)
913  (let* ((nbytes (%foreign-type-or-record-size type :bytes)))
914    `(%composite-pointer-ref ,nbytes ,sap (/ ,offset 8))))
915
916(def-foreign-type-method (mem-block :deposit-gen) (type sap offset value)
917  (let ((bits (foreign-mem-block-type-bits type)))
918    (unless bits
919      (error "Cannot deposit foreigns of type ~S (unknown size)." type))
920    `(%copy-macptr-to-macptr ,value 0 ,sap ,offset ',bits)))
921
922
923
924;;;; The ARRAY type.
925
926(def-foreign-type-class (array :include mem-block)
927  (element-type () :type foreign-type)
928  (dimensions () :type list))
929
930
931
932(def-foreign-type-method (array :unparse) (type)
933  `(array ,(%unparse-foreign-type (foreign-array-type-element-type type))
934          ,@(foreign-array-type-dimensions type)))
935
936(def-foreign-type-method (array :type=) (type1 type2)
937  (and (equal (foreign-array-type-dimensions type1)
938              (foreign-array-type-dimensions type2))
939       (foreign-type-= (foreign-array-type-element-type type1)
940                       (foreign-array-type-element-type type2))))
941
942(def-foreign-type-method (array :subtypep) (type1 type2)
943  (and (foreign-array-type-p type2)
944       (let ((dim1 (foreign-array-type-dimensions type1))
945             (dim2 (foreign-array-type-dimensions type2)))
946         (and (= (length dim1) (length dim2))
947              (or (and dim2
948                       (null (car dim2))
949                       (equal (cdr dim1) (cdr dim2)))
950                  (equal dim1 dim2))
951              (foreign-subtype-p (foreign-array-type-element-type type1)
952                               (foreign-array-type-element-type type2))))))
953
954
955;;;; The RECORD type.
956
957(defstruct (foreign-record-field
958             (:print-object
959              (lambda (field stream)
960                (print-unreadable-object (field stream :type t)
961                  (funcall (formatter "~S ~S~@[ ~D@~D~]")
962                           stream
963                           (foreign-record-field-type field)
964                           (foreign-record-field-name field)
965                           (foreign-record-field-bits field)
966                           (foreign-record-field-offset field))))))
967  (name () :type symbol)
968  (type () :type foreign-type)
969  (bits nil :type (or unsigned-byte null))
970  (offset 0 :type unsigned-byte))
971
972
973
974(defmethod make-load-form ((f foreign-record-field) &optional env)
975  (make-load-form-saving-slots f :environment env))
976
977(def-foreign-type-class (record :include mem-block)
978  (kind :struct :type (member :struct :union))
979  (name nil :type (or symbol null))
980  (fields nil :type list)
981  ;; For, e.g., records defined with #pragma options align=mac68k
982  ;; in effect.  When non-nil, this specifies the maximum alignment
983  ;; of record fields and the overall alignment of the record.
984  (alt-align nil :type (or unsigned-byte null)))
985
986(defmethod make-load-form ((r foreign-record-type) &optional environment)
987  (declare (ignore environment))
988  `(parse-foreign-type ',(unparse-foreign-type r)))
989
990
991(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*))
992  (let* ((result (if name
993                   (or
994                    (ecase kind
995                      (:struct (info-foreign-type-struct name ftd))
996                      (:union (info-foreign-type-union name ftd)))
997                    (case kind
998                      (:struct (setf (info-foreign-type-struct name ftd)
999                                     (make-foreign-record-type :name name :kind :struct)))
1000                      (:union  (setf (info-foreign-type-union name ftd)
1001                                     (make-foreign-record-type :name name :kind :union)))))
1002                   (make-foreign-record-type :kind kind))))
1003    (when fields
1004      (multiple-value-bind (parsed-fields alignment bits)
1005          (parse-field-list fields kind (foreign-record-type-alt-align result))
1006        (let* ((old-fields (foreign-record-type-fields result)))
1007          (setf (foreign-record-type-fields result) parsed-fields
1008                (foreign-record-type-alignment result) alignment
1009                (foreign-record-type-bits result) bits)
1010          (when old-fields
1011            (unless (record-fields-match old-fields parsed-fields 5)
1012              (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s"
1013                    kind name parsed-fields old-fields))))))
1014    (if name
1015      (unless (eq (auxiliary-foreign-type kind name) result)
1016        (setf (auxiliary-foreign-type kind name) result)))
1017    result))
1018
1019;;; PARSE-FOREIGN-RECORD-FIELDS -- internal
1020;;;
1021;;; Used by parse-foreign-type to parse the fields of struct and union
1022;;; types.  RESULT holds the record type we are paring the fields of,
1023;;; and FIELDS is the list of field specifications.
1024;;;
1025(defun parse-field-list (fields kind &optional alt-alignment)
1026  (collect ((parsed-fields))
1027    (let* ((total-bits 0)
1028           (overall-alignment 1)
1029           (first-field-p t)
1030           (attributes (ftd-attributes *target-ftd*))
1031           (poweropen-alignment (getf attributes :poweropen-alignment)))
1032         
1033      (dolist (field fields)
1034        (destructuring-bind (var type &optional bits) field
1035          (declare (ignore bits))
1036          (let* ((field-type (parse-foreign-type type))
1037                 (bits (ensure-foreign-type-bits field-type))
1038                 (natural-alignment (foreign-type-alignment field-type))
1039                 (alignment (if alt-alignment
1040                              (min natural-alignment alt-alignment)
1041                              (if poweropen-alignment
1042                                (if first-field-p
1043                                  (progn
1044                                    (setq first-field-p nil)
1045                                    natural-alignment)
1046                                  (min 32 natural-alignment))
1047                                natural-alignment)))
1048                 (parsed-field
1049                  (make-foreign-record-field :type field-type
1050                                             :name var)))
1051            (parsed-fields parsed-field)
1052            (when (null bits)
1053              (error "Unknown size: ~S"
1054                     (unparse-foreign-type field-type)))
1055            (when (null alignment)
1056              (error "Unknown alignment: ~S"
1057                     (unparse-foreign-type field-type)))
1058            (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
1059            (ecase kind
1060              (:struct
1061               (let ((offset (align-offset total-bits alignment)))
1062                 (setf (foreign-record-field-offset parsed-field) offset)
1063                 (setf (foreign-record-field-bits parsed-field) bits)
1064                 (setf total-bits (+ offset bits))))
1065              (:union
1066               (setf total-bits (max total-bits bits)))))))
1067      (values (parsed-fields)
1068              (or alt-alignment overall-alignment)
1069              (align-offset total-bits (or alt-alignment overall-alignment))))))
1070           
1071
1072
1073(defun parse-foreign-record-fields (result fields)
1074  (declare (type foreign-record-type result)
1075           (type list fields))
1076  (multiple-value-bind (parsed-fields alignment bits)
1077      (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result))
1078    (setf (foreign-record-type-fields result) parsed-fields
1079          (foreign-record-type-alignment result) alignment
1080          (foreign-record-type-bits result) bits)))
1081
1082
1083(def-foreign-type-method (record :unparse) (type)
1084  `(,(case (foreign-record-type-kind type)
1085       (:struct :struct)
1086       (:union :union)
1087       (t '???))
1088    ,(foreign-record-type-name type)
1089    ,@(unless (member type *record-types-already-unparsed* :test #'eq)
1090        (push type *record-types-already-unparsed*)
1091        (mapcar #'(lambda (field)
1092                    `(,(foreign-record-field-name field)
1093                      ,(%unparse-foreign-type (foreign-record-field-type field))
1094                      ,@(if (foreign-record-field-bits field)
1095                            (list (foreign-record-field-bits field)))))
1096                (foreign-record-type-fields type)))))
1097
1098;;; Test the record fields. The depth is limiting in case of cyclic
1099;;; pointers.
1100(defun record-fields-match (fields1 fields2 depth)
1101  (declare (type list fields1 fields2)
1102           (type (mod 64) depth))
1103  (labels ((record-type-= (type1 type2 depth)
1104             (and (eq (foreign-record-type-name type1)
1105                      (foreign-record-type-name type2))
1106                  (eq (foreign-record-type-kind type1)
1107                      (foreign-record-type-kind type2))
1108                  (= (length (foreign-record-type-fields type1))
1109                     (length (foreign-record-type-fields type2)))
1110                  (record-fields-match (foreign-record-type-fields type1)
1111                                       (foreign-record-type-fields type2)
1112                                       (1+ depth))))
1113           (pointer-type-= (type1 type2 depth)
1114             (let ((to1 (foreign-pointer-type-to type1))
1115                   (to2 (foreign-pointer-type-to type2)))
1116               (if to1
1117                   (if to2
1118                    (or (> depth 10)
1119                       (type-= to1 to2 (1+ depth)))
1120                       nil)
1121                   (null to2))))
1122           (type-= (type1 type2 depth)
1123             (cond ((and (foreign-pointer-type-p type1)
1124                         (foreign-pointer-type-p type2))
1125                    (or (> depth 10)
1126                        (pointer-type-= type1 type2 depth)))
1127                   ((and (foreign-record-type-p type1)
1128                         (foreign-record-type-p type2))
1129                    (record-type-= type1 type2 depth))
1130                   (t
1131                    (foreign-type-= type1 type2)))))
1132    (do ((fields1-rem fields1 (rest fields1-rem))
1133         (fields2-rem fields2 (rest fields2-rem)))
1134        ((or (eq fields1-rem fields2-rem)
1135             (endp fields1-rem)
1136             (endp fields2-rem))
1137         (eq fields1-rem fields2-rem))
1138      (let ((field1 (first fields1-rem))
1139            (field2 (first fields2-rem)))
1140        (declare (type foreign-record-field field1 field2))
1141        (unless (and (eq (foreign-record-field-name field1)
1142                         (foreign-record-field-name field2))
1143                     (eql (foreign-record-field-bits field1)
1144                          (foreign-record-field-bits field2))
1145                     (eql (foreign-record-field-offset field1)
1146                          (foreign-record-field-offset field2))
1147                     (let ((field1 (foreign-record-field-type field1))
1148                           (field2 (foreign-record-field-type field2)))
1149                       (type-= field1 field2 (1+ depth))))
1150          (return nil))))))
1151
1152(def-foreign-type-method (record :type=) (type1 type2)
1153  (and (eq (foreign-record-type-name type1)
1154           (foreign-record-type-name type2))
1155       (eq (foreign-record-type-kind type1)
1156           (foreign-record-type-kind type2))
1157       (= (length (foreign-record-type-fields type1))
1158          (length (foreign-record-type-fields type2)))
1159       (record-fields-match (foreign-record-type-fields type1)
1160                            (foreign-record-type-fields type2) 0)))
1161
1162
1163;;;; The FUNCTION and VALUES types.
1164
1165(defvar *values-type-okay* nil)
1166
1167(def-foreign-type-class (function :include mem-block)
1168  (result-type () :type foreign-type)
1169  (arg-types () :type list)
1170  (stub nil :type (or null function)))
1171
1172
1173
1174(def-foreign-type-method (function :unparse) (type)
1175  `(function ,(%unparse-foreign-type (foreign-function-type-result-type type))
1176             ,@(mapcar #'%unparse-foreign-type
1177                       (foreign-function-type-arg-types type))))
1178
1179(def-foreign-type-method (function :type=) (type1 type2)
1180  (and (foreign-type-= (foreign-function-type-result-type type1)
1181                     (foreign-function-type-result-type type2))
1182       (= (length (foreign-function-type-arg-types type1))
1183          (length (foreign-function-type-arg-types type2)))
1184       (every #'foreign-type-=
1185              (foreign-function-type-arg-types type1)
1186              (foreign-function-type-arg-types type2))))
1187
1188
1189(def-foreign-type-class (values)
1190  (values () :type list))
1191
1192
1193
1194(def-foreign-type-method (values :unparse) (type)
1195  `(values ,@(mapcar #'%unparse-foreign-type
1196                     (foreign-values-type-values type))))
1197
1198(def-foreign-type-method (values :type=) (type1 type2)
1199  (and (= (length (foreign-values-type-values type1))
1200          (length (foreign-values-type-values type2)))
1201       (every #'foreign-type-=
1202              (foreign-values-type-values type1)
1203              (foreign-values-type-values type2))))
1204
1205
1206
1207
1208;;;; The FOREIGN-SIZE macro.
1209
1210(defmacro foreign-size (type &optional (units :bits))
1211  "Return the size of the foreign type TYPE.  UNITS specifies the units to
1212   use and can be either :BITS, :BYTES, or :WORDS."
1213  (let* ((foreign-type (parse-foreign-type type))
1214         (bits (ensure-foreign-type-bits foreign-type)))
1215    (if bits
1216      (values (ceiling bits
1217                       (ecase units
1218                         (:bits 1)
1219                         (:bytes 8)
1220                         (:words 32))))
1221      (error "Unknown size for foreign type ~S."
1222             (unparse-foreign-type foreign-type)))))
1223
1224(defun ensure-foreign-type-bits (type)
1225  (or (foreign-type-bits type)
1226      (and (typep type 'foreign-record-type)
1227           (let* ((name (foreign-record-type-name type)))
1228             (and name
1229                  (load-record name)
1230                  (foreign-type-bits type))))
1231      (and (typep type 'foreign-array-type)
1232           (let* ((element-type (foreign-array-type-element-type type))
1233                  (dims (foreign-array-type-dimensions type)))
1234             (if (and (ensure-foreign-type-bits element-type)
1235                      (every #'integerp dims))
1236               (setf (foreign-array-type-alignment type)
1237                     (foreign-type-alignment element-type)
1238                     (foreign-array-type-bits type)
1239                     (* (align-offset (foreign-type-bits element-type)
1240                                      (foreign-type-alignment element-type))
1241                        (reduce #'* dims))))))))
1242
1243(defun require-foreign-type-bits (type)
1244  (or (ensure-foreign-type-bits type)
1245      (error "Can't determine attributes of foreign type ~s" type)))
1246
1247(defun %find-foreign-record (name)
1248  (or (info-foreign-type-struct name)
1249      (info-foreign-type-union name)
1250      (load-record name)))
1251
1252
1253(defun %foreign-type-or-record (type)
1254  (if (typep type 'foreign-type)
1255    type
1256    (if (consp type)
1257      (parse-foreign-type type)
1258      (or (%find-foreign-record type)
1259          (parse-foreign-type type)))))
1260
1261(defun %foreign-type-or-record-size (type &optional (units :bits))
1262  (let* ((info (%foreign-type-or-record type))
1263         (bits (ensure-foreign-type-bits info)))
1264    (if bits
1265      (values (ceiling bits
1266                       (ecase units
1267                         (:bits 1)
1268                         (:bytes 8)
1269                         (:words 32))))
1270      (error "Unknown size for foreign type ~S."
1271             (unparse-foreign-type info)))))
1272
1273(defun %find-foreign-record-type-field (type field-name)
1274  (ensure-foreign-type-bits type)       ;load the record type if necessary.
1275  (let* ((fields (foreign-record-type-fields type)))
1276    (or (find field-name  fields :key #'foreign-record-field-name :test #'string-equal)
1277                         (error "Record type ~a has no field named ~s.~&Valid field names are: ~&~a"
1278                                (foreign-record-type-name type)
1279                                field-name
1280                                (mapcar #'foreign-record-field-name fields)))))
1281
1282(defun %foreign-access-form (base-form type bit-offset accessors)
1283  (if (null accessors)
1284    (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1285    (etypecase type
1286      (foreign-record-type
1287       (let* ((field (%find-foreign-record-type-field type (car accessors))))
1288         (%foreign-access-form base-form
1289                               (foreign-record-field-type field)
1290                               (+ bit-offset (foreign-record-field-offset field))
1291                               (cdr accessors))))
1292      (foreign-pointer-type
1293       (%foreign-access-form
1294        (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1295        (foreign-pointer-type-to type)
1296        0
1297        accessors)))))
1298
1299(defun %foreign-array-access-form (base-form type index-form)
1300  (etypecase type
1301    ((or foreign-pointer-type foreign-array-type)
1302     (let* ((to (foreign-pointer-type-to type))
1303            (size (foreign-type-bits to))
1304            (bit-offset `(the fixnum (* ,size (the fixnum ,index-form)))))
1305       (invoke-foreign-type-method :extract-gen to base-form bit-offset)))))
1306
1307
1308
1309
1310;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value
1311
1312(defun naturalize (foreign type)
1313  (declare (type foreign-type type))
1314  (funcall (coerce (compute-naturalize-lambda type) 'function)
1315           foreign type))
1316
1317(defun deport (value type)
1318  (declare (type foreign-type type))
1319  (funcall (coerce (compute-deport-lambda type) 'function)
1320           value type))
1321
1322(defun extract-foreign-value (sap offset type)
1323  (declare (type macptr sap)
1324           (type unsigned-byte offset)
1325           (type foreign-type type))
1326  (funcall (coerce (compute-extract-lambda type) 'function)
1327           sap offset type))
1328
1329(defun deposit-foreign-value (sap offset type value)
1330  (declare (type macptr sap)
1331           (type unsigned-byte offset)
1332           (type foreign-type type))
1333  (funcall (coerce (compute-deposit-lambda type) 'function)
1334           sap offset type value))
1335
1336
1337
1338(defmacro external (name)
1339  "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name,
1340find it and return it. If not, create one and return it.
1341
1342Try to resolve the entry point to a memory address, and identify the
1343containing library.
1344
1345Be aware that under Darwin, external functions which are callable from C
1346have underscores prepended to their names, as in '_fopen'."
1347  `(load-eep ,name))
1348
1349(defmacro external-call (name &rest args)
1350  "Call the foreign function at the address obtained by resolving the
1351external-entry-point associated with name, passing the values of each arg
1352as a foreign argument of type indicated by the corresponding
1353arg-type-specifier. Returns the foreign function result (coerced to a
1354Lisp object of type indicated by result-type-specifier), or NIL if
1355result-type-specifer is :VOID or NIL"
1356  `(ff-call (%reference-external-entry-point
1357             (load-time-value (external ,name))) ,@args))
1358
1359(defmacro ff-call (entry &rest args)
1360  "Call the foreign function at address entrypoint passing the values of
1361each arg as a foreign argument of type indicated by the corresponding
1362arg-type-specifier. Returns the foreign function result (coerced to a
1363Lisp object of type indicated by result-type-specifier), or NIL if
1364result-type-specifer is :VOID or NIL"
1365  (funcall (ftd-ff-call-expand-function *target-ftd*)
1366           `(%ff-call ,entry) args))
1367       
1368         
1369(make-built-in-class 'external-entry-point *istruct-class*)
1370
1371(defmethod make-load-form ((eep external-entry-point) &optional env)
1372  (declare (ignore env))
1373  `(load-eep ,(eep.name eep)))
1374
1375
1376(defmethod print-object ((eep external-entry-point) out)
1377  (print-unreadable-object (eep out :type t :identity t)
1378    (format out "~s" (eep.name eep))
1379    (let* ((addr (eep.address eep))
1380           (container (eep.container eep)))
1381      (if addr
1382        #+ppc-target
1383        (progn
1384          #+32-bit-target
1385          (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2)))
1386          #+64-bit-target
1387          (format out " (#x~16,'0x) " (if (typep addr 'integer)
1388                                        (logand #xffffffffffffffff (ash addr 2))
1389                                        (%ptr-to-int addr))))
1390        #+x8664-target
1391        (format out " (#x~16,'0x) " addr)
1392        (format out " {unresolved} "))
1393      (when (and container (or (not (typep container 'macptr))
1394                                    (not (%null-ptr-p container))))
1395        (format out "~a" (shlib.soname container))))))
1396
1397(make-built-in-class 'foreign-variable *istruct-class*)
1398
1399(defmethod make-load-form ((fv foreign-variable) &optional env)
1400  (declare (ignore env))
1401  `(load-fv ,(fv.name fv) ',(fv.type fv)))
1402
1403(defmethod print-object ((fv foreign-variable) out)
1404  (print-unreadable-object (fv out :type t :identity t)
1405    (format out "~s" (fv.name fv))
1406    (let* ((addr (fv.addr fv))
1407           (container (fv.container fv)))
1408      (if addr
1409        #+32-bit-target
1410        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
1411        #+64-bit-target
1412                (format out " (#x~168,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
1413        (format out " {unresolved} "))
1414      (when (and container (or (not (typep container 'macptr))
1415                                    (not (%null-ptr-p container))))
1416        (format out "~a" (shlib.soname container))))))
1417
1418(make-built-in-class 'shlib *istruct-class*)
1419
1420(defmethod print-object ((s shlib) stream)
1421  (print-unreadable-object (s stream :type t :identity t)
1422    (format stream "~a" (or (shlib.soname s) (shlib.pathname s)))))
1423
1424#-darwin-target
1425(defun dlerror ()
1426  (with-macptrs ((p))
1427    (%setf-macptr p (#_dlerror))
1428    (unless (%null-ptr-p p) (%get-cstring p))))
1429
1430(defstruct (external-function-definition (:conc-name "EFD-")
1431                                         (:constructor
1432                                          make-external-function-definition
1433                                          (&key entry-name arg-specs
1434                                                result-spec
1435                                                (min-args (length arg-specs))))
1436                                         )
1437  (entry-name "" :type string)
1438  (arg-specs () :type list)
1439  (result-spec nil :type symbol)
1440  (min-args 0 :type fixnum))
1441
1442
1443(defun %external-call-expander (whole env)
1444  (declare (ignore env))
1445  (destructuring-bind (name &rest args) whole
1446    (collect ((call))
1447      (let* ((info (or (gethash name (ftd-external-function-definitions
1448                                      *target-ftd*))
1449                       (error "Unknown external-function: ~s" name)))
1450             (external-name (efd-entry-name info))
1451             (arg-specs (efd-arg-specs info))
1452             (result (efd-result-spec info))
1453             (monitor (eq (car args) :monitor-exception-ports)))
1454        (when monitor
1455          (setq args (cdr args))
1456          (call :monitor-exception-ports))
1457        (let* ((rtype (parse-foreign-type result)))
1458          (if (typep rtype 'foreign-record-type)
1459            (call (pop args))))
1460        (do* ((specs arg-specs (cdr specs))
1461              (args args (cdr args)))
1462             ((null specs)
1463              (call result)
1464              (if args
1465                (error "Extra arguments in ~s"  whole)
1466                `(external-call ,external-name ,@(call))))
1467          (let* ((spec (car specs)))
1468            (cond ((eq spec :void)
1469                   ;; must be last arg-spec; remaining args should be
1470                   ;; keyword/value pairs
1471                   (unless (evenp (length args))
1472                     (error "Remaining arguments should be keyword/value pairs: ~s"
1473                            args))
1474                   (do* ()
1475                        ((null args))
1476                     (call (pop args))
1477                     (call (pop args))))
1478                  (t
1479                   (call spec)
1480                   (if args
1481                     (call (car args))
1482                     (error "Missing arguments in ~s" whole))))))))))
1483
1484(defun translate-foreign-arg-type (foreign-type-spec)
1485  (let* ((foreign-type (parse-foreign-type foreign-type-spec)))
1486    (etypecase foreign-type
1487      (foreign-pointer-type :address)
1488      (foreign-integer-type
1489       (let* ((bits (foreign-integer-type-bits foreign-type))
1490              (signed (foreign-integer-type-signed foreign-type)))
1491         (declare (fixnum bits))
1492         (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte))
1493               ((<= bits 16) (if signed :signed-halfword :unsigned-halfword))
1494               ((<= bits 32) (if signed :signed-fullword :unsigned-fullword))
1495               ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword))
1496               (t `(:record ,bits)))))
1497      (foreign-float-type
1498       (ecase (foreign-float-type-bits foreign-type)
1499         (32 :single-float)
1500         (64 :double-float)))
1501      (foreign-record-type
1502       `(:record ,(foreign-record-type-bits foreign-type))))))
1503     
1504
1505(defmacro define-external-function (name (&rest arg-specs) result-spec
1506                                         &key (min-args (length arg-specs)))
1507  (let* ((entry-name nil)
1508         (package (find-package (ftd-interface-package-name *target-ftd*)))
1509         (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs))
1510         (result-keyword (unless (and (symbolp result-spec)
1511                                    (eq (make-keyword result-spec) :void))
1512                               (translate-foreign-arg-type result-spec))))
1513    (when (and (consp result-keyword) (eq (car result-keyword) :record))
1514      (push :address arg-keywords)
1515      (setq result-keyword nil))
1516    (if (consp name)
1517      (setq entry-name (cadr name) name (intern (unescape-foreign-name
1518                                                 (car name))
1519                                                package))
1520      (progn
1521        (setq entry-name (unescape-foreign-name name)
1522              name (intern entry-name package))
1523        (if (getf (ftd-attributes *target-ftd*)
1524                  :prepend-underscore)
1525          (setq entry-name (concatenate 'string "_" entry-name)))))
1526    `(progn
1527      (setf (gethash ',name (ftd-external-function-definitions *target-ftd*))
1528       (make-external-function-definition
1529        :entry-name ',entry-name
1530        :arg-specs ',arg-keywords
1531        :result-spec ',result-keyword
1532        :min-args ,min-args))
1533      (setf (macro-function ',name) #'%external-call-expander)
1534      ',name)))
1535
1536
1537#+darwinppc-target
1538(defun open-dylib (name)
1539  (with-cstrs ((name name))
1540    (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR 
1541                               #$NSADDIMAGE_OPTION_WITH_SEARCHING))))
1542
1543(defparameter *foreign-representation-type-keywords*
1544  `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte
1545    :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte
1546    :address
1547    :single-float :double-float
1548    :void))
1549
1550(defun null-coerce-foreign-arg (arg-type-keyword argform)
1551  (declare (ignore arg-type-keyword))
1552  argform)
1553
1554(defun null-coerce-foreign-result (result-type-keyword resultform)
1555  (declare (ignore result-type-keyword))
1556  resultform)
1557
1558(defun foreign-type-to-representation-type (f)
1559  (if (or (member f *foreign-representation-type-keywords*)
1560          (typep f 'unsigned-byte))
1561    f
1562    (let* ((ftype (if (typep f 'foreign-type)
1563                    f
1564                    (parse-foreign-type f))))
1565      (or
1566       (and (eq (foreign-type-class ftype) 'root) :void)         
1567       (typecase ftype
1568         ((or foreign-pointer-type foreign-array-type) :address)
1569         (foreign-double-float-type :double-float)
1570         (foreign-single-float-type :single-float)
1571         (foreign-integer-type
1572          (let* ((signed (foreign-integer-type-signed ftype))
1573                 (bits (foreign-integer-type-bits ftype)))
1574            (if signed
1575              (if (<= bits 8)
1576                :signed-byte
1577                (if (<= bits 16)
1578                  :signed-halfword
1579                  (if (<= bits 32)
1580                    :signed-fullword
1581                    (if (<= bits 64)
1582                      :signed-doubleword))))
1583              (if (<= bits 8)
1584                :unsigned-byte
1585                (if (<= bits 16)
1586                  :unsigned-halfword
1587                  (if (<= bits 32)
1588                    :unsigned-fullword
1589                    (if (<= bits 64)
1590                      :unsigned-doubleword)))))))
1591         (foreign-record-type
1592          (if (getf (ftd-attributes *target-ftd*)
1593                  :struct-by-value)
1594            (let* ((bits (ensure-foreign-type-bits ftype)))
1595              (ceiling bits (target-word-size-case
1596                             (32 32)
1597                             (64 64))))
1598          :address)))
1599       (error "can't determine representation keyword for ~s" f)))))
1600
1601(defun foreign-record-accessor-names (record-type &optional prefix)
1602  (collect ((accessors))
1603    (dolist (field (foreign-record-type-fields record-type) (accessors))
1604      (let* ((field-name (append prefix (list (foreign-record-field-name field))))
1605             (field-type (foreign-record-field-type field)))
1606        (if (typep field-type 'foreign-record-type)
1607          (dolist (s (foreign-record-accessor-names field-type field-name))
1608            (accessors s))
1609          (accessors field-name))))))
1610
1611
1612(defun canonicalize-foreign-type-ordinals (ftd)
1613  (let* ((canonical-ordinal 0))          ; used for :VOID
1614    (flet ((canonicalize-foreign-type-ordinal (spec)
1615             (let* ((new-ordinal (incf canonical-ordinal)))
1616               (when spec
1617                 (let* ((type (parse-foreign-type spec))
1618                        (old-ordinal (foreign-type-ordinal type)))
1619                   (unless (eql new-ordinal old-ordinal)
1620                     (remhash old-ordinal (ftd-ordinal-types ftd))
1621                     (setf (foreign-type-ordinal type) new-ordinal)
1622                     (note-foreign-type-ordinal type ftd))))
1623               new-ordinal)))
1624      (canonicalize-foreign-type-ordinal :signed)
1625      (canonicalize-foreign-type-ordinal :unsigned)
1626      (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil)
1627      (canonicalize-foreign-type-ordinal :address)
1628      (canonicalize-foreign-type-ordinal #-darwin-target
1629                                         :<D>l_info
1630                                         #+darwin-target nil)
1631      (canonicalize-foreign-type-ordinal '(:struct :timespec))
1632      (canonicalize-foreign-type-ordinal '(:struct :timeval))
1633      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
1634      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
1635      (canonicalize-foreign-type-ordinal '(:struct :linger))
1636      (canonicalize-foreign-type-ordinal '(:struct :hostent))
1637      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
1638      (canonicalize-foreign-type-ordinal '(:* :char))
1639      (canonicalize-foreign-type-ordinal '(:struct :stat))
1640      (canonicalize-foreign-type-ordinal '(:struct :passwd))
1641      (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil)
1642      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
1643      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
1644      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
1645      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
1646      )))
1647
1648(defun install-standard-foreign-types (ftd)
1649  (let* ((*target-ftd* ftd)
1650         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)))
1651
1652    (def-foreign-type-translator signed (&optional (bits 32))
1653      (if (<= bits 64)
1654        (svref *signed-integer-types* bits)
1655        (make-foreign-integer-type :bits bits)))
1656
1657
1658    (def-foreign-type-translator integer (&optional (bits 32))
1659      (if (<= bits 64)
1660        (svref *signed-integer-types* bits)
1661        (make-foreign-integer-type :bits bits)))
1662
1663    (def-foreign-type-translator unsigned (&optional (bits 32))
1664      (if (<= bits 64)
1665        (svref *unsigned-integer-types* bits)
1666        (make-foreign-integer-type :bits bits :signed nil)))
1667
1668    (def-foreign-type-translator bitfield (&optional (bits 1))
1669      (make-foreign-integer-type :bits bits :signed nil :alignment 1))
1670
1671    (def-foreign-type-translator root ()
1672      (make-foreign-type :class 'root :bits 0 :alignment 0))
1673
1674    (def-foreign-type-translator :<BOOL> () *bool-type*)
1675
1676    (def-foreign-type-translator single-float ()
1677      (make-foreign-single-float-type :type 'single-float))
1678
1679    (def-foreign-type-translator double-float ()
1680      (make-foreign-double-float-type :type 'double-float))
1681
1682    (def-foreign-type-translator macptr ()
1683      (make-foreign-macptr-type :bits natural-word-size))
1684
1685    (def-foreign-type-translator values (&rest values)
1686      (unless *values-type-okay*
1687        (error "Cannot use values types here."))
1688      (let ((*values-type-okay* nil))
1689        (make-foreign-values-type
1690         :values (mapcar #'parse-foreign-type values))))
1691
1692    (def-foreign-type-translator function (result-type &rest arg-types)
1693      (make-foreign-function-type
1694       :result-type (let ((*values-type-okay* t))
1695                      (parse-foreign-type result-type))
1696       :arg-types (mapcar #'parse-foreign-type arg-types)))
1697
1698    (def-foreign-type-translator struct (name &rest fields)
1699      (parse-foreign-record-type :struct name fields))
1700   
1701    (def-foreign-type-translator union (name &rest fields)
1702      (parse-foreign-record-type :union name fields))
1703
1704    (def-foreign-type-translator array (ele-type &rest dims)
1705      (when dims
1706        (unless (typep (first dims) '(or index null))
1707          (error "First dimension is not a non-negative fixnum or NIL: ~S"
1708                 (first dims)))
1709        (let ((loser (find-if-not #'(lambda (x) (typep x 'index))
1710                                  (rest dims))))
1711          (when loser
1712            (error "Dimension is not a non-negative fixnum: ~S" loser))))
1713       
1714      (let* ((type (parse-foreign-type ele-type))
1715             (pair (cons type dims)))
1716        (declare (dynamic-extent pair))
1717        (ensure-foreign-type-bits type)
1718        (or (gethash pair (ftd-array-types *target-ftd*))
1719            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
1720                 
1721                  (make-foreign-array-type
1722                   :element-type type
1723                   :dimensions dims
1724                   :alignment (foreign-type-alignment type)
1725                   :bits (if (and (ensure-foreign-type-bits type)
1726                                  (every #'integerp dims))
1727                           (* (align-offset (foreign-type-bits type)
1728                                            (foreign-type-alignment type))
1729                              (reduce #'* dims))))))))
1730
1731    (def-foreign-type-translator * (to)
1732      (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
1733        (ensure-foreign-type-bits to)
1734        (or (gethash to (ftd-pointer-types *target-ftd*))
1735            (setf (gethash to (ftd-pointer-types *target-ftd*))
1736                  (make-foreign-pointer-type
1737                   :to to
1738                   :bits natural-word-size)))))
1739   
1740    (def-foreign-type-translator boolean (&optional (bits 32))
1741      (make-foreign-boolean-type :bits bits :signed nil))
1742
1743    (def-foreign-type signed-char (signed 8))
1744    (def-foreign-type signed-byte (signed 8))
1745    (def-foreign-type short (signed 16))
1746    (def-foreign-type signed-halfword short)
1747    (def-foreign-type int (signed 32))
1748    (def-foreign-type signed-fullword int)
1749    (def-foreign-type signed-short (signed 16))
1750    (def-foreign-type signed-int (signed 32))
1751    (def-foreign-type signed-doubleword (signed 64))
1752    (def-foreign-type char #-darwin-target (unsigned 8)
1753                      #+darwin-target (signed 8))
1754    (def-foreign-type unsigned-char (unsigned 8))
1755    (def-foreign-type unsigned-byte (unsigned 8))
1756    (def-foreign-type unsigned-short (unsigned 16))
1757    (def-foreign-type unsigned-halfword unsigned-short)
1758    (def-foreign-type unsigned-int (unsigned 32))
1759    (def-foreign-type unsigned-fullword unsigned-int)
1760    (def-foreign-type unsigned-doubleword (unsigned 64))
1761    (def-foreign-type bit (bitfield 1))
1762
1763    (def-foreign-type float single-float)
1764    (def-foreign-type double double-float)
1765
1766    (%def-foreign-type :void *void-foreign-type*)
1767    (def-foreign-type address (* :void))
1768    (let* ((signed-long-type (parse-foreign-type
1769                              `(:signed ,natural-word-size)))
1770           (unsigned-long-type (parse-foreign-type
1771                                `(:unsigned ,natural-word-size))))
1772      (%def-foreign-type :long signed-long-type ftd)
1773      (%def-foreign-type :signed-long signed-long-type ftd)
1774      (%def-foreign-type :unsigned-long unsigned-long-type ftd))
1775    ))
1776
1777
1778
1779
1780
1781
Note: See TracBrowser for help on using the repository browser.