Refactor.
Fri Mar 14 10:23:40 PDT 2008 levente.meszaros@gmail.com
* Refactor.
diff -rN -u old-verrazano/src/backends/cffi/cffi.lisp new-verrazano/src/backends/cffi/cffi.lisp
--- old-verrazano/src/backends/cffi/cffi.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/backends/cffi/cffi.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -16,11 +16,12 @@
:initform nil
:initarg :output-filename
:accessor output-filename-of)
- (const-char-pointer-is-string :initform t
- :initarg :const-char-pointer-is-string
- :accessor const-char-pointer-is-string?))
+ (const-char-pointer-is-string
+ :initform t
+ :initarg :const-char-pointer-is-string
+ :accessor const-char-pointer-is-string?))
(:default-initargs
- :gccxml-node-types-to-output '(gccxml:struct gccxml:typedef gccxml:function gccxml:variable gccxml:macro)
+ :gccxml-node-types-to-output '(gccxml:struct gccxml:class gccxml:typedef gccxml:function gccxml:constructor gccxml:variable gccxml:macro)
:filter-definitions-from-indirect-files t))
(defmethod initialize-instance :after ((self cffi-backend) &key)
@@ -40,39 +41,6 @@
(setf (gethash name (exported-symbols-of *backend*)) t))
name)
-(defmethod is-ready-for-output? ((backend cffi-backend) (node gccxml:functiontype))
- (warn "Skipping ~A because it's a C typedef to a function type, which is not supported by CFFI" node)
- nil)
-
-(defmethod is-ready-for-output? ((backend cffi-backend) (node gccxml:macro))
- ;; skip macros that we can't really deal with or we are not interested in
- ;;(unless (body-of node) (break "A failed to parse macro: ~A" node))
- (and (zerop (length (arguments-of node)))
- (body-of node)))
-
-(defmethod is-ready-for-output? ((backend cffi-backend) (node gccxml:pointertype))
- (unless (is-ready-for-output? backend (type-of node))
- ;; CFFI can more-or-less handle pointers to unknown stuff (i.e. struct field offsets), so it's ok here
- (warn "Reporting ~A to be ready for output even though its target type ~A is not ready. See the code for details."
- node (type-of node)))
- t)
-
-(defmethod enqueue-for-output :around ((backend cffi-backend) (node gccxml:typedef))
- (bind ((type (type-of node)))
- (cond ((and (typep type '(or gccxml:struct gccxml:union))
- (string= (name-of type) (name-of node)))
- ;; if we have a "typedef struct foo {} foo;" then enqueue the artificial struct also
- (enqueue-for-output backend type)
- (call-next-method)
- ;; and mark the typedef as written. the typedef should be kept in the output queue because of various checks that may look for it.
- ;;(mark-definition-as-written backend node)
- )
- ((or (typep (type-of node) 'gccxml:functiontype)
- (and (typep (type-of node) 'gccxml:pointertype)
- (typep (type-of (type-of node)) 'gccxml:functiontype)))
- (warn "Skipping ~A because it's a typedef to a function type, which is not supported by CFFI" node))
- (t (call-next-method)))))
-
;; a mapping from GCCXML type names to CFFI type names
(defparameter *gccxml-fundamental-type->cffi-type*
'(("void" . :void)
diff -rN -u old-verrazano/src/backends/cffi/writers.lisp new-verrazano/src/backends/cffi/writers.lisp
--- old-verrazano/src/backends/cffi/writers.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/backends/cffi/writers.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -1,134 +1,72 @@
(in-package :verrazano)
-(defmethod write-definitions :before ((backend cffi-backend))
- (iter (for (node nil) :in-hashtable (definitions-to-output-of backend))
- (assert (name-of node))))
+(defmethod process-gccxml-node :around ((backend simple-backend) (node gccxml:node-with-name))
+ ;; KLUDGE: ignore STL nodes
+ (bind ((name (gccxml:name-of node)))
+ (unless (find #\< name)
+ (call-next-method))))
-(defmethod write-definitions :around ((backend cffi-backend))
+(defmethod process-gccxml-node :around ((backend cffi-backend) (node gccxml:gcc_xml))
(with-open-file (*standard-output* (output-filename-of backend)
:direction :output :if-exists :supersede)
- (bind ((body (with-output-to-string (*standard-output*)
+ (bind ((package-name (package-name-of backend))
+ (*package* (eval `(defpackage package-name (:use :cffi))))
+ (body (with-output-to-string (*standard-output*)
(call-next-method))))
- (format t ";;; Generated by Verrazano ~A~%" (asdf:component-version
- (asdf:find-system :verrazano)))
- (format t ";;; WARNING: This is a generated file, editing it is unwise!~%~%")
- (format t "(cl:in-package :cl-user)~%")
- (format t "(asdf:operate 'asdf:load-op :verrazano-runtime)~%")
- (format t "~S~%~%" `(defpackage
- ,(package-name-of backend)
- (:use :cffi)
- ,(list* :nicknames (package-nicknames-of backend))
- ,(list* :export (mapcar #'string-upcase
- (hash-table-keys (exported-symbols-of backend))))))
- (format t "(in-package ~S)~%" (package-name-of backend))
+ (write-formatted-text ";;; Generated by Verrazano ~A~%" (asdf:component-version
+ (asdf:find-system :verrazano)))
+ (write-formatted-text ";;; WARNING: This is a generated file, editing it is unwise!~%~%")
+ (write-form '(cl:in-package :cl-user))
+ (write-form '(asdf:operate 'asdf:load-op :verrazano-runtime))
+ (write-form `(defpackage
+ ,package-name
+ (:use :cffi)
+ ,(list* :nicknames (package-nicknames-of backend))
+ ,(list* :export (mapcar #'string-upcase
+ (hash-table-keys (exported-symbols-of backend))))))
+ (write-form `(in-package ,(package-name-of backend)))
+ (write-form '(cl:defun vtable-lookup (pobj indx coff)
+ (cl:let ((vptr (cffi:mem-ref pobj :pointer coff)))
+ (cffi:mem-aref vptr :pointer (- indx 2)))))
+ (write-form '(cl:defmacro virtual-funcall (pobj indx coff &body body)
+ `(cffi:foreign-funcall-pointer (vtable-lookup ,pobj ,indx ,coff) nil ,@body)))
(write-string body))))
-(defun write-composite-cffi-type (backend node type)
- (bind ((definer (ecase type
- (:struct "cffi:defcstruct")
- (:union "cffi:defcunion"))))
- (do-fields-of-composite-type (field node)
- (ensure-definition-is-already-written backend (type-of field)))
- (format t "~%(~A ~A~%" definer (enqueue-for-export
- (transform-name (name-of node) type)))
- (pprint-logical-block (*standard-output* nil :per-line-prefix " ")
- (bind ((bits 0))
- (do-fields-of-composite-type (field node)
- (unless (first-time-p)
- (pprint-newline :mandatory))
- (if (bits-of field)
- (progn
- ;; FIXME
- ;; KLUDGE try to generate sensible output
- (warn-and-write-as-comment
- "Skipping field ~A in ~A because it has a bitfield type which is not yet supported by CFFI! Check the layout manually!"
- field (context-of field))
- (incf bits (bits-of field))
- (cond ((= bits 32)
- (format t "~%(~A :int) ;; generated to pad 32 bits of skipped bitfield typed fields"
- (generate-unique-name "padding"))
- (setf bits 0))
- ((= bits 64)
- (format t "~%(~A :long) ;; generated to pad 64 bits of skipped bitfield typed fields"
- (generate-unique-name "padding"))
- (setf bits 0))))
- (progn
- (unless (zerop bits)
- (setf bits 0)
- ;; FIXME
- (warn-and-write-as-comment
- "Encountered a field while the previous bitfield typed fields do not add up to 32 or 64 bits. The fields offsets will be wrong in ~A!"
- node))
- (bind ((type (type-of field))
- (offset-in-bits (offset-of field))
- ((values offset-in-bytes remainder) (truncate offset-in-bits 8)))
- (declare (ignore offset-in-bytes))
- (if (zerop remainder)
- (progn
- (format t "(~A " (enqueue-for-export
- (transform-name (name-of field) :field)))
- (write-cffi-type type)
- ;; Unfortunately this would be problematic due to the varying size of the pointer type on 32/64 bit platforms
- ;; (format t " :offset ~A" offset-in-bytes)
- (format t ")"))
- (warn-and-write-as-comment
- "The offset of the field ~A in struct ~A is not at byte boundary; skipping it!"
- field (context-of field)))))))))
- (format t ")~%")))
-
-(defun write-composite-cffi-type-field (field)
- (if (bits-of field)
- (warn-and-write-as-comment
- "The field ~A in ~A has a bitfield type which is not yet supported by CFFI; skipping it!"
- field (context-of field))
- (bind ((type (type-of field))
- (offset-in-bits (offset-of field))
- ((values offset-in-bytes remainder) (truncate offset-in-bits 8)))
- (declare (ignore offset-in-bytes))
- (if (zerop remainder)
- (progn
- (format t "(~A " (enqueue-for-export
- (transform-name (name-of field) :field)))
- (write-cffi-type type)
- ;; This is problematic due to the varying size of the pointer type
- ;; (format t " :offset ~A" offset-in-bytes)
- (format t ")"))
- (warn-and-write-as-comment
- "The offset of the field ~A in struct ~A is not at byte boundary; skipping it!"
- field (context-of field))))))
-
-(defmethod write-definition ((backend cffi-backend) (node gccxml:struct))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:struct))
(write-composite-cffi-type backend node :struct))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:union))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:class))
+ (write-composite-cffi-type backend node :class))
+
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:union))
(write-composite-cffi-type backend node :union))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:macro))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:macro))
(assert (body-of node))
(assert (typep (body-of node) '(or string number)))
- (format t "~%(cl:defconstant ~A ~S)"
- (enqueue-for-export
- (transform-name (name-of node) :constant))
- (body-of node)))
+ (write-form `(cl:defconstant ,(symbolify
+ (enqueue-for-export
+ (transform-name (name-of node) :constant)))
+ ,(body-of node))))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:typedef))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:typedef))
(bind ((type (type-of node)))
- (if (and (typep type '(or gccxml:struct gccxml:union))
+ (if (and (typep type '(or gccxml:struct gccxml:class gccxml:union))
(string= (name-of type) (name-of node)))
;; it's an instance of the "deftype struct foo {} foo;" pattern, write the struct/union instead
- (write-definition backend type)
+ (process-gccxml-node backend type)
(progn
(when (string-equal (name-of node) "graph_t")
(break "here: ~A" node))
- (ensure-definition-is-already-written backend type)
+ (process-gccxml-node backend type)
(assert (null (find-node-by-name (name-of node) 'gccxml:struct *parser* :otherwise nil)))
- (ensure-definition-is-already-written backend type)
+ (process-gccxml-node backend type)
(format t "~%(cffi::defctype* ~A " (enqueue-for-export
(transform-name (name-of node) :type)))
(write-cffi-type type)
(format t ")~%")))))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:enumeration))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:enumeration))
(format t "~%(cffi:defcenum ~A~%" (enqueue-for-export
(transform-name (name-of node) :enum)))
(pprint-logical-block (*standard-output* nil :per-line-prefix " ")
@@ -143,40 +81,37 @@
(slot-value enum-value 'gccxml::init))))
(format t ")~%"))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:function))
- (bind ((returns (returns-of node)))
- (ensure-definition-is-already-written backend returns)
- (do-arguments-of-function (argument node)
- (unless (typep argument 'gccxml:ellipsis)
- (ensure-definition-is-already-written backend (type-of argument))))
- (format t "~%(cffi:defcfun (~S ~A) "
- (name-of node)
- (enqueue-for-export
- (transform-name (name-of node) :function)))
- (write-cffi-type returns)
- (pprint-logical-block (*standard-output* nil)
- (bind ((index 0))
- (do-arguments-of-function (argument node)
- (incf index)
- (if (typep argument 'gccxml:ellipsis)
- (write-string "&rest")
- (bind ((argument-name (aif (name-of argument)
- (transform-name it :variable)
- (format nil "arg~A" index)))
- (argument-type (type-of argument)))
- (pprint-newline :fill)
- (format t " (~A " argument-name)
- (write-cffi-type argument-type)
- (format t ")"))))))
- (format t ")~%")))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:constructor))
+ (write-cffi-function backend node)
+ (write-form `(cl:defun ,(symbolify
+ (enqueue-for-export
+ (transform-name (concatenate 'string (name-of node) "-new") :function))) ()
+ (cl:let ((instance (cffi:foreign-alloc ',(symbolify (transform-name (name-of (context-of node)) :class)))))
+ (,(symbolify (transform-name (function-name-of node) :function)) instance)
+ instance))))
-(defmethod write-definition ((backend cffi-backend) (node gccxml:variable))
- (format t "~%(cffi:defcvar (~S ~A) "
- (name-of node)
- (enqueue-for-export
- (transform-name (name-of node) :function)))
- (write-cffi-type (type-of node))
- (format t ")~%"))
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:function))
+ (write-cffi-function backend node))
+
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:variable))
+ (bind ((type (type-of node)))
+ (if (and (typep type 'gccxml:cvqualifiedtype)
+ (const? type))
+ (write-form `(cl:defconstant ,(symbolify
+ (enqueue-for-export
+ (transform-name (name-of node) :constant)))
+ ,(c-literal-to-lisp-literal (slot-value node 'gccxml:init))))
+ (progn
+ (process-gccxml-node backend type)
+ (format t "~%(cffi:defcvar (~S ~A) "
+ (or (mangled-of node) (name-of node))
+ (enqueue-for-export
+ (transform-name (name-of node) :function)))
+ (write-cffi-type type)
+ (format t ")~%")))))
+
+(defmethod process-gccxml-node ((backend cffi-backend) (node gccxml:node-with-type))
+ (process-gccxml-node backend (type-of node)))
(defgeneric write-cffi-type (type))
@@ -187,20 +122,20 @@
`(progn
,@(iter (for (type kind) :in entries)
(collect `(defmethod write-cffi-type ((node ,type))
- (write-string (enqueue-for-export
- (transform-name (name-of node) ,kind)))))))))
+ (if (name-of node)
+ (write-string (enqueue-for-export
+ (transform-name (name-of node) ,kind)))
+ (warn-and-write-as-comment "Skipping anonymous type ~A" node))))))))
(define
(gccxml:struct :struct)
+ (gccxml:class :class)
(gccxml:union :union)
(gccxml:typedef :type)
(gccxml:enumeration :enum)))
(defmethod write-cffi-type ((node gccxml:pointertype))
(bind ((target-type (type-of node)))
- (if (or (typep target-type 'gccxml:functiontype)
- (not (is-enqueued-for-output? *backend* target-type))
- (not (is-definition-already-written? *backend* target-type))
- (not (is-definition-being-written? *backend* target-type)))
+ (if (typep target-type 'gccxml:functiontype)
(write-string ":pointer")
(progn
(write-string "(:pointer ")
@@ -215,19 +150,194 @@
(bind ((count (1+ (parse-integer max))))
(format t " :count ~A" count))))
+(defmethod write-cffi-type ((node gccxml:referencetype))
+ (write-cffi-type (type-of node)))
+
+(defmethod write-cffi-type ((node gccxml:cvqualifiedtype))
+ (write-cffi-type (type-of node)))
+
(defmethod write-cffi-type ((node gccxml:fundamentaltype))
(bind ((gccxml-type (name-of node))
(cffi-type (cdr (assoc gccxml-type *gccxml-fundamental-type->cffi-type* :test #'string=))))
- (assert cffi-type () "No entry found for gccxml type ~S in *GCCXML-FUNDAMENTAL-TYPE->CFFI-TYPE*" gccxml-type)
- (write-keyword cffi-type)))
+ (if cffi-type
+ (write-keyword cffi-type)
+ (warn-and-write-as-comment "No entry found for gccxml type ~S in *GCCXML-FUNDAMENTAL-TYPE->CFFI-TYPE*" gccxml-type))))
+
+(defun write-composite-cffi-type (backend node type)
+ (if (name-of node)
+ (bind ((definer (ecase type
+ (:struct "cffi:defcstruct")
+ (:class "cffi:defcstruct")
+ (:union "cffi:defcunion"))))
+ (do-fields-of-composite-type (field node)
+ (process-gccxml-node backend (type-of field)))
+ (format t "~%(~A ~A~%" definer (enqueue-for-export
+ (transform-name (name-of node) type)))
+ (pprint-logical-block (*standard-output* nil :per-line-prefix " ")
+ (bind ((bits 0))
+ (do-fields-of-composite-type (field node)
+ (unless (first-time-p)
+ (pprint-newline :mandatory))
+ (if (bits-of field)
+ (progn
+ ;; FIXME
+ ;; KLUDGE try to generate sensible output
+ (warn-and-write-as-comment
+ "Skipping field ~A in ~A because it has a bitfield type which is not yet supported by CFFI! Check the layout manually!"
+ field (context-of field))
+ (incf bits (bits-of field))
+ (cond ((= bits 32)
+ (format t "~%(~A :int) ;; generated to pad 32 bits of skipped bitfield typed fields" ;
+ (generate-unique-name "padding"))
+ (setf bits 0))
+ ((= bits 64)
+ (format t "~%(~A :long) ;; generated to pad 64 bits of skipped bitfield typed fields"
+ (generate-unique-name "padding"))
+ (setf bits 0))))
+ (progn
+ (unless (zerop bits)
+ (setf bits 0)
+ ;; FIXME
+ (warn-and-write-as-comment
+ "Encountered a field while the previous bitfield typed fields do not add up to 32 or 64 bits. The fields offsets will be wrong in ~A!"
+ node))
+ (bind ((type (type-of field))
+ (offset-in-bits (offset-of field))
+ ((values offset-in-bytes remainder) (truncate offset-in-bits 8)))
+ (declare (ignore offset-in-bytes))
+ (if (zerop remainder)
+ (progn
+ (format t "(~A " (enqueue-for-export
+ (transform-name (name-of field) :field)))
+ (write-cffi-type type)
+ ;; Unfortunately this would be problematic due to the varying size of the pointer type on 32/64 bit platforms
+ ;; (format t " :offset ~A" offset-in-bytes)
+ (format t ")"))
+ (warn-and-write-as-comment
+ "The offset of the field ~A in struct ~A is not at byte boundary; skipping it!"
+ field (context-of field)))))))))
+ (format t ")~%"))
+ (warn-and-write-as-comment "Skipping anonymous composite type ~A" node)))
+
+(defun write-composite-cffi-type-field (field)
+ (if (bits-of field)
+ (warn-and-write-as-comment
+ "The field ~A in ~A has a bitfield type which is not yet supported by CFFI; skipping it!"
+ field (context-of field))
+ (bind ((type (type-of field))
+ (offset-in-bits (offset-of field))
+ ((values offset-in-bytes remainder) (truncate offset-in-bits 8)))
+ (declare (ignore offset-in-bytes))
+ (if (zerop remainder)
+ (progn
+ (format t "(~A " (enqueue-for-export
+ (transform-name (name-of field) :field)))
+ (write-cffi-type type)
+ ;; This is problematic due to the varying size of the pointer type
+ ;; (format t " :offset ~A" offset-in-bytes)
+ (format t ")"))
+ (warn-and-write-as-comment
+ "The offset of the field ~A in struct ~A is not at byte boundary; skipping it!"
+ field (context-of field))))))
+
+(defun remove-internal-suffix (name)
+ (bind ((suffix " *INTERNAL* "))
+ (if (ends-with-subseq suffix name)
+ (subseq name 0 (- (length name) (length suffix)))
+ name)))
+
+(defgeneric function-name-of (node)
+ (:method ((node gccxml:function))
+ (name-of node))
+
+ (:method ((node gccxml:operatormethod))
+ (concatenate 'string (name-of (context-of node)) "-operator-" (name-of node)))
+
+ (:method ((node gccxml:operatorfunction))
+ (concatenate 'string "operator-" (name-of node)))
+
+ (:method ((node gccxml:constructor))
+ (concatenate 'string (name-of node) "-constructor")))
+
+(defun write-cffi-function (backend node)
+ (bind ((returns
+ (unless (typep node 'gccxml:constructor)
+ (returns-of node))))
+ (when returns
+ (process-gccxml-node backend returns))
+ (do-arguments-of-function (argument node)
+ (unless (typep argument 'gccxml:ellipsis)
+ (process-gccxml-node backend (type-of argument))))
+ (format t "~%(cffi:defcfun (~S ~A) "
+ (or (awhen (mangled-of node)
+ (remove-internal-suffix it))
+ (name-of node))
+ (enqueue-for-export
+ (transform-name (function-name-of node) :function)))
+ (if returns
+ (write-cffi-type returns)
+ (format t ":void"))
+ (pprint-logical-block (*standard-output* nil)
+ (bind ((index 0))
+ (when (typep node '(or gccxml:constructor gccxml:method gccxml:operatormethod))
+ (format t " (this :pointer)"))
+ (do-arguments-of-function (argument node)
+ (incf index)
+ (if (typep argument 'gccxml:ellipsis)
+ (write-string "&rest")
+ (bind ((argument-name (aif (name-of argument)
+ (transform-name it :variable)
+ (format nil "arg~A" index)))
+ (argument-type (type-of argument)))
+ (pprint-newline :fill)
+ (format t " (~A " argument-name)
+ (write-cffi-type argument-type)
+ (format t ")"))))))
+ (format t ")~%")))
;; TODO move them
(defun warn-and-write-as-comment (message &rest args)
(apply #'warn message args)
(format t ";;; ")
- (apply #'format t message args))
+ (apply #'format t message args)
+ (terpri))
(defun write-keyword (keyword)
(assert (keywordp keyword))
(write-char #\:)
(write-string (string-downcase keyword)))
+
+(defun write-form (form)
+ (bind ((*print-pprint-dispatch* (copy-pprint-dispatch)))
+ (set-pprint-dispatch 'symbol
+ (lambda (stream symbol)
+ (bind ((package (symbol-package symbol))
+ (flag (nth-value 1 (find-symbol (symbol-name symbol) package))))
+ (write-string
+ (string-downcase
+ (cond ((and (string= "VERRAZANO" (package-name package))
+ (eq :internal flag))
+ (symbol-name symbol))
+ ((eq package *package*)
+ (symbol-name symbol))
+ ((eq package (find-package :keyword))
+ (concatenate 'string
+ ":"
+ (symbol-name symbol)))
+
+ (t
+ (concatenate 'string
+ (or (first (package-nicknames package))
+ (package-name package))
+ (if (eq :external flag)
+ ":"
+ "::")
+ (symbol-name symbol)))))
+ stream))))
+ (format t "~%~S~%" form)))
+
+(defun write-formatted-text (format &rest args)
+ (apply 'format t format args))
+
+(defun symbolify (name)
+ (intern (string-upcase name)))
diff -rN -u old-verrazano/src/flexml.lisp new-verrazano/src/flexml.lisp
--- old-verrazano/src/flexml.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/flexml.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -153,8 +153,8 @@
slot))
(defgeneric class-name-for-node-name (builder namespace-uri package local-name qualified-name)
- (:method (parser namespace-uri package (local-name string) qualified-name)
- (find-symbol (string-upcase local-name))))
+ (:method (builder namespace-uri package (local-name string) qualified-name)
+ (find-symbol (string-upcase local-name) (default-package-of builder))))
(defgeneric class-for-node-name (builder namespace-uri package local-name qualified-name)
(:method (builder namespace-uri package (local-name string) qualified-name)
diff -rN -u old-verrazano/src/frontend/api.lisp new-verrazano/src/frontend/api.lisp
--- old-verrazano/src/frontend/api.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/api.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -1,7 +1,9 @@
(in-package :verrazano)
(defvar *parser*)
+
(defvar *backend*)
+
(defvar *unique-name-counter*)
(defgeneric make-backend (backend-specification &key &allow-other-keys)
@@ -9,31 +11,5 @@
(assert (null args) () "MAKE-BACKEND was called with both a list BACKEND-SPECIFICATION and keyword args at the same time")
(apply 'make-backend backend-specification)))
-(defgeneric enqueue-for-output (backend node)
- (:documentation "Register the given node for later output. You can override it to force the output of dependent nodes, or for similar tasks."))
-
(defgeneric process-gccxml-node (backend node)
(:documentation "This is the toplevel protocol method called on the root gccxml node which by default calls it on all its subnodes."))
-
-(defgeneric write-definitions (backend)
- (:documentation "This is protocol method calls WRITE-DEFINITION on those gccxml nodes that were enqueued for output in the PROCESS-GCCXML-NODE phase."))
-
-(defgeneric write-definition (backend node)
- (:documentation "The actual output is done in this protocol."))
-
-;;; The rest is an extension to the API supported by SIMPLE-BACKEND
-
-;; TODO use collect-dependencies to sort the definitions, get rid of the ensure-definition-is-already-written garbage
-(defgeneric collect-dependencies (backend node))
-
-(defgeneric is-enqueued-for-output? (backend node))
-
-(defgeneric ensure-ready-for-output (backend node)
- (:documentation "Make sure that NODE is ok for output. This protocol is called before WRITE-DEFINITIONS."))
-
-(defgeneric is-ready-for-output? (backend node)
- (:documentation "Is this node ready to be emitted? This is called by ENSURE-READY-FOR-OUTPUT which dequeues the nodes from the output that are not reported ready."))
-
-(defgeneric remove-from-output (backend node)
- (:documentation "Remove the node from the output that was previously added by ENQUEUE-FOR-OUTPUT."))
-
diff -rN -u old-verrazano/src/frontend/backend.lisp new-verrazano/src/frontend/backend.lisp
--- old-verrazano/src/frontend/backend.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/backend.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -21,7 +21,6 @@
:initform *default-pathname-defaults*
:initarg :working-directory
:accessor working-directory-of)
-
;; the stuff below are used while the generation is running
(temporary-files
:initform (list)
@@ -31,12 +30,12 @@
((definitions-to-output
:initform (make-hash-table :test #'eq)
:accessor definitions-to-output-of)
- (already-written-definitions
- :initform (make-hash-table :test #'eq)
- :accessor already-written-definitions-of)
- (currently-being-written-definitions
+ (already-processed
+ :initform (make-hash-table :test #'equal)
+ :accessor already-processed-of)
+ (currently-being-processed
:initform (list)
- :accessor currently-being-written-definitions-of)
+ :accessor currently-being-processed-of)
(gccxml-node-types-to-output
:initarg :gccxml-node-types-to-output
:accessor gccxml-node-types-to-output-of
@@ -87,179 +86,22 @@
(temporary-directory-of *backend*))
(push it (temporary-files-of *backend*))))
-(defun is-definition-already-written? (backend node)
- (nth-value 1 (gethash node (already-written-definitions-of backend))))
-
-(defun is-definition-being-written? (backend node)
- (not (null (find node (currently-being-written-definitions-of backend)))))
-
-(defun mark-definition-as-written (backend node)
- (setf (gethash node (already-written-definitions-of backend)) t))
+(defmethod process-gccxml-node (backend node)
+ (values))
-(defgeneric ensure-definition-is-already-written (backend node)
- (:documentation "This method is used by the simple backend and derivates to enforce the proper order of output.")
- (:method ((backend simple-backend) (node gccxml:node))
- (when (and (is-enqueued-for-output? backend node)
- (not (is-definition-already-written? backend node))
- (not (is-definition-being-written? backend node)))
- (write-definition backend node)))
- (:method ((backend simple-backend) (node gccxml:pointertype))
- (call-next-method)
- (ensure-definition-is-already-written backend (type-of node))))
-
-(defmethod ensure-ready-for-output ((backend backend) (node gccxml:node))
- (unless (is-ready-for-output? backend node)
- ;; (break "Removing ~A" node)
- (warn "Removing ~A from the output queue because IS-READY-FOR-OUTPUT? not reported it to be ready"
- node)
- (remove-from-output backend node)))
-
-(defmethod remove-from-output ((backend simple-backend) (node t))
- (remhash node (definitions-to-output-of backend)))
-
-(defmethod is-enqueued-for-output? ((backend simple-backend) (node gccxml:node))
- (nth-value 1 (gethash node (definitions-to-output-of backend))))
-
-(defmethod write-definitions ((backend simple-backend))
- (iter (for definition :in (hash-table-keys (definitions-to-output-of backend)))
- (write-definition backend definition)))
-
-(defmethod write-definition :around ((backend simple-backend) (node gccxml:node))
- ;; skip definitions that have been already written
- (when (and (is-enqueued-for-output? backend node)
- (not (is-definition-already-written? backend node))
- (not (is-definition-being-written? backend node)))
- (unwind-protect
- (progn
- (push node (currently-being-written-definitions-of backend))
- (call-next-method))
- (pop (currently-being-written-definitions-of backend)))))
-
-(defmethod write-definition :after ((backend simple-backend) (node gccxml:node))
- (mark-definition-as-written backend node))
-
-(defmethod write-definition ((backend backend) (node t))
- ;;(break "Don't know how to write: ~A" node)
- (warn "Don't know how to write definition ~A with backend ~A, skipping it!" node backend))
+(defmethod process-gccxml-node :around ((backend simple-backend) node)
+ (bind ((already-processed (already-processed-of backend)))
+ (unless (gethash (list backend node) already-processed)
+ (setf (gethash (list backend node) already-processed) t)
+ (call-next-method))))
-(defmethod write-definition :before ((backend simple-backend) (node gccxml:definition))
- (assert (name-of node)))
+(defmethod process-gccxml-node ((backend simple-backend) (node gccxml:gcc_xml))
+ (iter (for child :in-vector (flexml:children-of node))
+ (when (or (not (filter-definitions-from-indirect-files-p backend))
+ (gethash (file-of child) (input-files-of *parser*)))
+ (process-gccxml-node backend child))))
-(defmethod process-gccxml-node :around ((backend simple-backend) (node gccxml:node))
- (bind ((name (slot-value node 'gccxml:name)))
+(defmethod process-gccxml-node :around ((backend simple-backend) (node gccxml:node-with-name))
+ (bind ((name (gccxml:name-of node)))
(when (funcall (name-filter-of backend) name)
(call-next-method))))
-
-(defmethod process-gccxml-node ((backend simple-backend) (node gccxml:node))
- (when (and (funcall (node-filter-of backend) node)
- (typep node 'gccxml:node-with-name)
- (name-of node)
- (not (artificial? node))
- (or (not (slot-boundp backend 'gccxml-node-types-to-output))
- (some (lambda (type)
- (typep node type))
- (gccxml-node-types-to-output-of backend)))
- (or (not (filter-definitions-from-indirect-files-p *backend*))
- (gethash (file-of node) (input-files-of *parser*))))
- (enqueue-for-output backend node)))
-
-(defmethod enqueue-for-output ((backend t) (node t))
- (error "Default ENQUEUE-FOR-OUTPUT reached for node ~A with backend ~A" node backend))
-
-(defmethod enqueue-for-output ((backend simple-backend) (node gccxml:definition))
- (setf (gethash node (definitions-to-output-of backend)) t))
-
-(defmethod enqueue-for-output ((backend simple-backend) (node gccxml:macro))
- (when (and (zerop (length (arguments-of node)))
- (not (zerop (length (raw-body-of node)))))
- (call-next-method)))
-
-(defmethod enqueue-for-output :around ((backend simple-backend) (node gccxml:pointertype))
- (enqueue-for-output backend (type-of node)))
-
-(defmethod enqueue-for-output :around ((backend simple-backend) (node gccxml:cvqualifiedtype))
- (enqueue-for-output backend (type-of node)))
-
-(defmethod enqueue-for-output :around ((backend simple-backend) (node gccxml:fundamentaltype))
- ;; no need to enqueue
- )
-
-(defun enqueue-struct-or-union-dependencies-for-output (backend node)
- (do-fields-of-composite-type (field node)
- (bind ((type (type-of field)))
- (when (typep type 'gccxml:definition)
- (unless (name-of type)
- (bind ((name (concatenate 'string (name-of node) "/" (name-of field))))
- (unless (starts-with-subseq "anonymous%" name)
- (setf name (concatenate 'string "anonymous%" name)))
- (setf (name-of type) name)))
- (enqueue-for-output backend type)))))
-
-(defmethod enqueue-for-output :after ((backend simple-backend) (node gccxml:struct))
- (unless (incomplete? node)
- (enqueue-struct-or-union-dependencies-for-output backend node)))
-
-(defmethod enqueue-for-output :after ((backend simple-backend) (node gccxml:union))
- (enqueue-struct-or-union-dependencies-for-output backend node))
-
-(defmethod enqueue-for-output :after ((backend simple-backend) (node gccxml:typedef))
- (enqueue-for-output backend (type-of node)))
-
-
-
-(defvar *seen-set-for-is-ready-for-output?*)
-
-(defmethod write-definitions :around ((backend simple-backend))
- ;; NOTE this is an :around method on purpose: the ENSURE-READY-FOR-OUTPUT happens before possible backend customizations on WRITE-DEFINITIONS :before
- (bind ((*seen-set-for-is-ready-for-output?* (make-hash-table :test #'eq)))
- (iter (for definition :in (hash-table-keys (definitions-to-output-of backend)))
- (ensure-ready-for-output backend definition)))
- (call-next-method))
-
-(defmethod is-ready-for-output? :around ((backend simple-backend) (node t))
- (assert (boundp '*seen-set-for-is-ready-for-output?*))
- (or (gethash node *seen-set-for-is-ready-for-output?*)
- (progn
- (setf (gethash node *seen-set-for-is-ready-for-output?*) t)
- (call-next-method))))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:function))
- (do-arguments-of-function (argument node :skip-ellipsis t)
- (unless (is-ready-for-output? backend (type-of argument))
- (return-from is-ready-for-output? nil)))
- (is-ready-for-output? backend (returns-of node)))
-
-(defun is-composite-type-ready-for-output? (backend node)
- (do-fields-of-composite-type (field node)
- (unless (is-ready-for-output? backend (type-of field))
- (return-from is-composite-type-ready-for-output? nil)))
- t)
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:struct))
- (is-composite-type-ready-for-output? backend node))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:union))
- (is-composite-type-ready-for-output? backend node))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:typedef))
- (is-ready-for-output? backend (type-of node)))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:variable))
- (is-ready-for-output? backend (type-of node)))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:pointertype))
- (is-ready-for-output? backend (type-of node)))
-
-(defmethod is-ready-for-output? ((backend simple-backend) (node gccxml:arraytype))
- (is-ready-for-output? backend (type-of node)))
-
-(macrolet ((ready (&rest types)
- `(progn
- ,@(iter (for type :in types)
- (collect `(defmethod is-ready-for-output? ((backend simple-backend) (node ,type))
- t))))))
- (ready
- gccxml:fundamentaltype
- gccxml:enumeration
- gccxml:macro))
-
diff -rN -u old-verrazano/src/frontend/driver.lisp new-verrazano/src/frontend/driver.lisp
--- old-verrazano/src/frontend/driver.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/driver.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -16,9 +16,8 @@
(format out "const int __verrazano_binding = 1;"))
(run-gccxml c-file xml-file macro-file)
(bind ((*parser* (parse-gccxml-output xml-file macro-file)))
- (map-gccxml-nodes (lambda (node)
- (process-gccxml-node *backend* node)))
- (write-definitions *backend*)
+ (process-gccxml-node *backend* (flexml:root-of *parser*))
+ #+nil
(break)))
(unless keep-temporary-files
(dolist (file (temporary-files-of *backend*))
@@ -59,4 +58,3 @@
(execute-shell-command
(format nil "cd \"~A\"; cvs -z6 -d :pserver:anoncvs@www.gccxml.org:/cvsroot/GCC_XML co gccxml"
install-path))))))
-
diff -rN -u old-verrazano/src/frontend/filters-and-transformers.lisp new-verrazano/src/frontend/filters-and-transformers.lisp
--- old-verrazano/src/frontend/filters-and-transformers.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/filters-and-transformers.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -11,7 +11,7 @@
(not (starts-with-dash-p name))))
(deftype name-kind ()
- `(member :function :variable :type :enum :enum-value :struct :union :field :constant))
+ `(member :function :variable :type :enum :enum-value :struct :class :union :field :constant))
(defun %standard-name-transformer (input)
(setf input (copy-seq input))
@@ -34,8 +34,11 @@
(defun dashes-to-hyphens (input)
"Replaces _ with - except at the very beginning."
- (substitute #\- #\_ input :start 1))
+ (if (> (length input) 0)
+ (substitute #\- #\_ input :start 1)
+ input))
+#+nil
(defun camel-case-to-hyphened (input)
(if (> (length input) 0)
(string-downcase
@@ -62,3 +65,43 @@
(setf in-uppercase? new-in-uppercase?)))
(write-char char))))
input))
+
+;;; XMLMessage -> xml-message
+;;; getXML -> get-xml
+;;; cMessage -> c-message
+(defun camel-case-to-hyphened (input)
+ "Insert a hyphen before each subsequent uppercase, lowercase alphanumeric characters"
+ (if (> (length input) 0)
+ (string-downcase
+ (with-output-to-string (*standard-output*)
+ (bind (last-char)
+ (flet ((local-write-char (char)
+ (unless (and last-char
+ (char= #\- char)
+ (char= #\- last-char))
+ (write-char char)
+ (setf last-char char))))
+ (iter (for i :upfrom 0)
+ (for char :in-vector input)
+ (for p-char :previous char :initially #\ )
+ ;; transition from uppercase to lowercase
+ (when (and (> i 1)
+ (alpha-char-p p-char)
+ (alpha-char-p char)
+ (upper-case-p p-char)
+ (lower-case-p char))
+ (local-write-char #\-))
+ (unless (zerop i)
+ (local-write-char p-char))
+ ;; transition from alphanumeric to non-alphanumeric
+ ;; transition from lowercase to uppercase
+ (when (or (and (alpha-char-p p-char)
+ (not (alpha-char-p char))
+ (not (char= char #\_)))
+ (and (alpha-char-p p-char)
+ (alpha-char-p char)
+ (lower-case-p p-char)
+ (upper-case-p char)))
+ (local-write-char #\-))
+ (finally (local-write-char char)))))))
+ input))
diff -rN -u old-verrazano/src/frontend/parser.lisp new-verrazano/src/frontend/parser.lisp
--- old-verrazano/src/frontend/parser.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/parser.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -83,7 +83,10 @@
(defclass gccxml:node-with-name (gccxml:node)
((gccxml:name
:initform nil
- :accessor gccxml:name-of)))
+ :accessor gccxml:name-of)
+ (gccxml:mangled
+ :initform nil
+ :accessor gccxml:mangled-of)))
(defclass gccxml:node-with-type (gccxml:node)
((gccxml:type
@@ -128,15 +131,22 @@
:initform nil
:type boolean
:accessor gccxml:incomplete?))
+ (gccxml:class (gccxml:definition gccxml:node-with-members)
+ (gccxml:incomplete
+ :initform nil
+ :type boolean
+ :accessor gccxml:incomplete?))
(gccxml:union (gccxml:definition gccxml:node-with-members))
(gccxml:typedef (gccxml:definition gccxml:node-with-type))
(gccxml:fundamentaltype (gccxml:node-with-name))
(gccxml:pointertype (gccxml:node-with-type))
+ gccxml:offsettype
(gccxml:arraytype (gccxml:node-with-type))
(gccxml:functiontype (gccxml:definition)
(gccxml:returns :type flexml:cross-referenced-node))
- (gccxml:cvqualifiedtype (gccxml:node-with-type))
- gccxml:referencetype
+ (gccxml:cvqualifiedtype (gccxml:node-with-type)
+ (gccxml:const :type boolean :accessor gccxml:const?))
+ (gccxml:referencetype (gccxml:node-with-type))
(gccxml:field (gccxml:node-with-name gccxml:node-with-type)
(gccxml:bits
:initform nil
@@ -145,7 +155,13 @@
(gccxml:offset
:type integer
:accessor gccxml:offset-of))
- gccxml:constructor
+ (gccxml:constructor (gccxml:node-with-name))
+ gccxml:destructor
+ gccxml:converter
+ (gccxml:operatorfunction (gccxml:function))
+ (gccxml:operatormethod (gccxml:function))
+ gccxml:base
+ (gccxml:method (gccxml:function))
(gccxml:file (gccxml:node-with-name))
(gccxml:macro (gccxml:definition)
(gccxml:name
@@ -222,6 +238,10 @@
(setf (gethash name macro-registry) macro-node)))
("#include"
(values))
+ ("#include_next"
+ (values))
+ ("#pragma"
+ (values))
("#undef"
(remhash name (macro-name->macro-node-of *parser*))
(values)))))))
@@ -246,7 +266,13 @@
(when (zerop (length str))
(return-from c-literal-to-lisp-literal))
(flet ((fail ()
- (error "Don't know how to process C literal ~S" str)))
+ (error "Don't know how to process C literal ~S" str))
+ (remove-trailing-size-specifiers (str)
+ (iter (for length = (length str))
+ (for last-char = (elt str (1- length)))
+ (while (member last-char '(#\F #\L #\l #\u) :test #'char=))
+ (setf str (subseq str 0 (1- length))))
+ str))
(cond
((and (starts-with #\( str)
(ends-with #\) str))
@@ -264,14 +290,12 @@
power)
(fail))
(expt 2 power))))
- ((starts-with-subseq "0x" str)
- (parse-number (concatenate 'string "#x" (subseq str 2 nil))))
- ((digit-char-p (elt str 0))
- (iter (for length = (length str))
- (for last-char = (elt str (1- length)))
- (while (member last-char '(#\F #\L) :test #'equalp))
- (setf str (subseq str 0 (1- length))))
- (parse-number str))
+ ((or (starts-with-subseq "0x" str)
+ (starts-with-subseq "#x" str))
+ (parse-number:parse-number (concatenate 'string "#x" (subseq (remove-trailing-size-specifiers str) 2 nil))))
+ ((or (char= #\- (elt str 0))
+ (digit-char-p (elt str 0)))
+ (parse-number:parse-number (remove-trailing-size-specifiers str)))
(t (values)))))
(defgeneric root-namespace-of (parser)
diff -rN -u old-verrazano/src/frontend/utility.lisp new-verrazano/src/frontend/utility.lisp
--- old-verrazano/src/frontend/utility.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/frontend/utility.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -25,7 +25,7 @@
(format *debug-io* "; Return code: ~A~%" return-code)
(if error-handler
(funcall error-handler return-code)
- (error "Command ~S returned ~S" command-string return-code))))))
+ (cerror "Ignore" "Command ~S returned ~S" command-string return-code))))))
(defmacro do-fields-of-composite-type ((variable node) &body body)
`(iter (for ,variable :in-sequence (members-of ,node))
diff -rN -u old-verrazano/src/packages.lisp new-verrazano/src/packages.lisp
--- old-verrazano/src/packages.lisp 2014-07-29 22:01:00.000000000 -0700
+++ new-verrazano/src/packages.lisp 2014-07-29 22:01:00.000000000 -0700
@@ -20,26 +20,39 @@
#:enumeration
#:enumvalue
#:struct
+ #:class
#:union
#:typedef
#:fundamentaltype
#:pointertype
+ #:offsettype
#:arraytype
#:functiontype
#:cvqualifiedtype
#:referencetype
#:field
#:constructor
+ #:destructor
+ #:converter
#:file
#:macro
+ #:operatorfunction
+ #:operatormethod
+ #:base
+ #:method
;; slots
#:name
#:name-of
+ #:mangled
+ #:mangled-of
#:members
#:members-of
#:type
#:type-of
+ #:const
+ #:const?
+ #:init
#:returns
#:returns-of
#:file