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

Last change on this file since 14423 was 14258, checked in by gz, 9 years ago

Defstruct changes: Get rid of *defstruct-share-accessor-functions*. Typecheck the structure object in copiers, accessors -- both the accessor functions and compiler transforms -- unless nx-inhibit-safety-checking is true. Try to be more consistent about when/how typecheck struct slot types. Generate setter as well as getter functions.

Added new macro, TYPECHECK, that, depending on the value of nx-inhibit-safety-checking, turns into either a declaration or a require-type with approppriately downgraded type.

I had to turn off the typechecking (with optimize declarations) in a handful of places because of a bootstrapping problem: there are some structure types in the ARCH package which are referenced before the package exists, causing bootstrap to fail.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 70.8 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 (if (foreign-array-type-p type)
1359                  (foreign-array-type-element-type type)
1360                  (foreign-pointer-type-to type)))
1361            (size (foreign-type-bits to))
1362            (bit-offset `(the fixnum (* ,size (the fixnum ,index-form)))))
1363       (invoke-foreign-type-method :extract-gen to base-form bit-offset)))))
1364
1365
1366
1367
1368;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value
1369
1370(defun naturalize (foreign type)
1371  (declare (type foreign-type type))
1372  (funcall (coerce (compute-naturalize-lambda type) 'function)
1373           foreign type))
1374
1375(defun deport (value type)
1376  (declare (type foreign-type type))
1377  (funcall (coerce (compute-deport-lambda type) 'function)
1378           value type))
1379
1380(defun extract-foreign-value (sap offset type)
1381  (declare (type macptr sap)
1382           (type unsigned-byte offset)
1383           (type foreign-type type))
1384  (funcall (coerce (compute-extract-lambda type) 'function)
1385           sap offset type))
1386
1387(defun deposit-foreign-value (sap offset type value)
1388  (declare (type macptr sap)
1389           (type unsigned-byte offset)
1390           (type foreign-type type))
1391  (funcall (coerce (compute-deposit-lambda type) 'function)
1392           sap offset type value))
1393
1394
1395
1396(defmacro external (name)
1397  "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name,
1398find it and return it. If not, create one and return it.
1399
1400Try to resolve the entry point to a memory address, and identify the
1401containing library.
1402
1403Be aware that under Darwin, external functions which are callable from C
1404have underscores prepended to their names, as in '_fopen'."
1405  `(load-eep ,name))
1406
1407(defmacro external-call (name &rest args)
1408  "Call the foreign function at the address obtained by resolving the
1409external-entry-point associated with name, passing the values of each arg
1410as a foreign argument of type indicated by the corresponding
1411arg-type-specifier. Returns the foreign function result (coerced to a
1412Lisp object of type indicated by result-type-specifier), or NIL if
1413result-type-specifer is :VOID or NIL"
1414  `(ff-call (%reference-external-entry-point
1415             (load-time-value (external ,name))) ,@args))
1416
1417(defmacro ff-call (entry &rest args)
1418  "Call the foreign function at address entrypoint passing the values of
1419each arg as a foreign argument of type indicated by the corresponding
1420arg-type-specifier. Returns the foreign function result (coerced to a
1421Lisp object of type indicated by result-type-specifier), or NIL if
1422result-type-specifer is :VOID or NIL"
1423  (funcall (ftd-ff-call-expand-function *target-ftd*)
1424           `(%ff-call ,entry) args))
1425       
1426         
1427
1428(defmethod make-load-form ((eep external-entry-point) &optional env)
1429  (declare (ignore env))
1430  `(load-eep ,(eep.name eep)))
1431
1432
1433(defmethod print-object ((eep external-entry-point) out)
1434  (print-unreadable-object (eep out :type t :identity t)
1435    (format out "~s" (eep.name eep))
1436    (let* ((addr (eep.address eep))
1437           (container (eep.container eep)))
1438      (if addr
1439        #+ppc-target
1440        (progn
1441          #+32-bit-target
1442          (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2)))
1443          #+64-bit-target
1444          (format out " (#x~16,'0x) " (if (typep addr 'integer)
1445                                        (logand #xffffffffffffffff (ash addr 2))
1446                                        (%ptr-to-int addr))))
1447        #+(or x8632-target arm-target)
1448        (format out " (#x~8,'0x) " addr)
1449        #+x8664-target
1450        (format out " (#x~16,'0x) " addr)
1451        (format out " {unresolved} "))
1452      (when (and container (or (not (typep container 'macptr))
1453                                    (not (%null-ptr-p container))))
1454        (format out "~a" (shlib.soname container))))))
1455
1456
1457
1458(defun %cons-foreign-variable (name type &optional container)
1459  (%istruct 'foreign-variable nil name type container))
1460
1461(defmethod make-load-form ((fv foreign-variable) &optional env)
1462  (declare (ignore env))
1463  `(load-fv ,(fv.name fv) ',(fv.type fv)))
1464
1465(defmethod print-object ((fv foreign-variable) out)
1466  (print-unreadable-object (fv out :type t :identity t)
1467    (format out "~s" (fv.name fv))
1468    (let* ((addr (fv.addr fv))
1469           (container (fv.container fv)))
1470      (if addr
1471        #+32-bit-target
1472        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
1473        #+64-bit-target
1474                (format out " (#x~16,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
1475        (format out " {unresolved} "))
1476      (when (and container (or (not (typep container 'macptr))
1477                                    (not (%null-ptr-p container))))
1478        (format out "~a" (shlib.soname container))))))
1479
1480
1481(defmethod print-object ((s shlib) stream)
1482  (print-unreadable-object (s stream :type t :identity t)
1483    (format stream "~a" (or (shlib.soname s) (shlib.pathname s)))))
1484
1485#-(or darwin-target windows-target)
1486(defun dlerror ()
1487  (with-macptrs ((p))
1488    (%setf-macptr p (#_dlerror))
1489    (unless (%null-ptr-p p) (%get-cstring p))))
1490
1491(defstruct (external-function-definition (:conc-name "EFD-")
1492                                         (:constructor
1493                                          make-external-function-definition
1494                                          (&key entry-name arg-specs
1495                                                result-spec
1496                                                (min-args (length arg-specs))))
1497                                         )
1498  (entry-name "" :type string)
1499  (arg-specs () :type list)
1500  (result-spec nil :type (or symbol list))
1501  (min-args 0 :type fixnum))
1502
1503
1504(defun %external-call-expander (whole env)
1505  (declare (ignore env))
1506  (destructuring-bind (name &rest args) whole
1507    (collect ((call))
1508      (let* ((info (or (gethash name (ftd-external-function-definitions
1509                                      *target-ftd*))
1510                       (error "Unknown external-function: ~s" name)))
1511             (external-name (efd-entry-name info))
1512             (arg-specs (efd-arg-specs info))
1513             (result (efd-result-spec info))
1514             (monitor (eq (car args) :monitor-exception-ports)))
1515        (when monitor
1516          (setq args (cdr args))
1517          (call :monitor-exception-ports))
1518        (let* ((rtype (parse-foreign-type result)))
1519          (if (typep rtype 'foreign-record-type)
1520            (call (pop args))))
1521        (do* ((specs arg-specs (cdr specs))
1522              (args args (cdr args)))
1523             ((null specs)
1524              (call result)
1525              (if args
1526                (error "Extra arguments in ~s"  whole)
1527                `(external-call ,external-name ,@(call))))
1528          (let* ((spec (car specs)))
1529            (cond ((eq spec :void)
1530                   ;; must be last arg-spec; remaining args should be
1531                   ;; keyword/value pairs
1532                   (unless (evenp (length args))
1533                     (error "Remaining arguments should be keyword/value pairs: ~s"
1534                            args))
1535                   (do* ()
1536                        ((null args))
1537                     (call (pop args))
1538                     (call (pop args))))
1539                  (t
1540                   (call spec)
1541                   (if args
1542                     (call (car args))
1543                     (error "Missing arguments in ~s" whole))))))))))
1544
1545(defun translate-foreign-arg-type (foreign-type-spec)
1546  (let* ((foreign-type (parse-foreign-type foreign-type-spec)))
1547    (etypecase foreign-type
1548      (foreign-pointer-type :address)
1549      (foreign-integer-type
1550       (let* ((bits (foreign-integer-type-bits foreign-type))
1551              (signed (foreign-integer-type-signed foreign-type)))
1552         (declare (fixnum bits))
1553         (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte))
1554               ((<= bits 16) (if signed :signed-halfword :unsigned-halfword))
1555               ((<= bits 32) (if signed :signed-fullword :unsigned-fullword))
1556               ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword))
1557               (t `(:record ,bits)))))
1558      (foreign-float-type
1559       (ecase (foreign-float-type-bits foreign-type)
1560         (32 :single-float)
1561         (64 :double-float)))
1562      (foreign-record-type
1563       `(:record ,(foreign-record-type-bits foreign-type))))))
1564     
1565
1566(defmacro define-external-function (name (&rest arg-specs) result-spec
1567                                         &key (min-args (length arg-specs)))
1568  (let* ((entry-name nil)
1569         (package (find-package (ftd-interface-package-name *target-ftd*)))
1570         (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs))
1571         (result-keyword (unless (and (symbolp result-spec)
1572                                    (eq (make-keyword result-spec) :void))
1573                               (translate-foreign-arg-type result-spec))))
1574    (when (and (consp result-keyword) (eq (car result-keyword) :record))
1575      (push :address arg-keywords)
1576      (setq result-keyword nil))
1577    (if (consp name)
1578      (setq entry-name (cadr name) name (intern (unescape-foreign-name
1579                                                 (car name))
1580                                                package))
1581      (progn
1582        (setq entry-name (unescape-foreign-name name)
1583              name (intern entry-name package))
1584        (if (getf (ftd-attributes *target-ftd*)
1585                  :prepend-underscore)
1586          (setq entry-name (concatenate 'string "_" entry-name)))))
1587    `(progn
1588      (setf (gethash ',name (ftd-external-function-definitions *target-ftd*))
1589       (make-external-function-definition
1590        :entry-name ',entry-name
1591        :arg-specs ',arg-keywords
1592        :result-spec ',result-keyword
1593        :min-args ,min-args))
1594      (setf (macro-function ',name) #'%external-call-expander)
1595      ',name)))
1596
1597
1598#+darwinppc-target
1599(defun open-dylib (name)
1600  (with-cstrs ((name name))
1601    (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR 
1602                               #$NSADDIMAGE_OPTION_WITH_SEARCHING))))
1603
1604(defparameter *foreign-representation-type-keywords*
1605  `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte
1606    :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte
1607    :address
1608    :single-float :double-float
1609    :void))
1610
1611(defun null-coerce-foreign-arg (arg-type-keyword argform)
1612  (declare (ignore arg-type-keyword))
1613  argform)
1614
1615(defun null-coerce-foreign-result (result-type-keyword resultform)
1616  (declare (ignore result-type-keyword))
1617  resultform)
1618
1619(defun foreign-type-to-representation-type (f)
1620  (if (or (member f *foreign-representation-type-keywords*)
1621          (typep f 'unsigned-byte))
1622    f
1623    (let* ((ftype (if (typep f 'foreign-type)
1624                    f
1625                    (parse-foreign-type f))))
1626      (or
1627       (and (eq (foreign-type-class ftype) 'root) :void)         
1628       (typecase ftype
1629         ((or foreign-pointer-type foreign-array-type) :address)
1630         (foreign-double-float-type :double-float)
1631         (foreign-single-float-type :single-float)
1632         (foreign-integer-type
1633          (let* ((signed (foreign-integer-type-signed ftype))
1634                 (bits (foreign-integer-type-bits ftype)))
1635            (if signed
1636              (if (<= bits 8)
1637                :signed-byte
1638                (if (<= bits 16)
1639                  :signed-halfword
1640                  (if (<= bits 32)
1641                    :signed-fullword
1642                    (if (<= bits 64)
1643                      :signed-doubleword))))
1644              (if (<= bits 8)
1645                :unsigned-byte
1646                (if (<= bits 16)
1647                  :unsigned-halfword
1648                  (if (<= bits 32)
1649                    :unsigned-fullword
1650                    (if (<= bits 64)
1651                      :unsigned-doubleword)))))))
1652         (foreign-record-type
1653          (if (getf (ftd-attributes *target-ftd*)
1654                  :struct-by-value)
1655            (let* ((bits (ensure-foreign-type-bits ftype)))
1656              (ceiling bits (target-word-size-case
1657                             (32 32)
1658                             (64 64))))
1659          :address)))
1660       (error "can't determine representation keyword for ~s" f)))))
1661
1662(defun foreign-record-accessor-names (record-type &optional prefix)
1663  (collect ((accessors))
1664    (dolist (field (foreign-record-type-fields record-type) (accessors))
1665      (let* ((field-name (append prefix (list (foreign-record-field-name field))))
1666             (field-type (foreign-record-field-type field)))
1667        (if (typep field-type 'foreign-record-type)
1668          (dolist (s (foreign-record-accessor-names field-type field-name))
1669            (accessors s))
1670          (accessors field-name))))))
1671
1672;;; Are all (scalar) fields in the field-list FIELDS floats ?'
1673(defun all-floats-in-field-list (fields)
1674  (dolist (field fields t)
1675    (let* ((field-type (foreign-record-field-type field)))
1676      (cond ((typep field-type 'foreign-record-type)
1677             (unless (all-floats-in-field-list (foreign-record-type-fields field-type))
1678                                     (return nil)))
1679            ((typep field-type 'foreign-array-type)
1680             (unless (typep (foreign-array-type-element-type field-type) 'foreign-float-type)
1681               (return nil)))
1682            (t (unless (typep field-type 'foreign-float-type)
1683                 (return nil)))))))
1684
1685;;; Are any (scalar) fields in the field-list FIELDS floats ?
1686(defun some-floats-in-field-list (fields)
1687  (dolist (field fields)
1688    (let* ((field-type (foreign-record-field-type field)))
1689      (cond ((typep field-type 'foreign-float-type)
1690             (return t))
1691            ((typep field-type 'foreign-record-type)
1692             (if (some-floats-in-field-list (foreign-record-type-fields field-type))
1693               (return t)))
1694            ((typep field-type 'foreign-array-type)
1695             (if (typep (foreign-array-type-element-type field-type)
1696                        'foreign-float-type)
1697               (return t)))))))
1698
1699;;; We don't use foreign type ordinals when cross-compiling,
1700;;; so the read-time conditionalization is OK here.
1701
1702#-windows-target
1703(defparameter *canonical-os-foreign-types*
1704  '((:struct :timespec)
1705    (:struct :stat)
1706    (:struct :passwd)
1707    #>Dl_info
1708    (:array (:struct :pollfd) 1)) )
1709
1710#+windows-target
1711(defparameter *canonical-os-foreign-types*
1712  `(#>FILETIME
1713    #>SYSTEM_INFO
1714    #>HANDLE
1715    #>PROCESS_INFORMATION
1716    #>STARTUPINFO
1717    (:array #>HANDLE 2)
1718    #>DWORD
1719    (:array #>wchar_t #.#$MAX_PATH)
1720    #>fd_set
1721    #>DWORD_PTR
1722    #>SYSTEMTIME))
1723   
1724   
1725(defun canonicalize-foreign-type-ordinals (ftd)
1726  (let* ((canonical-ordinal 0))          ; used for :VOID
1727    (flet ((canonicalize-foreign-type-ordinal (spec)
1728             (let* ((new-ordinal (incf canonical-ordinal)))
1729               (when spec
1730                 (let* ((type (parse-foreign-type spec))
1731                        (old-ordinal (foreign-type-ordinal type)))
1732                   (unless (eql new-ordinal old-ordinal)
1733                     (remhash old-ordinal (ftd-ordinal-types ftd))
1734                     (setf (foreign-type-ordinal type) new-ordinal)
1735                     (note-foreign-type-ordinal type ftd))))
1736               new-ordinal)))
1737      (canonicalize-foreign-type-ordinal :signed)
1738      (canonicalize-foreign-type-ordinal :unsigned)
1739      (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil)
1740      (canonicalize-foreign-type-ordinal :address)
1741      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
1742      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
1743      (canonicalize-foreign-type-ordinal '(:struct :linger))
1744      (canonicalize-foreign-type-ordinal '(:struct :hostent))
1745      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
1746      (canonicalize-foreign-type-ordinal '(:* :char))
1747      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
1748      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
1749      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
1750      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
1751      (canonicalize-foreign-type-ordinal '(:array :int 2))
1752      (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1))
1753      (canonicalize-foreign-type-ordinal '(:struct :dirent))
1754      (canonicalize-foreign-type-ordinal '(:struct :timeval))
1755      (canonicalize-foreign-type-ordinal '(:struct :addrinfo))
1756
1757      (setq canonical-ordinal (1- max-common-foreign-type-ordinal))
1758
1759      (dolist (spec *canonical-os-foreign-types*)
1760        (canonicalize-foreign-type-ordinal spec))
1761      (dolist (spec (ftd-platform-ordinal-types ftd))
1762        (canonicalize-foreign-type-ordinal spec)))))
1763
1764(defun install-standard-foreign-types (ftd)
1765  (let* ((*target-ftd* ftd)
1766         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word))
1767         (long-word-size (or (getf (ftd-attributes ftd) :bits-per-long)
1768                             natural-word-size)))
1769
1770    (def-foreign-type-translator signed (&optional (bits 32))
1771      (if (<= bits 64)
1772        (svref *signed-integer-types* bits)
1773        (make-foreign-integer-type :bits bits)))
1774
1775
1776    (def-foreign-type-translator integer (&optional (bits 32))
1777      (if (<= bits 64)
1778        (svref *signed-integer-types* bits)
1779        (make-foreign-integer-type :bits bits)))
1780
1781    (def-foreign-type-translator unsigned (&optional (bits 32))
1782      (if (<= bits 64)
1783        (svref *unsigned-integer-types* bits)
1784        (make-foreign-integer-type :bits bits :signed nil)))
1785
1786    (def-foreign-type-translator bitfield (&optional (bits 1))
1787      (make-foreign-integer-type :bits bits :signed nil :alignment 1))
1788
1789    (def-foreign-type-translator root ()
1790      (make-foreign-type :class 'root :bits 0 :alignment 0))
1791
1792    (def-foreign-type-translator :<BOOL> () *bool-type*)
1793
1794    (def-foreign-type-translator single-float ()
1795      (make-foreign-single-float-type :type 'single-float))
1796
1797    (def-foreign-type-translator double-float ()
1798      (make-foreign-double-float-type :type 'double-float))
1799
1800    (def-foreign-type-translator macptr ()
1801      (make-foreign-macptr-type :bits natural-word-size))
1802
1803    (def-foreign-type-translator values (&rest values)
1804      (unless *values-type-okay*
1805        (error "Cannot use values types here."))
1806      (let ((*values-type-okay* nil))
1807        (make-foreign-values-type
1808         :values (mapcar #'parse-foreign-type values))))
1809
1810    (def-foreign-type-translator function (result-type &rest arg-types)
1811      (make-foreign-function-type
1812       :result-type (let ((*values-type-okay* t))
1813                      (parse-foreign-type result-type))
1814       :arg-types (mapcar #'parse-foreign-type arg-types)))
1815
1816    (def-foreign-type-translator struct (name &rest fields)
1817      (parse-foreign-record-type :struct name fields))
1818   
1819    (def-foreign-type-translator union (name &rest fields)
1820      (parse-foreign-record-type :union name fields))
1821
1822    (def-foreign-type-translator transparent-union (name &rest fields)
1823      (parse-foreign-record-type :transparent-union name fields))
1824
1825    (def-foreign-type-translator array (ele-type &rest dims)
1826      (when dims
1827        ;; cross-compiling kludge. replaces '(or index null)
1828        (unless (typep (first dims) `(or
1829                                      ,(target-word-size-case
1830                                        (32 '(integer 0 #.(expt 2 24)))
1831                                        (64 '(integer 0 #.(expt 2 56))))
1832                                      null))
1833          (error "First dimension is not a non-negative fixnum or NIL: ~S"
1834                 (first dims)))
1835        (let ((loser (find-if-not #'(lambda (x) (typep x 'index))
1836                                  (rest dims))))
1837          (when loser
1838            (error "Dimension is not a non-negative fixnum: ~S" loser))))
1839       
1840      (let* ((type (parse-foreign-type ele-type))
1841             (pair (cons type dims)))
1842        (declare (dynamic-extent pair))
1843        (ensure-foreign-type-bits type)
1844        (or (gethash pair (ftd-array-types *target-ftd*))
1845            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
1846                 
1847                  (make-foreign-array-type
1848                   :element-type type
1849                   :dimensions dims
1850                   :alignment (foreign-type-alignment type)
1851                   :bits (if (and (ensure-foreign-type-bits type)
1852                                  (every #'integerp dims))
1853                           (* (align-offset (foreign-type-bits type)
1854                                            (foreign-type-alignment type))
1855                              (reduce #'* dims))))))))
1856
1857    (def-foreign-type-translator * (to)
1858      (let* ((ftd *target-ftd*)
1859             (to (if (eq to t) *void-foreign-type* (parse-foreign-type to ftd))))
1860        (or (gethash to (ftd-pointer-types ftd))
1861            (setf (gethash to (ftd-pointer-types *target-ftd*))
1862                  (make-foreign-pointer-type
1863                   :to to
1864                   :bits natural-word-size)))))
1865   
1866    (def-foreign-type-translator boolean (&optional (bits 32))
1867      (make-foreign-boolean-type :bits bits :signed nil))
1868
1869    (def-foreign-type signed-char (signed 8))
1870    (def-foreign-type signed-byte (signed 8))
1871    (def-foreign-type short (signed 16))
1872    (def-foreign-type signed-halfword short)
1873    (def-foreign-type int (signed 32))
1874    (def-foreign-type signed-fullword int)
1875    (def-foreign-type signed-short (signed 16))
1876    (def-foreign-type signed-int (signed 32))
1877    (def-foreign-type signed-doubleword (signed 64))
1878    (def-foreign-type char #-darwin-target (unsigned 8)
1879                      #+darwin-target (signed 8))
1880    (def-foreign-type unsigned-char (unsigned 8))
1881    (def-foreign-type unsigned-byte (unsigned 8))
1882    (def-foreign-type unsigned-short (unsigned 16))
1883    (def-foreign-type unsigned-halfword unsigned-short)
1884    (def-foreign-type unsigned-int (unsigned 32))
1885    (def-foreign-type unsigned-fullword unsigned-int)
1886    (def-foreign-type unsigned-doubleword (unsigned 64))
1887    (def-foreign-type bit (bitfield 1))
1888
1889    (def-foreign-type float single-float)
1890    (def-foreign-type double double-float)
1891
1892    (%def-foreign-type :void *void-foreign-type*)
1893    (def-foreign-type address (* :void))
1894    (let* ((signed-long-type (parse-foreign-type
1895                              `(:signed ,long-word-size)))
1896           (unsigned-long-type (parse-foreign-type
1897                                `(:unsigned ,long-word-size))))
1898      (%def-foreign-type :long signed-long-type ftd)
1899      (%def-foreign-type :signed-long signed-long-type ftd)
1900      (%def-foreign-type :unsigned-long unsigned-long-type ftd))
1901    ;;
1902    ;; Defining the handful of foreign structures that are used
1903    ;; to build Clozure CL here ensures that all backends see appropriate
1904    ;; definitions of them.
1905    ;;
1906    ;; Don't use DEF-FOREIGN-TYPE here; this often runs too
1907    ;; early in the cold load for that to work.
1908    ;;
1909    (parse-foreign-type
1910     '(:struct :cdb-datum
1911       (:data (* t))
1912       (:size (:unsigned 32)))
1913     ftd)
1914    (parse-foreign-type
1915     '(:struct :dbm-constant
1916       (:class (:unsigned 32))
1917       (:pad (:unsigned 32))
1918       (:value
1919        (:union nil
1920         (:s32 (:signed 32))
1921         (:u32 (:unsigned 32))
1922         (:single-float :float)
1923         (:double-float :double))))
1924     ftd)
1925    ;; This matches the xframe-list struct definition in
1926    ;; "ccl:lisp-kernel;constants.h"
1927    (parse-foreign-type
1928     '(:struct :xframe-list
1929       (:this (:* t #|(struct :ucontext)|#))
1930       (:prev (:* (:struct  :xframe-list))))
1931    ftd)
1932  ))
1933
1934(defmethod make-load-form ((p macptr) &optional env)
1935  (declare (ignore env))
1936  (let* ((value (%ptr-to-int p)))
1937    (unless (or (< value 65536)
1938                (>= value (- (ash 1 target::nbits-in-word) 65536)))
1939      (error "~&~s can't be referenced as a constant because its address contains more than 16 significant bits." p))
1940    (if (zerop value)
1941      '+null-ptr+
1942      `(%int-to-ptr ,value))))
1943
1944
1945
1946
Note: See TracBrowser for help on using the repository browser.