X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fdef-to-lisp.lisp;h=d87d7c2c5b4728627aa9099698a432c1f37354db;hb=260de2062fca170efdac3e42491d7d866c2d2e56;hp=201eaf8e104ef69c422a987dd90b9cc3a40f2c82;hpb=9b6bef920da10d33e6fcd43c1bc06cf528f4f507;p=sbcl.git diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 201eaf8..d87d7c2 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -16,6 +16,7 @@ (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\)) "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR." + (declare (simple-string string)) (coerce (loop for c across string if (member c dangerous-chars) collect escape-char collect c) @@ -112,12 +113,14 @@ code: (dolist (def definitions) (destructuring-bind (type lispname cname &optional doc export) def (case type - (:integer + ((:integer :errno) (as-c "#ifdef" cname) (printf "(cl:defconstant ~A %d \"~A\")" lispname doc cname) + (when (eql type :errno) + (printf "(cl:setf (get '~A 'errno) t)" lispname)) (as-c "#else") - (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) + (printf "(sb-int:style-warn \"Couldn't grovel for ~~A (unknown to the C compiler).\" \"~A\")" cname) (as-c "#endif")) (:enum (c-for-enum lispname cname export)) @@ -150,25 +153,31 @@ code: (definitions (read i))) (print-c-source f headers definitions package))))) -(defclass grovel-constants-file (asdf:cl-source-file) - ((package :accessor constants-package :initarg :package))) +(defclass grovel-constants-file (cl-source-file) + ((package :accessor constants-package :initarg :package) + (do-not-grovel :accessor do-not-grovel + :initform nil + :initarg :do-not-grovel))) +(defclass asdf::sb-grovel-constants-file (grovel-constants-file) ()) -(define-condition c-compile-failed (compile-failed) () - (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) -(define-condition a-dot-out-failed (compile-failed) () - (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) +(define-condition c-compile-failed (compile-file-error) + ((description :initform "C compiler failed"))) +(define-condition a-dot-out-failed (compile-file-error) + ((description :initform "a.out failed"))) -(defmethod asdf:perform ((op asdf:compile-op) - (component grovel-constants-file)) +(defmethod perform ((op compile-op) + (component grovel-constants-file)) ;; we want to generate all our temporary files in the fasl directory ;; because that's where we have write permission. Can't use /tmp; ;; it's insecure (these files will later be owned by root) - (let* ((output-file (car (output-files op component))) + (let* ((output-files (output-files op component)) + (output-file (first output-files)) + (warnings-file (second output-files)) (filename (component-pathname component)) + (context-format "~/asdf-action::format-action/") + (context-arguments `((,op . ,component))) + (condition-arguments `(:context-format ,context-format + :context-arguments ,context-arguments)) (real-output-file (if (typep output-file 'logical-pathname) (translate-logical-pathname output-file) @@ -183,64 +192,52 @@ code: (terpri) (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL")) filename tmp-c-source (constants-package component)) - (let* ((cc (or (sb-ext:posix-getenv "CC") - ;; It might be nice to include a CONTINUE or - ;; USE-VALUE restart here, but ASDF seems to insist - ;; on handling the errors itself. - (error "The CC environment variable has not been set in SB-GROVEL. Since this variable should always be set during the SBCL build process, this might indicate an SBCL with a broken contrib installation."))) - (code (sb-ext:process-exit-code - (sb-ext:run-program - cc - (append - (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS")) - #+(and linux largefile) - '("-D_LARGEFILE_SOURCE" - "-D_LARGEFILE64_SOURCE" - "-D_FILE_OFFSET_BITS=64") - #+(and x86-64 darwin) - '("-arch" "x86_64") - (list "-o" - (namestring tmp-a-dot-out) - (namestring tmp-c-source))) - :search t - :input nil - :output *trace-output*)))) - (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'c-compile-failed :operation op :component component))))) - (let ((code (sb-ext:process-exit-code - (sb-ext:run-program (namestring tmp-a-dot-out) - (list (namestring tmp-constants)) - :search nil - :input nil - :output *trace-output*)))) - (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'a-dot-out-failed :operation op :component component))))) + (unless (do-not-grovel component) + (let* ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "") + (sb-ext:posix-getenv "CC")) + (if (member :sb-building-contrib *features*) + (error "~@") + (sb-int:style-warn + "CC environment variable not set, SB-GROVEL falling back to \"cc\".")) + "cc")) + (code (sb-ext:process-exit-code + (sb-ext:run-program + cc + (append + (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS")) + #+(and linux largefile) + '("-D_LARGEFILE_SOURCE" + "-D_LARGEFILE64_SOURCE" + "-D_FILE_OFFSET_BITS=64") + #+(and (or x86 ppc) linux) '("-m32") + #+(and x86-64 darwin inode64) + '("-arch" "x86_64" + "-mmacosx-version-min=10.5" + "-D_DARWIN_USE_64_BIT_INODE") + #+(and x86-64 darwin (not inode64)) + '("-arch" "x86_64" + "-mmacosx-version-min=10.4") + #+(and x86 darwin) + '("-arch" "i386" + "-mmacosx-version-min=10.4") + #+(and x86-64 sunos) '("-m64") + (list "-o" + (namestring tmp-a-dot-out) + (namestring tmp-c-source))) + :search t + :input nil + :output *trace-output*)))) + (unless (= code 0) + (apply 'error 'c-compile-failed condition-arguments))) + (let ((code (sb-ext:process-exit-code + (sb-ext:run-program (namestring tmp-a-dot-out) + (list (namestring tmp-constants)) + :search nil + :input nil + :output *trace-output*)))) + (unless (= code 0) + (apply 'error 'a-dot-out-failed condition-arguments))) (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 "~@") - op component)) - (:error (error 'compile-warned :component component :operation op)) - (:ignore nil))) - (when failure-p - (case (operation-on-failure op) - (:warn (warn - (formatter "~@") - op component)) - (:error (error 'compile-failed :component component :operation op)) - (:ignore nil))) - (unless output - (error 'compile-error :component component :operation op))))) - + (compile-file* tmp-constants :output-file output-file :warnings-file warnings-file) + (check-lisp-compile-results output warnings-p failure-p context-format context-arguments)))))