Mon May 25 20:39:33 CEST 2009  Tobias Rautenkranz <tobias@rautenkranz.ch>
  * speed up get-struct-slot-value & cleanup
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp	2014-12-22 09:40:03.000000000 +0100
+++ new-smoke/src/clos.lisp	2014-12-22 09:40:04.000000000 +0100
@@ -358,11 +358,6 @@
 (defmethod convert-to-class (smoke-class (object smoke-standard-object))
   (cast object smoke-class))
 
-(defun make-smoke-constructor (class args)
-  (find-method-using-args class
-                          (name class)
-                          args))
-
 (defun call-constructor (object arguments)
   (if (null arguments)
       (let ((method (find-smoke-method (class-of object)
diff -rN -u old-smoke/src/marshall.lisp new-smoke/src/marshall.lisp
--- old-smoke/src/marshall.lisp	2014-12-22 09:40:03.000000000 +0100
+++ new-smoke/src/marshall.lisp	1970-01-01 01:00:00.000000000 +0100
@@ -1,152 +0,0 @@
-(in-package :smoke)
-
-(declaim (optimize (debug 3)))
-
-(defmacro average (&rest args)
-  `(floor (+ ,@args) ,(length args)))
-  
-
-(defun binary-find (lower upper < =)
-  (let ((mid (average lower upper)))
-    (if (= mid lower)
-        nil
-        (if (funcall = mid)
-            mid
-            (if (funcall < mid)
-                (binary-find lower mid < =)
-                (binary-find mid upper < =))))))
-
-(defun serach-method (smoke name)
-  (binary-find 1 (smoke-method-name-size smoke)
-               #'(lambda (index)
-                   (string< name
-                            (smoke-get-method-name smoke index)))
-               #'(lambda (index)
-                   (string= name
-                            (smoke-get-method-name smoke index)))))
-
-(defun find-last (lower upper =)
-  (if (or (>= lower upper)
-          (not (funcall = (1+ lower))))
-      lower
-     (find-last (1+ lower) upper =)))
-  
-                    
-(defun find-methods (smoke name)
-  (let* ((index (serach-method smoke name))
-         (= #'(lambda (index)
-                (string= name
-                         (smoke-get-method-name smoke index)
-                         :end2 (length name))))
-         (upper (find-last index (smoke-method-name-size smoke) =))
-         (methods nil))
-    (loop for i from index to upper do
-         (push (smoke-get-method-name smoke i)
-               methods))
-    methods))
-         
-                    
-
-;(defmethod exact-match ((object singl-float) type))
-(defun type-equal (type type-name)
-  (equal (name type) type-name))
-
-(defun exact-match (object type)
-  (format t "~A ~A~%" object (name type))
-  (ctypecase object 
-    (smoke-standard-object
-     (and (class-p type)
-          (derived-p (class-of object)
-                     (get-class type))))
-    (double-float (type-equal type "double"))
-    (single-float (type-equal type "float"))
-    (integer (type-equal type "int"))
-    (string (or (type-equal type "const char*")
-                (type-equal type "const QString&")))
-    (character (type-equal type "char"))))
-
-(defun exact-match-p (arguments types)
-  (if (or (null arguments) (null types))
-      (and (null arguments)
-           (null types))
-      (if (not (exact-match (first arguments)
-                            (first types)))
-          nil
-          (exact-match-p (rest arguments)
-                         (rest types)))))
-               
-(defun promotion-match (object type)
-  (ctypecase object
-    (character (type-equal type "int"))
-    (float (type-equal type "double"))
-    (boolean (type-equal type "int"))))
-
-(defun standard-conversion-match (object type)
-  (ctypecase object
-    (number (or (type-equal type "short")
-                (type-equal type "int")
-                (type-equal type "long")))))
-
-(defun constructor-match (object type)
-  (if (class-p type)
-      (let ((constructor (make-smoke-constructor (get-class type)
-                              (mung-arg object))))
-        (exact-match object (get-first-argument constructor)))
-      nil))
-  
-(defun find-ambiguous-method (predicate method)
-  (let ((index (- (id method))))
-    (loop as i = (smoke-ambiguous-method (smoke method)
-                                         index)
-       while (> i 0) do
-       (incf index)
-       (let ((ambiguous-method (make-instance 'smoke-method
-                                              :smoke (smoke method)
-                                              :id i)))
-         (when (funcall predicate ambiguous-method)
-           (return ambiguous-method))))))
-
-(defun find-method-using-args (class name arguments)
-  (with-foreign-object (m 'smoke-module-index)
-    (smoke-find-method m (smoke class) (id class)
-                       (concatenate 'string name
-                                    (munged-args arguments)))
-    (let ((method (make-instance 'smoke-method
-                                 :smoke (foreign-slot-value m
-                                                            'smoke-module-index
-                                                            'smoke)
-                                 :id (foreign-slot-value m
-                                                         'smoke-module-index
-                                                         'index))))
-      (when (< (id method) 0)
-        (setf method
-              (find-ambiguous-method #'(lambda (method)
-                                         (exact-match-p arguments (arguments method)))
-                                     method))
-        (assert (not (null method)) (method)
-                "No method ~A::~A for the arguments ~A"
-                (name class) name arguments))
-      method)))
-
-
-(defgeneric get-convert-function (to from))
-(defmethod get-convert-function ((to eql 'int) (from eql 'char)))
-(defmethod get-convert-function ((to cxx::int) (from string)))
-
-(get-convert-function 'int 'char)
-
-;'const int 'char:
-(get-convert-function 'int 'char)
-&& (convert-const-p 'char)
-
-;'int 'const char:
-(get-convert-function 'int 'char)
-&& (not (const-p 'char))
-
-
-(defclass int ()
-  ((const-p)))
-
-(defun get-convert-function (to from))
-
- 
diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp
--- old-smoke/src/objects/method.lisp	2014-12-22 09:40:03.000000000 +0100
+++ new-smoke/src/objects/method.lisp	2014-12-22 09:40:04.000000000 +0100
@@ -76,114 +76,6 @@
                    :id (foreign-slot-value m 'smoke-module-index 'index)
                    :smoke (foreign-slot-value m 'smoke-module-index 'smoke))))
 
-(defun type-equal (type type-name)
-  "Returns true when TYPE is of the type named TYPE-NAME and false otherwise."
-  (equal (name type) type-name))
-
-(defun exact-match (object type)
-  "Returns true when the type of OBJECT is exactly the same as TYPE and
-false otherwise."
-  (ctypecase object 
-    (smoke-standard-object
-     (and (class-p type)
-          (derived-p (class-of object)
-                     (get-class type))))
-    (double-float (type-equal type "double"))
-    (single-float (type-equal type "float"))
-    (integer (type-equal type "int"))
-                 ;; int is also enum
-                 ;; FIXME remove magic number 12
-                 ;;(= (type-id type) 12)))
-    (string (or (type-equal type "const char*")
-                (type-equal type "const QString&")))
-    (enum (smoke-type= (enum-type object)
-                     type))
-    (sequence (type-equal type "const QStringList&"))
-    (character (type-equal type "char"))))
-
-(defun exact-match-p (arguments types)
-  "Returns true when all the type of ARGUMENTS is the same as the
-corresponing type of TYPES and the length of the ARGUMENTS and TYPES list
-is equal."
-  (if (or (null arguments) (null types))
-      (and (null arguments)
-           (null types))
-      (if (not (exact-match (first arguments)
-                            (first types)))
-          nil
-          (exact-match-p (rest arguments)
-                         (rest types)))))
-
-(defun mung-arg (argument)
-  "Returns the mung char for ARUGMENT."
-  ;; FIXME void* is #\$ but void[] is #\?
-  ;; FIXME Get rid of the mugging stuff and compute the applicable methods
-  ;;  including argument promotion
-  (case argument
-    ((t nil) #\$) ;; Booleans
-    (otherwise
-     (ctypecase argument
-       (number #\$)
-       (character #\$)
-       (string #\$)
-       (foreign-pointer #\?)
-       (sequence #\?)
-       (enum #\$)
-       (smoke-standard-object #\#)))))
-
-(defun munged-args (arguments &optional (string nil))
-  "Maps the type of every item of ARGUMENTS to a char;
-Returns the list of the chars."
-  (if (null arguments)
-      string
-      (munged-args (rest arguments)
-                   (append string (list (mung-arg (first arguments)))))))
-
-(defun find-ambiguous-method (predicate method)
-  "Returns a method of the ambiguous method METHOD such that
-PREDICATE is true. NIL is returned when no matching method is found."
-  (assert (ambiguous-p method)
-          (method)
-          "The method is not ambiguous.")
-  (let ((index (- (id method))))
-    (loop as i = (smoke-ambiguous-method (smoke method)
-                                         index)
-       while (> i 0) do
-       (incf index)
-       (let ((ambiguous-method (make-instance 'smoke-method
-                                              :smoke (smoke method)
-                                              :id i)))
-         (when (funcall predicate ambiguous-method)
-           (return ambiguous-method))))))
-
-(defun find-method-using-args (class name arguments)
-  "Returns the method of class CLASS with the name NAME
-for the arguments ARGUMENTS."
-  (with-foreign-object (m 'smoke-module-index)
-    (smoke-find-method m (smoke class) (id class)
-                       (concatenate 'string name
-                                    (munged-args arguments)))
-    (let ((method (make-instance 'smoke-method
-                                 :smoke (foreign-slot-value m
-                                                            'smoke-module-index
-                                                            'smoke)
-                                 :id (foreign-slot-value m
-                                                         'smoke-module-index
-                                                         'index))))
-      (assert (valid-p method)
-              (method)
-              "No method ~A::~A for the arguments ~A" (name class) name arguments)
-      (when (ambiguous-p method)
-        (setf method
-              (find-ambiguous-method #'(lambda (method)
-                                         (exact-match-p arguments (arguments method)))
-                                     method))
-        (assert (not (null method)) (method)
-                "No method ~A::~A for the arguments ~A"
-                (name class) name arguments))
-      method)))
-
-
 (defun map-methods (function smoke)
   "Applys FUNCTION to the methods of SMOKE.
 The method argument to function must not be modified."
@@ -198,13 +90,16 @@
          (setf (slot-value method 'id) id)
          (funcall function method))))
 
-(defmethod get-struct-slot-value ((method smoke-method) slot-name)
+(defun method-slot-value (method slot-name)
+  (declare (smoke-method method)
+           (symbol slot-name)
+           (optimize (speed 3)))
   (foreign-slot-value (smoke-get-method (smoke method) (id method))
                       'smoke-method slot-name))
 
 (defmethod name ((method smoke-method))
   (smoke-get-method-name (smoke method)
-                         (get-struct-slot-value method 'name)))
+                         (method-slot-value method 'name)))
 
 (defun signature (method)
   "Returns the signature of METHOD."
@@ -226,7 +121,7 @@
 (defun return-type (method)
   "Returns the return type of METHOD."
   (make-instance 'smoke-type
-                 :id (get-struct-slot-value method 'return-type)
+                 :id (method-slot-value method 'return-type)
                  :smoke (smoke method)))
 
 (defun method-declaration (method)
@@ -240,7 +135,7 @@
   (:documentation "Returns the value for FLAG of OBJECT."))
 
 (defmethod get-flag ((method smoke-method) flag)
-  (logand (get-struct-slot-value method 'flags)
+  (logand (method-slot-value method 'flags)
           (foreign-enum-value 'smoke-method-flags flag)))
 
 (defgeneric constructor-p (object)
@@ -279,7 +174,7 @@
 
 (defmethod get-class ((method smoke-method))
   (make-instance 'smoke-class
-                 :id (get-struct-slot-value method 'class)
+                 :id (method-slot-value method 'class)
                  :smoke (smoke method)))
 
   
@@ -310,18 +205,18 @@
 
 (defun get-arguments-length (method)
   "Returns the number of arguments for METHOD."
-  (get-struct-slot-value method 'num-args))
+  (method-slot-value method 'num-args))
     
 (defun get-first-argument (method)
   "Returns the first argument of METHOD"
   (make-instance 'smoke-argument
-                 :id (get-struct-slot-value method 'arguments)
+                 :id (method-slot-value method 'arguments)
                  :smoke (smoke method)))
 
 (defun get-argument (method index)
   "Returns the type of METHODs argument with number INDEX."
   (make-instance 'smoke-argument
-                 :id (+ (get-struct-slot-value method 'arguments) index)
+                 :id (+ (method-slot-value method 'arguments) index)
                  :smoke (smoke method)))
 
 
diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp
--- old-smoke/src/objects/type.lisp	2014-12-22 09:40:03.000000000 +0100
+++ new-smoke/src/objects/type.lisp	2014-12-22 09:40:04.000000000 +0100
@@ -13,7 +13,10 @@
 (defmethod smoke::smoke ((type smoke-lazy-type))
   (eval (smoke-symbol type)))
 
-(defmethod get-struct-slot-value ((type smoke-type) slot-name)
+(defun type-slot-value (type slot-name)
+  (declare (smoke-type type)
+           (symbol slot-name)
+           (optimize (speed 3)))
   (foreign-slot-value (smoke-get-type (smoke type) (id type))
                       'smoke-type slot-name))
 
@@ -24,7 +27,7 @@
                  :smoke smoke))
 
 (defmethod name ((type smoke-type))
-  (get-struct-slot-value type 'name))
+  (type-slot-value type 'name))
 
 (defun smoke-type= (type1 type2)
   (and t ;(pointer-eq (smoke type1)
@@ -33,12 +36,12 @@
           (id type2))))
 
 (defmethod get-flag ((type smoke-type) flag)
-  (logand (get-struct-slot-value type 'flags)
+  (logand (type-slot-value type 'flags)
           #xF0 ;; = ! 0x0F
           (foreign-enum-value 'smoke-type-flags flag)))
 
 (defun get-allocation-flag (type)
-  (logand (get-struct-slot-value type 'flags)
+  (logand (type-slot-value type 'flags)
           #x30))
 
 (defun stack-p (type)
@@ -60,11 +63,11 @@
 (defun class-p (type)
   "Returns T when TYPE is a smoke class"
   (and (eql (type-id type) 13)
-       (/= -1 (get-struct-slot-value type 'class))))
+       (/= -1 (type-slot-value type 'class))))
 
 (defun type-id (type)
   "Returns the ID of TYPE."
-  (logand (get-struct-slot-value type 'flags)
+  (logand (type-slot-value type 'flags)
           (foreign-enum-value 'smoke-type-flags :type-id)))
 
 (defun void-p (type)
@@ -76,11 +79,11 @@
 
 (defmethod get-class ((type smoke-type))
   "Return the smoke-class of TYPE."
-  (assert (/= -1 (get-struct-slot-value type 'class))
+  (assert (/= -1 (type-slot-value type 'class))
           (type)
           "The type ~S is not a smoke class." (name type))
   (make-instance 'smoke-class
-                 :id (get-struct-slot-value type 'class)
+                 :id (type-slot-value type 'class)
                  :smoke (smoke type)))