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

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

Don't "naturally" align a record field if the field type's natural
alignment is greater than the word size (unless the ftd has a
:natural-alignment attribute.)

The ARM always aligns fields on natural boundaries; PPC32 and X8632
don't. (In other words, this has been wrong for years.)

If we ever support (SIMD) vector types, this'll have to be revisited.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.7 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           (bits-per-word (getf attributes :bits-per-word))
1084           (use-natural-alignment (getf attributes :natural-alignment)))
1085       
1086      (dolist (field fields)
1087        (destructuring-bind (var type &optional bits) field
1088          (declare (ignore bits))
1089          (let* ((field-type (parse-foreign-type type))
1090                 (bits (ensure-foreign-type-bits field-type))
1091                 (natural-alignment (foreign-type-alignment field-type))
1092                 (alignment (if alt-alignment
1093                              (min natural-alignment alt-alignment)
1094                              (if poweropen-alignment
1095                                (if first-field-p
1096                                  (progn
1097                                    (setq first-field-p nil)
1098                                    natural-alignment)
1099                                  (min 32 natural-alignment))
1100                                (if use-natural-alignment
1101                                  natural-alignment
1102                                  (min bits-per-word natural-alignment)))))
1103                 (parsed-field
1104                  (make-foreign-record-field :type field-type
1105                                             :name var)))
1106            (parsed-fields parsed-field)
1107            (when (null bits)
1108              (error "Unknown size: ~S"
1109                     (unparse-foreign-type field-type)))
1110            (when (null alignment)
1111              (error "Unknown alignment: ~S"
1112                     (unparse-foreign-type field-type)))
1113            (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
1114            (ecase kind
1115              (:struct
1116               (let ((offset (align-offset total-bits alignment)))
1117                 (setf (foreign-record-field-offset parsed-field) offset)
1118                 (setf (foreign-record-field-bits parsed-field) bits)
1119                 (setf total-bits (+ offset bits))))
1120              ((:union :transparent-union)
1121               (setf total-bits (max total-bits bits)))))))
1122      (values (parsed-fields)
1123              (or alt-alignment overall-alignment)
1124              (align-offset total-bits (or alt-alignment overall-alignment))))))
1125           
1126
1127
1128(defun parse-foreign-record-fields (result fields)
1129  (declare (type foreign-record-type result)
1130           (type list fields))
1131  (multiple-value-bind (parsed-fields alignment bits)
1132      (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result))
1133    (setf (foreign-record-type-fields result) parsed-fields
1134          (foreign-record-type-alignment result) alignment
1135          (foreign-record-type-bits result) bits)))
1136
1137
1138(def-foreign-type-method (record :unparse) (type)
1139  `(,(case (foreign-record-type-kind type)
1140       (:struct :struct)
1141       (:union :union)
1142       (:transparent-union :transparent-union)
1143       (t '???))
1144    ,(foreign-record-type-name type)
1145    ,@(unless (member type *record-types-already-unparsed* :test #'eq)
1146        (push type *record-types-already-unparsed*)
1147        (mapcar #'(lambda (field)
1148                    `(,(foreign-record-field-name field)
1149                      ,(%unparse-foreign-type (foreign-record-field-type field))
1150                      ,@(if (foreign-record-field-bits field)
1151                            (list (foreign-record-field-bits field)))))
1152                (foreign-record-type-fields type)))))
1153
1154;;; Test the record fields. The depth is limiting in case of cyclic
1155;;; pointers.
1156(defun record-fields-match (fields1 fields2 depth)
1157  (declare (type list fields1 fields2)
1158           (type (mod 64) depth))
1159  (labels ((record-type-= (type1 type2 depth)
1160             (and (eq (foreign-record-type-name type1)
1161                      (foreign-record-type-name type2))
1162                  (eq (foreign-record-type-kind type1)
1163                      (foreign-record-type-kind type2))
1164                  (= (length (foreign-record-type-fields type1))
1165                     (length (foreign-record-type-fields type2)))
1166                  (record-fields-match (foreign-record-type-fields type1)
1167                                       (foreign-record-type-fields type2)
1168                                       (1+ depth))))
1169           (pointer-type-= (type1 type2 depth)
1170             (let ((to1 (foreign-pointer-type-to type1))
1171                   (to2 (foreign-pointer-type-to type2)))
1172               (if to1
1173                   (if to2
1174                    (or (> depth 10)
1175                       (type-= to1 to2 (1+ depth)))
1176                       nil)
1177                   (null to2))))
1178           (type-= (type1 type2 depth)
1179             (cond ((and (foreign-pointer-type-p type1)
1180                         (foreign-pointer-type-p type2))
1181                    (or (> depth 10)
1182                        (pointer-type-= type1 type2 depth)))
1183                   ((and (foreign-record-type-p type1)
1184                         (foreign-record-type-p type2))
1185                    (record-type-= type1 type2 depth))
1186                   (t
1187                    (foreign-type-= type1 type2)))))
1188    (do ((fields1-rem fields1 (rest fields1-rem))
1189         (fields2-rem fields2 (rest fields2-rem)))
1190        ((or (eq fields1-rem fields2-rem)
1191             (endp fields1-rem)
1192             (endp fields2-rem))
1193         (eq fields1-rem fields2-rem))
1194      (let ((field1 (first fields1-rem))
1195            (field2 (first fields2-rem)))
1196        (declare (type foreign-record-field field1 field2))
1197        (unless (and (eq (foreign-record-field-name field1)
1198                         (foreign-record-field-name field2))
1199                     (eql (foreign-record-field-bits field1)
1200                          (foreign-record-field-bits field2))
1201                     (eql (foreign-record-field-offset field1)
1202                          (foreign-record-field-offset field2))
1203                     (let ((field1 (foreign-record-field-type field1))
1204                           (field2 (foreign-record-field-type field2)))
1205                       (type-= field1 field2 (1+ depth))))
1206          (return nil))))))
1207
1208(def-foreign-type-method (record :type=) (type1 type2)
1209  (and (eq (foreign-record-type-name type1)
1210           (foreign-record-type-name type2))
1211       (eq (foreign-record-type-kind type1)
1212           (foreign-record-type-kind type2))
1213       (= (length (foreign-record-type-fields type1))
1214          (length (foreign-record-type-fields type2)))
1215       (record-fields-match (foreign-record-type-fields type1)
1216                            (foreign-record-type-fields type2) 0)))
1217
1218
1219;;;; The FUNCTION and VALUES types.
1220
1221(defvar *values-type-okay* nil)
1222
1223(def-foreign-type-class (function :include mem-block)
1224  (result-type () :type foreign-type)
1225  (arg-types () :type list)
1226  (stub nil :type (or null function)))
1227
1228
1229
1230(def-foreign-type-method (function :unparse) (type)
1231  `(function ,(%unparse-foreign-type (foreign-function-type-result-type type))
1232             ,@(mapcar #'%unparse-foreign-type
1233                       (foreign-function-type-arg-types type))))
1234
1235(def-foreign-type-method (function :type=) (type1 type2)
1236  (and (foreign-type-= (foreign-function-type-result-type type1)
1237                     (foreign-function-type-result-type type2))
1238       (= (length (foreign-function-type-arg-types type1))
1239          (length (foreign-function-type-arg-types type2)))
1240       (every #'foreign-type-=
1241              (foreign-function-type-arg-types type1)
1242              (foreign-function-type-arg-types type2))))
1243
1244
1245(def-foreign-type-class (values)
1246  (values () :type list))
1247
1248
1249
1250(def-foreign-type-method (values :unparse) (type)
1251  `(values ,@(mapcar #'%unparse-foreign-type
1252                     (foreign-values-type-values type))))
1253
1254(def-foreign-type-method (values :type=) (type1 type2)
1255  (and (= (length (foreign-values-type-values type1))
1256          (length (foreign-values-type-values type2)))
1257       (every #'foreign-type-=
1258              (foreign-values-type-values type1)
1259              (foreign-values-type-values type2))))
1260
1261
1262
1263
1264;;;; The FOREIGN-SIZE macro.
1265
1266(defmacro foreign-size (type &optional (units :bits))
1267  "Return the size of the foreign type TYPE.  UNITS specifies the units to
1268   use and can be either :BITS, :BYTES, or :WORDS."
1269  (let* ((foreign-type (parse-foreign-type type))
1270         (bits (ensure-foreign-type-bits foreign-type)))
1271    (if bits
1272      (values (ceiling bits
1273                       (ecase units
1274                         (:bits 1)
1275                         (:bytes 8)
1276                         (:words 32))))
1277      (error "Unknown size for foreign type ~S."
1278             (unparse-foreign-type foreign-type)))))
1279
1280(defun ensure-foreign-type-bits (type)
1281  (or (foreign-type-bits type)
1282      (and (typep type 'foreign-record-type)
1283           (let* ((name (foreign-record-type-name type)))
1284             (and name
1285                  (load-record name)
1286                  (foreign-type-bits type))))
1287      (and (typep type 'foreign-array-type)
1288           (let* ((element-type (foreign-array-type-element-type type))
1289                  (dims (foreign-array-type-dimensions type)))
1290             (if (and (ensure-foreign-type-bits element-type)
1291                      (every #'integerp dims))
1292               (setf (foreign-array-type-alignment type)
1293                     (foreign-type-alignment element-type)
1294                     (foreign-array-type-bits type)
1295                     (* (align-offset (foreign-type-bits element-type)
1296                                      (foreign-type-alignment element-type))
1297                        (reduce #'* dims))))))))
1298
1299(defun require-foreign-type-bits (type)
1300  (or (ensure-foreign-type-bits type)
1301      (error "Can't determine attributes of foreign type ~s" type)))
1302
1303(defun %find-foreign-record (name)
1304  (or (info-foreign-type-struct name)
1305      (info-foreign-type-union name)
1306      (load-record name)))
1307
1308
1309(defun %foreign-type-or-record (type)
1310  (if (typep type 'foreign-type)
1311    type
1312    (if (consp type)
1313      (parse-foreign-type type)
1314      (or (%find-foreign-record type)
1315          (parse-foreign-type type)))))
1316
1317(defun %foreign-type-or-record-size (type &optional (units :bits))
1318  (let* ((info (%foreign-type-or-record type))
1319         (bits (ensure-foreign-type-bits info)))
1320    (if bits
1321      (values (ceiling bits
1322                       (ecase units
1323                         (:bits 1)
1324                         (:bytes 8)
1325                         (:words 32))))
1326      (error "Unknown size for foreign type ~S."
1327             (unparse-foreign-type info)))))
1328
1329(defun %find-foreign-record-type-field (type field-name)
1330  (ensure-foreign-type-bits type)       ;load the record type if necessary.
1331  (let* ((fields (foreign-record-type-fields type)))
1332    (or (find field-name  fields :key #'foreign-record-field-name :test #'string-equal)
1333                         (error "Record type ~a has no field named ~s.~&Valid field names are: ~&~a"
1334                                (foreign-record-type-name type)
1335                                field-name
1336                                (mapcar #'foreign-record-field-name fields)))))
1337
1338(defun %foreign-access-form (base-form type bit-offset accessors)
1339  (if (null accessors)
1340    (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1341    (etypecase type
1342      (foreign-record-type
1343       (let* ((field (%find-foreign-record-type-field type (car accessors))))
1344         (%foreign-access-form base-form
1345                               (foreign-record-field-type field)
1346                               (+ bit-offset (foreign-record-field-offset field))
1347                               (cdr accessors))))
1348      (foreign-pointer-type
1349       (%foreign-access-form
1350        (invoke-foreign-type-method :extract-gen type base-form bit-offset)
1351        (foreign-pointer-type-to type)
1352        0
1353        accessors)))))
1354
1355(defun %foreign-array-access-form (base-form type index-form)
1356  (etypecase type
1357    ((or foreign-pointer-type foreign-array-type)
1358     (let* ((to (foreign-pointer-type-to type))
1359            (size (foreign-type-bits to))
1360            (bit-offset `(the fixnum (* ,size (the fixnum ,index-form)))))
1361       (invoke-foreign-type-method :extract-gen to base-form bit-offset)))))
1362
1363
1364
1365
1366;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value
1367
1368(defun naturalize (foreign type)
1369  (declare (type foreign-type type))
1370  (funcall (coerce (compute-naturalize-lambda type) 'function)
1371           foreign type))
1372
1373(defun deport (value type)
1374  (declare (type foreign-type type))
1375  (funcall (coerce (compute-deport-lambda type) 'function)
1376           value type))
1377
1378(defun extract-foreign-value (sap offset type)
1379  (declare (type macptr sap)
1380           (type unsigned-byte offset)
1381           (type foreign-type type))
1382  (funcall (coerce (compute-extract-lambda type) 'function)
1383           sap offset type))
1384
1385(defun deposit-foreign-value (sap offset type value)
1386  (declare (type macptr sap)
1387           (type unsigned-byte offset)
1388           (type foreign-type type))
1389  (funcall (coerce (compute-deposit-lambda type) 'function)
1390           sap offset type value))
1391
1392
1393
1394(defmacro external (name)
1395  "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name,
1396find it and return it. If not, create one and return it.
1397
1398Try to resolve the entry point to a memory address, and identify the
1399containing library.
1400
1401Be aware that under Darwin, external functions which are callable from C
1402have underscores prepended to their names, as in '_fopen'."
1403  `(load-eep ,name))
1404
1405(defmacro external-call (name &rest args)
1406  "Call the foreign function at the address obtained by resolving the
1407external-entry-point associated with name, passing the values of each arg
1408as a foreign argument of type indicated by the corresponding
1409arg-type-specifier. Returns the foreign function result (coerced to a
1410Lisp object of type indicated by result-type-specifier), or NIL if
1411result-type-specifer is :VOID or NIL"
1412  `(ff-call (%reference-external-entry-point
1413             (load-time-value (external ,name))) ,@args))
1414
1415(defmacro ff-call (entry &rest args)
1416  "Call the foreign function at address entrypoint passing the values of
1417each arg as a foreign argument of type indicated by the corresponding
1418arg-type-specifier. Returns the foreign function result (coerced to a
1419Lisp object of type indicated by result-type-specifier), or NIL if
1420result-type-specifer is :VOID or NIL"
1421  (funcall (ftd-ff-call-expand-function *target-ftd*)
1422           `(%ff-call ,entry) args))
1423       
1424         
1425
1426(defmethod make-load-form ((eep external-entry-point) &optional env)
1427  (declare (ignore env))
1428  `(load-eep ,(eep.name eep)))
1429
1430
1431(defmethod print-object ((eep external-entry-point) out)
1432  (print-unreadable-object (eep out :type t :identity t)
1433    (format out "~s" (eep.name eep))
1434    (let* ((addr (eep.address eep))
1435           (container (eep.container eep)))
1436      (if addr
1437        #+ppc-target
1438        (progn
1439          #+32-bit-target
1440          (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2)))
1441          #+64-bit-target
1442          (format out " (#x~16,'0x) " (if (typep addr 'integer)
1443                                        (logand #xffffffffffffffff (ash addr 2))
1444                                        (%ptr-to-int addr))))
1445        #+(or x8632-target arm-target)
1446        (format out " (#x~8,'0x) " addr)
1447        #+x8664-target
1448        (format out " (#x~16,'0x) " addr)
1449        (format out " {unresolved} "))
1450      (when (and container (or (not (typep container 'macptr))
1451                                    (not (%null-ptr-p container))))
1452        (format out "~a" (shlib.soname container))))))
1453
1454
1455
1456(defun %cons-foreign-variable (name type &optional container)
1457  (%istruct 'foreign-variable nil name type container))
1458
1459(defmethod make-load-form ((fv foreign-variable) &optional env)
1460  (declare (ignore env))
1461  `(load-fv ,(fv.name fv) ',(fv.type fv)))
1462
1463(defmethod print-object ((fv foreign-variable) out)
1464  (print-unreadable-object (fv out :type t :identity t)
1465    (format out "~s" (fv.name fv))
1466    (let* ((addr (fv.addr fv))
1467           (container (fv.container fv)))
1468      (if addr
1469        #+32-bit-target
1470        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
1471        #+64-bit-target
1472                (format out " (#x~16,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
1473        (format out " {unresolved} "))
1474      (when (and container (or (not (typep container 'macptr))
1475                                    (not (%null-ptr-p container))))
1476        (format out "~a" (shlib.soname container))))))
1477
1478
1479(defmethod print-object ((s shlib) stream)
1480  (print-unreadable-object (s stream :type t :identity t)
1481    (format stream "~a" (or (shlib.soname s) (shlib.pathname s)))))
1482
1483#-(or darwin-target windows-target)
1484(defun dlerror ()
1485  (with-macptrs ((p))
1486    (%setf-macptr p (#_dlerror))
1487    (unless (%null-ptr-p p) (%get-cstring p))))
1488
1489(defstruct (external-function-definition (:conc-name "EFD-")
1490                                         (:constructor
1491                                          make-external-function-definition
1492                                          (&key entry-name arg-specs
1493                                                result-spec
1494                                                (min-args (length arg-specs))))
1495                                         )
1496  (entry-name "" :type string)
1497  (arg-specs () :type list)
1498  (result-spec nil :type (or symbol list))
1499  (min-args 0 :type fixnum))
1500
1501
1502(defun %external-call-expander (whole env)
1503  (declare (ignore env))
1504  (destructuring-bind (name &rest args) whole
1505    (collect ((call))
1506      (let* ((info (or (gethash name (ftd-external-function-definitions
1507                                      *target-ftd*))
1508                       (error "Unknown external-function: ~s" name)))
1509             (external-name (efd-entry-name info))
1510             (arg-specs (efd-arg-specs info))
1511             (result (efd-result-spec info))
1512             (monitor (eq (car args) :monitor-exception-ports)))
1513        (when monitor
1514          (setq args (cdr args))
1515          (call :monitor-exception-ports))
1516        (let* ((rtype (parse-foreign-type result)))
1517          (if (typep rtype 'foreign-record-type)
1518            (call (pop args))))
1519        (do* ((specs arg-specs (cdr specs))
1520              (args args (cdr args)))
1521             ((null specs)
1522              (call result)
1523              (if args
1524                (error "Extra arguments in ~s"  whole)
1525                `(external-call ,external-name ,@(call))))
1526          (let* ((spec (car specs)))
1527            (cond ((eq spec :void)
1528                   ;; must be last arg-spec; remaining args should be
1529                   ;; keyword/value pairs
1530                   (unless (evenp (length args))
1531                     (error "Remaining arguments should be keyword/value pairs: ~s"
1532                            args))
1533                   (do* ()
1534                        ((null args))
1535                     (call (pop args))
1536                     (call (pop args))))
1537                  (t
1538                   (call spec)
1539                   (if args
1540                     (call (car args))
1541                     (error "Missing arguments in ~s" whole))))))))))
1542
1543(defun translate-foreign-arg-type (foreign-type-spec)
1544  (let* ((foreign-type (parse-foreign-type foreign-type-spec)))
1545    (etypecase foreign-type
1546      (foreign-pointer-type :address)
1547      (foreign-integer-type
1548       (let* ((bits (foreign-integer-type-bits foreign-type))
1549              (signed (foreign-integer-type-signed foreign-type)))
1550         (declare (fixnum bits))
1551         (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte))
1552               ((<= bits 16) (if signed :signed-halfword :unsigned-halfword))
1553               ((<= bits 32) (if signed :signed-fullword :unsigned-fullword))
1554               ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword))
1555               (t `(:record ,bits)))))
1556      (foreign-float-type
1557       (ecase (foreign-float-type-bits foreign-type)
1558         (32 :single-float)
1559         (64 :double-float)))
1560      (foreign-record-type
1561       `(:record ,(foreign-record-type-bits foreign-type))))))
1562     
1563
1564(defmacro define-external-function (name (&rest arg-specs) result-spec
1565                                         &key (min-args (length arg-specs)))
1566  (let* ((entry-name nil)
1567         (package (find-package (ftd-interface-package-name *target-ftd*)))
1568         (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs))
1569         (result-keyword (unless (and (symbolp result-spec)
1570                                    (eq (make-keyword result-spec) :void))
1571                               (translate-foreign-arg-type result-spec))))
1572    (when (and (consp result-keyword) (eq (car result-keyword) :record))
1573      (push :address arg-keywords)
1574      (setq result-keyword nil))
1575    (if (consp name)
1576      (setq entry-name (cadr name) name (intern (unescape-foreign-name
1577                                                 (car name))
1578                                                package))
1579      (progn
1580        (setq entry-name (unescape-foreign-name name)
1581              name (intern entry-name package))
1582        (if (getf (ftd-attributes *target-ftd*)
1583                  :prepend-underscore)
1584          (setq entry-name (concatenate 'string "_" entry-name)))))
1585    `(progn
1586      (setf (gethash ',name (ftd-external-function-definitions *target-ftd*))
1587       (make-external-function-definition
1588        :entry-name ',entry-name
1589        :arg-specs ',arg-keywords
1590        :result-spec ',result-keyword
1591        :min-args ,min-args))
1592      (setf (macro-function ',name) #'%external-call-expander)
1593      ',name)))
1594
1595
1596#+darwinppc-target
1597(defun open-dylib (name)
1598  (with-cstrs ((name name))
1599    (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR 
1600                               #$NSADDIMAGE_OPTION_WITH_SEARCHING))))
1601
1602(defparameter *foreign-representation-type-keywords*
1603  `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte
1604    :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte
1605    :address
1606    :single-float :double-float
1607    :void))
1608
1609(defun null-coerce-foreign-arg (arg-type-keyword argform)
1610  (declare (ignore arg-type-keyword))
1611  argform)
1612
1613(defun null-coerce-foreign-result (result-type-keyword resultform)
1614  (declare (ignore result-type-keyword))
1615  resultform)
1616
1617(defun foreign-type-to-representation-type (f)
1618  (if (or (member f *foreign-representation-type-keywords*)
1619          (typep f 'unsigned-byte))
1620    f
1621    (let* ((ftype (if (typep f 'foreign-type)
1622                    f
1623                    (parse-foreign-type f))))
1624      (or
1625       (and (eq (foreign-type-class ftype) 'root) :void)         
1626       (typecase ftype
1627         ((or foreign-pointer-type foreign-array-type) :address)
1628         (foreign-double-float-type :double-float)
1629         (foreign-single-float-type :single-float)
1630         (foreign-integer-type
1631          (let* ((signed (foreign-integer-type-signed ftype))
1632                 (bits (foreign-integer-type-bits ftype)))
1633            (if signed
1634              (if (<= bits 8)
1635                :signed-byte
1636                (if (<= bits 16)
1637                  :signed-halfword
1638                  (if (<= bits 32)
1639                    :signed-fullword
1640                    (if (<= bits 64)
1641                      :signed-doubleword))))
1642              (if (<= bits 8)
1643                :unsigned-byte
1644                (if (<= bits 16)
1645                  :unsigned-halfword
1646                  (if (<= bits 32)
1647                    :unsigned-fullword
1648                    (if (<= bits 64)
1649                      :unsigned-doubleword)))))))
1650         (foreign-record-type
1651          (if (getf (ftd-attributes *target-ftd*)
1652                  :struct-by-value)
1653            (let* ((bits (ensure-foreign-type-bits ftype)))
1654              (ceiling bits (target-word-size-case
1655                             (32 32)
1656                             (64 64))))
1657          :address)))
1658       (error "can't determine representation keyword for ~s" f)))))
1659
1660(defun foreign-record-accessor-names (record-type &optional prefix)
1661  (collect ((accessors))
1662    (dolist (field (foreign-record-type-fields record-type) (accessors))
1663      (let* ((field-name (append prefix (list (foreign-record-field-name field))))
1664             (field-type (foreign-record-field-type field)))
1665        (if (typep field-type 'foreign-record-type)
1666          (dolist (s (foreign-record-accessor-names field-type field-name))
1667            (accessors s))
1668          (accessors field-name))))))
1669
1670;;; Are all (scalar) fields in the field-list FIELDS floats ?'
1671(defun all-floats-in-field-list (fields)
1672  (dolist (field fields t)
1673    (let* ((field-type (foreign-record-field-type field)))
1674      (cond ((typep field-type 'foreign-record-type)
1675             (unless (all-floats-in-field-list (foreign-record-type-fields field-type))
1676                                     (return nil)))
1677            ((typep field-type 'foreign-array-type)
1678             (unless (typep (foreign-array-type-element-type field-type) 'foreign-float-type)
1679               (return nil)))
1680            (t (unless (typep field-type 'foreign-float-type)
1681                 (return nil)))))))
1682
1683;;; Are any (scalar) fields in the field-list FIELDS floats ?
1684(defun some-floats-in-field-list (fields)
1685  (dolist (field fields)
1686    (let* ((field-type (foreign-record-field-type field)))
1687      (cond ((typep field-type 'foreign-float-type)
1688             (return t))
1689            ((typep field-type 'foreign-record-type)
1690             (if (some-floats-in-field-list (foreign-record-type-fields field-type))
1691               (return t)))
1692            ((typep field-type 'foreign-array-type)
1693             (if (typep (foreign-array-type-element-type field-type)
1694                        'foreign-float-type)
1695               (return t)))))))
1696
1697;;; We don't use foreign type ordinals when cross-compiling,
1698;;; so the read-time conditionalization is OK here.
1699
1700#-windows-target
1701(defparameter *canonical-os-foreign-types*
1702  '((:struct :timespec)
1703    (:struct :stat)
1704    (:struct :passwd)
1705    #>Dl_info
1706    (:array (:struct :pollfd) 1)) )
1707
1708#+windows-target
1709(defparameter *canonical-os-foreign-types*
1710  `(#>FILETIME
1711    #>SYSTEM_INFO
1712    #>HANDLE
1713    #>PROCESS_INFORMATION
1714    #>STARTUPINFO
1715    (:array #>HANDLE 2)
1716    #>DWORD
1717    (:array #>wchar_t #.#$MAX_PATH)
1718    #>fd_set
1719    #>DWORD_PTR
1720    #>SYSTEMTIME))
1721   
1722   
1723(defun canonicalize-foreign-type-ordinals (ftd)
1724  (let* ((canonical-ordinal 0))          ; used for :VOID
1725    (flet ((canonicalize-foreign-type-ordinal (spec)
1726             (let* ((new-ordinal (incf canonical-ordinal)))
1727               (when spec
1728                 (let* ((type (parse-foreign-type spec))
1729                        (old-ordinal (foreign-type-ordinal type)))
1730                   (unless (eql new-ordinal old-ordinal)
1731                     (remhash old-ordinal (ftd-ordinal-types ftd))
1732                     (setf (foreign-type-ordinal type) new-ordinal)
1733                     (note-foreign-type-ordinal type ftd))))
1734               new-ordinal)))
1735      (canonicalize-foreign-type-ordinal :signed)
1736      (canonicalize-foreign-type-ordinal :unsigned)
1737      (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil)
1738      (canonicalize-foreign-type-ordinal :address)
1739      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
1740      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
1741      (canonicalize-foreign-type-ordinal '(:struct :linger))
1742      (canonicalize-foreign-type-ordinal '(:struct :hostent))
1743      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
1744      (canonicalize-foreign-type-ordinal '(:* :char))
1745      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
1746      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
1747      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
1748      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
1749      (canonicalize-foreign-type-ordinal '(:array :int 2))
1750      (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1))
1751      (canonicalize-foreign-type-ordinal '(:struct :dirent))
1752      (canonicalize-foreign-type-ordinal '(:struct :timeval))
1753      (canonicalize-foreign-type-ordinal '(:struct :addrinfo))
1754
1755      (setq canonical-ordinal (1- max-common-foreign-type-ordinal))
1756
1757      (dolist (spec *canonical-os-foreign-types*)
1758        (canonicalize-foreign-type-ordinal spec))
1759      (dolist (spec (ftd-platform-ordinal-types ftd))
1760        (canonicalize-foreign-type-ordinal spec)))))
1761
1762(defun install-standard-foreign-types (ftd)
1763  (let* ((*target-ftd* ftd)
1764         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word))
1765         (long-word-size (or (getf (ftd-attributes ftd) :bits-per-long)
1766                             natural-word-size)))
1767
1768    (def-foreign-type-translator signed (&optional (bits 32))
1769      (if (<= bits 64)
1770        (svref *signed-integer-types* bits)
1771        (make-foreign-integer-type :bits bits)))
1772
1773
1774    (def-foreign-type-translator integer (&optional (bits 32))
1775      (if (<= bits 64)
1776        (svref *signed-integer-types* bits)
1777        (make-foreign-integer-type :bits bits)))
1778
1779    (def-foreign-type-translator unsigned (&optional (bits 32))
1780      (if (<= bits 64)
1781        (svref *unsigned-integer-types* bits)
1782        (make-foreign-integer-type :bits bits :signed nil)))
1783
1784    (def-foreign-type-translator bitfield (&optional (bits 1))
1785      (make-foreign-integer-type :bits bits :signed nil :alignment 1))
1786
1787    (def-foreign-type-translator root ()
1788      (make-foreign-type :class 'root :bits 0 :alignment 0))
1789
1790    (def-foreign-type-translator :<BOOL> () *bool-type*)
1791
1792    (def-foreign-type-translator single-float ()
1793      (make-foreign-single-float-type :type 'single-float))
1794
1795    (def-foreign-type-translator double-float ()
1796      (make-foreign-double-float-type :type 'double-float))
1797
1798    (def-foreign-type-translator macptr ()
1799      (make-foreign-macptr-type :bits natural-word-size))
1800
1801    (def-foreign-type-translator values (&rest values)
1802      (unless *values-type-okay*
1803        (error "Cannot use values types here."))
1804      (let ((*values-type-okay* nil))
1805        (make-foreign-values-type
1806         :values (mapcar #'parse-foreign-type values))))
1807
1808    (def-foreign-type-translator function (result-type &rest arg-types)
1809      (make-foreign-function-type
1810       :result-type (let ((*values-type-okay* t))
1811                      (parse-foreign-type result-type))
1812       :arg-types (mapcar #'parse-foreign-type arg-types)))
1813
1814    (def-foreign-type-translator struct (name &rest fields)
1815      (parse-foreign-record-type :struct name fields))
1816   
1817    (def-foreign-type-translator union (name &rest fields)
1818      (parse-foreign-record-type :union name fields))
1819
1820    (def-foreign-type-translator transparent-union (name &rest fields)
1821      (parse-foreign-record-type :transparent-union name fields))
1822
1823    (def-foreign-type-translator array (ele-type &rest dims)
1824      (when dims
1825        ;; cross-compiling kludge. replaces '(or index null)
1826        (unless (typep (first dims) `(or
1827                                      ,(target-word-size-case
1828                                        (32 '(integer 0 #.(expt 2 24)))
1829                                        (64 '(integer 0 #.(expt 2 56))))
1830                                      null))
1831          (error "First dimension is not a non-negative fixnum or NIL: ~S"
1832                 (first dims)))
1833        (let ((loser (find-if-not #'(lambda (x) (typep x 'index))
1834                                  (rest dims))))
1835          (when loser
1836            (error "Dimension is not a non-negative fixnum: ~S" loser))))
1837       
1838      (let* ((type (parse-foreign-type ele-type))
1839             (pair (cons type dims)))
1840        (declare (dynamic-extent pair))
1841        (ensure-foreign-type-bits type)
1842        (or (gethash pair (ftd-array-types *target-ftd*))
1843            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
1844                 
1845                  (make-foreign-array-type
1846                   :element-type type
1847                   :dimensions dims
1848                   :alignment (foreign-type-alignment type)
1849                   :bits (if (and (ensure-foreign-type-bits type)
1850                                  (every #'integerp dims))
1851                           (* (align-offset (foreign-type-bits type)
1852                                            (foreign-type-alignment type))
1853                              (reduce #'* dims))))))))
1854
1855    (def-foreign-type-translator * (to)
1856      (let* ((ftd *target-ftd*)
1857             (to (if (eq to t) *void-foreign-type* (parse-foreign-type to ftd))))
1858        (or (gethash to (ftd-pointer-types ftd))
1859            (setf (gethash to (ftd-pointer-types *target-ftd*))
1860                  (make-foreign-pointer-type
1861                   :to to
1862                   :bits natural-word-size)))))
1863   
1864    (def-foreign-type-translator boolean (&optional (bits 32))
1865      (make-foreign-boolean-type :bits bits :signed nil))
1866
1867    (def-foreign-type signed-char (signed 8))
1868    (def-foreign-type signed-byte (signed 8))
1869    (def-foreign-type short (signed 16))
1870    (def-foreign-type signed-halfword short)
1871    (def-foreign-type int (signed 32))
1872    (def-foreign-type signed-fullword int)
1873    (def-foreign-type signed-short (signed 16))
1874    (def-foreign-type signed-int (signed 32))
1875    (def-foreign-type signed-doubleword (signed 64))
1876    (def-foreign-type char #-darwin-target (unsigned 8)
1877                      #+darwin-target (signed 8))
1878    (def-foreign-type unsigned-char (unsigned 8))
1879    (def-foreign-type unsigned-byte (unsigned 8))
1880    (def-foreign-type unsigned-short (unsigned 16))
1881    (def-foreign-type unsigned-halfword unsigned-short)
1882    (def-foreign-type unsigned-int (unsigned 32))
1883    (def-foreign-type unsigned-fullword unsigned-int)
1884    (def-foreign-type unsigned-doubleword (unsigned 64))
1885    (def-foreign-type bit (bitfield 1))
1886
1887    (def-foreign-type float single-float)
1888    (def-foreign-type double double-float)
1889
1890    (%def-foreign-type :void *void-foreign-type*)
1891    (def-foreign-type address (* :void))
1892    (let* ((signed-long-type (parse-foreign-type
1893                              `(:signed ,long-word-size)))
1894           (unsigned-long-type (parse-foreign-type
1895                                `(:unsigned ,long-word-size))))
1896      (%def-foreign-type :long signed-long-type ftd)
1897      (%def-foreign-type :signed-long signed-long-type ftd)
1898      (%def-foreign-type :unsigned-long unsigned-long-type ftd))
1899    ;;
1900    ;; Defining the handful of foreign structures that are used
1901    ;; to build Clozure CL here ensures that all backends see appropriate
1902    ;; definitions of them.
1903    ;;
1904    ;; Don't use DEF-FOREIGN-TYPE here; this often runs too
1905    ;; early in the cold load for that to work.
1906    ;;
1907    (parse-foreign-type
1908     '(:struct :cdb-datum
1909       (:data (* t))
1910       (:size (:unsigned 32)))
1911     ftd)
1912    (parse-foreign-type
1913     '(:struct :dbm-constant
1914       (:class (:unsigned 32))
1915       (:pad (:unsigned 32))
1916       (:value
1917        (:union nil
1918         (:s32 (:signed 32))
1919         (:u32 (:unsigned 32))
1920         (:single-float :float)
1921         (:double-float :double))))
1922     ftd)
1923    ;; This matches the xframe-list struct definition in
1924    ;; "ccl:lisp-kernel;constants.h"
1925    (parse-foreign-type
1926     '(:struct :xframe-list
1927       (:this (:* t #|(struct :ucontext)|#))
1928       (:prev (:* (:struct  :xframe-list))))
1929    ftd)
1930  ))
1931
1932(defmethod make-load-form ((p macptr) &optional env)
1933  (declare (ignore env))
1934  (let* ((value (%ptr-to-int p)))
1935    (unless (or (< value 65536)
1936                (>= value (- (ash 1 target::nbits-in-word) 65536)))
1937      (error "~&~s can't be referenced as a constant because its address contains more than 16 significant bits." p))
1938    (if (zerop value)
1939      '+null-ptr+
1940      `(%int-to-ptr ,value))))
1941
1942
1943
1944
Note: See TracBrowser for help on using the repository browser.