From 7205f92429c5a883df2dff472323e121b50aa5e7 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Wed, 19 Oct 1994 23:49:54 +0000
Subject: [PATCH] Merge solaris patches.

---
 code/foreign.lisp | 106 ++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 103 insertions(+), 3 deletions(-)

diff --git a/code/foreign.lisp b/code/foreign.lisp
index 92bc12143..8096a4542 100644
--- a/code/foreign.lisp
+++ b/code/foreign.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.16 1994/10/01 00:38:19 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.17 1994/10/19 23:49:54 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -53,7 +53,7 @@
 		(t
 		 (incf code))))))))
 
-#+sparc
+#+(and sparc (not svr4))
 (alien:def-alien-type exec
   (alien:struct nil
     (magic c-call:unsigned-long)
@@ -65,6 +65,7 @@
     (trsize c-call:unsigned-long)
     (drsize c-call:unsigned-long)))
 
+#-svr4
 (defun allocate-space-in-foreign-segment (bytes)
   (let* ((pagesize-1 (1- (get-page-size)))
 	 (memory-needed (logandc2 (+ bytes pagesize-1) pagesize-1))
@@ -76,7 +77,7 @@
     (allocate-system-memory-at addr memory-needed)
     addr))
 
-#+sparc
+#+(and sparc (not svr4))
 (defun load-object-file (name)
   (format t ";;; Loading object file...~%")
   (multiple-value-bind (fd errno) (unix:unix-open name unix:o_rdonly 0)
@@ -271,6 +272,7 @@
             ))
       (unix:unix-close fd))))
 
+#-solaris
 (defun parse-symbol-table (name)
   (format t ";;; Parsing symbol table...~%")
   (let ((symbol-table (make-hash-table :test #'equal)))
@@ -288,6 +290,7 @@
 	    (setf (gethash symbol symbol-table) address)))))
     (setf lisp::*foreign-symbols* symbol-table)))
 
+#-solaris
 (defun load-foreign (files &key
 			   (libraries '("-lc"))
 			   (base-file
@@ -341,3 +344,100 @@
 	(when old-file
 	  (unix:unix-unlink old-file)))))
   (format t ";;; Done.~%"))
+
+
+(export '(alternate-get-global-address))
+
+#-solaris
+(defun alternate-get-global-address (symbol) 0)
+
+#+solaris
+(progn
+
+(defconstant rtld-lazy 1)
+(defconstant rtld-now 2)
+(defconstant rtld-global #o400)
+(defvar *global-table* NIL)
+
+(alien:def-alien-routine dlopen system-area-pointer
+  (str c-call:c-string) (i c-call:int))
+(alien:def-alien-routine dlsym system-area-pointer
+  (lib system-area-pointer)
+  (str c-call:c-string))
+(alien:def-alien-routine dlclose void (lib system-area-pointer))
+(alien:def-alien-routine dlerror c-call:c-string)
+
+(defun load-object-file (file)
+  ; rtld global: so it can find all the symbols previously loaded
+  ; rtld now: that way dlopen will fail if not all symbols are defined.
+  (let ((sap (dlopen file (logior rtld-now rtld-global))))
+       (if (zerop (sap-int sap))
+	   (error "Can't open object ~S: ~S" file (dlerror))
+	   (pushnew sap *global-table*))))
+
+(defun alternate-get-global-address (symbol)
+  (unless *global-table*
+	  ;; Prevent recursive call when dlopen isn't defined.
+	  (setq *global-table* (int-sap 0))
+	  ;; Load standard object
+	  (setq *global-table* (list (dlopen nil rtld-lazy)))
+	  (if (zerop (system:sap-int (car *global-table*)))
+	      (error "Can't open global symbol table: ~S" (dlerror))))
+  ;; find the symbol in any of the loaded obbjects,
+  ;; search in reverse order of loading, later loadings
+  ;; take precedence
+  (let ((result 0))
+       (do ((table *global-table* (cdr table)))
+	   ((or (null (car table)) (not (zerop result))))
+	   (setq result (sap-int (dlsym (car table) symbol))))
+       (values result)))
+
+(defun load-foreign (files &key
+			   (libraries '("-lc"))
+			   (base-file nil)
+			   (env ext:*environment-list*))
+  "Load-foreign loads a list of C object files into a running Lisp.  The files
+  argument should be a single file or a list of files.  The files may be
+  specified as namestrings or as pathnames.  The libraries argument should be a
+  list of library files as would be specified to ld.  They will be searched in
+  the order given.  The default is just \"-lc\", i.e., the C library.  The
+  base-file argument is used to specify a file to use as the starting place for
+  defined symbols.  The default is the C start up code for Lisp.  The env
+  argument is the Unix environment variable definitions for the invocation of
+  the linker.  The default is the environment passed to Lisp."
+  ;; Note: dlopen remembers the name of an object, when dlopenin
+  ;; the same name twice, the old objects is reused.
+  (declare (ignore base-file))
+  (let ((output-file (pick-temporary-file-name
+		      (concatenate 'string "/tmp/~D~S" (string (gensym)))))
+	(error-output (make-string-output-stream)))
+
+    (format t ";;; Running /usr/ccs/bin/ld...~%")
+    (force-output)
+    (let ((proc (ext:run-program
+		 "/usr/ccs/bin/ld"
+		 (list*
+			"-G"
+			"-o"
+			output-file
+			(append (mapcar #'(lambda (name)
+					    (unix-namestring name nil))
+					(if (atom files)
+					    (list files)
+					    files))
+				libraries))
+		 :env env
+		 :input nil
+		 :output error-output
+		 :error :output)))
+      (unless proc
+	(error "Could not run /usr/ccs/bin/ld"))
+      (unless (zerop (ext:process-exit-code proc))
+	(system:serve-all-events 0)
+	(error "/usr/ccs/bin/ld failed:~%~A"
+	       (get-output-stream-string error-output)))
+      (load-object-file output-file)
+      (unix:unix-unlink output-file)
+      ))
+  (format t ";;; Done.~%"))
+)
-- 
GitLab