/[cmucl]/src/code/foreign.lisp
ViewVC logotype

Diff of /src/code/foreign.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.50 by pmai, Sun Jul 25 19:32:37 2004 UTC revision 1.50.2.1 by rtoy, Mon Dec 19 01:09:50 2005 UTC
# Line 241  Line 241 
241  (defconstant mh-bundle        #x8)  (defconstant mh-bundle        #x8)
242  (defconstant mh-dylib-stub    #x9)  (defconstant mh-dylib-stub    #x9)
243    
244    ;;; Support for loading multi-arch ("fat") shared libraries.
245    (alien:def-alien-type fat-header
246      (alien:struct nil
247        (magic       (alien:unsigned 32))
248        (nfat-arch   (alien:unsigned 32))))
249    
250    (alien:def-alien-type fat-arch
251      (alien:struct nil
252        (cputype     (alien:signed 32))
253        (cpusubtype  (alien:signed 32))
254        (offset      (alien:unsigned 32))
255        (size        (alien:unsigned 32))
256        (align       (alien:unsigned 32))))
257    
258    (defconstant fat-header-magic #xcafebabe)
259    
260  (defun mach-o-p (h)  (defun mach-o-p (h)
261    "Make sure the header starts with the mach-o magic value."    "Make sure the header starts with the mach-o magic value."
262    (eql (alien:slot h 'magic) mh-magic))    (eql (alien:slot h 'magic) mh-magic))
263    
264    ;;; Read an unsigned 32-bit big-endian number from STREAM.
265    (defun read-u32-be (stream)
266      (let ((n 0))
267        (setf (ldb (byte 8 24) n) (read-byte stream))
268        (setf (ldb (byte 8 16) n) (read-byte stream))
269        (setf (ldb (byte 8 8)  n) (read-byte stream))
270        (setf (ldb (byte 8 0)  n) (read-byte stream))
271        n))
272    
273    ;;; Read the 32-bit magic number from STREAM then rewind it.
274    (defun read-object-file-magic (stream)
275      (let ((pos (file-position stream)))
276        (prog1
277            (read-u32-be stream)
278          (file-position stream pos))))
279    
280    ;;; XXX For a Darwin/x86 port, these functions will need to swap the
281    ;;; byte order of the structure members. Apple's documentation states
282    ;;; that all the fields of FAT-HEADER and FAT-ARCH are big-endian.
283    (defun read-mach-header (stream sap)
284      (unix:unix-read (lisp::fd-stream-fd stream) sap
285                      (alien:alien-size machheader :bytes)))
286    
287    (defun read-fat-header (stream sap)
288      (unix:unix-read (lisp::fd-stream-fd stream) sap
289                      (alien:alien-size fat-header :bytes)))
290    
291    (defun read-fat-arch (stream sap)
292      (unix:unix-read (lisp::fd-stream-fd stream) sap
293                      (alien:alien-size fat-arch :bytes)))
294    
295    ;;; Return a list of offsets in STREAM which contain Mach-O headers.
296    ;;; For single-architecture binaries, this will return (0), emulating
297    ;;; the previous behavior of loading the header from the start of the
298    ;;; file.  For fat binaries, there will be one offset in the result
299    ;;; list for each architecture present in the file.
300    (defun read-mach-header-offsets (stream)
301      (let ((magic (read-object-file-magic stream)))
302        (cond ((eql magic mh-magic)
303               (list 0))
304              ((eql magic fat-header-magic)
305               (alien:with-alien ((fat-header fat-header)
306                                  (fat-arch fat-arch))
307                 (read-fat-header stream (alien:alien-sap fat-header))
308                 (loop
309                    for i from 0 below (alien:slot fat-header 'nfat-arch)
310                    do (read-fat-arch stream (alien:alien-sap fat-arch))
311                    collect (alien:slot fat-arch 'offset))))
312              (t nil))))
313    
314    ;;; Return true if the Mach-O HEADER represents a shared library.
315    (defun shared-mach-header-p (header)
316      (and (eql (alien:slot header 'magic) mh-magic)
317           (or (eql (alien:slot header 'filetype) mh-dylib)
318               (eql (alien:slot header 'filetype) mh-bundle))))
319    
320  (defun file-shared-library-p (pathname)  (defun file-shared-library-p (pathname)
321    (with-open-file (obj pathname    (with-open-file (obj pathname
322                         :direction :input                         :direction :input
323                         :element-type '(unsigned-byte 8))                         :element-type '(unsigned-byte 8))
324      (let ((fd (lisp::fd-stream-fd obj)))      (let ((offsets (read-mach-header-offsets obj)))
325        (alien:with-alien ((header machheader))        (when offsets
326          (unix:unix-read fd (alien:alien-sap header)          (alien:with-alien ((header machheader))
327                          (alien:alien-size machheader :bytes))            (loop
328          (when (mach-o-p header)               for offset in offsets
329            (or (eql mh-dylib (alien:slot header 'filetype))               do (file-position obj offset)
330                (eql mh-bundle (alien:slot header 'filetype))))))))                  (read-mach-header obj (alien:alien-sap header))
331                 thereis (shared-mach-header-p header)))))))
332  ) ; #+darwin  ) ; #+darwin
333    
334    
# Line 659  to skip undefined symbols which don't ha Line 732  to skip undefined symbols which don't ha
732    (ensure-lisp-table-opened)    (ensure-lisp-table-opened)
733    ; rtld global: so it can find all the symbols previously loaded    ; rtld global: so it can find all the symbols previously loaded
734    ; rtld now: that way dlopen will fail if not all symbols are defined.    ; rtld now: that way dlopen will fail if not all symbols are defined.
735    (let* ((filename (namestring file ))    (let* ((filename (namestring (if (lisp::logical-pathname-p (pathname file))
736                                       (translate-logical-pathname file)
737                                       file)))
738           (sap (dlopen filename (logior rtld-now rtld-global))))           (sap (dlopen filename (logior rtld-now rtld-global))))
739      (cond ((zerop (sap-int sap))      (cond ((zerop (sap-int sap))
740             (let ((err-string (dlerror))             (let ((err-string (dlerror))

Legend:
Removed from v.1.50  
changed lines
  Added in v.1.50.2.1

  ViewVC Help
Powered by ViewVC 1.1.5