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