From 071d6b0ecc7a2fdfa19659a933d273cb8045de63 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 17 Apr 2003 17:50:57 +0000 Subject: [PATCH] * 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 | 10 ++ libguile/ChangeLog | 7 ++ libguile/eq.c | 27 ++--- libguile/snarf.h | 28 ++++- oop/ChangeLog | 5 + oop/goops.scm | 17 ++- test-suite/ChangeLog | 4 + test-suite/tests/goops.test | 205 +++++++++++++++++++++++++++++++++++- 8 files changed, 285 insertions(+), 18 deletions(-) diff --git a/NEWS b/NEWS index ea9a4fc3a..94b48bf0e 100644 --- a/NEWS +++ b/NEWS @@ -56,8 +56,18 @@ methods from their accessors. This makes the 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: diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1c6d6a93a..bedd678fd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-04-17 Mikael Djurfeldt + + * 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 * gc_os_dep.c: Added patch for UnixWare and OpenUNIX support. diff --git a/libguile/eq.c b/libguile/eq.c index b159f2433..d26a89ad3 100644 --- a/libguile/eq.c +++ b/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 x, SCM y), - "Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n" - "@code{equal?} recursively compares the contents of pairs,\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" - "@code{equal?} if they print the same. @code{equal?} may fail to\n" - "terminate if its arguments are circular data structures.") +SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, + (SCM x, SCM y), + "Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n" + "@code{equal?} recursively compares the contents of pairs,\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" + "@code{equal?} if they print the same. @code{equal?} may fail to\n" + "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 diff --git a/libguile/snarf.h b/libguile/snarf.h index 8ab3ff18e..5dd54172e 100644 --- a/libguile/snarf.h +++ b/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, \ diff --git a/oop/ChangeLog b/oop/ChangeLog index ac99ef445..b7c621c99 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,8 @@ +2003-04-17 Mikael Djurfeldt + + * goops.scm (equal?): Provide default method for `equal?'. + (compute-getters-n-setters): Check for bad init-thunks. + 2003-04-15 Mikael Djurfeldt * goops.scm (compute-getter-method): For custom getter: Check diff --git a/oop/goops.scm b/oop/goops.scm index 743985a42..04e900216 100644 --- a/oop/goops.scm +++ b/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) - (or (slot-definition-init-thunk s) + (define (compute-slot-init-function name 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 diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index bc17dc395..e90fb01f5 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-04-17 Mikael Djurfeldt + + * tests/goops.test: New tests. + 2003-04-12 Rob Browning * guile-test: added "Running test FOO" output by default. There diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 9705b19bc..a5cf919c8 100644 --- a/test-suite/tests/goops.test +++ b/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 ) ')) (pass-if "direct superclass" - (equal? (class-direct-supers ) (list ))))) + (equal? (class-direct-supers ) (list )))) + + (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 )) + (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 #f) (current-module)) + (eval '(undefine ) (current-module)) + (eval '(define-class ()) (current-module)) + (eval '(is-a? ) (current-module))) + + (pass-if "overwriting a binding to a non-class" + (eval '(define #f) (current-module)) + (eval '(define-class ()) (current-module)) + (eval '(is-a? ) (current-module))) + + (expect-fail "bad init-thunk" + (catch #t + (lambda () + (eval '(define-class () + (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 ) + (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 ) + (= 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 ) + (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 ) + (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 ) + (= 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 ) + (null? (generic-function-methods foo))) + (current-module))))) + +(with-test-prefix "object update" + (pass-if "defining class" + (eval '(define-class () + (x #:accessor x #:init-value 123) + (z #:accessor z #:init-value 789)) + (current-module)) + (eval '(is-a? ) (current-module))) + (pass-if "making instance" + (eval '(define foo (make )) (current-module)) + (eval '(and (is-a? foo ) (= (x foo) 123)) (current-module))) + (pass-if "redefining class" + (eval '(define-class () + (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 () + (x #:accessor x #:init-keyword #:x) + (y #:accessor y #:init-keyword #:y)) + (define-method (equal? (a ) (b )) + (equal? (y a) (y b))) + (define o1 (make #:x '(1) #:y '(3))) + (define o2 (make #:x '(2) #:y '(3))) + (define o3 (make #: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 () + (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 ) + (define bar (make )) + (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 () + (x #:accessor x #:init-keyword #:x) + (y #:accessor y #:init-keyword #:y)) + (define-class () + (o1 #:accessor o1 #:init-form (make #:x 1 #:y 2)) + (o2 #:accessor o2 #:init-form (make #:x 3 #:y 4)) + (x #:accessor x + #:allocation #:propagated + #:propagate-to '(o1 (o2 y))) + #:metaclass ) + (define o (make )) + (is-a? o )) + (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))))