(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
(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)
(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 "}")))
(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
(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)))))
+