From 885993c8af22e52a0a0f698b317b10cf93dd3b3c Mon Sep 17 00:00:00 2001 From: =?utf-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 16 Feb 2009 00:24:00 +0100 Subject: [PATCH] Remove "compiled closures" ("cclos") in favor of a simpler mechanism. The idea is to introduce `gsubrs' whose arity is encoded in their type (more precisely in the sizeof (void *) - 8 MSBs). This removes the indirection introduced by cclos and simplifies the code. * libguile/__scm.h (CCLO): Remove. * libguile/debug.c (scm_procedure_source, scm_procedure_environment): Remove references to `scm_tc7_cclo'. * libguile/eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2): Replace `scm_tc7_cclo' with `scm_tc7_gsubr'. * libguile/eval.i.c (CEVAL): Likewise. No longer make PROC the first argument. Directly invoke `scm_gsubr_apply ()' instead of jump to the `evap(N+1)' label. * libguile/evalext.c (scm_self_evaluating_p): Remove reference to `scm_tc7_cclo'. * libguile/gc-card.c (scm_i_sweep_card, scm_i_tag_name): Likewise. * libguile/gc-mark.c (scm_gc_mark_dependencies): Likewise. * libguile/goops.c (scm_class_of): Likewise. * libguile/print.c (iprin1): Likewise. * libguile/gsubr.c (create_gsubr): Use `unsigned int's for REQ, OPT and RST. Use `scm_tc7_gsubr' instead of `scm_makcclo ()' in the default case. (scm_gsubr_apply): Remove calls to `SCM_GSUBR_PROC ()'. * libguile/gsubr.h (SCM_GSUBR_TYPE): New definition. (SCM_GSUBR_MAX): Changed to 33. (SCM_SET_GSUBR_TYPE, SCM_GSUBR_PROC, SCM_SET_GSUBR_PROC, scm_f_gsubr_apply): Remove. * libguile/procprop.c (scm_i_procedure_arity): Remove reference to `scm_tc7_cclo'; add proper handling of `scm_tc7_gsubr'. * libguile/procs.c (scm_makcclo, scm_make_cclo): Remove. (scm_procedure_p): Remove reference to `scm_tc7_cclo'. (scm_thunk_p): Likewise, plus add proper `scm_tc7_gsubr' handling. * libguile/procs.h (SCM_CCLO_LENGTH, SCM_MAKE_CCLO_TAG, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE, SCM_SET_CCLO_BASE, SCM_CCLO_REF, SCM_CCLO_SET, SCM_CCLO_SUBR, SCM_SET_CCLO_SUBR, scm_makcclo, scm_make_cclo): Remove. * libguile/stacks.c (read_frames): Remove reference to `scm_f_gsubr_apply'. * libguile/tags.h (scm_tc7_cclo): Remove. (scm_tc7_gsubr): New. (scm_tcs_subrs): Add `scm_tc7_gsubr'. --- libguile/__scm.h | 4 +-- libguile/debug.c | 8 +----- libguile/eval.c | 8 +++--- libguile/eval.i.c | 42 +++++++++++------------------- libguile/evalext.c | 3 +- libguile/gc-card.c | 14 +--------- libguile/gc-mark.c | 15 ----------- libguile/goops.c | 4 +- libguile/gsubr.c | 70 ++++++++++++++++++++------------------------------ libguile/gsubr.h | 16 +++++------ libguile/print.c | 27 +------------------ libguile/procprop.c | 25 ++++++----------- libguile/procs.c | 47 +-------------------------------- libguile/procs.h | 17 ------------ libguile/stacks.c | 5 +--- libguile/tags.h | 5 ++- 16 files changed, 78 insertions(+), 232 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index d486b69..3672b1c 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -3,7 +3,7 @@ #ifndef SCM___SCM_H #define SCM___SCM_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -140,8 +140,6 @@ */ -#define CCLO - /* Guile Scheme supports the #f/() distinction; Guile Lisp won't. We have horrible plans for their unification. */ #undef SICP diff --git a/libguile/debug.c b/libguile/debug.c index 7b91cd3..0ac4442 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,5 +1,5 @@ /* Debugging extensions for Guile - * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -352,9 +352,6 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, if (!SCM_SMOB_DESCRIPTOR (proc).apply) break; case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif procprop: /* It would indeed be a nice thing if we supplied source even for built in procedures! */ @@ -385,9 +382,6 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0, case scm_tcs_closures: return SCM_ENV (proc); case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif return SCM_EOL; default: SCM_WRONG_TYPE_ARG (1, proc); diff --git a/libguile/eval.c b/libguile/eval.c index 14dc3c3..d20f72e 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -3243,7 +3243,7 @@ scm_trampoline_0 (SCM proc) break; case scm_tc7_asubr: case scm_tc7_rpsubr: - case scm_tc7_cclo: + case scm_tc7_gsubr: case scm_tc7_pws: trampoline = scm_call_0; break; @@ -3369,7 +3369,7 @@ scm_trampoline_1 (SCM proc) break; case scm_tc7_asubr: case scm_tc7_rpsubr: - case scm_tc7_cclo: + case scm_tc7_gsubr: case scm_tc7_pws: trampoline = scm_call_1; break; @@ -3463,7 +3463,7 @@ scm_trampoline_2 (SCM proc) else return NULL; break; - case scm_tc7_cclo: + case scm_tc7_gsubr: case scm_tc7_pws: trampoline = scm_call_2; break; diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 83878ff..83c476a 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -1,7 +1,7 @@ /* * eval.i.c - actual evaluator code for GUILE * - * Copyright (C) 2002, 03, 04, 05, 06, 07 Free Software Foundation, Inc. + * Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -1124,14 +1124,12 @@ dispatch: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_0 (proc)); - case scm_tc7_cclo: - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); + case scm_tc7_gsubr: #ifdef DEVAL debug.info->a.proc = proc; - debug.info->a.args = scm_list_1 (arg1); + debug.info->a.args = SCM_EOL; #endif - goto evap1; + RETURN (scm_gsubr_apply (scm_list_1 (proc))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -1245,15 +1243,12 @@ dispatch: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; RETURN (SCM_SMOB_APPLY_1 (proc, arg1)); - case scm_tc7_cclo: - arg2 = arg1; - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); + case scm_tc7_gsubr: #ifdef DEVAL debug.info->a.args = scm_cons (arg1, debug.info->a.args); debug.info->a.proc = proc; #endif - goto evap2; + RETURN (scm_gsubr_apply (scm_list_2 (proc, arg1))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -1351,16 +1346,15 @@ dispatch: goto badfun; RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); cclon: - case scm_tc7_cclo: + case scm_tc7_gsubr: #ifdef DEVAL - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons (proc, debug.info->a.args), + RETURN (SCM_APPLY (proc, debug.info->a.args, SCM_EOL)); #else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_ceval_args (x, + RETURN (SCM_APPLY (proc, + scm_cons (arg1, + scm_cons (arg2, + scm_ceval_args (x, env, proc))), SCM_EOL)); @@ -1492,7 +1486,7 @@ dispatch: goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, SCM_CDDR (debug.info->a.args))); - case scm_tc7_cclo: + case scm_tc7_gsubr: goto cclon; case scm_tc7_pws: proc = SCM_PROCEDURE (proc); @@ -1555,7 +1549,7 @@ dispatch: goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, scm_ceval_args (x, env, proc))); - case scm_tc7_cclo: + case scm_tc7_gsubr: goto cclon; case scm_tc7_pws: proc = SCM_PROCEDURE (proc); @@ -1867,19 +1861,15 @@ tail: RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args))); else RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args))); - case scm_tc7_cclo: + case scm_tc7_gsubr: #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); debug.vect[0].a.proc = proc; debug.vect[0].a.args = scm_cons (arg1, args); #else args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args)); - arg1 = proc; - proc = SCM_CCLO_SUBR (proc); #endif - goto tail; + RETURN (scm_gsubr_apply (scm_cons (proc, args))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL diff --git a/libguile/evalext.c b/libguile/evalext.c index 9bec8f4..5ca7806 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -106,7 +106,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: - case scm_tc7_cclo: case scm_tc7_pws: case scm_tcs_subrs: case scm_tcs_struct: diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 1948aff..0629da0 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -131,14 +131,6 @@ scm_i_sweep_card (scm_t_cell *card, SCM *free_list, scm_t_heap_segment *seg) scm_i_vector_free (scmptr); break; -#ifdef CCLO - case scm_tc7_cclo: - scm_gc_free (SCM_CCLO_BASE (scmptr), - SCM_CCLO_LENGTH (scmptr) * sizeof (SCM), - "compiled closure"); - break; -#endif - case scm_tc7_number: switch SCM_TYP16 (scmptr) { @@ -397,10 +389,6 @@ scm_i_tag_name (scm_t_bits tag) return "weak vector"; case scm_tc7_vector: return "vector"; -#ifdef CCLO - case scm_tc7_cclo: - return "compiled closure"; -#endif case scm_tc7_number: switch (tag) { diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index e73f6e1..1a66900 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -294,21 +294,6 @@ scm_gc_mark_dependencies (SCM p) } ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0); goto gc_mark_loop; -#ifdef CCLO - case scm_tc7_cclo: - { - size_t i = SCM_CCLO_LENGTH (ptr); - size_t j; - for (j = 1; j != i; ++j) - { - SCM obj = SCM_CCLO_REF (ptr, j); - if (!SCM_IMP (obj)) - scm_gc_mark (obj); - } - ptr = SCM_CCLO_REF (ptr, 0); - goto gc_mark_loop; - } -#endif case scm_tc7_string: ptr = scm_i_string_mark (ptr); diff --git a/libguile/goops.c b/libguile/goops.c index 4e64586..cc4e1eb 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008 +/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,2008,2009 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -233,7 +233,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_primitive_generic; else return scm_class_procedure; - case scm_tc7_cclo: + case scm_tc7_gsubr: return scm_class_procedure; case scm_tc7_pws: return scm_class_procedure_with_setter; diff --git a/libguile/gsubr.c b/libguile/gsubr.c index fdb70ed..4288633 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -44,7 +44,8 @@ SCM scm_f_gsubr_apply; static SCM create_gsubr (int define, const char *name, - int req, int opt, int rst, SCM (*fcn)()) + unsigned int req, unsigned int opt, unsigned int rst, + SCM (*fcn) ()) { SCM subr; @@ -52,53 +53,39 @@ create_gsubr (int define, const char *name, { case SCM_GSUBR_MAKTYPE(0, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(1, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(0, 1, 0): subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(1, 1, 0): subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(2, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(3, 0, 0): subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(0, 0, 1): subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn); - goto create_subr; + break; case SCM_GSUBR_MAKTYPE(2, 0, 1): subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); - create_subr: - if (define) - scm_define (SCM_SNAME (subr), subr); - return subr; + break; default: - { - SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L); - SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); - SCM sym = SCM_SNAME (subr); - if (SCM_GSUBR_MAX < req + opt + rst) - { - fprintf (stderr, - "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n", - req + opt + rst, name); - exit (1); - } - SCM_SET_GSUBR_PROC (cclo, subr); - SCM_SET_GSUBR_TYPE (cclo, - scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst))); - if (SCM_REC_PROCNAMES_P) - scm_set_procedure_property_x (cclo, scm_sym_name, sym); - if (define) - scm_define (sym, cclo); - return cclo; - } + subr = scm_c_make_subr (name, + scm_tc7_gsubr + | (SCM_GSUBR_MAKTYPE (req, opt, rst) << 8U), + fcn); } + + if (define) + scm_define (SCM_SNAME (subr), subr); + + return subr; } SCM @@ -190,20 +177,15 @@ scm_gsubr_apply (SCM args) #define FUNC_NAME "scm_gsubr_apply" { SCM self = SCM_CAR (args); - SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); + SCM (*fcn)() = SCM_SUBRF (self); SCM v[SCM_GSUBR_MAX]; - int typ = scm_to_int (SCM_GSUBR_TYPE (self)); + unsigned int typ = SCM_GSUBR_TYPE (self); long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); -#if 0 - if (n > SCM_GSUBR_MAX) - scm_misc_error (FUNC_NAME, - "Function ~S has illegal arity ~S.", - scm_list_2 (self, scm_from_int (n))); -#endif + args = SCM_CDR (args); for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { if (scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); + scm_wrong_num_args (SCM_SNAME (self)); v[i] = SCM_CAR(args); args = SCM_CDR(args); } @@ -218,7 +200,7 @@ scm_gsubr_apply (SCM args) if (SCM_GSUBR_REST(typ)) v[i] = args; else if (!scm_is_null (args)) - scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); + scm_wrong_num_args (SCM_SNAME (self)); switch (n) { case 2: return (*fcn)(v[0], v[1]); case 3: return (*fcn)(v[0], v[1], v[2]); @@ -229,6 +211,10 @@ scm_gsubr_apply (SCM args) case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]); case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]); case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]); + default: + scm_misc_error ((char *) SCM_SNAME (self), + "gsubr invocation with more than 10 arguments not implemented", + SCM_EOL); } return SCM_BOOL_F; /* Never reached. */ } diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 4185649..ea48436 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -3,7 +3,7 @@ #ifndef SCM_GSUBR_H #define SCM_GSUBR_H -/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -26,19 +26,17 @@ +/* Return an integer describing the arity of GSUBR, a subr of type + `scm_tc7_gsubr'. The result can be interpreted with `SCM_GSUBR_REQ ()' + and similar. */ +#define SCM_GSUBR_TYPE(gsubr) (SCM_CELL_TYPE (gsubr) >> 8) + #define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8)) +#define SCM_GSUBR_MAX 33 #define SCM_GSUBR_REQ(x) ((long)(x)&0xf) #define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4) #define SCM_GSUBR_REST(x) ((long)(x)>>8) -#define SCM_GSUBR_MAX 10 -#define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1)) -#define SCM_SET_GSUBR_TYPE(cclo, type) (SCM_CCLO_SET ((cclo), 1, (type))) -#define SCM_GSUBR_PROC(cclo) (SCM_CCLO_REF ((cclo), 2)) -#define SCM_SET_GSUBR_PROC(cclo, proc) (SCM_CCLO_SET ((cclo), 2, (proc))) - -SCM_API SCM scm_f_gsubr_apply; - SCM_API SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn) ()); SCM_API SCM scm_c_make_gsubr_with_generic (const char *name, diff --git a/libguile/print.c b/libguile/print.c index d218837..fa4cb1e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -657,30 +657,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port); scm_putc ('>', port); break; -#ifdef CCLO - case scm_tc7_cclo: - { - SCM proc = SCM_CCLO_SUBR (exp); - if (scm_is_eq (proc, scm_f_gsubr_apply)) - { - /* Print gsubrs as primitives */ - SCM name = scm_procedure_name (exp); - scm_puts ("#', port); - } - break; -#endif + case scm_tc7_pws: scm_puts ("#> 8) -#define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo) -#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), SCM_MAKE_CCLO_TAG(v))) -#define SCM_CCLO_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x)) -#define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v))) - -#define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i])) -#define SCM_CCLO_SET(x, i, v) (SCM_CCLO_BASE (x) [i] = SCM_UNPACK (v)) - -#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0)) -#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v))) - /* Closures */ @@ -129,7 +117,6 @@ SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type, SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)()); SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type, SCM (*fcn)(), SCM *gf); -SCM_API SCM scm_makcclo (SCM proc, size_t len); SCM_API SCM scm_procedure_p (SCM obj); SCM_API SCM scm_closure_p (SCM obj); SCM_API SCM scm_thunk_p (SCM obj); @@ -141,10 +128,6 @@ SCM_API SCM scm_procedure (SCM proc); SCM_API SCM scm_setter (SCM proc); SCM_INTERNAL void scm_init_procs (void); -#ifdef GUILE_DEBUG -SCM_API SCM scm_make_cclo (SCM proc, SCM len); -#endif /*GUILE_DEBUG*/ - #endif /* SCM_PROCS_H */ /* diff --git a/libguile/stacks.c b/libguile/stacks.c index 4b97a18..86597fa 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -1,5 +1,5 @@ /* Representation of stack frame debug information - * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation + * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -293,9 +293,6 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, NEXT_FRAME (iframe, n, quit); } } - else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply)) - /* Skip gsubr apply frames. */ - continue; else { NEXT_FRAME (iframe, n, quit); diff --git a/libguile/tags.h b/libguile/tags.h index 4e0700b..2f30369 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -455,7 +455,7 @@ typedef unsigned long scm_t_bits; #define scm_tc7_unused_9 79 #define scm_tc7_dsubr 61 -#define scm_tc7_cclo 63 +#define scm_tc7_gsubr 63 #define scm_tc7_rpsubr 69 #define scm_tc7_subr_0 85 #define scm_tc7_subr_1 87 @@ -677,7 +677,8 @@ enum scm_tc8_tags case scm_tc7_subr_1o:\ case scm_tc7_subr_2o:\ case scm_tc7_lsubr_2:\ - case scm_tc7_lsubr + case scm_tc7_lsubr: \ + case scm_tc7_gsubr -- 1.6.0.4