* tests/goops.test: New tests.

* goops.scm (equal?): Provide default method for `equal?'.
(compute-getters-n-setters): Check for bad init-thunks.

* eq.c (scm_equal_p): Turned into a primitive generic.

* snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
macros.

NEWS

@@ -56,8 +56,18 @@ methods from their accessors.
 This makes the <active-class> metaclass in (oop goops active-slot)
 working again.
 
+** equal? is now a primitive generic
+
+This means that it is possible to provide custom comparisons for new
+classes by specializing `equal?' to those classes.
+
 * Changes to the C interface 
 
+** New snarf macros: SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1
+
+These provide a way of adding primitive generics which is equivalent
+to SCM_DEFINE and SCM_DEFINE1.
+
 
 Changes since Guile 1.6.2:
 

libguile/ChangeLog

@@ -1,3 +1,10 @@
+2003-04-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* eq.c (scm_equal_p): Turned into a primitive generic.
+
+	* snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
+	macros.
+
 2003-04-16  Rob Browning  <rlb@defaultvalue.org>
 
 	* gc_os_dep.c: Added patch for UnixWare and OpenUNIX support.

libguile/eq.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -115,14 +115,14 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
 #undef FUNC_NAME
 
 
-SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
+SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
-             (SCM x, SCM y),
+			 (SCM x, SCM y),
-	     "Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n"
+ "Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n"
-	     "@code{equal?} recursively compares the contents of pairs,\n"
+ "@code{equal?} recursively compares the contents of pairs,\n"
-	     "vectors, and strings, applying @code{eqv?} on other objects such as\n"
+ "vectors, and strings, applying @code{eqv?} on other objects such as\n"
-	     "numbers and symbols.  A rule of thumb is that objects are generally\n"
+ "numbers and symbols.  A rule of thumb is that objects are generally\n"
-	     "@code{equal?}  if they print the same.  @code{equal?} may fail to\n"
+ "@code{equal?}  if they print the same.  @code{equal?} may fail to\n"
-	     "terminate if its arguments are circular data structures.")
+ "terminate if its arguments are circular data structures.")
 #define FUNC_NAME s_scm_equal_p
 {
   SCM_CHECK_STACK;
@@ -164,7 +164,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
   switch (SCM_TYP7 (x))
     {
     default:
-      return SCM_BOOL_F;
+      break;
     case scm_tc7_vector:
     case scm_tc7_wvect:
       return scm_vector_equal_p (x, y);
@@ -176,7 +176,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
 	if (scm_smobs[i].equalp)
 	  return (scm_smobs[i].equalp) (x, y);
 	else
-	  return SCM_BOOL_F;
+	  break;
       }
 #ifdef HAVE_ARRAYS
     case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect:
@@ -190,7 +190,10 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
 	return scm_array_equal_p (x, y);
 #endif
     }
-  return SCM_BOOL_F;
+  if (SCM_UNPACK (g_scm_equal_p))
+    return scm_call_generic_2 (g_scm_equal_p, x, y);
+  else
+    return SCM_BOOL_F;
 }
 #undef FUNC_NAME
 

libguile/snarf.h

@@ -5,7 +5,7 @@
 #ifndef LIBGUILE_SNARF_H
 #define LIBGUILE_SNARF_H
 
-/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2003 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -109,6 +109,20 @@ scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
 )\
 SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
 
+#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+static SCM g_ ## FNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+g_ ## FNAME = SCM_PACK (0); \
+scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
+                    		 (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
+				 &g_ ## FNAME); \
+)\
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
 #define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
 SCM_SNARF_HERE(\
 static const char s_ ## FNAME [] = PRIMNAME; \
@@ -117,6 +131,18 @@ SCM FNAME ARGLIST\
 SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \
 SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
 
+#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+static SCM g_ ## FNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+g_ ## FNAME = SCM_PACK (0); \
+scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \
+)\
+SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
+
 #define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN)  \
 SCM_SNARF_HERE(static const char RANAME[]=STR) \
 SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \

oop/ChangeLog

@@ -1,3 +1,8 @@
+2003-04-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* goops.scm (equal?): Provide default method for `equal?'.
+	(compute-getters-n-setters): Check for bad init-thunks.
+
 2003-04-15  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 
 	* goops.scm (compute-getter-method): For custom getter: Check

oop/goops.scm

@@ -658,6 +658,11 @@
 ;;; Methods to compare objects
 ;;;
 
+(define-method (equal? x y) #f)
+
+;;; These following two methods are for backward compatibility only.
+;;; They are not called by the Guile interpreter.
+;;;
 (define-method (object-eqv? x y)    #f)
 (define-method (object-equal? x y)  (eqv? x y))
 
@@ -1039,8 +1044,14 @@
 ;;; 
 (define (compute-getters-n-setters class slots env)
 
-  (define (compute-slot-init-function s)
+  (define (compute-slot-init-function name s)
-    (or (slot-definition-init-thunk s)
+    (or (let ((thunk (slot-definition-init-thunk s)))
+	  (and thunk
+	       (if (not (and (closure? thunk)
+			     (thunk? thunk)))
+		   (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+				name class thunk))
+	       thunk))
 	(let ((init (slot-definition-init-value s)))
 	  (and (not (unbound? init))
 	       (lambda () init)))))
@@ -1080,7 +1091,7 @@
 	   ;;   '() for other slots
 	   (verify-accessors name g-n-s)
 	   (cons name
-		 (cons (compute-slot-init-function s)
+		 (cons (compute-slot-init-function name s)
 		       (if (or (integer? g-n-s)
 			       (zero? size))
 			   g-n-s

test-suite/ChangeLog

@@ -1,3 +1,7 @@
+2003-04-17  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
+
+	* tests/goops.test: New tests.
+
 2003-04-12  Rob Browning  <rlb@defaultvalue.org>
 
 	* guile-test: added "Running test FOO" output by default.  There

test-suite/tests/goops.test

@@ -1,6 +1,6 @@
 ;;;; goops.test --- test suite for GOOPS                      -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2003 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -97,4 +97,205 @@
       (eq? (class-name <class>) '<class>))
 
     (pass-if "direct superclass"
-      (equal? (class-direct-supers <class>) (list <object>)))))
+      (equal? (class-direct-supers <class>) (list <object>))))
+
+  (with-test-prefix "class-precedence-list"
+    (for-each (lambda (class)
+		(run-test (if (slot-bound? class 'name)
+			      (class-name class)
+			      (with-output-to-string
+				(lambda ()
+				  (display class))))
+			  #t
+			  (lambda ()
+			    (catch #t
+				   (lambda ()
+				     (equal? (class-precedence-list class)
+					     (compute-cpl class)))
+				   (lambda args #t)))))
+	      (let ((table (make-hash-table 31)))
+		(let rec ((class <top>))
+		  (hash-create-handle! table class #f)
+		  (for-each rec (class-direct-subclasses class)))
+		(hash-fold (lambda (class ignore classes)
+			     (cons class classes))
+			   '()
+			   table))))
+  )
+
+(with-test-prefix "defining classes"
+
+  (with-test-prefix "define-class"
+
+    (pass-if "creating a new binding"
+      (eval '(define <foo> #f) (current-module))
+      (eval '(undefine <foo>) (current-module))
+      (eval '(define-class <foo> ()) (current-module))
+      (eval '(is-a? <foo> <class>) (current-module)))
+
+    (pass-if "overwriting a binding to a non-class"
+      (eval '(define <foo> #f) (current-module))
+      (eval '(define-class <foo> ()) (current-module))
+      (eval '(is-a? <foo> <class>) (current-module)))
+
+    (expect-fail "bad init-thunk"
+		 (catch #t
+			(lambda ()
+			  (eval '(define-class <foo> ()
+				   (x #:init-thunk (lambda (x) 1)))
+				(current-module))
+			  #t)
+			(lambda args
+			  #f)))
+    ))
+
+(with-test-prefix "defining generics"
+
+  (with-test-prefix "define-generic"
+
+    (pass-if "creating a new top-level binding"
+      (eval '(define foo #f) (current-module))
+      (eval '(undefine foo) (current-module))
+      (eval '(define-generic foo) (current-module))
+      (eval '(and (is-a? foo <generic>)
+		  (null? (generic-function-methods foo)))
+	    (current-module)))
+
+    (pass-if "overwriting a top-level binding to a non-generic"
+      (eval '(define (foo) #f) (current-module))
+      (eval '(define-generic foo) (current-module))
+      (eval '(and (is-a? foo <generic>)
+		  (= 1 (length (generic-function-methods foo))))
+	    (current-module)))
+
+    (pass-if "overwriting a top-level binding to a generic"
+      (eval '(define (foo) #f) (current-module))
+      (eval '(define-generic foo) (current-module))
+      (eval '(define-generic foo) (current-module))
+      (eval '(and (is-a? foo <generic>)
+		  (null? (generic-function-methods foo)))
+	    (current-module)))))
+
+(with-test-prefix "defining accessors"
+
+  (with-test-prefix "define-accessor"
+
+    (pass-if "creating a new top-level binding"
+      (eval '(define foo #f) (current-module))
+      (eval '(undefine foo) (current-module))
+      (eval '(define-accessor foo) (current-module))
+      (eval '(and (is-a? foo <generic-with-setter>)
+		  (null? (generic-function-methods foo)))
+	    (current-module)))
+
+    (pass-if "overwriting a top-level binding to a non-accessor"
+      (eval '(define (foo) #f) (current-module))
+      (eval '(define-accessor foo) (current-module))
+      (eval '(and (is-a? foo <generic-with-setter>)
+		  (= 1 (length (generic-function-methods foo))))
+	    (current-module)))
+
+    (pass-if "overwriting a top-level binding to an accessor"
+      (eval '(define (foo) #f) (current-module))
+      (eval '(define-accessor foo) (current-module))
+      (eval '(define-accessor foo) (current-module))
+      (eval '(and (is-a? foo <generic-with-setter>)
+		  (null? (generic-function-methods foo)))
+	    (current-module)))))
+
+(with-test-prefix "object update"
+  (pass-if "defining class"
+    (eval '(define-class <foo> ()
+	     (x #:accessor x #:init-value 123)
+	     (z #:accessor z #:init-value 789))
+	  (current-module))
+    (eval '(is-a? <foo> <class>) (current-module)))
+  (pass-if "making instance"
+    (eval '(define foo (make <foo>)) (current-module))
+    (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
+  (pass-if "redefining class"
+    (eval '(define-class <foo> ()
+	     (x #:accessor x #:init-value 123)
+	     (y #:accessor y #:init-value 456)
+	     (z #:accessor z #:init-value 789))
+	  (current-module))
+    (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))))
+
+(with-test-prefix "equal?"
+  (pass-if "equal"
+	   (eval '(begin
+		    (define-class <c> ()
+		      (x #:accessor x #:init-keyword #:x)
+		      (y #:accessor y #:init-keyword #:y))
+		    (define-method (equal? (a <c>) (b <c>))
+		      (equal? (y a) (y b)))
+		    (define o1 (make <c> #:x '(1) #:y '(3)))
+		    (define o2 (make <c> #:x '(2) #:y '(3)))
+		    (define o3 (make <c> #:x '(2) #:y '(4)))
+		    (equal? o1 o2))
+		 (current-module)))
+  (pass-if "not equal"
+	   (eval '(not (equal? o2 o3))
+		 (current-module))))
+
+(use-modules (oop goops active-slot))
+
+(with-test-prefix "active-slot"
+  (pass-if "defining class with active slot"
+    (eval '(begin
+	     (define z '())
+	     (define-class <bar> ()
+	       (x #:accessor x
+		  #:init-value 1
+		  #:allocation #:active
+		  #:before-slot-ref
+		  (lambda (o)
+		    (set! z (cons 'before-ref z))
+		    #t)
+		  #:after-slot-ref
+		  (lambda (o)
+		    (set! z (cons 'after-ref z)))
+		  #:before-slot-set!
+		  (lambda (o v)
+		    (set! z (cons* v 'before-set! z)))
+		  #:after-slot-set!
+		  (lambda (o v)
+		    (set! z (cons* v (x o) 'after-set! z))))
+	       #:metaclass <active-class>)
+	     (define bar (make <bar>))
+	     (x bar)
+	     (set! (x bar) 2)
+	     (equal? (reverse z)
+		     '(before-ref before-set! 1 before-ref after-ref
+		       after-set! 1 1 before-ref after-ref
+		       before-set! 2 before-ref after-ref after-set! 2 2)))
+	  (current-module))))
+
+(use-modules (oop goops composite-slot))
+
+(with-test-prefix "composite-slot"
+  (pass-if "creating instance with propagated slot"
+    (eval '(begin
+	     (define-class <a> ()
+	       (x #:accessor x #:init-keyword #:x)
+	       (y #:accessor y #:init-keyword #:y))
+	     (define-class <c> ()
+	       (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
+	       (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
+	       (x #:accessor x
+		  #:allocation #:propagated
+		  #:propagate-to '(o1 (o2 y)))
+	       #:metaclass <composite-class>)
+	     (define o (make <c>))
+	     (is-a? o <c>))
+	  (current-module)))
+  (pass-if "reading propagated slot"
+	   (eval '(= (x o) 1) (current-module)))
+  (pass-if "writing propagated slot"
+	   (eval '(begin
+		    (set! (x o) 5)
+		    (and (= (x (o1 o)) 5)
+			 (= (y (o1 o)) 2)
+			 (= (x (o2 o)) 3)
+			 (= (y (o2 o)) 5)))
+		 (current-module))))