1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER

[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 e091d59..585a84a 100644 (file)
--- a/contrib/sb-grovel/def-to-lisp.lisp
+++ b/contrib/sb-grovel/def-to-lisp.lisp
@@ -5,8 +5,18 @@
 (defun escape-for-string (string)
   (c-escape string))
 
+(defun split-cflags (string)
+  (remove-if (lambda (flag)
+               (zerop (length flag)))
+             (loop
+                for start = 0 then (if end (1+ end) nil)
+                for end = (and start (position #\Space string :start start))
+                while start
+                collect (subseq string start end))))
+
 (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)
@@ -103,10 +113,12 @@ 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)
            (as-c "#endif"))
@@ -142,7 +154,10 @@ code:
         (print-c-source  f headers definitions package)))))
 
 (defclass grovel-constants-file (asdf:cl-source-file)
-  ((package :accessor constants-package :initarg :package)))
+  ((package :accessor constants-package :initarg :package)
+   (do-not-grovel :accessor do-not-grovel
+                  :initform nil
+                  :initarg :do-not-grovel)))
 
 (define-condition c-compile-failed (compile-failed) ()
   (:report (lambda (c s)
@@ -174,37 +189,48 @@ code:
     (terpri)
     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
              filename tmp-c-source (constants-package component))
-    (let ((code (sb-ext:process-exit-code
-                 (sb-ext:run-program
-                  "gcc"
-                  (append
-                   (let ((cf (sb-ext:posix-getenv "EXTRA_CFLAGS")))
-                     (when (plusp (length cf))
-                       (list cf)))
-                   (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 "~@<C compiler failure when performing ~A on ~A.~@:>"
-                       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 "~@<a.out failure when performing ~A on ~A.~@:>"
-                       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"))
+                     ;; 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 "~@<C compiler failure when performing ~A on ~A.~@:>"
+                         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 "~@<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