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