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

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

Fix typeso.

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