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