From a48d60b1c01ebaf8c2b42be3ccc04f1c6d11e423 Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Thu, 6 Mar 2003 12:51:57 +0000 Subject: [PATCH] * srfi-1.c (scm_init_srfi_1): Extend root module map and for-each with the versions in this module using scm_c_extend_primitive_generic. * goops.scm (equal?): Define default method. * goops.c (scm_primitive_generic_generic): Enable primitive generic if not enabled. (scm_sys_goops_loaded): Setup unextended primitive generics. * goops.c, goops.h (scm_c_extend_primitive_generic): New function. * snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New snarf macros. * numbers.c (scm_abs): Use SCM_PRIMITIVE_GENERIC. (This is only a testing example. All uses of SCM_GPROC should be converted.) * procprop.c (scm_stand_in_scm_proc): Use scm_assq instead of scm_assoc. * eq.c (scm_equal_p): Turned into a primitive generic. --- libguile/ChangeLog | 19 ++++++++++++++ libguile/eq.c | 27 +++++++++++--------- libguile/goops.c | 60 ++++++++++++++++++++++++++++++++++++++++++--- libguile/goops.h | 1 + libguile/numbers.c | 14 +++++------ libguile/procprop.c | 4 +-- libguile/snarf.h | 28 ++++++++++++++++++++- oop/ChangeLog | 4 +++ oop/goops.scm | 2 ++ srfi/ChangeLog | 6 +++++ srfi/srfi-1.c | 7 ++++++ 11 files changed, 147 insertions(+), 25 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index dec04b624..b0a249ec0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,22 @@ +2003-03-06 Mikael Djurfeldt + + * goops.c (scm_primitive_generic_generic): Enable primitive + generic if not enabled. + (scm_sys_goops_loaded): Setup unextended primitive generics. + + * goops.c, goops.h (scm_c_extend_primitive_generic): New function. + + * snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New + snarf macros. + + * numbers.c (scm_abs): Use SCM_PRIMITIVE_GENERIC. (This is only a + testing example. All uses of SCM_GPROC should be converted.) + + * procprop.c (scm_stand_in_scm_proc): Use scm_assq instead of + scm_assoc. + + * eq.c (scm_equal_p): Turned into a primitive generic. + 2003-02-27 Rob Browning * Makefile.am (scmconfig.h): new target -- generate file from diff --git a/libguile/eq.c b/libguile/eq.c index bac72d051..3874b973b 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 @@ -134,14 +134,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; @@ -183,7 +183,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); @@ -195,7 +195,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: @@ -209,7 +209,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/goops.c b/libguile/goops.c index 4baf645a2..3f58d2815 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1682,14 +1682,67 @@ SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0, { if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr)) { - SCM gf = *SCM_SUBR_GENERIC (subr); - if (gf) - return gf; + if (!*SCM_SUBR_GENERIC (subr)) + scm_enable_primitive_generic_x (scm_list_1 (subr)); + return *SCM_SUBR_GENERIC (subr); } SCM_WRONG_TYPE_ARG (SCM_ARG1, subr); } #undef FUNC_NAME +typedef struct t_extension { + struct t_extension *next; + SCM extended; + SCM extension; +} t_extension; + +static t_extension *extensions = 0; + +SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); + +void +scm_c_extend_primitive_generic (SCM extended, SCM extension) +{ + if (goops_loaded_p) + { + SCM gf, gext; + if (!*SCM_SUBR_GENERIC (extended)) + scm_enable_primitive_generic_x (scm_list_1 (extended)); + gf = *SCM_SUBR_GENERIC (extended); + gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic), + gf, + SCM_SNAME (extension)); + *SCM_SUBR_GENERIC (extension) = gext; + } + else + { + t_extension *e = scm_malloc (sizeof (t_extension)); + t_extension **loc = &extensions; + /* Make sure that extensions are placed before their own + * extensions in the extensions list. O(N^2) algorithm, but + * extensions of primitive generics are rare. + */ + while (*loc && extension != (*loc)->extended) + loc = &(*loc)->next; + e->next = *loc; + e->extended = extended; + e->extension = extension; + *loc = e; + } +} + +static void +setup_extended_primitive_generics () +{ + while (extensions) + { + t_extension *e = extensions; + scm_c_extend_primitive_generic (e->extended, e->extension); + extensions = e->next; + free (e); + } +} + /****************************************************************************** * * Protocol for calling a generic fumction @@ -2694,6 +2747,7 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, var_compute_applicable_methods = scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, SCM_BOOL_F); + setup_extended_primitive_generics (); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/goops.h b/libguile/goops.h index 4d3d1b889..9e008d4b5 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -297,6 +297,7 @@ SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf); SCM_API SCM scm_generic_capability_p (SCM proc); SCM_API SCM scm_enable_primitive_generic_x (SCM subrs); SCM_API SCM scm_primitive_generic_generic (SCM subr); +SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension); SCM_API SCM stklos_version (void); SCM_API SCM scm_make (SCM args); SCM_API SCM scm_find_method (SCM args); diff --git a/libguile/numbers.c b/libguile/numbers.c index 5e86a5441..18431cf6e 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -289,11 +289,10 @@ SCM_DEFINE (scm_nan, "nan", 0, 0, 0, #undef FUNC_NAME -SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); -/* "Return the absolute value of @var{x}." - */ -SCM -scm_abs (SCM x) +SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0, + (SCM x), + "Return the absolute value of @var{x}.") +#define FUNC_NAME { if (SCM_INUMP (x)) { long int xx = SCM_INUM (x); @@ -317,9 +316,10 @@ scm_abs (SCM x) } else if (SCM_REALP (x)) { return scm_make_real (fabs (SCM_REAL_VALUE (x))); } else { - SCM_WTA_DISPATCH_1 (g_abs, x, 1, s_abs); + SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); } } +#undef FUNC_NAME SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); diff --git a/libguile/procprop.c b/libguile/procprop.c index f7887ed55..8dddc639c 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,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 @@ -160,7 +160,7 @@ static SCM scm_stand_in_scm_proc(SCM proc) { SCM answer; - answer = scm_assoc (proc, scm_stand_in_procs); + answer = scm_assq (proc, scm_stand_in_procs); if (SCM_FALSEP (answer)) { answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); diff --git a/libguile/snarf.h b/libguile/snarf.h index 8affa28c5..4200a212c 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -3,7 +3,7 @@ #ifndef SCM_SNARF_H #define SCM_SNARF_H -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 @@ -108,6 +108,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_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \ SCM_SNARF_HERE(\ static const char s_ ## FNAME [] = PRIMNAME; \ @@ -128,6 +142,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 932408b35..633b37300 100644 --- a/oop/ChangeLog +++ b/oop/ChangeLog @@ -1,3 +1,7 @@ +2003-03-06 Mikael Djurfeldt + + * goops.scm (equal?): Define default method. + 2003-01-18 Mikael Djurfeldt * goops.scm (method): Construct a new copy of the constant '('()) diff --git a/oop/goops.scm b/oop/goops.scm index 2ff6e902b..b769881b6 100644 --- a/oop/goops.scm +++ b/oop/goops.scm @@ -719,6 +719,8 @@ ;;; Methods to compare objects ;;; +(define-method (equal? x y) #f) + (define-method (object-eqv? x y) #f) (define-method (object-equal? x y) (eqv? x y)) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index 2d090b64f..97401db1c 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,9 @@ +2003-03-06 Mikael Djurfeldt + + * srfi-1.c (scm_init_srfi_1): Extend root module map and for-each + with the versions in this module using + scm_c_extend_primitive_generic. + 2003-02-03 Mikael Djurfeldt * srfi-1.c (srfi1_for_each): Corrected argument checking for the diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index afd3e78bc..d46e56ac1 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -348,9 +348,16 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0, void scm_init_srfi_1 (void) { + SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F); #ifndef SCM_MAGIC_SNARFER #include "srfi/srfi-1.x" #endif + scm_c_extend_primitive_generic + (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")), + SCM_VARIABLE_REF (scm_c_lookup ("map"))); + scm_c_extend_primitive_generic + (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")), + SCM_VARIABLE_REF (scm_c_lookup ("for-each"))); } /* End of srfi-1.c. */