0.8.13.78: Birds of Feather

            * Fix dladdr bogosities: test if dladdr is supported on
               the platform, and add an ldso_stub for it if so. This
               so that SBCL isn't dependant on the dladdr being at the
               same location at runtime as it was on the build-host.
               Move the dummy definition for FOREIGN-SYMBOL-IN-ADDRESS
               to target-load, so that backtraces on target will work
               before foreign.lisp is built. Clean up the real F-S-I-A
               definition to use the :os-provides-dladdr feature.
            * Fix manual bogosities: generate functions signalling
               UNSUPPORTED-OPERATOR-ERROR for SB-BSD-SOCKETS
               platform-dependant sockopts on platforms where they're
               not supported; make these functions have the normal
               doctrings. This so that manual building will work on
               non-Linux as well. Also clean up the .sbclrc examples
               slightly.

contrib/sb-bsd-sockets/defpackage.lisp

@@ -3,7 +3,6 @@
   (:shadow close listen)
   #+cmu (:shadowing-import-from "CL" with-array-data)
   #+sbcl (:shadowing-import-from "SB-KERNEL" with-array-data)
-
   #+cmu (:use "COMMON-LISP" "ALIEN" "SYSTEM" "EXT" "C-CALL")
   #+sbcl (:use "COMMON-LISP" "SB-ALIEN" #+nil "SB-SYSTEM" "SB-EXT" "SB-C-CALL"))
 
@@ -64,6 +63,7 @@
            non-blocking-mode
            )
   (:use "COMMON-LISP" "SB-BSD-SOCKETS-INTERNAL")
+  (:import-from "SB-INT" "UNSUPPORTED-OPERATOR" "FEATUREP")
   (:documentation
    "
 

contrib/sb-bsd-sockets/sockopt.lisp

@@ -37,45 +37,52 @@ Code for options that not every system has should be conditionalised:
 
 (defmacro define-socket-option
     (lisp-name documentation
-     level number buffer-type mangle-arg mangle-return mangle-setf-buffer)
+     level number buffer-type mangle-arg mangle-return mangle-setf-buffer
+     &optional features info)
   (let ((find-level
 	 (if (numberp (eval level))
 	     level
-	     `(get-protocol-by-name ,(string-downcase (symbol-name level))))))
+	     `(get-protocol-by-name ,(string-downcase (symbol-name level)))))
+	(supportedp (or (null features) (featurep features))))
     `(progn
       (export ',lisp-name)
-      (defun ,lisp-name (socket &aux (fd (socket-file-descriptor socket)))
-	,@(when documentation (list documentation))
-	(sb-alien:with-alien ((size sb-alien:integer)
-			      (buffer ,buffer-type))
-	  (setf size (sb-alien:alien-size ,buffer-type :bytes))
-	  (if (= -1 (sockint::getsockopt fd ,find-level ,number
-					 (sb-alien:addr buffer)
-					 (sb-alien:addr size)))
-	      (socket-error "getsockopt")
-	      (,mangle-return buffer size))))
-      (defun (setf ,lisp-name) (new-val socket
-				&aux (fd (socket-file-descriptor socket)))
-	(sb-alien:with-alien ((buffer ,buffer-type))
-	  (setf buffer ,(if mangle-arg
-			    `(,mangle-arg new-val)
-			    `new-val))
-	  (when (= -1 (sockint::setsockopt fd ,find-level ,number
-					   (,mangle-setf-buffer buffer)
-					   ,(if (eql buffer-type 'sb-alien:c-string)
-						`(length new-val)
-						`(sb-alien:alien-size ,buffer-type :bytes))))
-	    (socket-error "setsockopt")))))))
+      (defun ,lisp-name (socket)
+	,@(when documentation (list (concatenate 'string documentation " " info)))
+	,(if supportedp
+	     `(sb-alien:with-alien ((size sb-alien:integer)
+				      (buffer ,buffer-type))
+		  (setf size (sb-alien:alien-size ,buffer-type :bytes))
+		  (if (= -1 (sockint::getsockopt (socket-file-descriptor socket)
+						 ,find-level ,number
+						 (sb-alien:addr buffer)
+						 (sb-alien:addr size)))
+		      (socket-error "getsockopt")
+		      (,mangle-return buffer size)))
+	     `(error 'unsupported-operator :name ',lisp-name)))
+      (defun (setf ,lisp-name) (new-val socket)
+	,(if supportedp
+	     `(sb-alien:with-alien ((buffer ,buffer-type))
+		  (setf buffer ,(if mangle-arg
+				    `(,mangle-arg new-val)
+				    `new-val))
+		  (when (= -1 (sockint::setsockopt (socket-file-descriptor socket)
+						   ,find-level ,number
+						   (,mangle-setf-buffer buffer)
+						   ,(if (eql buffer-type 'sb-alien:c-string)
+							`(length new-val)
+							`(sb-alien:alien-size ,buffer-type :bytes))))
+		    (socket-error "setsockopt")))
+	     `(error 'unsupported-operator :name `(setf ,lisp-name)))))))
 
 ;;; sockopts that have integer arguments
 
 (defun foreign-int-to-integer (buffer size)
   (assert (= size (sb-alien:alien-size sb-alien:integer :bytes)))
   buffer)
 
-(defmacro define-socket-option-int (name level number)
+(defmacro define-socket-option-int (name level number &optional features (info ""))
   `(define-socket-option ,name nil ,level ,number
-     sb-alien:integer nil foreign-int-to-integer sb-alien:addr))
+     sb-alien:integer nil foreign-int-to-integer sb-alien:addr ,features ,info))
 
 (define-socket-option-int
   sockopt-receive-low-water sockint::sol-socket sockint::so-rcvlowat)
@@ -87,8 +94,9 @@ Code for options that not every system has should be conditionalised:
   sockopt-send-buffer sockint::sol-socket sockint::so-sndbuf)
 (define-socket-option-int
   sockopt-receive-buffer sockint::sol-socket sockint::so-rcvbuf)
-#+linux(define-socket-option-int
-  sockopt-priority sockint::sol-socket sockint::so-priority)
+(define-socket-option-int
+  sockopt-priority sockint::sol-socket sockint::so-priority :linux
+  "Available only on Linux.")
 
 ;;; boolean options are integers really
 
@@ -100,22 +108,27 @@ Code for options that not every system has should be conditionalised:
 (defun bool-to-foreign-int (val)
   (if val 1 0))
 
-(defmacro define-socket-option-bool (name level c-name)
+(defmacro define-socket-option-bool (name level c-name &optional features (info ""))
   `(define-socket-option ,name
-    ,(format nil "Return the value of the ~A socket option for SOCKET.  This can also be updated with SETF." (symbol-name c-name))
+    ,(format nil "~@<Return the value of the ~A socket option for SOCKET. ~
+                 This can also be updated with SETF.~:@>"
+	     (symbol-name c-name))
     ,level ,c-name
-     sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr))
+    sb-alien:integer bool-to-foreign-int foreign-int-to-bool sb-alien:addr
+    ,features ,info))
 
 (define-socket-option-bool
   sockopt-reuse-address sockint::sol-socket sockint::so-reuseaddr)
 (define-socket-option-bool
   sockopt-keep-alive sockint::sol-socket sockint::so-keepalive)
 (define-socket-option-bool
   sockopt-oob-inline sockint::sol-socket sockint::so-oobinline)
-#+linux(define-socket-option-bool
-  sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat)
-#+linux(define-socket-option-bool
-  sockopt-pass-credentials sockint::sol-socket sockint::so-passcred)
+(define-socket-option-bool
+  sockopt-bsd-compatible sockint::sol-socket sockint::so-bsdcompat :linux
+  "Available only on Linux.")
+(define-socket-option-bool
+  sockopt-pass-credentials sockint::sol-socket sockint::so-passcred :linux
+  "Available only on Linux.")
 (define-socket-option-bool
   sockopt-debug sockint::sol-socket sockint::so-debug)
 (define-socket-option-bool
@@ -129,8 +142,9 @@ Code for options that not every system has should be conditionalised:
   (declare (ignore args))
   x)
 
-#+linux(define-socket-option sockopt-bind-to-device nil sockint::sol-socket
-  sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity)
+(define-socket-option sockopt-bind-to-device nil sockint::sol-socket
+  sockint::so-bindtodevice sb-alien:c-string identity identity-1 identity
+  :linux "Available only on Linux")
 
 ;;; other kinds of socket option
 

doc/manual/start-stop.texinfo

@@ -301,20 +301,20 @@ initialization file does the trick:
 @lisp
 ;;; If the first user-processable command-line argument is a filename,
 ;;; disable the debugger, load the file handling shebang-line and quit.
-(let ((script (and (second sb-ext:*posix-argv*)
-                   (probe-file (second sb-ext:*posix-argv*)))))
+(let ((script (and (second *posix-argv*) (probe-file (second *posix-argv*)))))
   (when script
-    ;; Handle the possible shebang-line
+    ;; Handle shebang-line
     (set-dispatch-macro-character #\# #\!
 				  (lambda (stream char arg)
 				    (declare (ignore char arg))
 				    (read-line stream)))
     ;; Disable debugger
-    (setf sb-ext:*invoke-debugger-hook* 
-          (lambda (condition hook)
-            (declare (ignore hook))
-            (format *error-output* "Error: ~A~%" condition)
-            (quit :unix-status 1)))
+    (setf *invoke-debugger-hook* (lambda (condition hook)
+				   (declare (ignore hook))
+                                   ;; Uncomment to get backtraces on errors
+				   ;; (sb-debug:backtrace 20)
+				   (format *error-output* "Error: ~A~%" condition)
+				   (quit)))
     (load script)
     (quit)))
 @end lisp
@@ -364,7 +364,8 @@ handles recompilation automatically for ASDF-based systems.
 ;;; If a fasl was stale, try to recompile and load (once). 
 (defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
   (handler-case (call-next-method o c)
-    (sb-ext:invalid-fasl error ()
-     (asdf:perform (make-instance 'asdf:compile-op) c)
-     (call-next-method))))
+    ;; If a fasl was stale, try to recompile and load (once).
+    (sb-ext:invalid-fasl ()
+      (asdf:perform (make-instance 'asdf:compile-op) c)
+      (call-next-method))))
 @end lisp

make-config.sh

@@ -201,6 +201,8 @@ else
     echo > /dev/null
 fi
 
+sh tools-for-build/grovel-features.sh >> $ltf
+
 echo //finishing $ltf
 echo ')' >> $ltf
 

src/code/foreign.lisp

@@ -26,10 +26,10 @@
 ;;; It also works on OpenBSD, which isn't ELF, but is otherwise modern
 ;;; enough to have a fairly well working dlopen/dlsym implementation.
 (macrolet ((define-unsupported-fun (fun-name &optional (error-message "unsupported on this system"))
-	     `(defun ,fun-name (&rest rest)
-		,error-message
-                (declare (ignore rest))
-		(error 'unsupported-operator :name ',fun-name))))
+	       `(defun ,fun-name (&rest rest)
+		 ,error-message
+		 (declare (ignore rest))
+		 (error 'unsupported-operator :name ',fun-name))))
   #-(or linux sunos FreeBSD OpenBSD NetBSD darwin)
   (define-unsupported-fun load-shared-object)
   #+(or linux sunos FreeBSD OpenBSD NetBSD darwin)
@@ -136,32 +136,26 @@
 	  (unless (zerop possible-result)
 	    (return possible-result)))))
 
+    #+os-provides-dladdr
+    ;;; Override the early definition in target-load.lisp
     (defun foreign-symbol-in-address (sap)
-      (declare (ignore sap)))
-
-    (when (ignore-errors (foreign-symbol-address "dladdr"))
-      (setf (symbol-function 'foreign-symbol-in-address)
-	    ;; KLUDGE: This COMPILE trick is to avoid trying to
-	    ;; compile a reference to dladdr on platforms without it.
-	    (compile nil
-	     '(lambda (sap)
-	       (let ((addr (sap-int sap)))
-		 (with-alien ((info
-			       (struct dl-info
-				       (filename c-string)
-				       (base unsigned)
-				       (symbol c-string)
-				       (symbol-address unsigned)))
-			      (dladdr
-			       (function unsigned
-					 unsigned (* (struct dl-info)))
-			       :extern "dladdr"))
-		   (let ((err (alien-funcall dladdr addr (addr info))))
-		     (if (zerop err)
-			 nil
-			 (values (slot info 'symbol)
-				 (slot info 'filename)
-				 addr
-				 (- addr (slot info 'symbol-address)))))))))))
+      (let ((addr (sap-int sap)))
+	(with-alien ((info
+		      (struct dl-info
+			      (filename c-string)
+			      (base unsigned)
+			      (symbol c-string)
+			      (symbol-address unsigned)))
+		     (dladdr
+		      (function unsigned
+				unsigned (* (struct dl-info)))
+		      :extern "dladdr"))
+	  (let ((err (alien-funcall dladdr addr (addr info))))
+	    (if (zerop err)
+		nil
+		(values (slot info 'symbol)
+			(slot info 'filename)
+			addr
+			(- addr (slot info 'symbol-address))))))))
 
     ))					; PROGN, MACROLET

src/code/target-load.lisp

@@ -309,3 +309,7 @@
 (defun foreign-symbol-address (symbol)
   (int-sap (foreign-symbol-address-as-integer
 	    (sb!vm:extern-alien-name symbol))))
+
+;;; Overridden in foreign.lisp once we're running on target
+(defun foreign-symbol-in-address (sap)
+  (declare (ignore sap)))

tools-for-build/grovel-features.sh

@@ -0,0 +1,25 @@
+# Automated platform feature testing 
+
+DIR=tools-for-build
+
+# FIXME: Use this to test for dlopen presence and hence
+# load-shared-object buildability
+
+# $1 feature
+# $2 additional flags
+#
+# Assumes the presence of $1-test.c, which when built and
+# run should return with 104 if the feature is present.
+#
+featurep() {
+    bin="$DIR/$1-test"
+    rm -f $bin
+    cc $DIR/$1-test.c $2 -o $bin 2>&1 > /dev/null && $bin 2>&1 /dev/null
+    if [ "$?" = 104 ]
+    then
+	printf " :$1"
+    fi
+    rm -f $bin
+}
+
+featurep os-provides-dladdr -ldl

tools-for-build/ldso-stubs.lisp

@@ -258,6 +258,8 @@ ldso_stub__ ## fct: ;                           \\
                    "dlerror"
                    "dlopen"
                    "dlsym")
+		 #!+os-provides-dladdr 
+		 '("dladdr")
                  #!-(and sparc sunos) ;; !defined(SVR4)
                  '("sigsetmask")))
 

tools-for-build/os-provides-dladdr-test.c

@@ -0,0 +1,20 @@
+/* test to build and run so that we know if we have dladdr 
+ */
+
+/* bloody FSF dlcfn.h won't give us dladdr without this */
+#define _GNU_SOURCE
+
+#include <dlfcn.h>
+
+int main ()
+{
+   void * handle = dlopen((void*)0, RTLD_GLOBAL | RTLD_NOW);
+   void * addr = dlsym(handle, "printf");
+   Dl_info * info = (Dl_info*) malloc(sizeof(Dl_info));
+   dladdr(addr, info);
+   if (strcmp(info->dli_sname, "printf")) {
+       return 1;
+   } else {
+       return 104;
+   }
+}

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.13.77"
+"0.8.13.78"