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

Last change on this file since 9243 was 9243, checked in by gz, 11 years ago

Fix some more structure type decls, now that we check

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