diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/__scm.h | 4 | ||||
-rw-r--r-- | libguile/debug.c | 8 | ||||
-rw-r--r-- | libguile/eval.c | 8 | ||||
-rw-r--r-- | libguile/eval.i.c | 56 | ||||
-rw-r--r-- | libguile/evalext.c | 3 | ||||
-rw-r--r-- | libguile/goops.c | 2 | ||||
-rw-r--r-- | libguile/gsubr.c | 198 | ||||
-rw-r--r-- | libguile/gsubr.h | 19 | ||||
-rw-r--r-- | libguile/print.c | 27 | ||||
-rw-r--r-- | libguile/procprop.c | 25 | ||||
-rw-r--r-- | libguile/procs.c | 47 | ||||
-rw-r--r-- | libguile/procs.h | 17 | ||||
-rw-r--r-- | libguile/stacks.c | 5 | ||||
-rw-r--r-- | libguile/tags.h | 5 |
14 files changed, 195 insertions, 229 deletions
diff --git a/libguile/__scm.h b/libguile/__scm.h index d486b69bf..3672b1c09 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 91ba3fed8..a8ccdf8d3 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 49f1b583b..18cd3b11f 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 83878ff41..ae666d415 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_i_gsubr_apply (proc, SCM_UNDEFINED)); 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_i_gsubr_apply (proc, arg1, SCM_UNDEFINED)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL @@ -1350,20 +1345,11 @@ dispatch: if (!SCM_SMOB_APPLICABLE_P (proc)) 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), - SCM_EOL)); + RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args)); #else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_ceval_args (x, - env, - proc))), - SCM_EOL)); + RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED)); #endif case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) @@ -1492,8 +1478,8 @@ dispatch: goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, SCM_CDDR (debug.info->a.args))); - case scm_tc7_cclo: - goto cclon; + case scm_tc7_gsubr: + RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); debug.info->a.proc = proc; @@ -1555,8 +1541,16 @@ dispatch: goto badfun; RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, scm_ceval_args (x, env, proc))); - case scm_tc7_cclo: - goto cclon; + case scm_tc7_gsubr: + if (scm_is_null (SCM_CDR (x))) + /* 3 arguments */ + RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env), + SCM_UNDEFINED)); + else + RETURN (scm_i_gsubr_apply_list (proc, + scm_cons2 (arg1, arg2, + scm_ceval_args (x, env, + proc)))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); if (!SCM_CLOSUREP (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_i_gsubr_apply_list (proc, args)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); #ifdef DEVAL diff --git a/libguile/evalext.c b/libguile/evalext.c index 9bec8f410..5ca78066d 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/goops.c b/libguile/goops.c index 520b1c25d..bbeb58433 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -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 fdb70ed92..2b9a29dd1 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -21,6 +21,8 @@ #endif #include <stdio.h> +#include <stdarg.h> + #include "libguile/_scm.h" #include "libguile/procprop.h" #include "libguile/root.h" @@ -40,11 +42,10 @@ SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); -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,47 @@ 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; + unsigned type; + + type = SCM_GSUBR_MAKTYPE (req, opt, rst); + if (SCM_GSUBR_REQ (type) != req + || SCM_GSUBR_OPT (type) != opt + || SCM_GSUBR_REST (type) != rst) + scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst)); + + subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U), + fcn); } } + + if (define) + scm_define (SCM_SNAME (subr), subr); + + return subr; } SCM @@ -184,26 +179,121 @@ scm_c_define_gsubr_with_generic (const char *name, return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf); } +/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to + match the number of arguments of the underlying C function. */ +static SCM +gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv) +{ + SCM (*fcn) (); + unsigned int type, argc_max; + + type = SCM_GSUBR_TYPE (proc); + argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type) + + SCM_GSUBR_REST (type); + + if (SCM_UNLIKELY (argc != argc_max)) + /* We expect the exact argument count. */ + scm_wrong_num_args (SCM_SNAME (proc)); + + fcn = SCM_SUBRF (proc); + + switch (argc) + { + case 0: + return (*fcn) (); + case 1: + return (*fcn) (argv[0]); + case 2: + return (*fcn) (argv[0], argv[1]); + case 3: + return (*fcn) (argv[0], argv[1], argv[2]); + case 4: + return (*fcn) (argv[0], argv[1], argv[2], argv[3]); + case 5: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]); + case 6: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); + case 7: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], + argv[6]); + case 8: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], + argv[6], argv[7]); + case 9: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], + argv[6], argv[7], argv[8]); + case 10: + return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5], + argv[6], argv[7], argv[8], argv[9]); + default: + scm_misc_error ((char *) SCM_SNAME (proc), + "gsubr invocation with more than 10 arguments not implemented", + SCM_EOL); + } + return SCM_BOOL_F; /* Never reached. */ +} + +/* Apply PROC, a gsubr, to the given arguments. Missing optional arguments + are added, and rest arguments are turned into a list. */ SCM -scm_gsubr_apply (SCM args) -#define FUNC_NAME "scm_gsubr_apply" +scm_i_gsubr_apply (SCM proc, SCM arg, ...) +{ + unsigned int type, argc, argc_max; + SCM *argv; + va_list arg_list; + + type = SCM_GSUBR_TYPE (proc); + argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type); + argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv)); + + va_start (arg_list, arg); + + for (argc = 0; + !SCM_UNBNDP (arg) && argc < argc_max; + argc++, arg = va_arg (arg_list, SCM)) + argv[argc] = arg; + + if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type))) + scm_wrong_num_args (SCM_SNAME (proc)); + + /* Fill in optional arguments that were not passed. */ + while (argc < argc_max) + argv[argc++] = SCM_UNDEFINED; + + if (SCM_GSUBR_REST (type)) + { + /* Accumulate rest arguments in a list. */ + SCM *rest_loc; + + argv[argc_max] = SCM_EOL; + + for (rest_loc = &argv[argc_max]; + !SCM_UNBNDP (arg); + rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM)) + *rest_loc = scm_cons (arg, SCM_EOL); + + argc = argc_max + 1; + } + + va_end (arg_list); + + return gsubr_apply_raw (proc, argc, argv); +} + +/* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional + arguments are added, and rest arguments are kept into a list. */ +SCM +scm_i_gsubr_apply_list (SCM self, SCM args) +#define FUNC_NAME "scm_i_gsubr_apply" { - SCM self = SCM_CAR (args); - SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (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,19 +308,9 @@ 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))); - switch (n) { - case 2: return (*fcn)(v[0], v[1]); - case 3: return (*fcn)(v[0], v[1], v[2]); - case 4: return (*fcn)(v[0], v[1], v[2], v[3]); - case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]); - case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]); - case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]); - 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]); - } - return SCM_BOOL_F; /* Never reached. */ + scm_wrong_num_args (SCM_SNAME (self)); + + return gsubr_apply_raw (self, n, v); } #undef FUNC_NAME @@ -259,8 +339,6 @@ gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) void scm_init_gsubr() { - scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr, - scm_gsubr_apply); #ifdef GSUBR_TEST scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ #endif diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 418564901..65680a02c 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, @@ -50,7 +48,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name, int req, int opt, int rst, SCM (*fcn) (), SCM *gf); -SCM_API SCM scm_gsubr_apply (SCM args); +SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...); +SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args); SCM_INTERNAL void scm_init_gsubr (void); #endif /* SCM_GSUBR_H */ diff --git a/libguile/print.c b/libguile/print.c index 7906200ee..1852cf19a 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 @@ -671,30 +671,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 ("#<primitive-procedure", port); - if (scm_is_true (name)) - { - scm_putc (' ', port); - scm_puts (scm_i_symbol_chars (name), port); - } - } - else - { - scm_puts ("#<compiled-closure ", port); - scm_iprin1 (proc, port, pstate); - } - scm_putc ('>', port); - } - break; -#endif + case scm_tc7_pws: scm_puts ("#<procedure-with-setter", port); { diff --git a/libguile/procprop.c b/libguile/procprop.c index 88f2c2218..db16834c5 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,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 @@ -88,21 +88,14 @@ scm_i_procedure_arity (SCM proc) { return SCM_BOOL_F; } - case scm_tc7_cclo: - if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply)) - { - int type = scm_to_int (SCM_GSUBR_TYPE (proc)); - a += SCM_GSUBR_REQ (type); - o = SCM_GSUBR_OPT (type); - r = SCM_GSUBR_REST (type); - break; - } - else - { - proc = SCM_CCLO_SUBR (proc); - a -= 1; - goto loop; - } + case scm_tc7_gsubr: + { + unsigned int type = SCM_GSUBR_TYPE (proc); + a = SCM_GSUBR_REQ (type); + o = SCM_GSUBR_OPT (type); + r = SCM_GSUBR_REST (type); + break; + } case scm_tc7_pws: proc = SCM_PROCEDURE (proc); goto loop; diff --git a/libguile/procs.c b/libguile/procs.c index f99b524d0..56bb0bb14 100644 --- a/libguile/procs.c +++ b/libguile/procs.c @@ -81,39 +81,6 @@ scm_c_define_subr_with_generic (const char *name, } -#ifdef CCLO -SCM -scm_makcclo (SCM proc, size_t len) -{ - scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits), - "compiled closure"); - unsigned long i; - SCM s; - - for (i = 0; i < len; ++i) - base [i] = SCM_UNPACK (SCM_UNSPECIFIED); - - s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base); - SCM_SET_CCLO_SUBR (s, proc); - return s; -} - -/* Undocumented debugging procedure */ -#ifdef GUILE_DEBUG -SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0, - (SCM proc, SCM len), - "Create a compiled closure for @var{proc}, which reserves\n" - "@var{len} objects for its usage.") -#define FUNC_NAME s_scm_make_cclo -{ - return scm_makcclo (proc, scm_to_size_t (len)); -} -#undef FUNC_NAME -#endif -#endif - - - SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a procedure.") @@ -127,9 +94,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, break; case scm_tcs_closures: case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif case scm_tc7_pws: return SCM_BOOL_T; case scm_tc7_smob: @@ -167,10 +131,9 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, case scm_tc7_lsubr: case scm_tc7_rpsubr: case scm_tc7_asubr: -#ifdef CCLO - case scm_tc7_cclo: -#endif return SCM_BOOL_T; + case scm_tc7_gsubr: + return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); case scm_tc7_pws: obj = SCM_PROCEDURE (obj); goto again; @@ -221,12 +184,6 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, return SCM_BOOL_F; default: return SCM_BOOL_F; -/* - case scm_tcs_subrs: -#ifdef CCLO - case scm_tc7_cclo: -#endif -*/ } } #undef FUNC_NAME diff --git a/libguile/procs.h b/libguile/procs.h index 354d27179..3ccf1ee33 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -39,18 +39,6 @@ #define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g)) #define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits) g)) -#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 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 */ @@ -121,7 +109,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); @@ -133,10 +120,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 4b97a1827..86597fa0b 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 4e0700b52..2f30369d9 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 |