mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

* srfi-1.c (scm_init_srfi_1): Extend root module map and for-each

Browse source 
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.
This commit is contained in:
Mikael Djurfeldt 2003-03-06 12:51:57 +00:00
parent 1798b73dc4
commit a48d60b1c0
11 changed files with 147 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

19
libguile/ChangeLog
View file

@ -1,3 +1,22 @@
2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* 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 <rlb@defaultvalue.org>
* Makefile.am (scmconfig.h): new target -- generate file from

11
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
@ -134,7 +134,7 @@ 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),
"Return @code{#t} iff @var{x} and @var{y} are recursively @code{eqv?} equivalent.\n"
"@code{equal?} recursively compares the contents of pairs,\n"
@ -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,6 +209,9 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
return scm_array_equal_p (x, y);
#endif
}
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

60
libguile/goops.c
View file

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

1
libguile/goops.h
View file

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

14
libguile/numbers.c
View file

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

4
libguile/procprop.c
View file

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

28
libguile/snarf.h
View file

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

4
oop/ChangeLog
View file

@ -1,3 +1,7 @@
2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (equal?): Define default method.
2003-01-18 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* goops.scm (method): Construct a new copy of the constant '('())

2
oop/goops.scm
View file

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

6
srfi/ChangeLog
View file

@ -1,3 +1,9 @@
2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
* 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 <djurfeldt@nada.kth.se>
* srfi-1.c (srfi1_for_each): Corrected argument checking for the

7
srfi/srfi-1.c
View file

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