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

Last change on this file since 10827 was 10827, checked in by gb, 11 years ago

Don't define DLERROR on Windows, either.

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