source: branches/working-0711/ccl/lib/foreign-types.lisp @ 9915

Last change on this file since 9915 was 9915, checked in by gz, 12 years ago

Propagate r9243 from trunk

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