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))
|