/[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.23 by pw, Tue Aug 5 20:41:12 1997 UTC revision 1.24 by pw, Sat Aug 23 15:59:59 1997 UTC
# Line 241  Line 241 
241  #+hppa  #+hppa
242  (defconstant reloc-magic #x106)  (defconstant reloc-magic #x106)
243  #+hppa  #+hppa
244    (defconstant cpu-pa-risc1-0 #x20b)
245    #+hppa
246  (defconstant cpu-pa-risc1-1 #x210)  (defconstant cpu-pa-risc1-1 #x210)
247    #+hppa
248    (defconstant cpu-pa-risc-max #x2ff)
249    
250  #+hppa  #+hppa
251  (defun load-object-file (name)  (defun load-object-file (name)
# Line 284  Line 288 
288              ))              ))
289        (unix:unix-close fd))))        (unix:unix-close fd))))
290    
291  #-(or linux solaris)  #-(or linux solaris irix)
292  (defun parse-symbol-table (name)  (defun parse-symbol-table (name)
293    (format t ";;; Parsing symbol table...~%")    (format t ";;; Parsing symbol table...~%")
294    (let ((symbol-table (make-hash-table :test #'equal)))    (let ((symbol-table (make-hash-table :test #'equal)))
# Line 332  Line 336 
336      #+hpux      #+hpux
337      (dolist (f files)      (dolist (f files)
338        (with-open-file (stream f :element-type '(unsigned-byte 16))        (with-open-file (stream f :element-type '(unsigned-byte 16))
339          (unless (eql (read-byte stream) cpu-pa-risc1-1)          (unless (let ((sysid (read-byte stream)))
340                      (or (eql sysid cpu-pa-risc1-0)
341                          (and (>= sysid cpu-pa-risc1-1)
342                               (<= sysid cpu-pa-risc-max))))
343            (error "Object file is wrong format, so can't load-foreign:~            (error "Object file is wrong format, so can't load-foreign:~
344                    ~%  ~S"                    ~%  ~S"
345                   f))                   f))
# Line 375  Line 382 
382    
383  (export '(alternate-get-global-address))  (export '(alternate-get-global-address))
384    
385  #-(or freebsd solaris linux)  #-(or freebsd solaris linux irix)
386  (defun alternate-get-global-address (symbol)  (defun alternate-get-global-address (symbol)
387    (declare (type simple-string symbol)    (declare (type simple-string symbol)
388             (ignore symbol))             (ignore symbol))
389    0)    0)
390    
391  #+(or linux solaris)  #+(or linux solaris irix)
392  (progn  (progn
393    
394  (defconstant rtld-lazy 1)  (defconstant rtld-lazy 1)
395  (defconstant rtld-now 2)  (defconstant rtld-now 2)
396  (defconstant rtld-global #o400)  (defconstant rtld-global #-irix #o400 #+irix 4)
397  (defvar *global-table* NIL)  (defvar *global-table* NIL)
398    (defvar *dso-linker*
399      #+solaris "/usr/ccs/bin/ld"
400      #+(or linux irix) "/usr/bin/ld")
401    
402  (alien:def-alien-routine dlopen system-area-pointer  (alien:def-alien-routine dlopen system-area-pointer
403    (str c-call:c-string) (i c-call:int))    (str c-call:c-string) (i c-call:int))
# Line 403  Line 413 
413    (let ((sap (dlopen file (logior rtld-now rtld-global))))    (let ((sap (dlopen file (logior rtld-now rtld-global))))
414         (if (zerop (sap-int sap))         (if (zerop (sap-int sap))
415             (error "Can't open object ~S: ~S" file (dlerror))             (error "Can't open object ~S: ~S" file (dlerror))
416             (pushnew sap *global-table*))))             (pushnew sap *global-table* :test #'sap=))))
417    
418  (defun alternate-get-global-address (symbol)  (defun alternate-get-global-address (symbol)
419    (unless *global-table*    (unless *global-table*
# Line 441  Line 451 
451    (let ((output-file (pick-temporary-file-name    (let ((output-file (pick-temporary-file-name
452                        (concatenate 'string "/tmp/~D~C" (string (gensym)))))                        (concatenate 'string "/tmp/~D~C" (string (gensym)))))
453          (error-output (make-string-output-stream)))          (error-output (make-string-output-stream)))
454    
455      #-linux (format t ";;; Running /usr/ccs/bin/ld...~%")      (format t ";;; Running ~A...~%" *dso-linker*)
     #+linux (format t ";;; Running /usr/bin/ld...~%")  
456      (force-output)      (force-output)
457      (let ((proc (ext:run-program      (let ((proc (ext:run-program
458                   #-linux "/usr/ccs/bin/ld"                   *dso-linker*
                  #+linux "/usr/bin/ld"  
459                   (list*                   (list*
460                          "-G"                          #+(or solaris linux) "-G" #+irix "-shared"
461                          "-o"                          "-o"
462                          output-file                          output-file
463                          (append (mapcar #'(lambda (name)                          (append (mapcar #'(lambda (name)
# Line 463  Line 471 
471                   :output error-output                   :output error-output
472                   :error :output)))                   :error :output)))
473        (unless proc        (unless proc
474          (error  #+linux "Could not run /usr/bin/ld"         (error "Could not run ~A" *dso-linker*))
                 #-linux "Could not run /usr/ccs/bin/ld"))  
475        (unless (zerop (ext:process-exit-code proc))        (unless (zerop (ext:process-exit-code proc))
476          (system:serve-all-events 0)          (system:serve-all-events 0)
477          (error #-linux "/usr/ccs/bin/ld failed:~%~A"          (error "~A failed:~%~A" *dso-linker*
                #+linux "/usr/bin/ld failed:~%~A"  
478                 (get-output-stream-string error-output)))                 (get-output-stream-string error-output)))
479        (load-object-file output-file)        (load-object-file output-file)
480        (unix:unix-unlink output-file)        (unix:unix-unlink output-file)

Legend:
Removed from v.1.23  
changed lines
  Added in v.1.24

  ViewVC Help
Powered by ViewVC 1.1.5