From 424402274218149eb9ff7fc560b55534c4b2b70c Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sat, 4 Aug 2007 21:06:28 +0200
Subject: Allegro CL compatibility.

darcs-hash:04fca2e78b76d10a855512ab7716cb74a3e414c1
---
 Lisp/data-types.lisp        |  8 +++++++-
 Lisp/libobjcl.lisp          |  1 -
 Lisp/memory-management.lisp | 30 ------------------------------
 Lisp/weak-hash-tables.lisp  |  8 +++++---
 4 files changed, 12 insertions(+), 35 deletions(-)

(limited to 'Lisp')

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 847b599..7bb4d5f 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -4,6 +4,11 @@
 ;;;; (@* "Foreign data types")
 (defctype char-pointer :pointer)
 
+;; Let us just hope that two longs make a long long, space-wise.
+(defcstruct double-long
+  (left :long)
+  (right :long))
+
 (defcunion obj-data-union
   (id-val :pointer)
   (class-val :pointer)
@@ -13,7 +18,8 @@
   (short-val :short)
   (int-val :int)
   (long-val :long)
-  (long-long-val :long-long)
+  #-cffi-features:no-long-long (long-long-val :long-long)
+  #+cffi-features:no-long-long (double-long-val double-long)
   (float-val :float)
   (double-val :double)
   (bool-val :boolean)
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 84d4aa6..1139004 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -137,4 +137,3 @@ conventional case for namespace identifiers in Objective C."
     (prog1
         (%objcl-class-name obj-data)
       (dealloc-obj-data obj-data))))
-
diff --git a/Lisp/memory-management.lisp b/Lisp/memory-management.lisp
index 600e079..8331932 100644
--- a/Lisp/memory-management.lisp
+++ b/Lisp/memory-management.lisp
@@ -6,36 +6,6 @@
 (defvar *exception-objects* (make-weak-value-hash-table))
 
 
-#+cmu
-(progn
-  (declaim (inline make-weak-value-hash-table))
-
-  (defun make-weak-value-hash-table ()
-    (make-hash-table :test 'eql))
-
-  (defun weak-gethash (key hash-table &optional (default nil))
-    (let ((pointer (gethash key hash-table default)))
-      (or (and (trivial-garbage:weak-pointer-p pointer)
-               (trivial-garbage:weak-pointer-value pointer))
-          (prog1 default
-            ;; Clean up.
-            (remhash key hash-table)))))
-
-  (defun (setf weak-gethash) (value key hash-table)
-    (setf (gethash key hash-table)
-          (trivial-garbage:make-weak-pointer value))))
-
-#-cmu
-(progn
-  (declaim (inline make-weak-value-hash-table))
-
-  (defun make-weak-value-hash-table ()
-    (trivial-garbage:make-weak-hash-table :weakness :value
-                                          :test 'eql))
-
-  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
-        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
-
 ;; We call the `retain' method on every object that we receive from a
 ;; method call or otherwise except non-convenience constructor methods
 ;; (i.e. those whose name starts with `alloc' or `new').  Upon
diff --git a/Lisp/weak-hash-tables.lisp b/Lisp/weak-hash-tables.lisp
index 6221d8a..ae8ad0c 100644
--- a/Lisp/weak-hash-tables.lisp
+++ b/Lisp/weak-hash-tables.lisp
@@ -23,11 +23,13 @@
 
 #-cmu
 (progn
-  (declaim (inline make-weak-value-hash-table))
+  (declaim (inline make-weak-value-hash-table (setf weak-gethash)))
 
   (defun make-weak-value-hash-table ()
     (trivial-garbage:make-weak-hash-table :weakness :value
                                           :test 'eql))
 
-  (setf (fdefinition 'weak-gethash)        (fdefinition 'gethash)
-        (fdefinition '(setf weak-gethash)) (fdefinition '(setf gethash))))
+  (setf (fdefinition 'weak-gethash) (fdefinition 'gethash))
+
+  (defun (setf weak-gethash) (value key hash-table)
+    (setf (gethash key hash-table) value)))
-- 
cgit v1.2.3