repos / smoke / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Fix attribute vs method map to same Lisp name clash.
Annotate for file /src/smoke-to-clos.lisp
2009-04-05 tobias 1 (in-package :smoke)
15:36:29 ' 2
2009-06-11 tobias 3 (defun constant-definition (package method smoke)
2009-04-05 tobias 4 "Returns an expression that defines a constant for the enum METHOD.
15:36:29 ' 5 The second return value is the expression to export the constant."
' 6 (let ((symbol
2009-09-09 tobias 7 (if (or (string= (name (get-class method))
13:22:32 ' 8 "Qt")
' 9 (string= (name (get-class method))
' 10 "QGlobalSpace"))
2009-04-05 tobias 11 (lispify (concatenate 'string "+" (name method)
2009-06-11 tobias 12 "+")
2009-08-30 tobias 13 package)
2009-04-05 tobias 14 (lispify (concatenate 'string
15:36:29 ' 15 (name (get-class method))
' 16 ".+"
2009-06-11 tobias 17 (name method) "+")
2009-08-30 tobias 18 package))))
2009-04-05 tobias 19 (values
2009-08-30 tobias 20 (if (= 8 (type-id (return-type method)))
2010-01-10 tobias 21 `(define-constant ,symbol ;; a long, not really an enum.
2009-08-30 tobias 22 ,(enum-call method))
13:51:40 ' 23 `(define-constant ,symbol
' 24 (make-instance 'enum
' 25 :value ,(enum-call method)
' 26 :type (make-instance 'smoke-type
' 27 :id ,(id (return-type method))
' 28 :smoke ,smoke))
' 29 :test #'enum=))
2009-05-14 tobias 30 symbol)))
2009-04-05 tobias 31
2009-06-11 tobias 32 (defun static-method-symbol (package method)
2009-04-05 tobias 33 "Returns the lisp symbol for the static method METHOD."
15:36:29 ' 34 (let ((class (get-class method)))
' 35 (lispify (concatenate 'string
' 36 (if (string= (name class)
' 37 "QGlobalSpace")
' 38 nil
' 39 (concatenate 'string
' 40 (name class)
' 41 "."))
2009-06-11 tobias 42 (name method))
14:35:40 ' 43 package)))
2009-04-05 tobias 44
2009-06-11 tobias 45 (defun static-method-definition (package method &optional (argument-count -1))
2009-04-05 tobias 46 "Returns an expression to define a function for the static METHOD.
15:36:29 ' 47 The second return value is the expression to export the function."
' 48 (let* ((class (get-class method))
' 49 (method-name (name method))
2009-06-11 tobias 50 (name (static-method-symbol package method)))
2009-04-05 tobias 51 (values
2009-05-11 tobias 52 `(defun ,name ,(if (< argument-count 0)
20:18:23 ' 53 '(&rest args)
' 54 (make-lambda argument-count))
2010-01-10 tobias 55 (call-using-args
08:49:36 ' 56 (find-class (quote ,(lispify (name class)
' 57 (if (string= (name class)
' 58 "QGlobalSpace")
' 59 *package* ;; See #'MAKE-SMOKE-CLASSES
' 60 package))))
' 61 ,method-name
' 62 ,(if (< argument-count 0)
' 63 'args
' 64 `(list ,@(make-lambda argument-count)))))
2009-05-14 tobias 65 name)))
2009-04-05 tobias 66
2009-05-19 tobias 67 (defun ensure-generic-methods (symbols-names)
11:09:12 ' 68 "Ensures the generic functions for SYMBOLS-NAMES."
' 69 (declare (list symbols-names)
' 70 (optimize (speed 3)))
' 71 (dolist (symbol-name symbols-names)
' 72 (ensure-generic-function (first symbol-name)
' 73 :cxx-name (rest symbol-name)
2009-04-12 tobias 74 :generic-function-class 'smoke-gf
14:43:33 ' 75 :lambda-list '(object &rest args))
2009-05-19 tobias 76 (export (first symbol-name) :cxx)))
11:09:12 ' 77
2009-05-11 tobias 78 (defun setf-method-definition (method)
17:55:42 ' 79 `(defun (setf ,(lispify (subseq (name method) 3) :cxx)) (new-value object)
' 80 (,(lispify (name method) :cxx) object new-value)
' 81 new-value))
' 82
2009-06-22 tobias 83 (defmacro sizes= ((smoke)&rest arrays)
12:18:08 ' 84 `(and ,@(loop for array in arrays collect
' 85 `(= (smoke-array-length (,array ,smoke))
' 86 ,(smoke-array-length (funcall (fdefinition array)
' 87 (eval smoke)))))))
' 88
2009-04-05 tobias 89 (defmacro check-recompile (smoke)
2010-01-10 tobias 90 "Raises an error or tries to recompile when the fasl of the define-classes-and-gfs
17:30:48 ' 91 was not compiled against the current smoke module."
' 92 (with-unique-names (restart)
' 93 `(eval-when (:load-toplevel :execute)
' 94 (unless (sizes= (,smoke)
' 95 smoke-module-methods
' 96 smoke-module-method-names
' 97 smoke-module-method-maps
' 98 smoke-module-classes
' 99 smoke-module-types)
' 100 (let ((,restart (find-restart 'asdf:try-recompiling)))
' 101 (if ,restart
' 102 (invoke-restart ,restart)
' 103 (error "The smoke module ~A changed, you need to recompile the lisp file."
' 104 (smoke-get-module-name (smoke-module-pointer ,smoke)))))))))
2009-04-05 tobias 105
2009-06-11 tobias 106 (defmacro define-classes-and-gfs (package smoke)
2009-04-05 tobias 107 "Process the C++ methods of the Smoke module SMOKE.
15:36:29 ' 108 Expands to DEFUNs for static methods, DEFINE-CONSTANTs for enum methods
' 109 and a function do define the generic methods a load-time."
' 110 ;;; symbol - id pairs are stored in the hash-tables to prevent the
2009-07-01 tobias 111 ;;; multiple definition of a function with the same name.
2009-04-05 tobias 112 (let ((generics (make-hash-table))
15:36:29 ' 113 (constants)
' 114 (functions)
' 115 (function-symbols (make-hash-table))
2009-05-11 tobias 116 (setf-function-symbols (make-hash-table))
2009-04-05 tobias 117 (exports))
15:36:29 ' 118 (map-methods
' 119 #'(lambda (method)
2010-01-10 tobias 120 (when (and (enum-p method)
08:49:36 ' 121 ;; qt.network has QIODevice::NotOpen(), but the
' 122 ;; class is external (workaround).
' 123 (not (external-p (get-class method))))
2009-06-11 tobias 124 (multiple-value-bind (def export) (constant-definition package method smoke)
2009-04-05 tobias 125 (push def
15:36:29 ' 126 constants)
' 127 (push export exports)))
' 128 (when (and (not (destructor-p method))
' 129 (not (constructor-p method))
' 130 (not (enum-p method))
' 131 (not (eql nil (name method)))
2009-07-01 tobias 132 (string/= (name method) "tr")) ;; we have a custom qt:tr function
2009-05-11 tobias 133 (let ((name (name method)))
17:55:42 ' 134 (when (and (starts-with-subseq "set" name)
' 135 (> (length name) 3)
' 136 (upper-case-p (char name 3))
' 137 (= 1 (get-arguments-length method)))
' 138 (unless (nth-value 1 (gethash (lispify name :cxx) setf-function-symbols))
' 139 (setf (gethash (lispify name :cxx) setf-function-symbols) t)
' 140 (push (setf-method-definition method) functions)))
2010-04-03 tobias 141 (let ((lisp-name (lispify name "CXX")))
12:03:07 ' 142 (unless (and (gethash lisp-name generics) (attribute-p method))
' 143 (setf (gethash lisp-name generics) name))))
2009-04-05 tobias 144 (when (static-p method)
2009-06-11 tobias 145 (let* ((function-symbol (static-method-symbol package method))
2009-05-11 tobias 146 (methods (gethash function-symbol function-symbols)))
2010-01-10 tobias 147 (unless (fboundp function-symbol) ;; do not overwrite
08:49:36 ' 148 ;; existing functions e.g. qInstallMsgHandler of
' 149 ;; qt.core with that of qt.gui which causes a
' 150 ;; segfault when loading from an saved image.
' 151 (setf (gethash function-symbol function-symbols)
' 152 (if methods (- (id method)) (id method))))))))
2009-04-05 tobias 153 (eval smoke))
2009-05-11 tobias 154 (loop for id being the hash-values of function-symbols do
2009-06-22 tobias 155 (let ((method (make-smoke-method
12:18:08 ' 156 :smoke (eval smoke)
' 157 :id (abs id))))
2009-05-11 tobias 158 (multiple-value-bind (definition export)
20:18:23 ' 159 (static-method-definition
2009-06-11 tobias 160 package
2009-05-11 tobias 161 method
20:18:23 ' 162 (if (< 0 id)
' 163 (get-arguments-length method)
' 164 -1))
' 165 (push definition functions)
' 166 (push export exports))))
2009-04-05 tobias 167 `(progn (check-recompile ,smoke)
15:36:29 ' 168 ,@functions
2010-01-17 tobias 169 (eval-startup (:compile-toplevel :load-toplevel :execute)
2010-01-23 tobias 170 ;; FIXME when loading the Lisp image we no longer need
19:45:41 ' 171 ;; to call #'ensure-class, but the class-map needs still
2010-01-17 tobias 172 ;; to be populated by #'add-id-class-map and #'add-id;
21:04:08 ' 173 ;; For now we ignore the negligible overhead.
' 174 (make-smoke-classes ,package ,smoke))
2009-07-08 tobias 175 (eval-when (:load-toplevel :execute)
2009-05-19 tobias 176 (ensure-generic-methods ',(hash-table-alist generics)))
2009-04-05 tobias 177 ,@constants
2009-05-19 tobias 178 (eval-when (:load-toplevel :execute)
2009-06-11 tobias 179 (export (quote ,exports) ,package)))))
2009-04-05 tobias 180
Crece desde el pueblo el futuro / crece desde el pie