X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fdef-to-lisp.lisp;h=b39ff5e2bd7cbc64154e6fc518dbb9b6c837d2e7;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=265a0cefad4b29cde71ec0ca0e697fe1d0c0eb17;hpb=d4c7ab04ed10729a2cfa3321f4382d8a218ad958;p=sbcl.git

diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp
index 265a0ce..b39ff5e 100644
--- a/contrib/sb-grovel/def-to-lisp.lisp
+++ b/contrib/sb-grovel/def-to-lisp.lisp
@@ -37,6 +37,19 @@ code:
 	   (c-escape formatter)
 	   args)))
 
+(defun c-for-enum (lispname elements export)
+  (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname)
+  (dolist (element elements)
+    (destructuring-bind (lisp-element-name c-element-name) element
+      (printf " (~S %d)" lisp-element-name c-element-name)))
+  (printf ")))")
+  (when export
+    (dolist (element elements)
+      (destructuring-bind (lisp-element-name c-element-name) element
+        (declare (ignore c-element-name))
+	(unless (keywordp lisp-element-name)
+	  (printf "(export '~S)" lisp-element-name))))))
+
 (defun c-for-structure (lispname cstruct)
   (destructuring-bind (cname &rest elements) cstruct
     (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname
@@ -78,18 +91,17 @@ 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"))
+          (:enum
+           (c-for-enum lispname cname export))
 	  (:type
 	   (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname
 		   (format nil "SIGNED_(~A)" cname)
@@ -106,8 +118,9 @@ code:
 	   (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 +134,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 +163,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)))))
+