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

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

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