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

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

Canonical foreign type ordinal for (:array (:struct :pollfd) 1).

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