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

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

Intern foreign-array-types, too.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 63.8 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 :key))
73  (pointer-types (make-hash-table :test #'equalp))
74  (array-types (make-hash-table :test #'equalp)))
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)
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  (or
423   (ecase kind
424     (:struct
425      (info-foreign-type-struct name ftd))
426     (:union
427      (info-foreign-type-union name ftd))
428     (:enum
429      (info-foreign-type-enum name ftd)))
430   (flet ((aux-defn-matches (x)
431            (and (eq (first x) kind) (eq (second x) name))))
432     (let ((in-auxiliaries
433            (or (find-if #'aux-defn-matches *new-auxiliary-types*)
434                (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
435       (if in-auxiliaries
436         (values (third in-auxiliaries) t))))))
437
438(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*))
439  (flet ((aux-defn-matches (x)
440           (and (eq (first x) kind) (eq (second x) name))))
441    (when (find-if #'aux-defn-matches *new-auxiliary-types*)
442      (error "Attempt to multiple define ~A ~S." kind name))
443    (when (find-if #'aux-defn-matches *auxiliary-type-definitions*)
444      (error "Attempt to shadow definition of ~A ~S." kind name)))
445  (push (list kind name defn) *new-auxiliary-types*)
446  (ecase kind
447    (:struct
448     (setf (info-foreign-type-struct name ftd) defn))
449    (:union
450     (setf (info-foreign-type-union name ftd) defn))
451    (:enum
452     (setf (info-foreign-type-enum name ftd) defn)))
453  defn)
454
455(defsetf auxiliary-foreign-type %set-auxiliary-foreign-type)
456
457
458;;; *record-type-already-unparsed* -- internal
459;;;
460;;; Holds the list of record types that have already been unparsed.  This is
461;;; used to keep from outputing the slots again if the same structure shows
462;;; up twice.
463;;;
464(defvar *record-types-already-unparsed*)
465
466;;; UNPARSE-FOREIGN-TYPE -- public.
467;;;
468(defun unparse-foreign-type (type)
469  "Convert the foreign-type structure TYPE back into a list specification of
470   the type."
471  (declare (type foreign-type type))
472  (let ((*record-types-already-unparsed* nil))
473    (%unparse-foreign-type type)))
474
475;;; %UNPARSE-FOREIGN-TYPE -- internal.
476;;;
477;;; Does all the work of UNPARSE-FOREIGN-TYPE.  It's seperate because we need
478;;; to recurse inside the binding of *record-types-already-unparsed*.
479;;;
480(defun %unparse-foreign-type (type)
481  (invoke-foreign-type-method :unparse type))
482
483
484
485
486;;;; Foreign type defining stuff.
487
488(defmacro def-foreign-type-translator (name lambda-list &body body &environment env)
489  (expand-type-macro '%def-foreign-type-translator name lambda-list body env))
490
491
492(defun %def-foreign-type-translator (name translator docs)
493  (declare (ignore docs))
494  (setf (info-foreign-type-translator name) translator)
495  (clear-info-foreign-type-definition name)
496  #+nil
497  (setf (documentation name 'foreign-type) docs)
498  name)
499
500
501(defmacro def-foreign-type (name type)
502  "If name is non-NIL, define name to be an alias for the foreign type
503specified by foreign-type-spec. If foreign-type-spec is a named structure
504or union type, additionally defines that structure or union type.
505
506If name is NIL, foreign-type-spec must be a named foreign struct or union
507definition, in which case the foreign structure or union definition is put
508in effect.
509
510Note that there are two separate namespaces for foreign type names, one for
511the names of ordinary types and one for the names of structs and unions.
512Which one name refers to depends on foreign-type-spec in the obvious manner."
513  (with-auxiliary-foreign-types
514    (let ((foreign-type (parse-foreign-type type)))
515      `(eval-when (:compile-toplevel :load-toplevel :execute)
516         ,@(when *new-auxiliary-types*
517             `((%def-auxiliary-foreign-types ',*new-auxiliary-types*)))
518         ,@(when name
519             `((%def-foreign-type ',name ',foreign-type)))))))
520
521(defun %def-auxiliary-foreign-types (types)
522  (dolist (info types)
523    (destructuring-bind (kind name defn) info
524      (macrolet ((frob (accessor)
525                   `(let ((old (,accessor name)))
526                      (unless (or (null old) (foreign-type-= old defn))
527                        (warn "Redefining ~A ~S to be:~%  ~S,~%was:~%  ~S"
528                              kind name defn old))
529                      (setf (,accessor name) defn))))
530        (ecase kind
531          (:struct (frob info-foreign-type-struct))
532          (:union (frob info-foreign-type-union))
533          (:enum (frob info-foreign-type-enum)))))))
534
535(defun %def-foreign-type (name new &optional (ftd *target-ftd*))
536  (ecase (info-foreign-type-kind name ftd)
537    (:primitive
538     (error "~S is a built-in foreign type." name))
539    (:defined
540     (let ((old (info-foreign-type-definition name ftd)))
541       (unless (or (null old) (foreign-type-= new old))
542         (warn "Redefining ~S to be:~%  ~S,~%was~%  ~S" name
543               (unparse-foreign-type new) (unparse-foreign-type old)))))
544    (:unknown))
545  (setf (info-foreign-type-definition name ftd) new)
546  (setf (info-foreign-type-kind name ftd) :defined)
547  name)
548
549
550
551;;;; Interfaces to the different methods
552
553(defun foreign-type-= (type1 type2)
554  "Return T iff TYPE1 and TYPE2 describe equivalent foreign types."
555  (or (eq type1 type2)
556      (and (eq (foreign-type-class type1)
557               (foreign-type-class type2))
558           (invoke-foreign-type-method :type= type1 type2))))
559
560(defun foreign-subtype-p (type1 type2)
561  "Return T iff the foreign type TYPE1 is a subtype of TYPE2.  Currently, the
562   only supported subtype relationships are is that any pointer type is a
563   subtype of (* t), and any array type first dimension will match
564   (array <eltype> nil ...).  Otherwise, the two types have to be
565   FOREIGN-TYPE-=."
566  (or (eq type1 type2)
567      (invoke-foreign-type-method :subtypep type1 type2)))
568
569(defun foreign-typep (object type)
570  "Return T iff OBJECT is a foreign of type TYPE."
571  (let ((lisp-rep-type (compute-lisp-rep-type type)))
572    (if lisp-rep-type
573        (typep object lisp-rep-type))))
574
575
576(defun compute-naturalize-lambda (type)
577  `(lambda (foreign ignore)
578     (declare (ignore ignore))
579     ,(invoke-foreign-type-method :naturalize-gen type 'foreign)))
580
581(defun compute-deport-lambda (type)
582  (declare (type foreign-type type))
583  (multiple-value-bind
584      (form value-type)
585      (invoke-foreign-type-method :deport-gen type 'value)
586    `(lambda (value ignore)
587       (declare (type ,(or value-type
588                           (compute-lisp-rep-type type)
589                           `(foreign ,type))
590                      value)
591                (ignore ignore))
592       ,form)))
593
594(defun compute-extract-lambda (type)
595  `(lambda (sap offset ignore)
596     (declare (type system-area-pointer sap)
597              (type unsigned-byte offset)
598              (ignore ignore))
599     (naturalize ,(invoke-foreign-type-method :extract-gen type 'sap 'offset)
600                 ',type)))
601
602(defun compute-deposit-lambda (type)
603  (declare (type foreign-type type))
604  `(lambda (sap offset ignore value)
605     (declare (type system-area-pointer sap)
606              (type unsigned-byte offset)
607              (ignore ignore))
608     (let ((value (deport value ',type)))
609       ,(invoke-foreign-type-method :deposit-gen type 'sap 'offset 'value)
610       ;; Note: the reason we don't just return the pre-deported value
611       ;; is because that would inhibit any (deport (naturalize ...))
612       ;; optimizations that might have otherwise happen.  Re-naturalizing
613       ;; the value might cause extra consing, but is flushable, so probably
614       ;; results in better code.
615       (naturalize value ',type))))
616
617(defun compute-lisp-rep-type (type)
618  (invoke-foreign-type-method :lisp-rep type))
619
620(defun compute-foreign-rep-type (type)
621  (invoke-foreign-type-method :foreign-rep type))
622
623
624
625
626
627;;;; Default methods.
628
629(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0))
630
631(def-foreign-type-method (root :unparse) (type)
632  (if (eq type *void-foreign-type*)
633    :void
634    `(!!unknown-foreign-type!! ,(type-of type))))
635
636(def-foreign-type-method (root :type=) (type1 type2)
637  (declare (ignore type1 type2))
638  t)
639
640(def-foreign-type-method (root :subtypep) (type1 type2)
641  (foreign-type-= type1 type2))
642
643(def-foreign-type-method (root :lisp-rep) (type)
644  (declare (ignore type))
645  nil)
646
647(def-foreign-type-method (root :foreign-rep) (type)
648  (declare (ignore type))
649  '*)
650
651(def-foreign-type-method (root :naturalize-gen) (type foreign)
652  (declare (ignore foreign))
653  (error "Cannot represent ~S typed foreigns." type))
654
655(def-foreign-type-method (root :deport-gen) (type object)
656  (declare (ignore object))
657  (error "Cannot represent ~S typed foreigns." type))
658
659(def-foreign-type-method (root :extract-gen) (type sap offset)
660  (declare (ignore sap offset))
661  (error "Cannot represent ~S typed foreigns." type))
662
663(def-foreign-type-method (root :deposit-gen) (type sap offset value)
664  `(setf ,(invoke-foreign-type-method :extract-gen type sap offset) ,value))
665
666(def-foreign-type-method (root :arg-tn) (type state)
667  (declare (ignore state))
668  (error "Cannot pass foreigns of type ~S as arguments to call-out"
669         (unparse-foreign-type type)))
670
671(def-foreign-type-method (root :result-tn) (type state)
672  (declare (ignore state))
673  (error "Cannot return foreigns of type ~S from call-out"
674         (unparse-foreign-type type)))
675
676
677
678;;;; The INTEGER type.
679
680(def-foreign-type-class (integer)
681  (signed t :type (member t nil)))
682
683(defvar *unsigned-integer-types*
684  (let* ((a (make-array 33)))
685    (dotimes (i 33 a)
686      (setf (svref a i) (make-foreign-integer-type :signed nil
687                                                   :bits i
688                                                   :alignment
689                                                   (if (= 1 (logcount i))
690                                                     i
691                                                     1))))))
692
693(defvar *signed-integer-types*
694  (let* ((a (make-array 33)))
695    (dotimes (i 33 a)
696      (setf (svref a i) (make-foreign-integer-type :signed t
697                                                   :bits i
698                                                   :alignment
699                                                   (if (= 1 (logcount i))
700                                                     i
701                                                     1))))))
702         
703
704(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwinppc-target t #-darwinppc-target nil))
705
706                                                 
707
708(def-foreign-type-method (integer :unparse) (type)
709  (if (eq type *bool-type*)
710    :<BOOL>
711    (let* ((bits (foreign-integer-type-bits type))
712           (signed (foreign-integer-type-signed type))
713           (alignment (foreign-integer-type-alignment type)))
714      (if (eql alignment 1)
715        (if (eql bits 1)
716          :bit
717          `(:bitfield ,bits))
718        (list (if signed :signed :unsigned) bits)))))
719 
720(def-foreign-type-method (integer :type=) (type1 type2)
721  (and (eq (foreign-integer-type-signed type1)
722           (foreign-integer-type-signed type2))
723       (= (foreign-integer-type-bits type1)
724          (foreign-integer-type-bits type2))))
725
726(def-foreign-type-method (integer :lisp-rep) (type)
727  (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte)
728        (foreign-integer-type-bits type)))
729
730(def-foreign-type-method (integer :foreign-rep) (type)
731  (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte)
732        (foreign-integer-type-bits type)))
733
734(def-foreign-type-method (integer :naturalize-gen) (type foreign)
735  (declare (ignore type))
736  foreign)
737
738(def-foreign-type-method (integer :deport-gen) (type value)
739  (declare (ignore type))
740  value)
741
742(def-foreign-type-method (integer :extract-gen) (type sap offset)
743  (declare (type foreign-integer-type type))
744  (let ((ref-form
745         (if (foreign-integer-type-signed type)
746          (case (foreign-integer-type-bits type)
747            (8 `(%get-signed-byte ,sap (/ ,offset 8)))
748            (16 `(%get-signed-word ,sap (/ ,offset 8)))
749            (32 `(%get-signed-long ,sap (/ ,offset 8)))
750            (64 `(%%get-signed-longlong ,sap (/ ,offset 8))))
751          (case (foreign-integer-type-bits type)
752            (1 `(%get-bit ,sap ,offset))
753            (8 `(%get-unsigned-byte ,sap (/ ,offset 8)))
754            (16 `(%get-unsigned-word ,sap (/ ,offset 8)))
755            (32 `(%get-unsigned-long ,sap (/ ,offset 8)))
756            (64 `(%%get-unsigned-longlong ,sap (/ ,offset 8)))
757            (t  `(%get-bitfield ,sap ,offset ,(foreign-integer-type-bits type)))))))
758    (or ref-form
759        (error "Cannot extract ~D bit integers."
760               (foreign-integer-type-bits type)))))
761
762
763
764;;;; The BOOLEAN type.
765
766(def-foreign-type-class (boolean :include integer :include-args (signed)))
767
768
769
770(def-foreign-type-method (boolean :lisp-rep) (type)
771  (declare (ignore type))
772  `(member t nil))
773
774(def-foreign-type-method (boolean :naturalize-gen) (type foreign)
775  (declare (ignore type))
776  `(not (zerop ,foreign)))
777
778(def-foreign-type-method (boolean :deport-gen) (type value)
779  (declare (ignore type))
780  `(if ,value 1 0))
781
782
783(def-foreign-type-method (boolean :unparse) (type)
784  `(boolean ,(foreign-boolean-type-bits type)))
785
786
787;;;; the FLOAT types.
788
789(def-foreign-type-class (float)
790  (type () :type symbol))
791
792(def-foreign-type-method (float :unparse) (type)
793  (foreign-float-type-type type))
794
795(def-foreign-type-method (float :lisp-rep) (type)
796  (foreign-float-type-type type))
797
798(def-foreign-type-method (float :foreign-rep) (type)
799  (foreign-float-type-type type))
800
801(def-foreign-type-method (float :naturalize-gen) (type foreign)
802  (declare (ignore type))
803  foreign)
804
805(def-foreign-type-method (float :deport-gen) (type value)
806  (declare (ignore type))
807  value)
808
809
810(def-foreign-type-class (single-float :include (float (bits 32))
811                                    :include-args (type)))
812
813
814(def-foreign-type-method (single-float :extract-gen) (type sap offset)
815  (declare (ignore type))
816  `(%get-single-float ,sap (/ ,offset 8)))
817
818
819(def-foreign-type-class (double-float :include (float (bits 64))
820                                    :include-args (type)))
821
822
823(def-foreign-type-method (double-float :extract-gen) (type sap offset)
824  (declare (ignore type))
825  `(%get-double-float ,sap (/ ,offset 8)))
826
827
828
829;;;; The MACPTR type
830
831(def-foreign-type-class (macptr))
832
833
834(def-foreign-type-method (macptr :unparse) (type)
835  (declare (ignore type))
836  'macptr)
837
838(def-foreign-type-method (macptr :lisp-rep) (type)
839  (declare (ignore type))
840  'macptr)
841
842(def-foreign-type-method (macptr :foreign-rep) (type)
843  (declare (ignore type))
844  'macptr)
845
846(def-foreign-type-method (macptr :naturalize-gen) (type foreign)
847  (declare (ignore type))
848  foreign)
849
850(def-foreign-type-method (macptr :deport-gen) (type object)
851  (declare (ignore type))
852  object)
853
854(def-foreign-type-method (macptr :extract-gen) (type sap offset)
855  (declare (ignore type))
856  `(%get-ptr ,sap (/ ,offset 8)))
857
858
859;;;; the FOREIGN-VALUE type.
860
861(def-foreign-type-class (foreign-value :include macptr))
862
863(def-foreign-type-method (foreign-value :lisp-rep) (type)
864  (declare (ignore type))
865  nil)
866
867(def-foreign-type-method (foreign-value :naturalize-gen) (type foreign)
868  `(%macptr-foreign ,foreign ',type))
869
870(def-foreign-type-method (foreign-value :deport-gen) (type value)
871  (declare (ignore type))
872  `(foreign-macptr ,value))
873
874
875
876;;;; The POINTER type.
877
878(def-foreign-type-class (pointer :include (foreign-value))
879  (to *void-foreign-type* :type foreign-type))
880
881
882
883(def-foreign-type-method (pointer :unparse) (type)
884  (let ((to (foreign-pointer-type-to type)))
885    `(:* ,(if to
886             (%unparse-foreign-type to)
887             :void))))
888
889(def-foreign-type-method (pointer :type=) (type1 type2)
890  (let ((to1 (foreign-pointer-type-to type1))
891        (to2 (foreign-pointer-type-to type2)))
892    (if to1
893        (if to2
894            (foreign-type-= to1 to2)
895            nil)
896        (null to2))))
897
898(def-foreign-type-method (pointer :subtypep) (type1 type2)
899  (and (foreign-pointer-type-p type2)
900       (let ((to1 (foreign-pointer-type-to type1))
901             (to2 (foreign-pointer-type-to type2)))
902         (if to1
903             (if to2
904                 (foreign-subtype-p to1 to2)
905                 t)
906             (null to2)))))
907
908(def-foreign-type-method (pointer :deport-gen) (type value)
909  (values
910   `(etypecase ,value
911      (null
912       (int-sap 0))
913      (macptr
914       ,value)
915      ((foreign ,type)
916       (foreign-sap ,value)))
917   `(or null macptr (foreign ,type))))
918
919
920;;;; The MEM-BLOCK type.
921
922
923(def-foreign-type-class (mem-block :include foreign-value))
924
925(def-foreign-type-method (mem-block :extract-gen) (type sap offset)
926  (let* ((nbytes (%foreign-type-or-record-size type :bytes)))
927    `(%composite-pointer-ref ,nbytes ,sap (/ ,offset 8))))
928
929(def-foreign-type-method (mem-block :deposit-gen) (type sap offset value)
930  (let ((bits (foreign-mem-block-type-bits type)))
931    (unless bits
932      (error "Cannot deposit foreigns of type ~S (unknown size)." type))
933    `(%copy-macptr-to-macptr ,value 0 ,sap ,offset ',bits)))
934
935
936
937;;;; The ARRAY type.
938
939(def-foreign-type-class (array :include mem-block)
940  (element-type () :type foreign-type)
941  (dimensions () :type list))
942
943
944
945(def-foreign-type-method (array :unparse) (type)
946  `(array ,(%unparse-foreign-type (foreign-array-type-element-type type))
947          ,@(foreign-array-type-dimensions type)))
948
949(def-foreign-type-method (array :type=) (type1 type2)
950  (and (equal (foreign-array-type-dimensions type1)
951              (foreign-array-type-dimensions type2))
952       (foreign-type-= (foreign-array-type-element-type type1)
953                       (foreign-array-type-element-type type2))))
954
955(def-foreign-type-method (array :subtypep) (type1 type2)
956  (and (foreign-array-type-p type2)
957       (let ((dim1 (foreign-array-type-dimensions type1))
958             (dim2 (foreign-array-type-dimensions type2)))
959         (and (= (length dim1) (length dim2))
960              (or (and dim2
961                       (null (car dim2))
962                       (equal (cdr dim1) (cdr dim2)))
963                  (equal dim1 dim2))
964              (foreign-subtype-p (foreign-array-type-element-type type1)
965                               (foreign-array-type-element-type type2))))))
966
967
968;;;; The RECORD type.
969
970(defstruct (foreign-record-field
971             (:print-object
972              (lambda (field stream)
973                (print-unreadable-object (field stream :type t)
974                  (funcall (formatter "~S ~S~@[ ~D@~D~]")
975                           stream
976                           (foreign-record-field-type field)
977                           (foreign-record-field-name field)
978                           (foreign-record-field-bits field)
979                           (foreign-record-field-offset field))))))
980  (name () :type symbol)
981  (type () :type foreign-type)
982  (bits nil :type (or unsigned-byte null))
983  (offset 0 :type unsigned-byte))
984
985
986
987(defmethod make-load-form ((f foreign-record-field) &optional env)
988  (make-load-form-saving-slots f :environment env))
989
990(def-foreign-type-class (record :include mem-block)
991  (kind :struct :type (member :struct :union))
992  (name nil :type (or symbol null))
993  (fields nil :type list)
994  ;; For, e.g., records defined with #pragma options align=mac68k
995  ;; in effect.  When non-nil, this specifies the maximum alignment
996  ;; of record fields and the overall alignment of the record.
997  (alt-align nil :type (or unsigned-byte null)))
998
999
1000(defun parse-foreign-record-type (kind name fields)
1001  (if fields
1002    (let* ((old (and name (auxiliary-foreign-type kind name)))
1003           (result (or old
1004                       (make-foreign-record-type :name name :kind kind))))
1005      (when (and name (not (eq old result)))
1006        (setf (auxiliary-foreign-type kind name) result))
1007      (parse-foreign-record-fields result fields)
1008      result)
1009    (if name
1010      (or (auxiliary-foreign-type kind name)
1011          (setf (auxiliary-foreign-type kind name)
1012                (make-foreign-record-type :name name :kind kind)))
1013      (make-foreign-record-type :kind kind))))
1014
1015;;; PARSE-FOREIGN-RECORD-FIELDS -- internal
1016;;;
1017;;; Used by parse-foreign-type to parse the fields of struct and union
1018;;; types.  RESULT holds the record type we are paring the fields of,
1019;;; and FIELDS is the list of field specifications.
1020;;;
1021(defun parse-foreign-record-fields (result fields)
1022  (declare (type foreign-record-type result)
1023           (type list fields))
1024  (let* ((total-bits 0)
1025         (overall-alignment 1)
1026         (parsed-fields nil)
1027         (first-field-p t)
1028         (alt-alignment (foreign-record-type-alt-align result))
1029         (attributes (ftd-attributes *target-ftd*))
1030         (poweropen-alignment (getf attributes :poweropen-alignment)))
1031         
1032    (dolist (field fields)
1033      (destructuring-bind (var type &optional bits) field
1034        (declare (ignore bits))
1035        (let* ((field-type (parse-foreign-type type))
1036               (bits (ensure-foreign-type-bits field-type))
1037               (natural-alignment (foreign-type-alignment field-type))
1038               (alignment (if alt-alignment
1039                            (min natural-alignment alt-alignment)
1040                            (if poweropen-alignment
1041                              (if first-field-p
1042                                (progn
1043                                  (setq first-field-p nil)
1044                                  natural-alignment)
1045                                (min 32 natural-alignment))
1046                              natural-alignment)))
1047               (parsed-field
1048                (make-foreign-record-field :type field-type
1049                                           :name var)))
1050          (push parsed-field parsed-fields)
1051          (when (null bits)
1052            (error "Unknown size: ~S"
1053                   (unparse-foreign-type field-type)))
1054          (when (null alignment)
1055            (error "Unknown alignment: ~S"
1056                   (unparse-foreign-type field-type)))
1057          (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
1058          (ecase (foreign-record-type-kind result)
1059            (:struct
1060             (let ((offset (align-offset total-bits alignment)))
1061               (setf (foreign-record-field-offset parsed-field) offset)
1062               (setf (foreign-record-field-bits parsed-field) bits)
1063               (setf total-bits (+ offset bits))))
1064            (:union
1065             (setf total-bits (max total-bits bits)))))))
1066    (let ((new (nreverse parsed-fields)))
1067      (setf (foreign-record-type-fields result) new))
1068    (setf (foreign-record-type-alignment result) (or alt-alignment
1069                                                     overall-alignment))
1070    (setf (foreign-record-type-bits result)
1071          (align-offset total-bits (or alt-alignment overall-alignment)))))
1072
1073(def-foreign-type-method (record :unparse) (type)
1074  `(,(case (foreign-record-type-kind type)
1075       (:struct :struct)
1076       (:union :union)
1077       (t '???))
1078    ,(foreign-record-type-name type)
1079    ,@(unless (member type *record-types-already-unparsed* :test #'eq)
1080        (push type *record-types-already-unparsed*)
1081        (mapcar #'(lambda (field)
1082                    `(,(foreign-record-field-name field)
1083                      ,(%unparse-foreign-type (foreign-record-field-type field))
1084                      ,@(if (foreign-record-field-bits field)
1085                            (list (foreign-record-field-bits field)))))
1086                (foreign-record-type-fields type)))))
1087
1088;;; Test the record fields. The depth is limiting in case of cyclic
1089;;; pointers.
1090(defun record-fields-match (fields1 fields2 depth)
1091  (declare (type list fields1 fields2)
1092           (type (mod 64) depth))
1093  (labels ((record-type-= (type1 type2 depth)
1094             (and (eq (foreign-record-type-name type1)
1095                      (foreign-record-type-name type2))
1096                  (eq (foreign-record-type-kind type1)
1097                      (foreign-record-type-kind type2))
1098                  (= (length (foreign-record-type-fields type1))
1099                     (length (foreign-record-type-fields type2)))
1100                  (record-fields-match (foreign-record-type-fields type1)
1101                                       (foreign-record-type-fields type2)
1102                                       (1+ depth))))
1103           (pointer-type-= (type1 type2 depth)
1104             (let ((to1 (foreign-pointer-type-to type1))
1105                   (to2 (foreign-pointer-type-to type2)))
1106               (if to1
1107                   (if to2
1108                    (or (> depth 10)
1109                       (type-= to1 to2 (1+ depth)))
1110                       nil)
1111                   (null to2))))
1112           (type-= (type1 type2 depth)
1113             (cond ((and (foreign-pointer-type-p type1)
1114                         (foreign-pointer-type-p type2))
1115                    (or (> depth 10)
1116                        (pointer-type-= type1 type2 depth)))
1117                   ((and (foreign-record-type-p type1)
1118                         (foreign-record-type-p type2))
1119                    (record-type-= type1 type2 depth))
1120                   (t
1121                    (foreign-type-= type1 type2)))))
1122    (do ((fields1-rem fields1 (rest fields1-rem))
1123         (fields2-rem fields2 (rest fields2-rem)))
1124        ((or (eq fields1-rem fields2-rem)
1125             (endp fields1-rem)
1126             (endp fields2-rem))
1127         (eq fields1-rem fields2-rem))
1128      (let ((field1 (first fields1-rem))
1129            (field2 (first fields2-rem)))
1130        (declare (type foreign-record-field field1 field2))
1131        (unless (and (eq (foreign-record-field-name field1)
1132                         (foreign-record-field-name field2))
1133                     (eql (foreign-record-field-bits field1)
1134                          (foreign-record-field-bits field2))
1135                     (eql (foreign-record-field-offset field1)
1136                          (foreign-record-field-offset field2))
1137                     (let ((field1 (foreign-record-field-type field1))
1138                           (field2 (foreign-record-field-type field2)))
1139                       (type-= field1 field2 (1+ depth))))
1140          (return nil))))))
1141
1142(def-foreign-type-method (record :type=) (type1 type2)
1143  (and (eq (foreign-record-type-name type1)
1144           (foreign-record-type-name type2))
1145       (eq (foreign-record-type-kind type1)
1146           (foreign-record-type-kind type2))
1147       (= (length (foreign-record-type-fields type1))
1148          (length (foreign-record-type-fields type2)))
1149       (record-fields-match (foreign-record-type-fields type1)
1150                            (foreign-record-type-fields type2) 0)))
1151
1152
1153;;;; The FUNCTION and VALUES types.
1154
1155(defvar *values-type-okay* nil)
1156
1157(def-foreign-type-class (function :include mem-block)
1158  (result-type () :type foreign-type)
1159  (arg-types () :type list)
1160  (stub nil :type (or null function)))
1161
1162
1163
1164(def-foreign-type-method (function :unparse) (type)
1165  `(function ,(%unparse-foreign-type (foreign-function-type-result-type type))
1166             ,@(mapcar #'%unparse-foreign-type
1167                       (foreign-function-type-arg-types type))))
1168
1169(def-foreign-type-method (function :type=) (type1 type2)
1170  (and (foreign-type-= (foreign-function-type-result-type type1)
1171                     (foreign-function-type-result-type type2))
1172       (= (length (foreign-function-type-arg-types type1))
1173          (length (foreign-function-type-arg-types type2)))
1174       (every #'foreign-type-=
1175              (foreign-function-type-arg-types type1)
1176              (foreign-function-type-arg-types type2))))
1177
1178
1179(def-foreign-type-class (values)
1180  (values () :type list))
1181
1182
1183
1184(def-foreign-type-method (values :unparse) (type)
1185  `(values ,@(mapcar #'%unparse-foreign-type
1186                     (foreign-values-type-values type))))
1187
1188(def-foreign-type-method (values :type=) (type1 type2)
1189  (and (= (length (foreign-values-type-values type1))
1190          (length (foreign-values-type-values type2)))
1191       (every #'foreign-type-=
1192              (foreign-values-type-values type1)
1193              (foreign-values-type-values type2))))
1194
1195
1196
1197
1198;;;; The FOREIGN-SIZE macro.
1199
1200(defmacro foreign-size (type &optional (units :bits))
1201  "Return the size of the foreign type TYPE.  UNITS specifies the units to
1202   use and can be either :BITS, :BYTES, or :WORDS."
1203  (let* ((foreign-type (parse-foreign-type type))
1204         (bits (ensure-foreign-type-bits foreign-type)))
1205    (if bits
1206      (values (ceiling bits
1207                       (ecase units
1208                         (:bits 1)
1209                         (:bytes 8)
1210                         (:words 32))))
1211      (error "Unknown size for foreign type ~S."
1212             (unparse-foreign-type foreign-type)))))
1213
1214(defun ensure-foreign-type-bits (type)
1215  (or (foreign-type-bits type)
1216      (and (typep type 'foreign-record-type)
1217           (let* ((name (foreign-record-type-name type)))
1218             (and name
1219                  (load-record name)
1220                  (foreign-type-bits type))))
1221      (and (typep type 'foreign-array-type)
1222           (let* ((element-type (foreign-array-type-element-type type))
1223                  (dims (foreign-array-type-dimensions type)))
1224             (if (and (ensure-foreign-type-bits element-type)
1225                      (every #'integerp dims))
1226               (setf (foreign-array-type-alignment type)
1227                     (foreign-type-alignment element-type)
1228                     (foreign-array-type-bits type)
1229                     (* (align-offset (foreign-type-bits element-type)
1230                                      (foreign-type-alignment element-type))
1231                        (reduce #'* dims))))))))
1232
1233(defun require-foreign-type-bits (type)
1234  (or (ensure-foreign-type-bits type)
1235      (error "Can't determine attributes of foreign type ~s" type)))
1236
1237(defun %find-foreign-record (name)
1238  (or (info-foreign-type-struct name)
1239      (info-foreign-type-union name)
1240      (load-record name)))
1241
1242
1243(defun %foreign-type-or-record (type)
1244  (if (typep type 'foreign-type)
1245    type
1246    (if (consp type)
1247      (parse-foreign-type type)
1248      (or (%find-foreign-record type)
1249          (parse-foreign-type type)))))
1250
1251(defun %foreign-type-or-record-size (type &optional (units :bits))
1252  (let* ((info (%foreign-type-or-record type))
1253         (bits (ensure-foreign-type-bits info)))
1254    (if bits
1255      (values (ceiling bits
1256                       (ecase units
1257                         (:bits 1)
1258                         (:bytes 8)
1259                         (:words 32))))
1260      (error "Unknown size for foreign type ~S."
1261             (unparse-foreign-type info)))))
1262
1263(defun %find-foreign-record-type-field (type field-name)
1264  (ensure-foreign-type-bits type)       ;load the record type if necessary.
1265  (let* ((fields (foreign-record-type-fields type)))
1266    (or (find field-name  fields :key #'foreign-record-field-name :test #'string-equal)
1267                         (error "Record type ~a has no field named ~s.~&Valid field names are: ~&~a"
1268                                (foreign-record-type-name type)
1269                                field-name
1270                                (mapcar #'foreign-record-field-name fields)))))
1271
1272(defun %foreign-access-form (base-form type bit-offset accessors)
1273  (if (null accessors)
1274    (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1275    (etypecase type
1276      (foreign-record-type
1277       (let* ((field (%find-foreign-record-type-field type (car accessors))))
1278         (%foreign-access-form base-form
1279                               (foreign-record-field-type field)
1280                               (+ bit-offset (foreign-record-field-offset field))
1281                               (cdr accessors))))
1282      (foreign-pointer-type
1283       (%foreign-access-form
1284        (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1285        (foreign-pointer-type-to type)
1286        0
1287        accessors)))))
1288
1289(defun %foreign-array-access-form (base-form type index-form)
1290  (etypecase type
1291    ((or foreign-pointer-type foreign-array-type)
1292     (let* ((to (foreign-pointer-type-to type))
1293            (size (foreign-type-bits to))
1294            (bit-offset `(the fixnum (* ,size (the fixnum ,index-form)))))
1295       (invoke-foreign-type-method :extract-gen to base-form bit-offset)))))
1296
1297
1298
1299
1300;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value
1301
1302(defun naturalize (foreign type)
1303  (declare (type foreign-type type))
1304  (funcall (coerce (compute-naturalize-lambda type) 'function)
1305           foreign type))
1306
1307(defun deport (value type)
1308  (declare (type foreign-type type))
1309  (funcall (coerce (compute-deport-lambda type) 'function)
1310           value type))
1311
1312(defun extract-foreign-value (sap offset type)
1313  (declare (type macptr sap)
1314           (type unsigned-byte offset)
1315           (type foreign-type type))
1316  (funcall (coerce (compute-extract-lambda type) 'function)
1317           sap offset type))
1318
1319(defun deposit-foreign-value (sap offset type value)
1320  (declare (type macptr sap)
1321           (type unsigned-byte offset)
1322           (type foreign-type type))
1323  (funcall (coerce (compute-deposit-lambda type) 'function)
1324           sap offset type value))
1325
1326
1327
1328(defmacro external (name)
1329  "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name,
1330find it and return it. If not, create one and return it.
1331
1332Try to resolve the entry point to a memory address, and identify the
1333containing library.
1334
1335Be aware that under Darwin, external functions which are callable from C
1336have underscores prepended to their names, as in '_fopen'."
1337  `(load-eep ,name))
1338
1339(defmacro external-call (name &rest args)
1340  "Call the foreign function at the address obtained by resolving the
1341external-entry-point associated with name, passing the values of each arg
1342as a foreign argument of type indicated by the corresponding
1343arg-type-specifier. Returns the foreign function result (coerced to a
1344Lisp object of type indicated by result-type-specifier), or NIL if
1345result-type-specifer is :VOID or NIL"
1346  `(ff-call (%reference-external-entry-point
1347             (load-time-value (external ,name))) ,@args))
1348
1349(defmacro ff-call (entry &rest args)
1350  "Call the foreign function at address entrypoint passing the values of
1351each arg as a foreign argument of type indicated by the corresponding
1352arg-type-specifier. Returns the foreign function result (coerced to a
1353Lisp object of type indicated by result-type-specifier), or NIL if
1354result-type-specifer is :VOID or NIL"
1355  (funcall (ftd-ff-call-expand-function *target-ftd*)
1356           `(%ff-call ,entry) args))
1357       
1358         
1359(make-built-in-class 'external-entry-point *istruct-class*)
1360
1361(defmethod make-load-form ((eep external-entry-point) &optional env)
1362  (declare (ignore env))
1363  `(load-eep ,(eep.name eep)))
1364
1365
1366(defmethod print-object ((eep external-entry-point) out)
1367  (print-unreadable-object (eep out :type t :identity t)
1368    (format out "~s" (eep.name eep))
1369    (let* ((addr (eep.address eep))
1370           (container (eep.container eep)))
1371      (if addr
1372        #+ppc-target
1373        (progn
1374          #+32-bit-target
1375          (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2)))
1376          #+64-bit-target
1377          (format out " (#x~16,'0x) " (if (typep addr 'integer)
1378                                        (logand #xffffffffffffffff (ash addr 2))
1379                                        (%ptr-to-int addr))))
1380        #+x8664-target
1381        (format out " (#x~16,'0x) " addr)
1382        (format out " {unresolved} "))
1383      (when (and container (or (not (typep container 'macptr))
1384                                    (not (%null-ptr-p container))))
1385        (format out "~a" (shlib.soname container))))))
1386
1387(make-built-in-class 'foreign-variable *istruct-class*)
1388
1389(defmethod make-load-form ((fv foreign-variable) &optional env)
1390  (declare (ignore env))
1391  `(load-fv ,(fv.name fv) ',(fv.type fv)))
1392
1393(defmethod print-object ((fv foreign-variable) out)
1394  (print-unreadable-object (fv out :type t :identity t)
1395    (format out "~s" (fv.name fv))
1396    (let* ((addr (fv.addr fv))
1397           (container (fv.container fv)))
1398      (if addr
1399        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
1400        (format out " {unresolved} "))
1401      (when (and container (or (not (typep container 'macptr))
1402                                    (not (%null-ptr-p container))))
1403        (format out "~a" (shlib.soname container))))))
1404
1405(make-built-in-class 'shlib *istruct-class*)
1406
1407(defmethod print-object ((s shlib) stream)
1408  (print-unreadable-object (s stream :type t :identity t)
1409    (format stream "~a" (or (shlib.soname s) (shlib.pathname s)))))
1410
1411#-darwin-target
1412(defun dlerror ()
1413  (with-macptrs ((p))
1414    (%setf-macptr p (#_dlerror))
1415    (unless (%null-ptr-p p) (%get-cstring p))))
1416
1417(defstruct (external-function-definition (:conc-name "EFD-")
1418                                         (:constructor
1419                                          make-external-function-definition
1420                                          (&key entry-name arg-specs
1421                                                result-spec
1422                                                (min-args (length arg-specs))))
1423                                         )
1424  (entry-name "" :type string)
1425  (arg-specs () :type list)
1426  (result-spec nil :type symbol)
1427  (min-args 0 :type fixnum))
1428
1429
1430(defun %external-call-expander (whole env)
1431  (declare (ignore env))
1432  (destructuring-bind (name &rest args) whole
1433    (collect ((call))
1434      (let* ((info (or (gethash name (ftd-external-function-definitions
1435                                      *target-ftd*))
1436                       (error "Unknown external-function: ~s" name)))
1437             (external-name (efd-entry-name info))
1438             (arg-specs (efd-arg-specs info))
1439             (result (efd-result-spec info))
1440             (monitor (eq (car args) :monitor-exception-ports)))
1441        (when monitor
1442          (setq args (cdr args))
1443          (call :monitor-exception-ports))
1444        (let* ((rtype (parse-foreign-type result)))
1445          (if (typep rtype 'foreign-record-type)
1446            (call (pop args))))
1447        (do* ((specs arg-specs (cdr specs))
1448              (args args (cdr args)))
1449             ((null specs)
1450              (call result)
1451              (if args
1452                (error "Extra arguments in ~s"  whole)
1453                `(external-call ,external-name ,@(call))))
1454          (let* ((spec (car specs)))
1455            (cond ((eq spec :void)
1456                   ;; must be last arg-spec; remaining args should be
1457                   ;; keyword/value pairs
1458                   (unless (evenp (length args))
1459                     (error "Remaining arguments should be keyword/value pairs: ~s"
1460                            args))
1461                   (do* ()
1462                        ((null args))
1463                     (call (pop args))
1464                     (call (pop args))))
1465                  (t
1466                   (call spec)
1467                   (if args
1468                     (call (car args))
1469                     (error "Missing arguments in ~s" whole))))))))))
1470
1471(defun translate-foreign-arg-type (foreign-type-spec)
1472  (let* ((foreign-type (parse-foreign-type foreign-type-spec)))
1473    (etypecase foreign-type
1474      (foreign-pointer-type :address)
1475      (foreign-integer-type
1476       (let* ((bits (foreign-integer-type-bits foreign-type))
1477              (signed (foreign-integer-type-signed foreign-type)))
1478         (declare (fixnum bits))
1479         (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte))
1480               ((<= bits 16) (if signed :signed-halfword :unsigned-halfword))
1481               ((<= bits 32) (if signed :signed-fullword :unsigned-fullword))
1482               ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword))
1483               (t `(:record ,bits)))))
1484      (foreign-float-type
1485       (ecase (foreign-float-type-bits foreign-type)
1486         (32 :single-float)
1487         (64 :double-float)))
1488      (foreign-record-type
1489       `(:record ,(foreign-record-type-bits foreign-type))))))
1490     
1491
1492(defmacro define-external-function (name (&rest arg-specs) result-spec
1493                                         &key (min-args (length arg-specs)))
1494  (let* ((entry-name nil)
1495         (package (find-package (ftd-interface-package-name *target-ftd*)))
1496         (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs))
1497         (result-keyword (unless (and (symbolp result-spec)
1498                                    (eq (make-keyword result-spec) :void))
1499                               (translate-foreign-arg-type result-spec))))
1500    (when (and (consp result-keyword) (eq (car result-keyword) :record))
1501      (push :address arg-keywords)
1502      (setq result-keyword nil))
1503    (if (consp name)
1504      (setq entry-name (cadr name) name (intern (unescape-foreign-name
1505                                                 (car name))
1506                                                package))
1507      (progn
1508        (setq entry-name (unescape-foreign-name name)
1509              name (intern entry-name package))
1510        (if (getf (ftd-attributes *target-ftd*)
1511                  :prepend-underscore)
1512          (setq entry-name (concatenate 'string "_" entry-name)))))
1513    `(progn
1514      (setf (gethash ',name (ftd-external-function-definitions *target-ftd*))
1515       (make-external-function-definition
1516        :entry-name ',entry-name
1517        :arg-specs ',arg-keywords
1518        :result-spec ',result-keyword
1519        :min-args ,min-args))
1520      (setf (macro-function ',name) #'%external-call-expander)
1521      ',name)))
1522
1523
1524#+darwinppc-target
1525(defun open-dylib (name)
1526  (with-cstrs ((name name))
1527    (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR 
1528                               #$NSADDIMAGE_OPTION_WITH_SEARCHING))))
1529
1530(defparameter *foreign-representation-type-keywords*
1531  `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte
1532    :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte
1533    :address
1534    :single-float :double-float
1535    :void))
1536
1537(defun null-coerce-foreign-arg (arg-type-keyword argform)
1538  (declare (ignore arg-type-keyword))
1539  argform)
1540
1541(defun null-coerce-foreign-result (result-type-keyword resultform)
1542  (declare (ignore result-type-keyword))
1543  resultform)
1544
1545(defun foreign-type-to-representation-type (f)
1546  (if (or (member f *foreign-representation-type-keywords*)
1547          (typep f 'unsigned-byte))
1548    f
1549    (let* ((ftype (if (typep f 'foreign-type)
1550                    f
1551                    (parse-foreign-type f))))
1552      (or
1553       (and (eq (foreign-type-class ftype) 'root) :void)         
1554       (typecase ftype
1555         ((or foreign-pointer-type foreign-array-type) :address)
1556         (foreign-double-float-type :double-float)
1557         (foreign-single-float-type :single-float)
1558         (foreign-integer-type
1559          (let* ((signed (foreign-integer-type-signed ftype))
1560                 (bits (foreign-integer-type-bits ftype)))
1561            (if signed
1562              (if (<= bits 8)
1563                :signed-byte
1564                (if (<= bits 16)
1565                  :signed-halfword
1566                  (if (<= bits 32)
1567                    :signed-fullword
1568                    (if (<= bits 64)
1569                      :signed-doubleword))))
1570              (if (<= bits 8)
1571                :unsigned-byte
1572                (if (<= bits 16)
1573                  :unsigned-halfword
1574                  (if (<= bits 32)
1575                    :unsigned-fullword
1576                    (if (<= bits 64)
1577                      :unsigned-doubleword)))))))
1578         (foreign-record-type
1579          (if (getf (ftd-attributes *target-ftd*)
1580                  :struct-by-value)
1581            (let* ((bits (ensure-foreign-type-bits ftype)))
1582              (ceiling bits (target-word-size-case
1583                             (32 32)
1584                             (64 64))))
1585          :address)))
1586       (error "can't determine representation keyword for ~s" f)))))
1587
1588(defun foreign-record-accessor-names (record-type &optional prefix)
1589  (collect ((accessors))
1590    (dolist (field (foreign-record-type-fields record-type) (accessors))
1591      (let* ((field-name (append prefix (list (foreign-record-field-name field))))
1592             (field-type (foreign-record-field-type field)))
1593        (if (typep field-type 'foreign-record-type)
1594          (dolist (s (foreign-record-accessor-names field-type field-name))
1595            (accessors s))
1596          (accessors field-name))))))
1597
1598(defun canonicalize-foreign-type-ordinals (ftd)
1599  (let* ((canonical-ordinal 0))          ; used for :VOID
1600    (flet ((canonicalize-foreign-type-ordinal (spec)
1601             (let* ((new-ordinal (incf canonical-ordinal)))
1602               (when spec
1603                 (let* ((type (parse-foreign-type spec))
1604                        (old-ordinal (foreign-type-ordinal type)))
1605                   (unless (eql new-ordinal old-ordinal)
1606                     (remhash old-ordinal (ftd-ordinal-types ftd))
1607                     (setf (foreign-type-ordinal type) new-ordinal)
1608                     (note-foreign-type-ordinal type ftd))))
1609               new-ordinal)))
1610      (canonicalize-foreign-type-ordinal :signed)
1611      (canonicalize-foreign-type-ordinal :unsigned)
1612      (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil)
1613      (canonicalize-foreign-type-ordinal :address)
1614      (canonicalize-foreign-type-ordinal #-darwin-target
1615                                         '(:struct :<D>l_info)
1616                                         #+darwin-target nil)
1617      (canonicalize-foreign-type-ordinal '(:struct :timespec))
1618      (canonicalize-foreign-type-ordinal '(:struct :timeval))
1619      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
1620      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
1621      (canonicalize-foreign-type-ordinal '(:struct :linger))
1622      (canonicalize-foreign-type-ordinal '(:struct :hostent))
1623      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
1624      (canonicalize-foreign-type-ordinal '(:* :char))
1625      (canonicalize-foreign-type-ordinal '(:struct :stat))
1626      (canonicalize-foreign-type-ordinal '(:struct :passwd))
1627      (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil)
1628      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
1629      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
1630      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)))))
1631                   
1632(defun install-standard-foreign-types (ftd)
1633  (let* ((*target-ftd* ftd)
1634         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)))
1635    (def-foreign-type-translator signed (&optional (bits 32))
1636      (if (<= bits 32)
1637        (svref *signed-integer-types* bits)
1638        (make-foreign-integer-type :bits bits)))
1639
1640
1641    (def-foreign-type-translator integer (&optional (bits 32))
1642      (if (<= bits 32)
1643        (svref *signed-integer-types* bits)
1644        (make-foreign-integer-type :bits bits)))
1645
1646    (def-foreign-type-translator unsigned (&optional (bits 32))
1647      (if (<= bits 32)
1648        (svref *unsigned-integer-types* bits)
1649        (make-foreign-integer-type :bits bits :signed nil)))
1650
1651    (def-foreign-type-translator bitfield (&optional (bits 1))
1652      (make-foreign-integer-type :bits bits :signed nil :alignment 1))
1653
1654    (def-foreign-type-translator root ()
1655      (make-foreign-type :class 'root :bits 0 :alignment 0))
1656
1657    (def-foreign-type-translator :<BOOL> () *bool-type*)
1658
1659    (def-foreign-type-translator single-float ()
1660      (make-foreign-single-float-type :type 'single-float))
1661
1662    (def-foreign-type-translator double-float ()
1663      (make-foreign-double-float-type :type 'double-float))
1664
1665    (def-foreign-type-translator macptr ()
1666      (make-foreign-macptr-type :bits natural-word-size))
1667
1668    (def-foreign-type-translator values (&rest values)
1669      (unless *values-type-okay*
1670        (error "Cannot use values types here."))
1671      (let ((*values-type-okay* nil))
1672        (make-foreign-values-type
1673         :values (mapcar #'parse-foreign-type values))))
1674
1675    (def-foreign-type-translator function (result-type &rest arg-types)
1676      (make-foreign-function-type
1677       :result-type (let ((*values-type-okay* t))
1678                      (parse-foreign-type result-type))
1679       :arg-types (mapcar #'parse-foreign-type arg-types)))
1680    (def-foreign-type-translator struct (name &rest fields)
1681      (parse-foreign-record-type :struct name fields))
1682   
1683    (def-foreign-type-translator union (name &rest fields)
1684      (parse-foreign-record-type :union name fields))
1685
1686    (def-foreign-type-translator array (ele-type &rest dims)
1687      (when dims
1688        (unless (typep (first dims) '(or index null))
1689          (error "First dimension is not a non-negative fixnum or NIL: ~S"
1690                 (first dims)))
1691        (let ((loser (find-if-not #'(lambda (x) (typep x 'index))
1692                                  (rest dims))))
1693          (when loser
1694            (error "Dimension is not a non-negative fixnum: ~S" loser))))
1695       
1696      (let* ((type (parse-foreign-type ele-type))
1697            (pair (cons type dims)))
1698        (declare (dynamic-extent pair))
1699        (or (gethash pair (ftd-array-types *target-ftd*))
1700            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
1701                 
1702                  (make-foreign-array-type
1703                   :element-type type
1704                   :dimensions dims
1705                   :alignment (foreign-type-alignment type)
1706                   :bits (if (and (ensure-foreign-type-bits type)
1707                                  (every #'integerp dims))
1708                           (* (align-offset (foreign-type-bits type)
1709                                            (foreign-type-alignment type))
1710                              (reduce #'* dims))))))))
1711    (def-foreign-type-translator * (to)
1712      (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
1713        (or (gethash to (ftd-pointer-types *target-ftd*))
1714            (setf (gethash to (ftd-pointer-types *target-ftd*))
1715                  (make-foreign-pointer-type
1716                   :to to
1717                   :bits natural-word-size)))))
1718    (def-foreign-type-translator boolean (&optional (bits 32))
1719      (make-foreign-boolean-type :bits bits :signed nil))
1720    (def-foreign-type signed-char (signed 8))
1721    (def-foreign-type signed-byte (signed 8))
1722    (def-foreign-type short (signed 16))
1723    (def-foreign-type signed-halfword short)
1724    (def-foreign-type int (signed 32))
1725    (def-foreign-type signed-fullword int)
1726    (def-foreign-type signed-short (signed 16))
1727    (def-foreign-type signed-int (signed 32))
1728    (def-foreign-type signed-doubleword (signed 64))
1729    (def-foreign-type char #-darwin-target (unsigned 8)
1730                      #+darwin-target (signed 8))
1731    (def-foreign-type unsigned-char (unsigned 8))
1732    (def-foreign-type unsigned-byte (unsigned 8))
1733    (def-foreign-type unsigned-short (unsigned 16))
1734    (def-foreign-type unsigned-halfword unsigned-short)
1735    (def-foreign-type unsigned-int (unsigned 32))
1736    (def-foreign-type unsigned-fullword unsigned-int)
1737    (def-foreign-type unsigned-doubleword (unsigned 64))
1738    (def-foreign-type bit (bitfield 1))
1739
1740    (def-foreign-type float single-float)
1741    (def-foreign-type double double-float)
1742
1743    (%def-foreign-type :void *void-foreign-type*)
1744    (def-foreign-type address (* :void))
1745    (let* ((signed-long-type (parse-foreign-type
1746                              `(:signed ,natural-word-size)))
1747           (unsigned-long-type (parse-foreign-type
1748                                `(:unsigned ,natural-word-size))))
1749      (%def-foreign-type :long signed-long-type ftd)
1750      (%def-foreign-type :signed-long signed-long-type ftd)
1751      (%def-foreign-type :unsigned-long unsigned-long-type ftd))
1752    ;;
1753    ;; Defining the handful of foreign structures that are used
1754    ;; to build OpenMCL here ensures that all backends see appropriate
1755    ;; definitions of them.
1756    ;;
1757    (def-foreign-type nil
1758        (struct :cdb-datum
1759                (:data (* t))
1760                (:size (:unsigned 32))))
1761    (def-foreign-type nil
1762        (:struct :dbm-constant
1763                 (:class (:unsigned 32))
1764                 (:pad (:unsigned 32))
1765                 (:value
1766                  (:union nil
1767                          (:s32 (:signed 32))
1768                          (:u32 (:unsigned 32))
1769                          (:single-float :float)
1770                          (:double-float :double)))))
1771    ;; This matches the xframe-list struct definition in
1772    ;; "ccl:lisp-kernel;constants.h"
1773    (def-foreign-type nil
1774        (struct :xframe-list
1775                (this (* t #|(struct :ucontext)|#))
1776                (prev (* (struct  :xframe-list)))))
1777    (canonicalize-foreign-type-ordinals ftd)
1778    ))
1779
1780
1781(install-standard-foreign-types *host-ftd*)
1782
Note: See TracBrowser for help on using the repository browser.