Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz * Fix for Clozure CL diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -311,84 +311,88 @@ (symbol-function (lispify (name smoke-method) "CXX"))) (defcallback dispatch-method :boolean - ((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)) (declare (optimize (speed 3))) - (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)) (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 () - :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 () :report (lambda (stream) (declare (stream stream)) - (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." (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)))))))) + (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)))) ;;FIXME use CHANGE-CLASS instead? (defun cast (object class) diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp --- old-smoke/src/method.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/method.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -18,7 +18,7 @@ `(define-constant ,symbol (make-instance 'enum :value ,(enum-call method) - :type (make-instance 'smoke-lazy-type + :type (make-instance 'smoke-type :id ,(id (return-type method)) :smoke ,smoke)) :test #'enum=) @@ -150,7 +150,6 @@ `(progn (check-recompile ,smoke) ,@functions (eval-startup (:execute) - (register-smoke-module-var (quote ,smoke)) (make-smoke-classes ,package ,smoke) (ensure-generic-methods ',(hash-table-alist generics))) ,@constants diff -rN -u old-smoke/src/objects/class.lisp new-smoke/src/objects/class.lisp --- old-smoke/src/objects/class.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/objects/class.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -2,7 +2,7 @@ (defclass smoke-class () ;; FXIME maybe change back to id - ((pointer :type foreign-pointer + ((pointer ;:type foreign-pointer :initarg :pointer :reader pointer) (smoke :type smoke-module diff -rN -u old-smoke/src/objects/enum.lisp new-smoke/src/objects/enum.lisp --- old-smoke/src/objects/enum.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/objects/enum.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -17,14 +17,11 @@ (:documentation "Holds the integer value and type of an C++ enum value.")) ;; Clozure CL needs this +;; for the constants (e.g.: QT:+ALT+) (defmethod make-load-form ((enum enum) &optional environment) - (declare (ignore environment)) `(make-instance 'enum :value ,(value enum) - :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))) (defmethod print-object ((enum enum) stream) (print-unreadable-object (enum stream :type t) diff -rN -u old-smoke/src/objects/type.lisp new-smoke/src/objects/type.lisp --- old-smoke/src/objects/type.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/objects/type.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -18,8 +18,13 @@ (print-unreadable-object (type stream :type t) (princ (name type) stream)))) -(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)))))) (declaim (inline type-slot-value)) (defun type-slot-value (type slot-name) diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp --- old-smoke/src/overload-resolution.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/overload-resolution.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -91,9 +91,9 @@ (type smoke-class class) (optimize (speed 3))) (let* ((start 1) ;; 0 is "no method" - (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)))) (declare (type (smoke-index 0) start end)) (loop until (> start end) do (let* ((index (the smoke-index (floor (+ end start) 2))) diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -27,7 +27,7 @@ (in-package #:smoke) -(declaim (inline call-s-method) (optimize (debug 3))) +(declaim (inline call-s-method)) (defun call-s-method (method object-pointer stack-pointer) (foreign-funcall-pointer (foreign-slot-value (pointer (get-class method)) @@ -79,7 +79,7 @@ (defun delete-pointer (pointer class) "Destructs the object at POINTER of type CLASS. Calls the destrutor and frees the memory." -; (declare (optimize (speed 3))) + (declare (optimize (speed 3))) (let ((method-name (concatenate 'string "~" (name class)))) (s-call (make-smoke-method-from-name class method-name) @@ -188,21 +188,22 @@ (let ((smoke-module (intern "*SMOKE-MODULE*"))) `(progn (eval-startup (:compile-toplevel :execute) - (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)) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter ,smoke-module (make-smoke-module))) (eval-startup (:compile-toplevel :execute) - (,init-function) - (init ,variable ,smoke-module)) + (,init-function) + (init ,variable ,smoke-module) + (register-smoke-module-var ',smoke-module)) (define-classes-and-gfs ,package ,smoke-module)))) @@ -216,6 +217,10 @@ "Declares METHOD transfers the ownership of OBJECT to the first argument of LAMBDA-LIST." `(defmethod ,method :before ,lambda-list + (declare (ignorable ,@(loop for arg in (rest lambda-list) collect + (if (consp arg) + (first arg) + arg)))) (transfer-ownership-to ,object ,(if (consp (first lambda-list)) (first (first lambda-list)) (first lambda-list))))) diff -rN -u old-smoke/test.lisp new-smoke/test.lisp --- old-smoke/test.lisp 2014-10-01 19:32:22.000000000 +0200 +++ new-smoke/test.lisp 2014-10-01 19:32:22.000000000 +0200 @@ -1,6 +1,7 @@ #| MALLOC_CHECK_=3 sbcl --noinform --disable-debugger --noprint --load $0 --end-toplevel-options "$@" || exit 1 sh ./test-bundle.sh || exit 2 +ccl --batch --quiet --load $0 || exit 3 exit 0 # do not use --script to allow loading mudballs with ${HOME}/.sbclrc # Used for testing on darcs record. @@ -26,4 +27,5 @@ ;(setf 5am:*debug-on-error* t) (mb:test :smoke) -(sb-ext:quit) +#+sbcl (sb-ext:quit) +#+ccl (ccl:quit)