Permalink
Browse files

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.
  • Loading branch information...
1 parent d1287b8 commit 4bc6b918bb99e8dcd17bbe6479a06e52b2d04a6c @nikodemus nikodemus committed Aug 25, 2004
@@ -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
"
@@ -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
@@ -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
View
@@ -201,6 +201,8 @@ else
echo > /dev/null
fi
+sh tools-for-build/grovel-features.sh >> $ltf
+
echo //finishing $ltf
echo ')' >> $ltf
View
@@ -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
@@ -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)))
@@ -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
@@ -258,6 +258,8 @@ ldso_stub__ ## fct: ; \\
"dlerror"
"dlopen"
"dlsym")
+ #!+os-provides-dladdr
+ '("dladdr")
#!-(and sparc sunos) ;; !defined(SVR4)
'("sigsetmask")))
@@ -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;
+ }
+}
View
@@ -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"

0 comments on commit 4bc6b91

Please sign in to comment.