1.0.10.19: Check also for MIPS foreign_function_call lossage
[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 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
116            (as-c "#ifdef" cname)
117            (printf "(cl:defconstant ~A %d \"~A\")" lispname doc
118                    cname)
119            (as-c "#else")
120            (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
121            (as-c "#endif"))
122           (:enum
123            (c-for-enum lispname cname export))
124           (:type
125            (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname
126                    (format nil "SIGNED_(~A)" cname)
127                    (format nil "(8*sizeof(~A))" cname)))
128           (:string
129            (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
130                    cname))
131           (:function
132            (printf "(cl:declaim (cl:inline ~A))" lispname)
133            (destructuring-bind (f-cname &rest definition) cname
134              (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname)
135              (printf "~{  ~W~^\\n~})" definition)))
136           (:structure
137            (c-for-structure lispname cname))
138           (otherwise
139            ;; should we really not sprechen espagnol, monsieurs?
140            (error "Unknown grovel keyword encountered: ~A" type)))
141         (when export
142           (printf "(cl:export '~A)" lispname))))
143     (as-c "return 0;")
144     (as-c "}")))
145
146 (defun c-constants-extract  (filename output-file package)
147   (with-open-file (f output-file :direction :output :if-exists :supersede)
148     (with-open-file (i filename :direction :input)
149       (let* ((headers (read i))
150              (definitions (read i)))
151         (print-c-source  f headers definitions package)))))
152
153 (defclass grovel-constants-file (asdf:cl-source-file)
154   ((package :accessor constants-package :initarg :package)
155    (do-not-grovel :accessor do-not-grovel
156                   :initform nil
157                   :initarg :do-not-grovel)))
158
159 (define-condition c-compile-failed (compile-failed) ()
160   (:report (lambda (c s)
161              (format s "~@<C compiler failed when performing ~A on ~A.~@:>"
162                      (error-operation c) (error-component c)))))
163 (define-condition a-dot-out-failed (compile-failed) ()
164   (:report (lambda (c s)
165              (format s "~@<a.out failed when performing ~A on ~A.~@:>"
166                      (error-operation c) (error-component c)))))
167
168 (defmethod asdf:perform ((op asdf:compile-op)
169                          (component grovel-constants-file))
170   ;; we want to generate all our temporary files in the fasl directory
171   ;; because that's where we have write permission.  Can't use /tmp;
172   ;; it's insecure (these files will later be owned by root)
173   (let* ((output-file (car (output-files op component)))
174          (filename (component-pathname component))
175          (real-output-file
176           (if (typep output-file 'logical-pathname)
177               (translate-logical-pathname output-file)
178               (pathname output-file)))
179          (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
180          (tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe"
181                                          real-output-file))
182          (tmp-constants (merge-pathnames #p"constants.lisp-temp"
183                                          real-output-file)))
184     (princ (list filename output-file real-output-file
185                  tmp-c-source tmp-a-dot-out tmp-constants))
186     (terpri)
187     (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
188              filename tmp-c-source (constants-package component))
189     (unless (do-not-grovel component)
190       (let* ((cc (or (sb-ext:posix-getenv "CC")
191                      ;; It might be nice to include a CONTINUE or
192                      ;; USE-VALUE restart here, but ASDF seems to insist
193                      ;; on handling the errors itself.
194                      (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.")))
195              (code (sb-ext:process-exit-code
196                     (sb-ext:run-program
197                      cc
198                      (append
199                       (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
200                       #+(and linux largefile)
201                       '("-D_LARGEFILE_SOURCE"
202                         "-D_LARGEFILE64_SOURCE"
203                         "-D_FILE_OFFSET_BITS=64")
204                       #+(and x86-64 darwin)
205                       '("-arch" "x86_64")
206                       (list "-o"
207                             (namestring tmp-a-dot-out)
208                             (namestring tmp-c-source)))
209                      :search t
210                      :input nil
211                      :output *trace-output*))))
212         (unless (= code 0)
213           (case (operation-on-failure op)
214             (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
215                          op component))
216             (:error
217              (error 'c-compile-failed :operation op :component component)))))
218       (let ((code (sb-ext:process-exit-code
219                    (sb-ext:run-program (namestring tmp-a-dot-out)
220                                        (list (namestring tmp-constants))
221                                        :search nil
222                                        :input nil
223                                        :output *trace-output*))))
224         (unless (= code 0)
225           (case (operation-on-failure op)
226             (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
227                          op component))
228             (:error
229              (error 'a-dot-out-failed :operation op :component component))))))
230     (multiple-value-bind (output warnings-p failure-p)
231         (compile-file tmp-constants :output-file output-file)
232       (when warnings-p
233         (case (operation-on-warnings op)
234           (:warn (warn
235                   (formatter "~@<COMPILE-FILE warned while ~
236                               performing ~A on ~A.~@:>")
237                   op component))
238           (:error (error 'compile-warned :component component :operation op))
239           (:ignore nil)))
240       (when failure-p
241         (case (operation-on-failure op)
242           (:warn (warn
243                   (formatter "~@<COMPILE-FILE failed while ~
244                               performing ~A on ~A.~@:>")
245                   op component))
246           (:error (error 'compile-failed :component component :operation op))
247           (:ignore nil)))
248       (unless output
249         (error 'compile-error :component component :operation op)))))
250