mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

* tests/goops.test: New tests.

Browse source 
* 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.
This commit is contained in:
Mikael Djurfeldt 2003-04-17 17:50:57 +00:00
parent 95a0ecc3c7
commit 071d6b0ecc
8 changed files with 285 additions and 18 deletions
Download patch file Download diff file Expand all files Collapse all files

10
NEWS
View file

@ -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:

7
libguile/ChangeLog
View file

@ -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.

27
libguile/eq.c
View file

@ -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

28
libguile/snarf.h
View file

@ -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, \

5
oop/ChangeLog
View file

@ -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

17
oop/goops.scm
View file

@ -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

4
test-suite/ChangeLog
View file

@ -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

205
test-suite/tests/goops.test
View file

@ -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))))