Thu Jun 11 20:45:05 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* futile CLISP fixes

--- old-smoke/src/clos.lisp 2014-09-30 10:31:01.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-30 10:31:01.000000000 +0200

@@ -451,6 +451,7 @@

ret))

(defun keep-wrapper (object new-owner)

+ #-clisp

(when (member object (owned-objects new-owner))

(cerror "ignore" "~A has already been called for ~A."

#'keep-wrapper object))

--- old-smoke/src/object-map.lisp 2014-09-30 10:31:01.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-30 10:31:01.000000000 +0200

@@ -21,9 +21,19 @@

"Synchronized hash table not implemented."))

(defun make-synchronized-hash-table (&key weakness)

(if weakness

- #-cmucl (make-weak-hash-table :weakness weakness)

+ #-cmucl (make-weak-hash-table :weakness #-clisp weakness

+ ;; CLISP crash with weak hash table

+ ;; leak memory (see also: #'keep-wrapper)

+ #+clisp nil)

#+cmucl (make-hash-table :weak-p weakness)

(make-hash-table))))

+

+;; FIXME

+;; CLISP has problems with weak hashtables and finalizers.

+;; trivial-garbage has a workaround!?

+;; http://sourceforge.net/tracker/index.php?func=detail&aid=1472478&group_id=1355&atid=101355

+;; crashes 2.47 and 2.44.1

+;; Works when not using a weak hash table, but now we are leaking memory!

(defvar *object-map* (make-synchronized-hash-table :weakness :value)

@@ -31,27 +41,37 @@

except object with a non virtual destuctor which had their ownership transfered

to C++.")

+(declaim (inline ptr -address))

+(defun ptr-address (pointer)

+ ;; CLISP returns NIL for a null pointer

+ #+clisp

+ (if pointer

+ (pointer-address pointer)

+ 0)

+ #-clisp

+ (pointer-address pointer))

+

(declaim (inline get-object))

(defun get-object (pointer)

- (gethash (pointer-address pointer) *object-map*))

+ (gethash (ptr-address pointer) *object-map*))

(declaim (inline (setf get-object)))

(defun (setf get-object) (value pointer)

- (setf (gethash (pointer-address pointer) *object-map*)

+ (setf (gethash (ptr-address pointer) *object-map*)

value))

(defun has-pointer-p (pointer)

"Returns T when there is an object for POINTER in the map and NIL otherwise."

- (nth-value 1 (gethash (pointer-address pointer) *object-map*)))

+ (nth-value 1 (gethash (ptr-address pointer) *object-map*)))

(defun remove-if-exists (pointer)

- (remhash (pointer-address pointer) *object-map*))

+ (remhash (ptr-address pointer) *object-map*))

(defun remove-object (pointer)

(assert (has-pointer-p pointer)

(pointer)

"No object to remove for pointer ~A." pointer)

- (remhash (pointer-address pointer) *object-map*))

+ (remhash (ptr-address pointer) *object-map*))

(defun report-finalize-error (condition function class pointer)

"Report the error CONDITION it the finalizer FUNCTION for the