0.8.12.40:

[sbcl.git] / contrib / sb-grovel / def-to-lisp.lisp

diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp
index 265a0ce..a929fd0 100644 (file)
--- a/contrib/sb-grovel/def-to-lisp.lisp
+++ b/contrib/sb-grovel/def-to-lisp.lisp
@@ -78,15 +78,12 @@ code:
              (format nil "sizeof(~A)" type)))
     (printf ")")
     (dolist (def definitions)
-      (destructuring-bind (type lispname cname &optional doc dont-export) def
+      (destructuring-bind (type lispname cname &optional doc export) def
        (case type
          (:integer
           (as-c "#ifdef" cname)
           (printf "(cl:defconstant ~A %d \"~A\")" lispname doc
                   cname)
-          ;; XXX: do this?
-          (unless dont-export
-            (printf "(cl:export '~A)" lispname))
           (as-c "#else")
           (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
           (as-c "#endif"))
@@ -103,11 +100,13 @@ code:
             (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
             (printf "~{  ~W~^\\n~})" definition)))
          (:structure
+          ;; FIXME: structure slots should be auto-exportable as well.
           (c-for-structure lispname cname))
          (otherwise
           ;; should we really not sprechen espagnol, monsieurs?
-          (error "Unknown grovel keyword encountered: ~A" type))
-       )))
+          (error "Unknown grovel keyword encountered: ~A" type)))
+       (when export
+         (printf "(cl:export '~A)" lispname))))
     (as-c "return 0;")
     (as-c "}")))
 
@@ -121,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 "~@<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
@@ -141,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 "~@<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)))))
+