From: Andreas Fuchs Date: Mon, 19 Jul 2004 20:46:47 +0000 (+0000) Subject: 0.8.12.40: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ecae2f9323086c64d026d4ce719590907f486c63;p=sbcl.git 0.8.12.40: Fix SB-GROVEL to make less catastrophic types Thanks to Christophe for most (in fact, all except 2) of these fixes. * Make sb-grovel's compile failures a bit clearer: There are now separate conditions for c-compile-failed, a-dot-out-failed, and the normal lisp compile/load failures. * don't use gensym for structure member names; This confused the environment horribly. * make identity-1 a macro so that its uses get optimized away. As a result, * sb-bsd-sockets::make-host-ent doesn't throw a compiler optimization note on run time any more. * sb-grovel doesn't lie about vector types on array structure fields' SETF accessor any more. As a result, no more type error warnings on constants.lisp-temp compilation any more! * sb-bsd-sockets' getprotobyname alien function accepts a (* protoent) structure now. * export error-component and error-operation from asdf.lisp --- diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 5f8a599..9536f92 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -89,6 +89,7 @@ #:*asdf-revision* #:operation-error #:compile-failed #:compile-warned #:compile-error + #:error-component #:error-operation #:system-definition-error #:missing-component #:missing-dependency diff --git a/contrib/sb-bsd-sockets/constants.lisp b/contrib/sb-bsd-sockets/constants.lisp index 97a9fa8..e8004f4 100644 --- a/contrib/sb-bsd-sockets/constants.lisp +++ b/contrib/sb-bsd-sockets/constants.lisp @@ -108,7 +108,7 @@ (c-string-pointer name "char *" "p_name") ((* (* t)) aliases "char **" "p_aliases") (integer proto "int" "p_proto"))) - (:function getprotobyname ("getprotobyname" (* t) + (:function getprotobyname ("getprotobyname" (* protoent) (name c-string))) (:integer inaddr-any "INADDR_ANY") (:structure in-addr ("struct in_addr" diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index 7fc2892..8015908 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -27,25 +27,6 @@ eventually, so that we can do DNS lookups in parallel with other things ;(define-condition no-recovery-error (socket-error)) ; name server error ;(define-condition try-again-error (socket-error)) ; temporary -(defun get-host-by-name (host-name) - "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. -HOST-NAME may also be an IP address in dotted quad notation or some other -weird stuff - see gethostbyname(3) for grisly details." - (make-host-ent (sockint::gethostbyname host-name))) - -(defun get-host-by-address (address) - "Returns a HOST-ENT instance for ADDRESS, which should be a vector of - (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for -grisly details." - (sockint::with-in-addr packed-addr () - (let ((addr-vector (coerce address 'vector))) - (loop for i from 0 below (length addr-vector) - do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i) - (elt addr-vector i))) - (make-host-ent (sockint::gethostbyaddr packed-addr - 4 - sockint::af-inet))))) - (defun make-host-ent (h) (if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname")) (let* ((length (sockint::hostent-length h)) @@ -53,10 +34,9 @@ grisly details." for al = (sb-alien:deref (sockint::hostent-aliases h) i) while al collect al)) - (address0 (sockint::hostent-addresses h)) (addresses (loop for i = 0 then (1+ i) - for ad = (sb-alien:deref address0 i) + for ad = (sb-alien:deref (sockint::hostent-addresses h) i) until (sb-alien:null-alien ad) collect (ecase (sockint::hostent-type h) (#.sockint::af-inet @@ -70,6 +50,25 @@ grisly details." :aliases aliases :addresses addresses))) +(defun get-host-by-name (host-name) + "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition. +HOST-NAME may also be an IP address in dotted quad notation or some other +weird stuff - see gethostbyname(3) for grisly details." + (make-host-ent (sockint::gethostbyname host-name))) + +(defun get-host-by-address (address) + "Returns a HOST-ENT instance for ADDRESS, which should be a vector of + (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for +grisly details." + (sockint::with-in-addr packed-addr () + (let ((addr-vector (coerce address 'vector))) + (loop for i from 0 below (length addr-vector) + do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i) + (elt addr-vector i))) + (make-host-ent (sockint::gethostbyaddr packed-addr + 4 + sockint::af-inet))))) + ;;; The remainder is my fault - gw (defvar *name-service-errno* 0 diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 19e4107..a929fd0 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -120,6 +120,15 @@ code: (defclass grovel-constants-file (asdf:cl-source-file) ((package :accessor constants-package :initarg :package))) +(define-condition c-compile-failed (compile-failed) () + (:report (lambda (c s) + (format s "~@" + (error-operation c) (error-component c))))) +(define-condition a-dot-out-failed (compile-failed) () + (:report (lambda (c s) + (format s "~@" + (error-operation c) (error-component c))))) + (defmethod asdf:perform ((op asdf:compile-op) (component grovel-constants-file)) ;; we want to generate all our temporary files in the fasl directory @@ -140,14 +149,45 @@ code: (terpri) (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL")) filename tmp-c-source (constants-package component)) - (and - (= (run-shell-command "gcc ~A -o ~S ~S" - (if (sb-ext:posix-getenv "EXTRA_CFLAGS") - (sb-ext:posix-getenv "EXTRA_CFLAGS") - "") - (namestring tmp-a-dot-out) - (namestring tmp-c-source)) 0) - (= (run-shell-command "~A >~A" - (namestring tmp-a-dot-out) - (namestring tmp-constants)) 0) - (compile-file tmp-constants :output-file output-file)))) + (let ((code (run-shell-command "gcc ~A -o ~S ~S" + (if (sb-ext:posix-getenv "EXTRA_CFLAGS") + (sb-ext:posix-getenv "EXTRA_CFLAGS") + "") + (namestring tmp-a-dot-out) + (namestring tmp-c-source)))) + (unless (= code 0) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'c-compile-failed :operation op :component component))))) + (let ((code (run-shell-command "~A >~A" + (namestring tmp-a-dot-out) + (namestring tmp-constants)))) + (unless (= code 0) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'a-dot-out-failed :operation op :component component))))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file tmp-constants :output-file output-file) + (when warnings-p + (case (operation-on-warnings op) + (:warn (warn + (formatter "~@") + op component)) + (:error (error 'compile-warned :component component :operation op)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure op) + (:warn (warn + (formatter "~@") + op component)) + (:error (error 'compile-failed :component component :operation op)) + (:ignore nil))) + (unless output + (error 'compile-error :component component :operation op))))) + diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index e07bb59..457e453 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -65,8 +65,8 @@ ;; unfortunately; and it will only accept unquoted type ;; forms. `(sb-alien:array ,elt-type ,(or array-size - (/ size (eval `(sb-alien:alien-size ,elt-type :bytes)))))) - `(vector t)))) + (/ size (eval `(sb-alien:alien-size ,elt-type :bytes)))))) + t))) (defun retrieve-type-for (type size table) (multiple-value-bind (type-fn found) @@ -97,13 +97,13 @@ :type `(array char ,len) :offset offset :size len - :name (gensym "PADDING"))) + :name (gentemp "PADDING"))) (defun mk-struct (offset &rest children) - (make-instance 'struct :name (gensym "STRUCT") + (make-instance 'struct :name (gentemp "STRUCT") :children (remove nil children) :offset offset)) (defun mk-union (offset &rest children) - (make-instance 'union :name (gensym "UNION") + (make-instance 'union :name (gentemp "UNION") :children (remove nil children) :offset offset)) (defun mk-val (name type h-type offset size) @@ -255,7 +255,7 @@ deeply nested structures." (defgeneric accessor-modifier-for (element-type accessor-type)) -(defun identity-1 (thing &rest ignored) +(defmacro identity-1 (thing &rest ignored) (declare (ignore ignored)) thing) (defun (setf identity-1) (new-thing place &rest ignored) @@ -272,9 +272,6 @@ deeply nested structures." (defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) (accessor-type (eql :setter))) 'c-string->lisp-string) -(defmethod accessor-modifier-for ((element-type (eql 'C-STRING)) - (accessor-type (eql :getter))) - 'c-string->lisp-string) (defun c-string->lisp-string (string &optional limit) (declare (ignore limit)) @@ -302,14 +299,16 @@ deeply nested structures." (symbol-name (name root))))) (labels ((accessor (root rpath) (apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root)))))) - `((defun ,(intern accessor-name) (struct) - (declare (cl:type (alien ,struct-name) struct) + `((declaim (inline ,(intern accessor-name) + (setf ,(intern accessor-name)))) + (defun ,(intern accessor-name) (struct) + (declare (cl:type (alien (* ,struct-name)) struct) (optimize (speed 3))) (,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel)) :getter) ,(accessor root rpath) ,(size root))) (defun (setf ,(intern accessor-name)) (new-val struct) - (declare (cl:type (alien ,struct-name) struct) + (declare (cl:type (alien (* ,struct-name)) struct) (cl:type ,(lisp-type-for (type root) (size root)) new-val) (optimize (speed 3))) ,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root) @@ -358,8 +357,7 @@ deeply nested structures." (size root))))) (generate-struct-definition name root nil)) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (sb-alien:define-alien-type ,@(first struct-elements))) + (sb-alien:define-alien-type ,@(first struct-elements)) ,@accessors (defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body) (labels ((field-name (x) @@ -393,4 +391,4 @@ deeply nested structures." (defun foreign-nullp (c) "C is a pointer to 0?" - (null-alien c)) \ No newline at end of file + (null-alien c)) diff --git a/version.lisp-expr b/version.lisp-expr index 18e3493..87c781b 100644 --- a/version.lisp-expr +++ b/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.12.39" +"0.8.12.40"