source: release/1.9/source/library/mach-o.lisp @ 15706

Last change on this file since 15706 was 13067, checked in by rme, 10 years ago

Update copyright notices.

File size: 5.7 KB
Line 
1;;; Copyright 2009 Clozure Associates
2;;; This file is part of Clozure CL. 
3;;;
4;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU
5;;; Public License , known as the LLGPL and distributed with Clozure
6;;; CL as the file "LICENSE".  The LLGPL consists of a preamble and
7;;; the LGPL, which is distributed with Clozure CL as the file "LGPL".
8;;; Where these conflict, the preamble takes precedence.
9;;;
10;;; Clozure CL is referenced in the preamble as the "LIBRARY."
11;;;
12;;; The LLGPL is also available online at
13;;; http://opensource.franz.com/preamble.html
14
15(defstruct mach-o-file
16  header
17  load-commands
18  segments
19  symbols
20  strings)
21
22(defmethod print-object ((m mach-o-file) stream)
23  (print-unreadable-object (m stream :type t :identity t)))
24
25
26(defstruct mach-o-string-table
27  (hash (make-hash-table :test #'equal))
28  (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t)))
29
30(defstruct mach-o-symbol
31  string-index
32  type
33  sect
34  desc
35  value)
36
37(defun init-mach-o-string-table (fd symtab-command)
38  (fd-lseek fd (pref symtab-command #>symtab_command.stroff) #$SEEK_SET)
39  (let* ((strsize (pref symtab-command #>symtab_command.strsize))
40         (nbytes (+ strsize strsize))
41         (bytes (make-array nbytes :element-type '(unsigned-byte 8)))
42         (out 0))
43    (declare (fixnum nbytes strsize out))
44    (%stack-block ((buf 32768))
45      (do* ((n strsize))
46           ((= n 0))
47        (let* ((bufsize (fd-read fd buf (min n 32768))))
48          (%copy-ptr-to-ivector buf 0 bytes out bufsize)
49          (incf out bufsize)
50          (decf n bufsize))))
51    (make-mach-o-string-table
52     :string (make-array nbytes
53                         :element-type '(unsigned-byte 8)
54                         :displaced-to bytes
55                         :fill-pointer strsize
56                         :adjustable t))))
57
58(defun init-mach-o-symbols64 (fd symtab-command)
59  (fd-lseek fd (pref symtab-command #>symtab_command.symoff) #$SEEK_SET)
60  (rlet ((nlist #>nlist_64))
61    (let* ((nsyms (pref symtab-command #>symtab_command.nsyms))
62           (nentries (* nsyms 2))
63           (vec (make-array nentries)))
64      (declare (fixnum nsyms nentries))
65      (flet ((read-nlist ()
66               (fd-read fd nlist (record-length #>nlist_64))
67               (make-mach-o-symbol :string-index (pref nlist #>nlist_64.n_un.n_strx)
68                                   :type (pref nlist #>nlist_64.n_type)
69                                   :sect (pref nlist #>nlist_64.n_sect)
70                                   :desc (pref nlist #>nlist_64.n_desc)
71                                   :value (pref nlist #>nlist_64.n_value))))
72        (dotimes (i nsyms (make-array nentries
73                                      :displaced-to vec
74                                      :fill-pointer nsyms
75                                      :adjustable t))
76          (setf (svref vec i) (read-nlist)))))))
77   
78
79(defun read-header-and-load-commands64 (fd)
80  (fd-lseek fd 0 #$SEEK_SET)
81  (let* ((mh (make-record :mach_header_64))
82         (mach-o (make-mach-o-file :header mh)))
83    (when (= (fd-read fd mh (record-length :mach_header_64))
84             (record-length :mach_header_64))
85      (collect ((commands))
86        (flet ((read-command ()
87                 (rlet ((cmd :load_command))
88                   (fd-read fd cmd (record-length :load_command))
89                   (let* ((n (pref cmd :load_command.cmdsize))
90                          (p (#_malloc n))
91                          (q (%inc-ptr p (record-length :load_command))))
92                     (#_memcpy p cmd (record-length :load_command))
93                     (fd-read fd q (- n (record-length :load_command)))
94                     (let* ((lcmd (pref cmd :load_command.cmd))
95                            (ftype 
96                             (cond ((= lcmd #$LC_SEGMENT_64)
97                                    (load-record #>segment_command_64))
98                                   ((= lcmd #$LC_SYMTAB)
99                                    (load-record #>symtab_command))
100                                   ((= lcmd #$LC_DYSYMTAB)
101                                    (load-record #>dysymtab_command))
102                                   ((= lcmd #$LC_LOAD_DYLINKER)
103                                    (load-record #>dylinker_command))
104                                   ((= lcmd #$LC_UUID)
105                                    (load-record #>uuid_command))
106                                   ((= lcmd #$LC_LOAD_DYLIB)
107                                    (load-record #>dylib_command))
108                                   ((= lcmd #$LC_UNIXTHREAD)
109                                    (load-record #>thread_command)))))
110
111                       (if ftype
112                         (%set-macptr-type p (foreign-record-type-ordinal ftype))
113                         (format t "~&~x" lcmd)))
114                     p))))
115          (dotimes (i (pref mh :mach_header_64.ncmds))
116            (commands (read-command)))
117          (setf (mach-o-file-load-commands mach-o) (commands))
118          (dolist (cmd (mach-o-file-load-commands mach-o))
119            (when (= #$LC_SYMTAB (pref cmd #>load_command.cmd))
120              (setf (mach-o-file-strings mach-o)
121                    (init-mach-o-string-table fd cmd)
122                    (mach-o-file-symbols mach-o)
123                    (init-mach-o-symbols64 fd cmd))))
124          mach-o)))))
125
126(defun mach-o-string-index (mo string)
127  (let* ((bytes (make-array (the fixnum (+ (length string) 2)) :element-type '(unsigned-byte 8))))
128    (declare (dynamic-extent bytes))
129    (dotimes (i (length string))
130      (setf (aref bytes (1+ i)) (char-code (char string i))))
131    (let* ((pos (search bytes (mach-o-string-table-string (mach-o-file-strings mo)))))
132      (when pos (1+ pos)))))
133             
Note: See TracBrowser for help on using the repository browser.