source: trunk/source/lib/foreign-types.lisp @ 10671

Last change on this file since 10671 was 10671, checked in by gb, 11 years ago

Handle :bits-per-long attribute in foreign-type-data initialization.

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