From: Andreas F. <ant...@us...> - 2004-07-19 20:47:05
|
Update of /cvsroot/sbcl/sbcl/contrib/sb-grovel In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15968/contrib/sb-grovel Modified Files: def-to-lisp.lisp foreign-glue.lisp Log Message: 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 Index: def-to-lisp.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-grovel/def-to-lisp.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- def-to-lisp.lisp 1 Jun 2004 17:02:23 -0000 1.13 +++ def-to-lisp.lisp 19 Jul 2004 20:46:48 -0000 1.14 @@ -120,6 +120,15 @@ (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 "~@<C compiler failed when performing ~A on ~A.~@:>" + (error-operation c) (error-component c))))) +(define-condition a-dot-out-failed (compile-failed) () + (:report (lambda (c s) + (format s "~@<a.out failed when performing ~A on ~A.~@:>" + (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 @@ (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 "~@<C compiler failure when performing ~A on ~A.~@:>" + 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 "~@<a.out failure when performing ~A on ~A.~@:>" + 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 "~@<COMPILE-FILE warned while ~ + performing ~A on ~A.~@:>") + op component)) + (:error (error 'compile-warned :component component :operation op)) + (:ignore nil))) + (when failure-p + (case (operation-on-failure op) + (:warn (warn + (formatter "~@<COMPILE-FILE failed while ~ + performing ~A on ~A.~@:>") + op component)) + (:error (error 'compile-failed :component component :operation op)) + (:ignore nil))) + (unless output + (error 'compile-error :component component :operation op))))) + Index: foreign-glue.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/contrib/sb-grovel/foreign-glue.lisp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- foreign-glue.lisp 29 Jun 2004 08:50:57 -0000 1.7 +++ foreign-glue.lisp 19 Jul 2004 20:46:48 -0000 1.8 @@ -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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (defun foreign-nullp (c) "C is a pointer to 0?" - (null-alien c)) \ No newline at end of file + (null-alien c)) |