-(in-package :SB-GROVEL)
-(defvar *export-symbols* nil)
+(in-package #:sb-grovel)
-(defun c-for-structure (stream lisp-name c-struct)
- (destructuring-bind (c-name &rest elements) c-struct
- (format stream "printf(\"(sb-grovel::define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
- (dolist (e elements)
- (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
- (format stream "printf(\"(sb-grovel::define-c-accessor ~A-~A ~A ~A \");~%"
- lisp-name lisp-el-name lisp-name lisp-type)
- ;; offset
- (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
- c-name c-el-name)
- ;; length
- (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
- c-name c-el-name)
- (format stream "printf(\")\\n\");~%")))))
+(defvar *default-c-stream* nil)
+
+(defun escape-for-string (string)
+ (c-escape string))
+
+(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))
+
+(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.
+The first argument is the C string that should be passed to
+printf.
-(defun c-for-function (stream lisp-name alien-defn)
- (destructuring-bind (c-name &rest definition) alien-defn
- (let ((*print-right-margin* nil))
- (format stream "printf(\"(cl:declaim (cl:inline ~A))\\n\");~%"
- lisp-name)
- (princ "printf(\"(sb-grovel::define-foreign-routine (" stream)
- (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
- (princ lisp-name stream)
- (princ " ) " stream)
- (terpri stream)
- (dolist (d definition)
- (write d :length nil
- :right-margin nil :stream stream)
- (princ " " stream))
- (format stream ")\\n\");")
- (terpri stream))))
+The rest of the arguments are consumed by FORMAT clauses, until
+there are no more FORMAT clauses to fill. If there are more
+arguments, they are emitted as printf arguments.
+There is no error checking done, unless you pass too few FORMAT
+clause args. I recommend using this formatting convention in
+code:
+
+ (printf \"string ~A ~S %d %d\" format-arg-1 format-arg-2
+ printf-arg-1 printf-arg-2)"
+ (let ((*print-pretty* nil))
+ (apply #'format *default-c-stream*
+ " printf (\"~@?\\n\"~@{, ~A~});~%"
+ (c-escape formatter)
+ args)))
+
+(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))
+ (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 "))")))
(defun print-c-source (stream headers definitions package-name)
- (let ((*print-right-margin* nil))
- (format stream "#define SIGNEDP(x) (((x)-1)<0)~%")
- (format stream "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")~%")
- (loop for i in headers
+ (declare (ignorable definitions package-name))
+ (let ((*default-c-stream* stream)
+ (*print-right-margin* nil))
+ (loop for i in (cons "stdio.h" headers)
do (format stream "#include <~A>~%" i))
- (format stream "main() { ~%
-printf(\"(in-package ~S)\\\n\");~%" package-name)
- (format stream "printf(\"(cl:deftype int () '(%ssigned-byte %d))\\\n\",SIGNED_(int),8*sizeof (int));~%")
- (format stream "printf(\"(cl:deftype char () '(%ssigned-byte %d))\\\n\",SIGNED_(char),8*sizeof (char));~%")
- (format stream "printf(\"(cl:deftype long () '(%ssigned-byte %d))\\\n\",SIGNED_(long),8*sizeof (long));~%")
- (format stream "printf(\"(cl:defconstant size-of-int %d)\\\n\",sizeof (int));~%")
- (format stream "printf(\"(cl:defconstant size-of-char %d)\\\n\",sizeof (char));~%")
- (format stream "printf(\"(cl:defconstant size-of-long %d)\\\n\",sizeof (long));~%")
+ (as-c "#define SIGNEDP(x) (((x)-1)<0)")
+ (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
+ (as-c "int main() {")
+ (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
+ ))
+ (printf " (cl:setf (cl:gethash %d *integer-sizes*) 'sb-alien:~A)" (substitute #\- #\Space type)
+ (format nil "sizeof(~A)" type)))
+ (printf ")")
(dolist (def definitions)
- (destructuring-bind (type lispname cname &optional doc) def
- (cond ((eq type :integer)
- (format stream
- "printf(\"(cl:defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
- lispname doc cname))
- ((eq type :type)
- (format stream
- "printf(\"(sb-alien:define-alien-type ~A (sb-alien:%ssigned %d))\\\n\",SIGNED_(~A),8*(sizeof(~A)));~%"
- lispname cname cname))
- ((eq type :string)
- (format stream
- "printf(\"(cl:defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
- lispname doc cname))
- ((eq type :function)
- (c-for-function stream lispname cname))
- ((eq type :structure)
- (c-for-structure stream lispname cname))
- (t
- (format stream
- "printf(\";; Non hablo Espagnol, Monsieur~%")))))
- (format stream "exit(0);~%}")))
+ (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"))
+ (: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 "}")))
(defun c-constants-extract (filename output-file package)
- (with-open-file (f output-file :direction :output)
+ (with-open-file (f output-file :direction :output :if-exists :supersede)
(with-open-file (i filename :direction :input)
(let* ((headers (read i))
(definitions (read i)))
(defclass grovel-constants-file (asdf:cl-source-file)
((package :accessor constants-package :initarg :package)))
+(define-condition c-compile-failed (compile-failed) ()
+ (:report (lambda (c s)
+ (format s "~@<C compiler failed when performing ~A on ~A.~@:>"
+ (error-operation c) (error-component c)))))
+(define-condition a-dot-out-failed (compile-failed) ()
+ (:report (lambda (c s)
+ (format s "~@<a.out failed when performing ~A on ~A.~@:>"
+ (error-operation c) (error-component c)))))
+
(defmethod asdf:perform ((op asdf:compile-op)
(component grovel-constants-file))
;; we want to generate all our temporary files in the fasl directory
(terpri)
(funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
filename tmp-c-source (constants-package component))
- (and
- (= (run-shell-command "gcc -o ~S ~S" (namestring tmp-a-dot-out)
- (namestring tmp-c-source)) 0)
- (= (run-shell-command "~A >~A"
- (namestring tmp-a-dot-out)
- (namestring tmp-constants)) 0)
- (compile-file tmp-constants :output-file output-file))))
+ (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))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
+ 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))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
+ 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)
+ (when warnings-p
+ (case (operation-on-warnings op)
+ (:warn (warn
+ (formatter "~@<COMPILE-FILE warned while ~
+ performing ~A on ~A.~@:>")
+ op component))
+ (:error (error 'compile-warned :component component :operation op))
+ (:ignore nil)))
+ (when failure-p
+ (case (operation-on-failure op)
+ (:warn (warn
+ (formatter "~@<COMPILE-FILE failed while ~
+ performing ~A on ~A.~@:>")
+ op component))
+ (:error (error 'compile-failed :component component :operation op))
+ (:ignore nil)))
+ (unless output
+ (error 'compile-error :component component :operation op)))))