/[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.7 by ram, Fri Aug 30 17:23:40 1991 UTC revision 1.7.1.1 by wlott, Fri Jan 24 05:13:25 1992 UTC
# Line 24  Line 24 
24  (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))  (defun pick-temporary-file-name (&optional (base "/tmp/tmp~D~C"))
25    (let ((code (char-code #\A)))    (let ((code (char-code #\A)))
26      (loop      (loop
27        (let ((name (format nil base (mach:unix-getpid) (code-char code))))        (let ((name (format nil base (unix:unix-getpid) (code-char code))))
28          (multiple-value-bind          (multiple-value-bind
29              (fd errno)              (fd errno)
30              (mach:unix-open name              (unix:unix-open name
31                              (logior mach:o_wronly mach:o_creat mach:o_excl)                              (logior unix:o_wronly unix:o_creat unix:o_excl)
32                              #o666)                              #o666)
33            (cond ((not (null fd))            (cond ((not (null fd))
34                   (mach:unix-close fd)                   (unix:unix-close fd)
35                   (return name))                   (return name))
36                  ((not (= errno mach:eexist))                  ((not (= errno unix:eexist))
37                   (error "Could not create temporary file ~S: ~A"                   (error "Could not create temporary file ~S: ~A"
38                          name (mach:get-unix-error-msg errno)))                          name (unix:get-unix-error-msg errno)))
39    
40                  ((= code (char-code #\Z))                  ((= code (char-code #\Z))
41                   (setf code (char-code #\a)))                   (setf code (char-code #\a)))
# Line 45  Line 45 
45                   (incf code))))))))                   (incf code))))))))
46    
47  #+sparc  #+sparc
48  (ext:def-c-record exec  (alien:def-alien-type exec
49    (magic ext:unsigned-long)    (alien:struct nil
50    (text ext:unsigned-long)      (magic c-call:unsigned-long)
51    (data ext:unsigned-long)      (text c-call:unsigned-long)
52    (bss ext:unsigned-long)      (data c-call:unsigned-long)
53    (syms ext:unsigned-long)      (bss c-call:unsigned-long)
54    (entry ext:unsigned-long)      (syms c-call:unsigned-long)
55    (trsize ext:unsigned-long)      (entry c-call:unsigned-long)
56    (drsize ext:unsigned-long))      (trsize c-call:unsigned-long)
57        (drsize c-call:unsigned-long)))
58    
59  (defun allocate-space-in-foreign-segment (bytes)  (defun allocate-space-in-foreign-segment (bytes)
60    (let* ((pagesize-1 (1- (get-page-size)))    (let* ((pagesize-1 (1- (get-page-size)))
# Line 69  Line 70 
70  #+sparc  #+sparc
71  (defun load-object-file (name)  (defun load-object-file (name)
72    (format t ";;; Loading object file...~%")    (format t ";;; Loading object file...~%")
73    (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
74      (unless fd      (unless fd
75        (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))        (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
76      (unwind-protect      (unwind-protect
77          (with-stack-alien (header exec #.(ext:c-sizeof 'exec))          (alien:with-alien ((header exec))
78            (mach:unix-read fd            (unix:unix-read fd
79                            (alien-sap (alien-value header))                            (alien:alien-sap header)
80                            (truncate (alien-size (alien-value header))                            (alien:alien-size exec :bytes))
                                     (bytes 1)))  
81            (let* ((len-of-text-and-data            (let* ((len-of-text-and-data
82                    (+ (alien-access (exec-text (alien-value header)))                    (+ (alien:slot header 'text) (alien:slot header 'data)))
                      (alien-access (exec-data (alien-value header)))))  
83                   (memory-needed                   (memory-needed
84                    (+ len-of-text-and-data                    (+ len-of-text-and-data (alien:slot header 'bss)))
                      (alien-access (exec-bss (alien-value header)))))  
85                   (addr (allocate-space-in-foreign-segment memory-needed)))                   (addr (allocate-space-in-foreign-segment memory-needed)))
86              (mach:unix-read fd addr len-of-text-and-data)))              (unix:unix-read fd addr len-of-text-and-data)))
87        (mach:unix-close fd))))        (unix:unix-close fd))))
88    
89  #+pmax  #+pmax
90  (ext:def-c-record filehdr  (alien:def-alien-type filehdr
91    (magic ext:unsigned-short)    (alien:struct nil
92    (nscns ext:unsigned-short)      (magic c-call:unsigned-short)
93    (timdat ext:long)      (nscns c-call:unsigned-short)
94    (symptr ext:long)      (timdat c-call:long)
95    (nsyms ext:long)      (symptr c-call:long)
96    (opthdr ext:unsigned-short)      (nsyms c-call:long)
97    (flags ext:unsigned-short))      (opthdr c-call:unsigned-short)
98        (flags c-call:unsigned-short)))
99  #+pmax  
100  (ext:def-c-record aouthdr  #+pmax
101    (magic ext:short)  (alien:def-alien-type aouthdr
102    (vstamp ext:short)    (alien:struct nil
103    (tsize ext:long)      (magic c-call:short)
104    (dsize ext:long)      (vstamp c-call:short)
105    (bsize ext:long)      (tsize c-call:long)
106    (entry ext:long)      (dsize c-call:long)
107    (text_start ext:long)      (bsize c-call:long)
108    (data_start ext:long))      (entry c-call:long)
109        (text_start c-call:long)
110        (data_start c-call:long)))
111    
112  #+pmax  #+pmax
113  (defconstant filhsz 20)  (defconstant filhsz 20)
# Line 119  Line 119 
119  #+pmax  #+pmax
120  (defun load-object-file (name)  (defun load-object-file (name)
121    (format t ";;; Loading object file...~%")    (format t ";;; Loading object file...~%")
122    (multiple-value-bind (fd errno) (mach:unix-open name mach:o_rdonly 0)    (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
123      (unless fd      (unless fd
124        (error "Could not open ~S: ~A" name (mach:get-unix-error-msg errno)))        (error "Could not open ~S: ~A" name (unix:get-unix-error-msg errno)))
125      (unwind-protect      (unwind-protect
126          (with-stack-alien (filehdr filehdr #.(ext:c-sizeof 'filehdr))          (alien:with-alien ((filehdr filehdr)
127            (with-stack-alien (aouthdr aouthdr #.(ext:c-sizeof 'aouthdr))                             (aouthdr aouthdr))
128              (mach:unix-read fd            (unix:unix-read fd
129                              (alien-sap (alien-value filehdr))                            (alien:alien-sap filehdr)
130                              (truncate (alien-size (alien-value filehdr))                            (alien:alien-size filehdr :bytes))
131                                        (bytes 1)))            (unix:unix-read fd
132              (mach:unix-read fd                            (alien:alien-sap aouthdr)
133                              (alien-sap (alien-value aouthdr))                            (alien:alien-size aouthdr :bytes))
134                              (truncate (alien-size (alien-value aouthdr))            (let* ((len-of-text-and-data
135                                        (bytes 1)))                    (+ (alien:slot aouthdr 'tsize) (alien:slot aouthdr 'dsize)))
136              (let* ((len-of-text-and-data                   (memory-needed
137                      (+ (alien-access (aouthdr-tsize (alien-value aouthdr)))                    (+ len-of-text-and-data (alien:slot aouthdr 'bsize)))
138                         (alien-access (aouthdr-dsize (alien-value aouthdr)))))                   (addr (allocate-space-in-foreign-segment memory-needed))
139                     (memory-needed                   (pad-size-1 (if (< (alien:slot aouthdr 'vstamp) 23) 7 15)))
140                      (+ len-of-text-and-data              (unix:unix-lseek fd
141                         (alien-access (aouthdr-bsize (alien-value aouthdr)))))                               (logandc2 (+ filhsz aouthsz
142                     (addr (allocate-space-in-foreign-segment memory-needed))                                            (* scnhsz
143                     (pad-size-1 (if (< (alien-access                                               (alien:slot filehdr 'nscns))
144                                         (aouthdr-vstamp (alien-value aouthdr)))                                            pad-size-1)
145                                        23)                                         pad-size-1)
146                                     7 15)))                               unix:l_set)
147                (mach:unix-lseek fd              (unix:unix-read fd addr len-of-text-and-data)))
148                                 (logandc2 (+ filhsz aouthsz        (unix:unix-close fd))))
                                             (* scnhsz  
                                                (alien-access  
                                                 (filehdr-nscns  
                                                  (alien-value filehdr))))  
                                             pad-size-1)  
                                          pad-size-1)  
                                mach:l_set)  
               (mach:unix-read fd addr len-of-text-and-data))))  
       (mach:unix-close fd))))  
149    
150  (defun parse-symbol-table (name)  (defun parse-symbol-table (name)
151    (format t ";;; Parsing symbol table...~%")    (format t ";;; Parsing symbol table...~%")
# Line 219  Line 210 
210                 linker (get-output-stream-string error-output)))                 linker (get-output-stream-string error-output)))
211        (load-object-file output-file)        (load-object-file output-file)
212        (parse-symbol-table symbol-table-file)        (parse-symbol-table symbol-table-file)
213        (mach:unix-unlink symbol-table-file)        (unix:unix-unlink symbol-table-file)
214        (let ((old-file *previous-linked-object-file*))        (let ((old-file *previous-linked-object-file*))
215          (setf *previous-linked-object-file* output-file)          (setf *previous-linked-object-file* output-file)
216          (when old-file          (when old-file
217            (mach:unix-unlink old-file)))))            (unix:unix-unlink old-file)))))
218    (format t ";;; Done.~%"))    (format t ";;; Done.~%"))

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.7.1.1

  ViewVC Help
Powered by ViewVC 1.1.5