contrib/sb-grovel/def-to-lisp.lisp

   1 (in-package #:sb-grovel)
   2
   3 (defvar *default-c-stream* nil)
   4
   5 (defun escape-for-string (string)
   6   (c-escape string))
   7
   8 (defun split-cflags (string)
   9   (remove-if (lambda (flag)
  10                (zerop (length flag)))
  11              (loop
  12                 for start = 0 then (if end (1+ end) nil)
  13                 for end = (and start (position #\Space string :start start))
  14                 while start
  15                 collect (subseq string start end))))
  16
  17 (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\))
  18   "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
  19   (declare (simple-string string))
  20   (coerce (loop for c across string
  21                 if (member c dangerous-chars) collect escape-char
  22                 collect c)
  23           'string))
  24
  25 (defun as-c (&rest args)
  26   "Pretty-print ARGS into the C source file, separated by #\Space"
  27   (format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args)))
  28
  29 (defun printf (formatter &rest args)
  30   "Emit C code to fprintf the quoted code, via FORMAT.
  31 The first argument is the C string that should be passed to
  32 printf.
  33
  34 The rest of the arguments are consumed by FORMAT clauses, until
  35 there are no more FORMAT clauses to fill. If there are more
  36 arguments, they are emitted as printf arguments.
  37
  38 There is no error checking done, unless you pass too few FORMAT
  39 clause args. I recommend using this formatting convention in
  40 code:
  41
  42  (printf \"string ~A ~S %d %d\" format-arg-1 format-arg-2
  43          printf-arg-1 printf-arg-2)"
  44   (let ((*print-pretty* nil))
  45     (apply #'format *default-c-stream*
  46            "    fprintf (out, \"~@?\\n\"~@{, ~A~});~%"
  47            (c-escape formatter)
  48            args)))
  49
  50 (defun c-for-enum (lispname elements export)
  51   (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname)
  52   (dolist (element elements)
  53     (destructuring-bind (lisp-element-name c-element-name) element
  54       (printf " (~S %d)" lisp-element-name c-element-name)))
  55   (printf ")))")
  56   (when export
  57     (dolist (element elements)
  58       (destructuring-bind (lisp-element-name c-element-name) element
  59         (declare (ignore c-element-name))
  60         (unless (keywordp lisp-element-name)
  61           (printf "(export '~S)" lisp-element-name))))))
  62
  63 (defun c-for-structure (lispname cstruct)
  64   (destructuring-bind (cname &rest elements) cstruct
  65     (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname
  66             (format nil "sizeof(~A)" cname))
  67     (dolist (e elements)
  68       (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e
  69         (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type)
  70         ;; offset
  71         (as-c "{" cname "t;")
  72         (printf "  %d"
  73                 (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name))
  74         (as-c "}")
  75         ;; length
  76         (if distrust-length
  77             (printf "  0)")
  78             (progn
  79               (as-c "{" cname "t;")
  80               (printf "  %d)"
  81                       (format nil "sizeof(t.~A)" c-el-name))
  82               (as-c "}")))))
  83     (printf "))")))
  84
  85 (defun print-c-source (stream headers definitions package-name)
  86   (declare (ignorable definitions package-name))
  87   (let ((*default-c-stream* stream)
  88         (*print-right-margin* nil))
  89     (loop for i in (cons "stdio.h" headers)
  90           do (format stream "#include <~A>~%" i))
  91     (as-c "#define SIGNEDP(x) (((x)-1)<0)")
  92     (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
  93     (as-c "int main(int argc, char *argv[]) {")
  94     (as-c "    FILE *out;")
  95     (as-c "    if (argc != 2) {")
  96     (as-c "        printf(\"Invalid argcount!\");")
  97     (as-c "        return 1;")
  98     (as-c "    } else")
  99     (as-c "        out = fopen(argv[1], \"w\");")
 100     (as-c "    if (!out) {")
 101     (as-c "        printf(\"Error opening output file!\");")
 102     (as-c "        return 1;")
 103     (as-c "    }")
 104     (printf "(cl:in-package #:~A)" package-name)
 105     (printf "(cl:eval-when (:compile-toplevel)")
 106     (printf "  (cl:defparameter *integer-sizes* (cl:make-hash-table))")
 107     (dolist (type '("char" "short" "long" "int"
 108                     #+nil"long long" ; TODO: doesn't exist in sb-alien yet
 109                     ))
 110       (printf "  (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
 111               (format nil "sizeof(~A)" type)))
 112     (printf ")")
 113     (dolist (def definitions)
 114       (destructuring-bind (type lispname cname &optional doc export) def
 115         (case type
 116           ((:integer :errno)
 117            (as-c "#ifdef" cname)
 118            (printf "(cl:defconstant ~A %d \"~A\")" lispname doc
 119                    cname)
 120            (when (eql type :errno)
 121              (printf "(cl:setf (get '~A 'errno) t)" lispname))
 122            (as-c "#else")
 123            (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
 124            (as-c "#endif"))
 125           (:enum
 126            (c-for-enum lispname cname export))
 127           (:type
 128            (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname
 129                    (format nil "SIGNED_(~A)" cname)
 130                    (format nil "(8*sizeof(~A))" cname)))
 131           (:string
 132            (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
 133                    cname))
 134           (:function
 135            (printf "(cl:declaim (cl:inline ~A))" lispname)
 136            (destructuring-bind (f-cname &rest definition) cname
 137              (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
 138              (printf "~{  ~W~^\\n~})" definition)))
 139           (:structure
 140            (c-for-structure lispname cname))
 141           (otherwise
 142            ;; should we really not sprechen espagnol, monsieurs?
 143            (error "Unknown grovel keyword encountered: ~A" type)))
 144         (when export
 145           (printf "(cl:export '~A)" lispname))))
 146     (as-c "return 0;")
 147     (as-c "}")))
 148
 149 (defun c-constants-extract  (filename output-file package)
 150   (with-open-file (f output-file :direction :output :if-exists :supersede)
 151     (with-open-file (i filename :direction :input)
 152       (let* ((headers (read i))
 153              (definitions (read i)))
 154         (print-c-source  f headers definitions package)))))
 155
 156 (defclass grovel-constants-file (asdf:cl-source-file)
 157   ((package :accessor constants-package :initarg :package)
 158    (do-not-grovel :accessor do-not-grovel
 159                   :initform nil
 160                   :initarg :do-not-grovel)))
 161
 162 (define-condition c-compile-failed (compile-failed) ()
 163   (:report (lambda (c s)
 164              (format s "~@<C compiler failed when performing ~A on ~A.~@:>"
 165                      (error-operation c) (error-component c)))))
 166 (define-condition a-dot-out-failed (compile-failed) ()
 167   (:report (lambda (c s)
 168              (format s "~@<a.out failed when performing ~A on ~A.~@:>"
 169                      (error-operation c) (error-component c)))))
 170
 171 (defmethod asdf:perform ((op asdf:compile-op)
 172                          (component grovel-constants-file))
 173   ;; we want to generate all our temporary files in the fasl directory
 174   ;; because that's where we have write permission.  Can't use /tmp;
 175   ;; it's insecure (these files will later be owned by root)
 176   (let* ((output-file (car (output-files op component)))
 177          (filename (component-pathname component))
 178          (real-output-file
 179           (if (typep output-file 'logical-pathname)
 180               (translate-logical-pathname output-file)
 181               (pathname output-file)))
 182          (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
 183          (tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe"
 184                                          real-output-file))
 185          (tmp-constants (merge-pathnames #p"constants.lisp-temp"
 186                                          real-output-file)))
 187     (princ (list filename output-file real-output-file
 188                  tmp-c-source tmp-a-dot-out tmp-constants))
 189     (terpri)
 190     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
 191              filename tmp-c-source (constants-package component))
 192     (unless (do-not-grovel component)
 193       (let* ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
 194                           (sb-ext:posix-getenv "CC"))
 195                      ;; It might be nice to include a CONTINUE or
 196                      ;; USE-VALUE restart here, but ASDF seems to insist
 197                      ;; on handling the errors itself.
 198                      (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.")))
 199              (code (sb-ext:process-exit-code
 200                     (sb-ext:run-program
 201                      cc
 202                      (append
 203                       (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
 204                       #+(and linux largefile)
 205                       '("-D_LARGEFILE_SOURCE"
 206                         "-D_LARGEFILE64_SOURCE"
 207                         "-D_FILE_OFFSET_BITS=64")
 208                       #+(and x86-64 darwin inode64)
 209                       '("-arch" "x86_64"
 210                         "-mmacosx-version-min=10.5"
 211                         "-D_DARWIN_USE_64_BIT_INODE")
 212                       #+(and x86-64 darwin (not inode64))
 213                       '("-arch" "x86_64"
 214                         "-mmacosx-version-min=10.4")
 215                       #+(and x86 darwin)
 216                       '("-arch" "i386"
 217                         "-mmacosx-version-min=10.4")
 218                       #+(and x86-64 sunos) '("-m64")
 219                       (list "-o"
 220                             (namestring tmp-a-dot-out)
 221                             (namestring tmp-c-source)))
 222                      :search t
 223                      :input nil
 224                      :output *trace-output*))))
 225         (unless (= code 0)
 226           (case (operation-on-failure op)
 227             (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
 228                          op component))
 229             (:error
 230              (error 'c-compile-failed :operation op :component component)))))
 231       (let ((code (sb-ext:process-exit-code
 232                    (sb-ext:run-program (namestring tmp-a-dot-out)
 233                                        (list (namestring tmp-constants))
 234                                        :search nil
 235                                        :input nil
 236                                        :output *trace-output*))))
 237         (unless (= code 0)
 238           (case (operation-on-failure op)
 239             (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
 240                          op component))
 241             (:error
 242              (error 'a-dot-out-failed :operation op :component component))))))
 243     (multiple-value-bind (output warnings-p failure-p)
 244         (compile-file tmp-constants :output-file output-file)
 245       (when warnings-p
 246         (case (operation-on-warnings op)
 247           (:warn (warn
 248                   (formatter "~@<COMPILE-FILE warned while ~
 249                               performing ~A on ~A.~@:>")
 250                   op component))
 251           (:error (error 'compile-warned :component component :operation op))
 252           (:ignore nil)))
 253       (when failure-p
 254         (case (operation-on-failure op)
 255           (:warn (warn
 256                   (formatter "~@<COMPILE-FILE failed while ~
 257                               performing ~A on ~A.~@:>")
 258                   op component))
 259           (:error (error 'compile-failed :component component :operation op))
 260           (:ignore nil)))
 261       (unless output
 262         (error 'compile-error :component component :operation op)))))
 263