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

Last change on this file since 14171 was 14171, checked in by gb, 9 years ago

Darwin/ARM changes.

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