Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Fix for Clozure CL
hunk ./src/clos.lisp 314
- ((binding :pointer)
- (method smoke-index)
- (object-ptr :pointer)
- (stack smoke-stack)
- (abstract :boolean))
+ ((binding :pointer)
+ (method smoke-index)
+ (object-ptr :pointer)
+ (stack smoke-stack)
+ (abstract :boolean))
hunk ./src/clos.lisp 320
- (let* ((method (make-smoke-method
- :smoke (gethash (pointer-address (smoke-get-smoke binding))
- *smoke-modules*)
- :id method)))
- (loop
- (restart-case
- (return-from dispatch-method
- (let ((gf (get-gf-for-method method)))
- (declare (function gf))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~A called."
- (method-declaration method)))
- nil)
- (let ((object (get-object object-ptr)))
- ;; FIXME:
- ;;(assert object
- ;; (object)
- ;; "No object for ~A to call ~A." object-ptr method)
- (if object
+ (let ((object (get-object object-ptr)))
+ ;; FIXME:
+ ;;(assert object
+ ;; (object)
+ ;; "No object for ~A to call ~A." object-ptr method)
+ (if (and object (typep (class-of object) 'cxx:class))
+ ;; Do not allow overwriting methods of classes the users has not derived from (like in C++),
+ ;; to reduce overhead.
+ (let* ((method (make-smoke-method
+ :smoke (gethash (pointer-address (smoke-get-smoke binding))
+ *smoke-modules*)
+ :id method)))
+ (loop
+ (restart-case
+ (return-from dispatch-method
+ (let ((gf (get-gf-for-method method)))
+ (declare (function gf))
+ (if (null (gf-methods gf))
hunk ./src/clos.lisp 339
- (put-returnvalue stack
- (apply gf object
- (stack-to-args
- (inc-pointer stack [_$_]
- (foreign-type-size
- 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method)
- object)
- t)
- nil)))))
- ;; Restarts to prevent stack unwinding across the C++ stack.
- (call-default ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Call default implementation ~A instead."
- method))
- :test (lambda (condition)
- (declare (ignore condition))
- (not abstract))
- (return-from dispatch-method nil))
- (use-returnvalue (return-value)
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Supply a return value for ~A."
- (method-declaration method)))
- :test (lambda (condition)
- (declare (ignore condition))
- (not (void-p (return-type method))))
- :interactive (lambda ()
- (format *query-io* "~&Enter a new return value: ")
- (multiple-value-list (eval (read *query-io*))))
- (put-returnvalue stack return-value [_$_]
- (return-type method)
- (get-object object-ptr))
- (return-from dispatch-method t))
- (return ()
+ (when abstract
+ (error "Abstract method ~A called."
+ (method-declaration method)))
+ nil)
+ (if object
+ (progn
+ (put-returnvalue stack
+ (apply gf object
+ (stack-to-args
+ (inc-pointer stack [_$_]
+ (foreign-type-size
+ 'smoke-stack-item))
+ (get-first-argument method)))
+ (return-type method)
+ object)
+ t)
+ nil))))
+ ;; Restarts to prevent stack unwinding across the C++ stack.
+ (call-default ()
hunk ./src/clos.lisp 360
- (format stream "Return void for ~A."
+ (format stream "Call default implementation ~A instead."
+ method))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not abstract))
+ (return-from dispatch-method nil))
+ (use-returnvalue (return-value)
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Supply a return value for ~A."
hunk ./src/clos.lisp 373
- (void-p (return-type method)))
- (return-from dispatch-method (values)))
- (retry ()
- :report (lambda (stream)
- (declare (stream stream))
- (format stream "Try again calling ~A." [_$_]
- (method-declaration method))))))))
+ (not (void-p (return-type method))))
+ :interactive (lambda ()
+ (format *query-io* "~&Enter a new return value: ")
+ (multiple-value-list (eval (read *query-io*))))
+ (put-returnvalue stack return-value [_$_]
+ (return-type method)
+ (get-object object-ptr))
+ (return-from dispatch-method t))
+ (return ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Return void for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (void-p (return-type method)))
+ (return-from dispatch-method (values)))
+ (retry ()
+ :report (lambda (stream)
+ (declare (stream stream))
+ (format stream "Try again calling ~A." [_$_]
+ (method-declaration method))))))
+ nil))))
hunk ./src/method.lisp 21
- :type (make-instance 'smoke-lazy-type
+ :type (make-instance 'smoke-type
hunk ./src/method.lisp 153
- (register-smoke-module-var (quote ,smoke))
hunk ./src/objects/class.lisp 5
- ((pointer :type foreign-pointer
+ ((pointer ;:type foreign-pointer
hunk ./src/objects/enum.lisp 20
+;; for the constants (e.g.: QT:+ALT+)
hunk ./src/objects/enum.lisp 22
- (declare (ignore environment))
hunk ./src/objects/enum.lisp 24
- :type (make-instance 'smoke::smoke-lazy-type
- :id ,(id (enum-type enum))
- :smoke ',(smoke::get-smoke-variable-for-pointer
- (smoke::smoke (enum-type enum))))))
+ :type ,(make-load-form (enum-type enum) environment)))
hunk ./src/objects/type.lisp 21
-(defclass smoke-lazy-type (smoke-type)
- ())
+;; Clozure CL needs this
+(defmethod make-load-form ((type smoke-type) &optional environment)
+ (declare (ignore environment))
+ `(make-instance 'smoke-type
+ :id ,(id type)
+ :smoke (eval ,(get-smoke-variable-for-pointer
+ (smoke-module-pointer (smoke type))))))
hunk ./src/overload-resolution.lisp 94
- (class-id (id class))
- (smoke (smoke class))
- (end (smoke-array-length (smoke-module-method-maps smoke))))
+ (class-id (id class))
+ (smoke (smoke class))
+ (end (smoke-array-length (smoke-module-method-maps smoke))))
hunk ./src/smoke.lisp 30
-(declaim (inline call-s-method) (optimize (debug 3)))
+(declaim (inline call-s-method))
hunk ./src/smoke.lisp 82
-; (declare (optimize (speed 3)))
+ (declare (optimize (speed 3)))
hunk ./src/smoke.lisp 191
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (define-foreign-library ,library
- (:unix ,(format nil "~(~A~).so.2" library))
- (t (:default ,(format nil "~(~A~)" library))))
- (use-foreign-library ,library))
- (defcvar (,variable ,variable-name :read-only t) :pointer)
- (defcfun (,init-function ,(format nil "_Z~A~Av"
- (length function-name)
- function-name))
- :void))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (define-foreign-library ,library
+ (:unix ,(format nil "~(~A~).so.2" library))
+ (t (:default ,(format nil "~(~A~)" library))))
+ (use-foreign-library ,library))
+ (defcvar (,variable ,variable-name :read-only t) :pointer)
+ (defcfun (,init-function ,(format nil "_Z~A~Av"
+ (length function-name)
+ function-name))
+ :void))
hunk ./src/smoke.lisp 204
- (,init-function)
- (init ,variable ,smoke-module))
+ (,init-function)
+ (init ,variable ,smoke-module)
+ (register-smoke-module-var ',smoke-module))
hunk ./src/smoke.lisp 220
+ (declare (ignorable ,@(loop for arg in (rest lambda-list) collect
+ (if (consp arg)
+ (first arg)
+ arg))))
hunk ./test.lisp 4
+ccl --batch --quiet --load $0 || exit 3
hunk ./test.lisp 30
-(sb-ext:quit)
+#+sbcl (sb-ext:quit)
+#+ccl (ccl:quit)