source: branches/win64/lib/foreign-types.lisp @ 8955

Last change on this file since 8955 was 8955, checked in by gb, 12 years ago

Conditionalize canonical foreign types for win64.

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