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-structure (lispname cstruct)
  41   (destructuring-bind (cname &rest elements) cstruct
  42     (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname
  43             (format nil "sizeof(~A)" cname))
  44     (dolist (e elements)
  45       (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e
  46         (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type)
  47         ;; offset
  48         (as-c "{" cname "t;")
  49         (printf "  %d"
  50                 (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name))
  51         (as-c "}")
  52         ;; length
  53         (if distrust-length
  54             (printf "  0)")
  55             (progn
  56               (as-c "{" cname "t;")
  57               (printf "  %d)"
  58                       (format nil "sizeof(t.~A)" c-el-name))
  59               (as-c "}")))))
  60     (printf "))")))
  61
  62 (defun print-c-source (stream headers definitions package-name)
  63   (declare (ignorable definitions package-name))
  64   (let ((*default-c-stream* stream)
  65         (*print-right-margin* nil))
  66     (loop for i in (cons "stdio.h" headers)
  67           do (format stream "#include <~A>~%" i))
  68     (as-c "#define SIGNEDP(x) (((x)-1)<0)")
  69     (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
  70     (as-c "int main() {")
  71     (printf "(cl:in-package #:~A)" package-name)
  72     (printf "(cl:eval-when (:compile-toplevel)")
  73     (printf "  (cl:defparameter *integer-sizes* (cl:make-hash-table))")
  74     (dolist (type '("char" "short" "long" "int"
  75                     #+nil"long long" ; TODO: doesn't exist in sb-alien yet
  76                     ))
  77       (printf "  (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
  78               (format nil "sizeof(~A)" type)))
  79     (printf ")")
  80     (dolist (def definitions)
  81       (destructuring-bind (type lispname cname &optional doc dont-export) def
  82         (case type
  83           (:integer
  84            (as-c "#ifdef" cname)
  85            (printf "(cl:defconstant ~A %d \"~A\")" lispname doc
  86                    cname)
  87            ;; XXX: do this?
  88            (unless dont-export
  89              (printf "(cl:export '~A)" lispname))
  90            (as-c "#else")
  91            (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
  92            (as-c "#endif"))
  93           (:type
  94            (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname
  95                    (format nil "SIGNED_(~A)" cname)
  96                    (format nil "(8*sizeof(~A))" cname)))
  97           (:string
  98            (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
  99                    cname))
 100           (:function
 101            (printf "(cl:declaim (cl:inline ~A))" lispname)
 102            (destructuring-bind (f-cname &rest definition) cname
 103              (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
 104              (printf "~{  ~W~^\\n~})" definition)))
 105           (:structure
 106            (c-for-structure lispname cname))
 107           (otherwise
 108            ;; should we really not sprechen espagnol, monsieurs?
 109            (error "Unknown grovel keyword encountered: ~A" type))
 110         )))
 111     (as-c "return 0;")
 112     (as-c "}")))
 113
 114 (defun c-constants-extract  (filename output-file package)
 115   (with-open-file (f output-file :direction :output :if-exists :supersede)
 116     (with-open-file (i filename :direction :input)
 117       (let* ((headers (read i))
 118              (definitions (read i)))
 119         (print-c-source  f headers definitions package)))))
 120
 121 (defclass grovel-constants-file (asdf:cl-source-file)
 122   ((package :accessor constants-package :initarg :package)))
 123
 124 (defmethod asdf:perform ((op asdf:compile-op)
 125                          (component grovel-constants-file))
 126   ;; we want to generate all our temporary files in the fasl directory
 127   ;; because that's where we have write permission.  Can't use /tmp;
 128   ;; it's insecure (these files will later be owned by root)
 129   (let* ((output-file (car (output-files op component)))
 130          (filename (component-pathname component))
 131          (real-output-file
 132           (if (typep output-file 'logical-pathname)
 133               (translate-logical-pathname output-file)
 134               (pathname output-file)))
 135          (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
 136          (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
 137          (tmp-constants (merge-pathnames #p"constants.lisp-temp"
 138                                          real-output-file)))
 139     (princ (list filename output-file real-output-file
 140                  tmp-c-source tmp-a-dot-out tmp-constants))
 141     (terpri)
 142     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
 143              filename tmp-c-source (constants-package component))
 144     (and
 145      (= (run-shell-command "gcc ~A -o ~S ~S"
 146                            (if (sb-ext:posix-getenv "EXTRA_CFLAGS")
 147                                (sb-ext:posix-getenv "EXTRA_CFLAGS")
 148                                 "")
 149                            (namestring tmp-a-dot-out)
 150                            (namestring tmp-c-source)) 0)
 151      (= (run-shell-command "~A >~A"
 152                            (namestring tmp-a-dot-out)
 153                            (namestring tmp-constants)) 0)
 154      (compile-file tmp-constants :output-file output-file))))