source: branches/working-0711/ccl/lib/foreign-types.lisp @ 13070

Last change on this file since 13070 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

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