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

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

Register the foreign type ordinal of :ARRAY foreign types.

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