Wed Jul 1 00:47:39 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Fix for Clozure CL

--- old-smoke/src/clos.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:41:12.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)

--- old-smoke/src/method.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/method.lisp 2014-09-28 09:41:12.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

--- old-smoke/src/objects/class.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/objects/class.lisp 2014-09-28 09:41:12.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

--- old-smoke/src/objects/enum.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/objects/enum.lisp 2014-09-28 09:41:12.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)

--- old-smoke/src/objects/type.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/objects/type.lisp 2014-09-28 09:41:12.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)

--- old-smoke/src/overload-resolution.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/overload-resolution.lisp 2014-09-28 09:41:12.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)))

--- old-smoke/src/smoke.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:41:12.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)))))

--- old-smoke/test.lisp 2014-09-28 09:41:12.000000000 +0200

+++ new-smoke/test.lisp 2014-09-28 09:41:12.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)