X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fdef-to-lisp.lisp;h=3aedfe208b73be366245a2add1d72406cc5d789a;hb=9848482c761d4ecdafb43889a5c7a759c0f24b9a;hp=b39ff5e2bd7cbc64154e6fc518dbb9b6c837d2e7;hpb=1cae060fd9735f9c1f63538969e68c99b48f46e6;p=sbcl.git diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index b39ff5e..3aedfe2 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -5,19 +5,28 @@ (defun escape-for-string (string) (c-escape string)) +(defun split-cflags (string) + (remove-if (lambda (flag) + (zerop (length flag))) + (loop + for start = 0 then (if end (1+ end) nil) + for end = (and start (position #\Space string :start start)) + while start + collect (subseq string start end)))) + (defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\)) "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR." (coerce (loop for c across string - if (member c dangerous-chars) collect escape-char - collect c) - 'string)) + if (member c dangerous-chars) collect escape-char + collect c) + 'string)) (defun as-c (&rest args) "Pretty-print ARGS into the C source file, separated by #\Space" (format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args))) (defun printf (formatter &rest args) - "Emit C code to printf the quoted code, via FORMAT. + "Emit C code to fprintf the quoted code, via FORMAT. The first argument is the C string that should be passed to printf. @@ -33,9 +42,9 @@ code: printf-arg-1 printf-arg-2)" (let ((*print-pretty* nil)) (apply #'format *default-c-stream* - " printf (\"~@?\\n\"~@{, ~A~});~%" - (c-escape formatter) - args))) + " fprintf (out, \"~@?\\n\"~@{, ~A~});~%" + (c-escape formatter) + args))) (defun c-for-enum (lispname elements export) (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname) @@ -47,80 +56,90 @@ code: (dolist (element elements) (destructuring-bind (lisp-element-name c-element-name) element (declare (ignore c-element-name)) - (unless (keywordp lisp-element-name) - (printf "(export '~S)" lisp-element-name)))))) + (unless (keywordp lisp-element-name) + (printf "(export '~S)" lisp-element-name)))))) (defun c-for-structure (lispname cstruct) (destructuring-bind (cname &rest elements) cstruct (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %d" lispname - (format nil "sizeof(~A)" cname)) + (format nil "sizeof(~A)" cname)) (dolist (e elements) (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e - (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type) - ;; offset - (as-c "{" cname "t;") - (printf " %d" - (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name)) - (as-c "}") - ;; length - (if distrust-length - (printf " 0)") - (progn - (as-c "{" cname "t;") - (printf " %d)" - (format nil "sizeof(t.~A)" c-el-name)) - (as-c "}"))))) + (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type) + ;; offset + (as-c "{" cname "t;") + (printf " %d" + (format nil "((unsigned long)&(t.~A)) - ((unsigned long)&(t))" c-el-name)) + (as-c "}") + ;; length + (if distrust-length + (printf " 0)") + (progn + (as-c "{" cname "t;") + (printf " %d)" + (format nil "sizeof(t.~A)" c-el-name)) + (as-c "}"))))) (printf "))"))) (defun print-c-source (stream headers definitions package-name) (declare (ignorable definitions package-name)) (let ((*default-c-stream* stream) - (*print-right-margin* nil)) + (*print-right-margin* nil)) (loop for i in (cons "stdio.h" headers) do (format stream "#include <~A>~%" i)) (as-c "#define SIGNEDP(x) (((x)-1)<0)") (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")") - (as-c "int main() {") + (as-c "int main(int argc, char *argv[]) {") + (as-c " FILE *out;") + (as-c " if (argc != 2) {") + (as-c " printf(\"Invalid argcount!\");") + (as-c " return 1;") + (as-c " } else") + (as-c " out = fopen(argv[1], \"w\");") + (as-c " if (!out) {") + (as-c " printf(\"Error opening output file!\");") + (as-c " return 1;") + (as-c " }") (printf "(cl:in-package #:~A)" package-name) (printf "(cl:eval-when (:compile-toplevel)") (printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))") (dolist (type '("char" "short" "long" "int" - #+nil"long long" ; TODO: doesn't exist in sb-alien yet - )) + #+nil"long long" ; TODO: doesn't exist in sb-alien yet + )) (printf " (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type) - (format nil "sizeof(~A)" type))) + (format nil "sizeof(~A)" type))) (printf ")") (dolist (def definitions) (destructuring-bind (type lispname cname &optional doc export) def - (case type - (:integer - (as-c "#ifdef" cname) - (printf "(cl:defconstant ~A %d \"~A\")" lispname doc - cname) - (as-c "#else") - (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) - (as-c "#endif")) + (case type + (:integer + (as-c "#ifdef" cname) + (printf "(cl:defconstant ~A %d \"~A\")" lispname doc + cname) + (as-c "#else") + (printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname) + (as-c "#endif")) (:enum (c-for-enum lispname cname export)) - (:type - (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname - (format nil "SIGNED_(~A)" cname) - (format nil "(8*sizeof(~A))" cname))) - (:string - (printf "(cl:defparameter ~A %s \"~A\"" lispname doc - cname)) - (:function - (printf "(cl:declaim (cl:inline ~A))" lispname) - (destructuring-bind (f-cname &rest definition) cname - (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname) - (printf "~{ ~W~^\\n~})" definition))) - (:structure - (c-for-structure lispname cname)) - (otherwise - ;; should we really not sprechen espagnol, monsieurs? - (error "Unknown grovel keyword encountered: ~A" type))) - (when export - (printf "(cl:export '~A)" lispname)))) + (:type + (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %d)))" lispname + (format nil "SIGNED_(~A)" cname) + (format nil "(8*sizeof(~A))" cname))) + (:string + (printf "(cl:defparameter ~A %s \"~A\"" lispname doc + cname)) + (:function + (printf "(cl:declaim (cl:inline ~A))" lispname) + (destructuring-bind (f-cname &rest definition) cname + (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname) + (printf "~{ ~W~^\\n~})" definition))) + (:structure + (c-for-structure lispname cname)) + (otherwise + ;; should we really not sprechen espagnol, monsieurs? + (error "Unknown grovel keyword encountered: ~A" type))) + (when export + (printf "(cl:export '~A)" lispname)))) (as-c "return 0;") (as-c "}"))) @@ -136,72 +155,90 @@ code: (define-condition c-compile-failed (compile-failed) () (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (define-condition a-dot-out-failed (compile-failed) () (:report (lambda (c s) - (format s "~@" - (error-operation c) (error-component c))))) + (format s "~@" + (error-operation c) (error-component c))))) (defmethod asdf:perform ((op asdf:compile-op) - (component grovel-constants-file)) + (component grovel-constants-file)) ;; we want to generate all our temporary files in the fasl directory ;; because that's where we have write permission. Can't use /tmp; ;; it's insecure (these files will later be owned by root) (let* ((output-file (car (output-files op component))) - (filename (component-pathname component)) - (real-output-file - (if (typep output-file 'logical-pathname) - (translate-logical-pathname output-file) - (pathname output-file))) - (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) - (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file)) - (tmp-constants (merge-pathnames #p"constants.lisp-temp" - real-output-file))) + (filename (component-pathname component)) + (real-output-file + (if (typep output-file 'logical-pathname) + (translate-logical-pathname output-file) + (pathname output-file))) + (tmp-c-source (merge-pathnames #p"foo.c" real-output-file)) + (tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe" + real-output-file)) + (tmp-constants (merge-pathnames #p"constants.lisp-temp" + real-output-file))) (princ (list filename output-file real-output-file - tmp-c-source tmp-a-dot-out tmp-constants)) + tmp-c-source tmp-a-dot-out tmp-constants)) (terpri) (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL")) - filename tmp-c-source (constants-package component)) - (let ((code (run-shell-command "gcc ~A -o ~S ~S" - (if (sb-ext:posix-getenv "EXTRA_CFLAGS") - (sb-ext:posix-getenv "EXTRA_CFLAGS") - "") - (namestring tmp-a-dot-out) - (namestring tmp-c-source)))) + filename tmp-c-source (constants-package component)) + (let* ((cc (or (sb-ext:posix-getenv "CC") + ;; It might be nice to include a CONTINUE or + ;; USE-VALUE restart here, but ASDF seems to insist + ;; on handling the errors itself. + (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."))) + (code (sb-ext:process-exit-code + (sb-ext:run-program + cc + (append + (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS")) + #+(and linux largefile) + '("-D_LARGEFILE_SOURCE" + "-D_LARGEFILE64_SOURCE" + "-D_FILE_OFFSET_BITS=64") + (list "-o" + (namestring tmp-a-dot-out) + (namestring tmp-c-source))) + :search t + :input nil + :output *trace-output*)))) (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'c-compile-failed :operation op :component component))))) - (let ((code (run-shell-command "~A >~A" - (namestring tmp-a-dot-out) - (namestring tmp-constants)))) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'c-compile-failed :operation op :component component))))) + (let ((code (sb-ext:process-exit-code + (sb-ext:run-program (namestring tmp-a-dot-out) + (list (namestring tmp-constants)) + :search nil + :input nil + :output *trace-output*)))) (unless (= code 0) - (case (operation-on-failure op) - (:warn (warn "~@" - op component)) - (:error - (error 'a-dot-out-failed :operation op :component component))))) + (case (operation-on-failure op) + (:warn (warn "~@" + op component)) + (:error + (error 'a-dot-out-failed :operation op :component component))))) (multiple-value-bind (output warnings-p failure-p) - (compile-file tmp-constants :output-file output-file) + (compile-file tmp-constants :output-file output-file) (when warnings-p - (case (operation-on-warnings op) - (:warn (warn - (formatter "~@") - op component)) - (:error (error 'compile-warned :component component :operation op)) - (:ignore nil))) + op component)) + (:error (error 'compile-warned :component component :operation op)) + (:ignore nil))) (when failure-p - (case (operation-on-failure op) - (:warn (warn - (formatter "~@") - op component)) - (:error (error 'compile-failed :component component :operation op)) - (:ignore nil))) + op component)) + (:error (error 'compile-failed :component component :operation op)) + (:ignore nil))) (unless output - (error 'compile-error :component component :operation op))))) + (error 'compile-error :component component :operation op)))))