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 printf 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            "    printf (\"~@?\\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() {")
  84     (printf "(cl:in-package #:~A)" package-name)
  85     (printf "(cl:eval-when (:compile-toplevel)")
  86     (printf "  (cl:defparameter *integer-sizes* (cl:make-hash-table))")
  87     (dolist (type '("char" "short" "long" "int"
  88                     #+nil"long long" ; TODO: doesn't exist in sb-alien yet
  89                     ))
  90       (printf "  (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
  91               (format nil "sizeof(~A)" type)))
  92     (printf ")")
  93     (dolist (def definitions)
  94       (destructuring-bind (type lispname cname &optional doc export) def
  95         (case type
  96           (:integer
  97            (as-c "#ifdef" cname)
  98            (printf "(cl:defconstant ~A %d \"~A\")" lispname doc
  99                    cname)
 100            (as-c "#else")
 101            (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
 102            (as-c "#endif"))
 103           (:enum
 104            (c-for-enum lispname cname export))
 105           (:type
 106            (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname
 107                    (format nil "SIGNED_(~A)" cname)
 108                    (format nil "(8*sizeof(~A))" cname)))
 109           (:string
 110            (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
 111                    cname))
 112           (:function
 113            (printf "(cl:declaim (cl:inline ~A))" lispname)
 114            (destructuring-bind (f-cname &rest definition) cname
 115              (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
 116              (printf "~{  ~W~^\\n~})" definition)))
 117           (:structure
 118            (c-for-structure lispname cname))
 119           (otherwise
 120            ;; should we really not sprechen espagnol, monsieurs?
 121            (error "Unknown grovel keyword encountered: ~A" type)))
 122         (when export
 123           (printf "(cl:export '~A)" lispname))))
 124     (as-c "return 0;")
 125     (as-c "}")))
 126
 127 (defun c-constants-extract  (filename output-file package)
 128   (with-open-file (f output-file :direction :output :if-exists :supersede)
 129     (with-open-file (i filename :direction :input)
 130       (let* ((headers (read i))
 131              (definitions (read i)))
 132         (print-c-source  f headers definitions package)))))
 133
 134 (defclass grovel-constants-file (asdf:cl-source-file)
 135   ((package :accessor constants-package :initarg :package)))
 136
 137 (define-condition c-compile-failed (compile-failed) ()
 138   (:report (lambda (c s)
 139              (format s "~@<C compiler failed when performing ~A on ~A.~@:>"
 140                      (error-operation c) (error-component c)))))
 141 (define-condition a-dot-out-failed (compile-failed) ()
 142   (:report (lambda (c s)
 143              (format s "~@<a.out failed when performing ~A on ~A.~@:>"
 144                      (error-operation c) (error-component c)))))
 145
 146 (defmethod asdf:perform ((op asdf:compile-op)
 147                          (component grovel-constants-file))
 148   ;; we want to generate all our temporary files in the fasl directory
 149   ;; because that's where we have write permission.  Can't use /tmp;
 150   ;; it's insecure (these files will later be owned by root)
 151   (let* ((output-file (car (output-files op component)))
 152          (filename (component-pathname component))
 153          (real-output-file
 154           (if (typep output-file 'logical-pathname)
 155               (translate-logical-pathname output-file)
 156               (pathname output-file)))
 157          (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
 158          (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
 159          (tmp-constants (merge-pathnames #p"constants.lisp-temp"
 160                                          real-output-file)))
 161     (princ (list filename output-file real-output-file
 162                  tmp-c-source tmp-a-dot-out tmp-constants))
 163     (terpri)
 164     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
 165              filename tmp-c-source (constants-package component))
 166     (let ((code (run-shell-command "gcc ~A -o ~S ~S"
 167                                    (if (sb-ext:posix-getenv "EXTRA_CFLAGS")
 168                                        (sb-ext:posix-getenv "EXTRA_CFLAGS")
 169                                        "")
 170                                    (namestring tmp-a-dot-out)
 171                                    (namestring tmp-c-source))))
 172       (unless (= code 0)
 173         (case (operation-on-failure op)
 174           (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
 175                        op component))
 176           (:error
 177            (error 'c-compile-failed :operation op :component component)))))
 178     (let ((code (run-shell-command "~A >~A"
 179                                    (namestring tmp-a-dot-out)
 180                                    (namestring tmp-constants))))
 181       (unless (= code 0)
 182         (case (operation-on-failure op)
 183           (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
 184                        op component))
 185           (:error
 186            (error 'a-dot-out-failed :operation op :component component)))))
 187     (multiple-value-bind (output warnings-p failure-p)
 188         (compile-file tmp-constants :output-file output-file)
 189       (when warnings-p
 190         (case (operation-on-warnings op)
 191           (:warn (warn
 192                   (formatter "~@<COMPILE-FILE warned while ~
 193                               performing ~A on ~A.~@:>")
 194                   op component))
 195           (:error (error 'compile-warned :component component :operation op))
 196           (:ignore nil)))
 197       (when failure-p
 198         (case (operation-on-failure op)
 199           (:warn (warn
 200                   (formatter "~@<COMPILE-FILE failed while ~
 201                               performing ~A on ~A.~@:>")
 202                   op component))
 203           (:error (error 'compile-failed :component component :operation op))
 204           (:ignore nil)))
 205       (unless output
 206         (error 'compile-error :component component :operation op)))))
 207