diff options
38 files changed, 369 insertions, 301 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 6458869ef..058620928 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,15 @@ +2001-06-28 Keisuke Nishida <kxn30@po.cwru.edu> + + * list.h (scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5, + scm_list_n): New functions. + (SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, + SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify): Deprecated. + (lots of files): Use the new functions. + + * goops.c (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4): Use scm_call_N. + + * strings.c: #include "libguile/deprecation.h". + 2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de> * read.c (scm_lreadr): When reading a hash token, check for a diff --git a/libguile/continuations.c b/libguile/continuations.c index 3bf0f9074..ae936fe78 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -232,7 +232,7 @@ continuation_apply (SCM cont, SCM args) || continuation->base != rootcont->base) { SCM_MISC_ERROR ("continuation from wrong top level: ~S", - SCM_LIST1 (cont)); + scm_list_1 (cont)); } scm_dowinds (continuation->dynenv, diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 6501d7fa3..9271fb0c5 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -66,7 +66,7 @@ scm_c_issue_deprecation_warning (const char *msg) if (SCM_BOOLP (issued_msgs)) issued_msgs = SCM_BOOL_T; else - scm_issue_deprecation_warning (SCM_LIST1 (scm_makfrom0str (msg))); + scm_issue_deprecation_warning (scm_list_1 (scm_makfrom0str (msg))); } SCM_DEFINE(scm_issue_deprecation_warning, diff --git a/libguile/dynl.c b/libguile/dynl.c index 1bc797af9..006bbff6a 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -254,7 +254,7 @@ sysdep_dynl_link (const char *fname, const char *subr) SCM_ALLOW_INTS; fn = scm_makfrom0str (fname); msg = scm_makfrom0str (lt_dlerror ()); - scm_misc_error (subr, "file: ~S, message: ~S", SCM_LIST2 (fn, msg)); + scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg)); } return (void *) handle; } diff --git a/libguile/environments.c b/libguile/environments.c index 58a4cff8b..541427641 100644 --- a/libguile/environments.c +++ b/libguile/environments.c @@ -816,7 +816,7 @@ update_catch_handler (void *ptr, SCM tag, SCM args) SCM observer = data->observer; SCM message = scm_makfrom0str ("Observer `~A' signals `~A' error: ~S"); - return scm_cons (message, SCM_LIST3 (observer, tag, args)); + return scm_cons (message, scm_list_3 (observer, tag, args)); } diff --git a/libguile/error.c b/libguile/error.c index b37db72a5..0fd20718a 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -81,10 +81,10 @@ scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest) message ? message : "<empty message>"); abort (); } - arg_list = SCM_LIST4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, - message ? scm_makfrom0str (message) : SCM_BOOL_F, - args, - rest); + arg_list = scm_list_4 (subr ? scm_makfrom0str (subr) : SCM_BOOL_F, + message ? scm_makfrom0str (message) : SCM_BOOL_F, + args, + rest); scm_ithrow (key, arg_list, 1); /* No return, but just in case: */ @@ -202,7 +202,7 @@ scm_out_of_range (const char *subr, SCM bad_value) scm_error (scm_out_of_range_key, subr, "Argument out of range: ~S", - SCM_LIST1(bad_value), + scm_list_1 (bad_value), SCM_BOOL_F); } @@ -212,7 +212,7 @@ scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos) scm_error (scm_out_of_range_key, subr, "Argument ~S out of range: ~S", - SCM_LIST2(pos,bad_value), + scm_list_2 (pos,bad_value), SCM_BOOL_F); } @@ -224,7 +224,7 @@ scm_wrong_num_args (SCM proc) scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - SCM_LIST1(proc), + scm_list_1 (proc), SCM_BOOL_F); } @@ -235,7 +235,7 @@ scm_error_num_args_subr (const char *subr) scm_error (scm_args_number_key, NULL, "Wrong number of arguments to ~A", - SCM_LIST1 (scm_makfrom0str (subr)), + scm_list_1 (scm_makfrom0str (subr)), SCM_BOOL_F); } @@ -248,8 +248,8 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) subr, (pos == 0) ? "Wrong type argument: ~S" : "Wrong type argument in position ~A: ~S", - (pos == 0) ? SCM_LIST1(bad_value) - : SCM_LIST2(SCM_MAKINUM(pos), bad_value), + (pos == 0) ? scm_list_1 (bad_value) + : scm_list_2 (SCM_MAKINUM (pos), bad_value), SCM_BOOL_F); } @@ -260,13 +260,13 @@ scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *sz if (pos == 0) { scm_error (scm_arg_type_key, subr, "Wrong type argument (expecting ~A): ~S", - SCM_LIST2(msg,bad_value), + scm_list_2 (msg, bad_value), SCM_BOOL_F); } else { scm_error (scm_arg_type_key, subr, "Wrong type argument in position ~A (expecting ~A): ~S", - SCM_LIST3(SCM_MAKINUM(pos),msg,bad_value), + scm_list_3 (SCM_MAKINUM (pos), msg, bad_value), SCM_BOOL_F); } } @@ -300,7 +300,7 @@ scm_wta (SCM arg, const char *pos, const char *s_subr) if ((~0x1fL) & (long) pos) { /* error string supplied. */ - scm_misc_error (s_subr, pos, SCM_LIST1 (arg)); + scm_misc_error (s_subr, pos, scm_list_1 (arg)); } else { diff --git a/libguile/eval.c b/libguile/eval.c index ffd195ca5..337c52a8c 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2523,7 +2523,7 @@ dispatch: proc = x; badfun: /* scm_everr (x, env,...) */ - scm_misc_error (NULL, "Wrong type to apply: ~S", SCM_LIST1 (proc)); + scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); case scm_tc7_vector: case scm_tc7_wvect: #ifdef HAVE_ARRAYS diff --git a/libguile/evalext.c b/libguile/evalext.c index b19f94c21..aa44cc502 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -63,8 +63,8 @@ scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED) if (SCM_SYMBOLP (SCM_CAR (x))) return scm_cons (SCM_IM_SET_X, x); else if (SCM_CONSP (SCM_CAR (x))) - return scm_cons (SCM_LIST2 (scm_sym_setter, SCM_CAAR (x)), - scm_append (SCM_LIST2 (SCM_CDAR (x), SCM_CDR (x)))); + return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)), + scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x)))); else scm_misc_error (scm_s_set_x, scm_s_variable, SCM_EOL); } diff --git a/libguile/filesys.c b/libguile/filesys.c index 0593414c3..4f7a5d09e 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -574,7 +574,8 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - SCM_LIST2 (scm_makfrom0str (strerror (errno)), object), + scm_list_2 (scm_makfrom0str (strerror (errno)), + object), en); } return scm_stat2scm (&stat_temp); @@ -753,7 +754,7 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, SCM_VALIDATE_DIR (1, port); if (!SCM_DIR_OPEN_P (port)) - SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); errno = 0; SCM_SYSCALL (rdent = readdir ((DIR *) SCM_CELL_WORD_1 (port))); @@ -774,7 +775,7 @@ SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0, { SCM_VALIDATE_DIR (1, port); if (!SCM_DIR_OPEN_P (port)) - SCM_MISC_ERROR ("Directory ~S is not open.", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); rewinddir ((DIR *) SCM_CELL_WORD_1 (port)); @@ -1162,9 +1163,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, if (rv < 0) SCM_SYSERROR; } - return SCM_LIST3 (retrieve_select_type (&read_set, read_ports_ready, reads), - retrieve_select_type (&write_set, write_ports_ready, writes), - retrieve_select_type (&except_set, SCM_EOL, excepts)); + return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), + retrieve_select_type (&write_set, write_ports_ready, writes), + retrieve_select_type (&except_set, SCM_EOL, excepts)); } #undef FUNC_NAME #endif /* HAVE_SELECT */ @@ -1325,7 +1326,7 @@ SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0, int en = errno; SCM_SYSERROR_MSG ("~A: ~S", - SCM_LIST2 (scm_makfrom0str (strerror (errno)), str), + scm_list_2 (scm_makfrom0str (strerror (errno)), str), en); } return scm_stat2scm(&stat_temp); diff --git a/libguile/fluids.c b/libguile/fluids.c index 206808ab1..3f092ffff 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -253,7 +253,7 @@ SCM scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) #define FUNC_NAME "scm_c_with_fluid" { - return scm_c_with_fluids (SCM_LIST1 (fluid), SCM_LIST1 (value), + return scm_c_with_fluids (scm_list_1 (fluid), SCM_LIST1 (value), cproc, cdata); } #undef FUNC_NAME diff --git a/libguile/gc.c b/libguile/gc.c index dc14f5216..ac7f8fe85 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -841,18 +841,18 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, local_scm_gc_cells_swept = scm_gc_cells_swept_acc; local_scm_gc_cells_marked = scm_gc_cells_marked_acc; - answer = scm_listify (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), - scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), - scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), - scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), - scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), - scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), - scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), - scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), - scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), - scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)), - scm_cons (sym_heap_segments, heap_segs), - SCM_UNDEFINED); + answer = scm_list_n (scm_cons (sym_gc_time_taken, scm_ulong2num (local_scm_gc_time_taken)), + scm_cons (sym_cells_allocated, scm_ulong2num (local_scm_cells_allocated)), + scm_cons (sym_heap_size, scm_ulong2num (local_scm_heap_size)), + scm_cons (sym_mallocated, scm_ulong2num (local_scm_mallocated)), + scm_cons (sym_mtrigger, scm_ulong2num (local_scm_mtrigger)), + scm_cons (sym_times, scm_ulong2num (local_scm_gc_times)), + scm_cons (sym_gc_mark_time_taken, scm_ulong2num (local_scm_gc_mark_time_taken)), + scm_cons (sym_gc_sweep_time_taken, scm_ulong2num (local_scm_gc_sweep_time_taken)), + scm_cons (sym_cells_marked, scm_i_dbl2big (local_scm_gc_cells_marked)), + scm_cons (sym_cells_swept, scm_i_dbl2big (local_scm_gc_cells_swept)), + scm_cons (sym_heap_segments, heap_segs), + SCM_UNDEFINED); SCM_ALLOW_INTS; return answer; } diff --git a/libguile/gh.h b/libguile/gh.h index af1f952ed..dab80b07f 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -188,7 +188,7 @@ SCM gh_lookup (const char *sname); SCM gh_module_lookup (SCM module, const char *sname); SCM gh_cons(SCM x, SCM y); -#define gh_list scm_listify +#define gh_list scm_list_n unsigned long gh_length(SCM l); SCM gh_append(SCM args); SCM gh_append2(SCM l1, SCM l2); diff --git a/libguile/gh_list.c b/libguile/gh_list.c index 71af25ee8..6935ffc4a 100644 --- a/libguile/gh_list.c +++ b/libguile/gh_list.c @@ -59,27 +59,27 @@ gh_length (SCM l) them all together into a single list, which is returned. This is equivalent to the Scheme procedure (append list1 list2 ...) */ SCM -gh_append(SCM args) +gh_append (SCM args) { - return scm_append(args); + return scm_append (args); } SCM -gh_append2(SCM l1, SCM l2) +gh_append2 (SCM l1, SCM l2) { - return scm_append(scm_listify(l1, l2, SCM_UNDEFINED)); + return scm_append (scm_list_2 (l1, l2)); } SCM gh_append3(SCM l1, SCM l2, SCM l3) { - return scm_append(scm_listify(l1, l2, l3, SCM_UNDEFINED)); + return scm_append (scm_list_3 (l1, l2, l3)); } SCM -gh_append4(SCM l1, SCM l2, SCM l3, SCM l4) +gh_append4 (SCM l1, SCM l2, SCM l3, SCM l4) { - return scm_append(scm_listify(l1, l2, l3, l4, SCM_UNDEFINED)); + return scm_append (scm_list_4 (l1, l2, l3, l4)); } /* gh_reverse() is defined as a macro in gh.h */ diff --git a/libguile/goops.c b/libguile/goops.c index 3ae186e75..13a677218 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -76,22 +76,22 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) #define DEFVAR(v,val) \ -{ scm_eval (SCM_LIST3 (scm_sym_define_public, (v), (val)), \ - scm_module_goops); } +{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ + scm_module_goops); } /* Temporary hack until we get the new module system */ /*fixme* Should optimize by keeping track of the variable object itself */ #define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ (v), SCM_BOOL_F))) /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST1 (a), SCM_EOL)) -#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST2 (a, b), SCM_EOL)) -#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST3 (a, b, c), SCM_EOL)) -#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \ - SCM_LIST4 (a, b, c, d), SCM_EOL)) +#define CALL_GF1(name,a) (scm_call_1 (GETVAR (scm_str2symbol (name)), \ + a)) +#define CALL_GF2(name,a,b) (scm_call_2 (GETVAR (scm_str2symbol (name)), \ + a, b)) +#define CALL_GF3(name,a,b,c) (scm_call_3 (GETVAR (scm_str2symbol (name)), \ + a, b, c)) +#define CALL_GF4(name,a,b,c,d) (scm_call_4 (GETVAR (scm_str2symbol (name)), \ + a, b, c, d)) /* Class redefinition protocol: @@ -245,7 +245,7 @@ remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen) tmp = SCM_CAAR (l); if (!SCM_SYMBOLP (tmp)) - scm_misc_error ("%compute-slots", "bad slot name ~S", SCM_LIST1 (tmp)); + scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp)); if (SCM_FALSEP (scm_c_memq (tmp, slots_already_seen))) { res = scm_cons (SCM_CAR (l), res); @@ -261,8 +261,9 @@ build_slots_list (SCM dslots, SCM cpl) register SCM res = dslots; for (cpl = SCM_CDR(cpl); SCM_NNULLP(cpl); cpl = SCM_CDR(cpl)) - res = scm_append (SCM_LIST2 (SCM_SLOT (SCM_CAR (cpl), scm_si_direct_slots), - res)); + res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl), + scm_si_direct_slots), + res)); /* res contains a list of slots. Remove slots which appears more than once */ return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL); @@ -323,7 +324,7 @@ compute_getters_n_setters (SCM slots) { init = scm_get_keyword (k_init_value, options, 0); if (init) - init = scm_closure (SCM_LIST2 (SCM_EOL, init), SCM_EOL); + init = scm_closure (scm_list_2 (SCM_EOL, init), SCM_EOL); else init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F); } @@ -353,7 +354,7 @@ scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr SCM obj = SCM_CAR (l); if (!SCM_KEYWORDP (obj)) - scm_misc_error (subr, "bad keyword: ~S", SCM_LIST1 (obj)); + scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj)); else if (SCM_EQ_P (obj, key)) return SCM_CADR (l); else @@ -379,7 +380,7 @@ SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0, SCM_ASSERT (SCM_KEYWORDP (key), key, SCM_ARG1, FUNC_NAME); len = scm_ilength (l); if (len < 0 || len % 2 == 1) - scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", SCM_LIST1 (l)); + scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l)); return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME); } @@ -422,7 +423,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, long n = scm_ilength (SCM_CDR (slot_name)); if (n & 1) /* odd or -1 */ SCM_MISC_ERROR ("class contains bogus slot definition: ~S", - SCM_LIST1 (slot_name)); + scm_list_1 (slot_name)); tmp = scm_i_get_keyword (k_init_keyword, SCM_CDR (slot_name), n, @@ -434,7 +435,7 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, /* an initarg was provided for this slot */ if (!SCM_KEYWORDP (tmp)) SCM_MISC_ERROR ("initarg must be a keyword. It was ~S", - SCM_LIST1 (tmp)); + scm_list_1 (tmp)); slot_value = scm_i_get_keyword (tmp, initargs, n_initargs, @@ -487,12 +488,12 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0, nfields = SCM_SLOT (class, scm_si_nfields); if (!SCM_INUMP (nfields) || SCM_INUM (nfields) < 0) SCM_MISC_ERROR ("bad value in nfields slot: ~S", - SCM_LIST1 (nfields)); + scm_list_1 (nfields)); n = 2 * SCM_INUM (nfields); if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1 && SCM_SUBCLASSP (class, scm_class_class)) SCM_MISC_ERROR ("class object doesn't have enough fields: ~S", - SCM_LIST1 (nfields)); + scm_list_1 (nfields)); s = n > 0 ? scm_must_malloc (n, FUNC_NAME) : 0; for (i = 0; i < n; i += 2) @@ -606,7 +607,7 @@ scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots) /* Initialize its slots */ #if 0 - cpl = compute_cpl (dsupers, SCM_LIST1(z)); + cpl = compute_cpl (dsupers, scm_list_1 (z)); #endif SCM_SET_SLOT (z, scm_si_direct_supers, dsupers); cpl = compute_cpl (z); @@ -661,47 +662,47 @@ static SCM build_class_class_slots () { return maplist ( - scm_cons (SCM_LIST3 (scm_str2symbol ("layout"), - k_class, - scm_class_protected_read_only), - scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"), - k_class, - scm_class_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"), - k_class, - scm_class_self), + scm_cons (scm_list_3 (scm_str2symbol ("layout"), + k_class, + scm_class_protected_read_only), + scm_cons (scm_list_3 (scm_str2symbol ("vcell"), + k_class, + scm_class_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("vtable"), + k_class, + scm_class_self), scm_cons (scm_str2symbol ("print"), - scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"), - k_class, - scm_class_protected_opaque), - scm_cons (SCM_LIST3 (scm_str2symbol ("setter"), - k_class, - scm_class_protected_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("procedure"), + k_class, + scm_class_protected_opaque), + scm_cons (scm_list_3 (scm_str2symbol ("setter"), + k_class, + scm_class_protected_opaque), scm_cons (scm_str2symbol ("redefined"), - scm_cons (SCM_LIST3 (scm_str2symbol ("h0"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h1"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h2"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h3"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h4"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h5"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h6"), - k_class, - scm_class_int), - scm_cons (SCM_LIST3 (scm_str2symbol ("h7"), - k_class, - scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h0"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h1"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h2"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h3"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h4"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h5"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h6"), + k_class, + scm_class_int), + scm_cons (scm_list_3 (scm_str2symbol ("h7"), + k_class, + scm_class_int), scm_cons (scm_str2symbol ("name"), scm_cons (scm_str2symbol ("direct-supers"), scm_cons (scm_str2symbol ("direct-slots"), @@ -763,16 +764,16 @@ create_basic_classes (void) name = scm_str2symbol ("<object>"); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, - SCM_LIST1 (scm_class_top), + scm_list_1 (scm_class_top), SCM_EOL)); DEFVAR (name, scm_class_object); /* <top> <object> and <class> were partially initialized. Correct them here */ - SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, SCM_LIST1 (scm_class_class)); + SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class)); - SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_LIST1 (scm_class_object)); - SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_LIST3 (scm_class_class, scm_class_object, scm_class_top)); + SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object)); + SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top)); } /******************************************************************************/ @@ -1065,7 +1066,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) if (!SCM_CLOSUREP (code)) return SCM_SUBRF (code) (obj); env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST1 (obj), + scm_list_1 (obj), SCM_ENV (code)); /* Evaluate the closure body */ return scm_eval_body (SCM_CDR (SCM_CODE (code)), env); @@ -1104,7 +1105,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) else { env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), - SCM_LIST2 (obj, value), + scm_list_2 (obj, value), SCM_ENV (code)); /* Evaluate the closure body */ scm_eval_body (SCM_CDR (SCM_CODE (code)), env); @@ -1521,7 +1522,7 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class) { if (!burnin (obj)) scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven, - (void *) SCM_LIST2 (obj, new_class), + (void *) scm_list_2 (obj, new_class), (void *) obj); } @@ -1552,10 +1553,12 @@ SCM_SYMBOL (scm_sym_args, "args"); SCM scm_make_method_cache (SCM gf) { - return SCM_LIST5 (SCM_IM_DISPATCH, scm_sym_args, SCM_MAKINUM (1), - scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, - list_of_no_method), - gf); + return scm_list_5 (SCM_IM_DISPATCH, + scm_sym_args, + SCM_MAKINUM (1), + scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE, + list_of_no_method), + gf); } static void @@ -1616,9 +1619,9 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1 SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr), subr, SCM_ARGn, FUNC_NAME); *SCM_SUBR_GENERIC (subr) - = scm_make (SCM_LIST3 (scm_class_generic, - k_name, - SCM_SNAME (subr))); + = scm_make (scm_list_3 (scm_class_generic, + k_name, + SCM_SNAME (subr))); subrs = SCM_CDR (subrs); } return SCM_UNSPECIFIED; @@ -1915,7 +1918,7 @@ scm_m_atdispatch (SCM xorig, SCM env) x = SCM_CDR (x); gf = SCM_XEVALCAR (x, env); SCM_VALIDATE_PUREGENERIC (SCM_ARG4, gf); - return SCM_LIST5 (SCM_IM_DISPATCH, args, n, v, gf); + return scm_list_5 (SCM_IM_DISPATCH, args, n, v, gf); } #undef FUNC_NAME @@ -2003,13 +2006,13 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, { #ifdef USE_THREADS z = scm_make_struct (class, SCM_INUM0, - SCM_LIST4 (SCM_EOL, - SCM_INUM0, - SCM_BOOL_F, - scm_make_mutex ())); + scm_list_4 (SCM_EOL, + SCM_INUM0, + SCM_BOOL_F, + scm_make_mutex ())); #else z = scm_make_struct (class, SCM_INUM0, - SCM_LIST3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); + scm_list_3 (SCM_EOL, SCM_INUM0, SCM_BOOL_F)); #endif scm_set_procedure_property_x (z, scm_sym_name, scm_get_keyword (k_name, @@ -2092,7 +2095,7 @@ SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1, gf = SCM_CAR(l); l = SCM_CDR(l); SCM_VALIDATE_GENERIC (1, gf); if (SCM_NULLP (SCM_SLOT (gf, scm_si_methods))) - SCM_MISC_ERROR ("no methods for generic ~S", SCM_LIST1 (gf)); + SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf)); return scm_compute_applicable_methods (gf, l, len - 1, 1); } @@ -2139,7 +2142,7 @@ make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) tmp, SCM_CONSP (super) ? super - : SCM_LIST1 (super), + : scm_list_1 (super), slots)); DEFVAR(tmp, *var); } @@ -2151,30 +2154,30 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"), - scm_str2symbol ("specializers"), - scm_str2symbol ("procedure"), - scm_str2symbol ("code-table")); - SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"), - k_init_keyword, - k_slot_definition)); + SCM method_slots = scm_list_4 (scm_str2symbol ("generic-function"), + scm_str2symbol ("specializers"), + scm_str2symbol ("procedure"), + scm_str2symbol ("code-table")); + SCM amethod_slots = scm_list_1 (scm_list_3 (scm_str2symbol ("slot-definition"), + k_init_keyword, + k_slot_definition)); #ifdef USE_THREADS - SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex")); + SCM mutex_slot = scm_list_1 (scm_str2symbol ("make-mutex")); #else SCM mutex_slot = SCM_BOOL_F; #endif - SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"), - SCM_LIST3 (scm_str2symbol ("n-specialized"), - k_init_value, - SCM_INUM0), - SCM_LIST3 (scm_str2symbol ("used-by"), - k_init_value, - SCM_BOOL_F), - SCM_LIST3 (scm_str2symbol ("cache-mutex"), - k_init_thunk, - scm_closure (SCM_LIST2 (SCM_EOL, - mutex_slot), - SCM_EOL))); + SCM gf_slots = scm_list_4 (scm_str2symbol ("methods"), + scm_list_3 (scm_str2symbol ("n-specialized"), + k_init_value, + SCM_INUM0), + scm_list_3 (scm_str2symbol ("used-by"), + k_init_value, + SCM_BOOL_F), + scm_list_3 (scm_str2symbol ("cache-mutex"), + k_init_thunk, + scm_closure (scm_list_2 (SCM_EOL, + mutex_slot), + SCM_EOL))); /* Foreign class slot classes */ make_stdcls (&scm_class_foreign_slot, "<foreign-slot>", @@ -2187,15 +2190,15 @@ create_standard_classes (void) scm_class_class, scm_class_foreign_slot, SCM_EOL); make_stdcls (&scm_class_self, "<self-slot>", scm_class_class, - SCM_LIST2 (scm_class_foreign_slot, scm_class_read_only), + scm_list_2 (scm_class_foreign_slot, scm_class_read_only), SCM_EOL); make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_opaque), + scm_list_2 (scm_class_protected, scm_class_opaque), SCM_EOL); make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>", scm_class_class, - SCM_LIST2 (scm_class_protected, scm_class_read_only), + scm_list_2 (scm_class_protected, scm_class_read_only), SCM_EOL); make_stdcls (&scm_class_scm, "<scm-slot>", scm_class_class, scm_class_protected, SCM_EOL); @@ -2216,12 +2219,12 @@ create_standard_classes (void) make_stdcls (&scm_class_foreign_class, "<foreign-class>", scm_class_class, scm_class_class, - SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"), - k_class, - scm_class_opaque), - SCM_LIST3 (scm_str2symbol ("destructor"), - k_class, - scm_class_opaque))); + scm_list_2 (scm_list_3 (scm_str2symbol ("constructor"), + k_class, + scm_class_opaque), + scm_list_3 (scm_str2symbol ("destructor"), + k_class, + scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "<foreign-object>", scm_class_foreign_class, scm_class_object, SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN); @@ -2253,16 +2256,16 @@ create_standard_classes (void) SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC); make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>", scm_class_entity_class, - SCM_LIST2 (scm_class_generic, scm_class_entity_with_setter), + scm_list_2 (scm_class_generic, scm_class_entity_with_setter), SCM_EOL); #if 0 /* Patch cpl since compute_cpl doesn't support multiple inheritance. */ SCM_SET_SLOT (scm_class_generic_with_setter, scm_si_cpl, - scm_append (SCM_LIST3 (SCM_LIST2 (scm_class_generic_with_setter, - scm_class_generic), - SCM_SLOT (scm_class_entity_with_setter, - scm_si_cpl), - SCM_EOL))); + scm_append (scm_list_3 (scm_list_2 (scm_class_generic_with_setter, + scm_class_generic), + SCM_SLOT (scm_class_entity_with_setter, + scm_si_cpl), + SCM_EOL))); #endif SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC); @@ -2309,7 +2312,7 @@ create_standard_classes (void) scm_class_class, scm_class_port, SCM_EOL); make_stdcls (&scm_class_input_output_port, "<input-output-port>", scm_class_class, - SCM_LIST2 (scm_class_input_port, scm_class_output_port), + scm_list_2 (scm_class_input_port, scm_class_output_port), SCM_EOL); } @@ -2349,7 +2352,7 @@ scm_make_extended_class (char *type_name) { return make_class_from_template ("<%s>", type_name, - SCM_LIST1 (scm_class_top)); + scm_list_1 (scm_class_top)); } static void @@ -2376,21 +2379,20 @@ scm_make_port_classes (long ptobnum, char *type_name) { SCM c, class = make_class_from_template ("<%s-port>", type_name, - SCM_LIST1 (scm_class_port)); + scm_list_1 (scm_class_port)); scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-input-port>", type_name, - SCM_LIST2 (class, scm_class_input_port)); + scm_list_2 (class, scm_class_input_port)); scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum] = make_class_from_template ("<%s-output-port>", type_name, - SCM_LIST2 (class, scm_class_output_port)); + scm_list_2 (class, scm_class_output_port)); scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum] = c = make_class_from_template ("<%s-input-output-port>", type_name, - SCM_LIST2 (class, - scm_class_input_output_port)); + scm_list_2 (class, scm_class_input_output_port)); /* Patch cpl (since this tree is too complex for the C level compute-cpl) */ SCM_SET_SLOT (c, scm_si_cpl, scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl))); @@ -2447,7 +2449,7 @@ scm_make_foreign_object (SCM class, SCM initargs) void * (*constructor) (SCM) = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor); if (constructor == 0) - SCM_MISC_ERROR ("Can't make instances of class ~S", SCM_LIST1 (class)); + SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class)); return scm_wrap_object (class, constructor (initargs)); } #undef FUNC_NAME @@ -2469,7 +2471,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM name, class; name = scm_str2symbol (s_name); if (SCM_IMP (supers)) - supers = SCM_LIST1 (scm_class_foreign_object); + supers = scm_list_1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); scm_sys_inherit_magic_x (class, supers); @@ -2513,40 +2515,42 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter); SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2, setter ? setter : default_setter); - SCM getm = scm_closure (SCM_LIST2 (SCM_LIST1 (sym_o), - SCM_LIST2 (get, sym_o)), + SCM getm = scm_closure (scm_list_2 (scm_list_1 (sym_o), + scm_list_2 (get, sym_o)), SCM_EOL); - SCM setm = scm_closure (SCM_LIST2 (SCM_LIST2 (sym_o, sym_x), - SCM_LIST3 (set, sym_o, sym_x)), + SCM setm = scm_closure (scm_list_2 (scm_list_2 (sym_o, sym_x), + scm_list_3 (set, sym_o, sym_x)), SCM_EOL); { SCM name = scm_str2symbol (slot_name); SCM aname = scm_str2symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); - SCM slot = SCM_LIST5 (name, - k_class, slot_class, - setter ? k_accessor : k_getter, - gf); - SCM gns = SCM_LIST4 (name, SCM_BOOL_F, get, set); - - scm_add_method (gf, scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST1 (class), - k_procedure, getm))); + SCM slot = scm_list_5 (name, + k_class, + slot_class, + setter ? k_accessor : k_getter, + gf); + SCM gns = scm_list_4 (name, SCM_BOOL_F, get, set); + + scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor, + k_specializers, + scm_list_1 (class), + k_procedure, + getm))); scm_add_method (scm_setter (gf), - scm_make (SCM_LIST5 (scm_class_accessor, - k_specializers, - SCM_LIST2 (class, - scm_class_top), - k_procedure, setm))); + scm_make (scm_list_5 (scm_class_accessor, + k_specializers, + scm_list_2 (class, scm_class_top), + k_procedure, + setm))); DEFVAR (aname, gf); SCM_SET_SLOT (class, scm_si_slots, - scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_slots), - SCM_LIST1 (slot)))); + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots), + scm_list_1 (slot)))); SCM_SET_SLOT (class, scm_si_getters_n_setters, - scm_append_x (SCM_LIST2 (SCM_SLOT (class, scm_si_getters_n_setters), - SCM_LIST1 (gns)))); + scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters), + scm_list_1 (gns)))); } } { @@ -2589,10 +2593,9 @@ scm_ensure_accessor (SCM name) SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F); if (!SCM_IS_A_P (gf, scm_class_generic_with_setter)) { - gf = scm_make (SCM_LIST3 (scm_class_generic, k_name, name)); - gf = scm_make (SCM_LIST5 (scm_class_generic_with_setter, - k_name, name, - k_setter, gf)); + gf = scm_make (scm_list_3 (scm_class_generic, k_name, name)); + gf = scm_make (scm_list_5 (scm_class_generic_with_setter, + k_name, name, k_setter, gf)); } return gf; } @@ -2602,7 +2605,7 @@ SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!"); void scm_add_method (SCM gf, SCM m) { - scm_eval (SCM_LIST3 (sym_internal_add_method_x, gf, m), scm_module_goops); + scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops); } #ifdef GUILE_DEBUG @@ -2661,7 +2664,7 @@ scm_init_goops_builtins (void) #include "libguile/goops.x" #endif - list_of_no_method = scm_permanent_object (SCM_LIST1 (sym_no_method)); + list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method)); hell = scm_must_malloc (hell_size, "hell"); #ifdef USE_THREADS @@ -2677,9 +2680,9 @@ scm_init_goops_builtins (void) { SCM name = scm_str2symbol ("no-applicable-method"); scm_no_applicable_method - = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, - k_name, - name))); + = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic, + k_name, + name))); DEFVAR (name, scm_no_applicable_method); } diff --git a/libguile/gsubr.c b/libguile/gsubr.c index ebb09f3b1..e7513ba00 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -220,7 +220,7 @@ scm_gsubr_apply (SCM args) if (n > SCM_GSUBR_MAX) scm_misc_error (FUNC_NAME, "Function ~S has illegal arity ~S.", - SCM_LIST2 (self, SCM_MAKINUM (n))); + scm_list_2 (self, SCM_MAKINUM (n))); #endif args = SCM_CDR (args); for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { diff --git a/libguile/guardians.c b/libguile/guardians.c index d579948ae..db9574635 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -230,7 +230,7 @@ guardian_apply (SCM guardian, SCM obj, SCM throw_p) { if (DESTROYED_P (GUARDIAN (guardian))) scm_misc_error ("guard", "attempted use of destroyed guardian: ~A", - SCM_LIST1 (guardian)); + scm_list_1 (guardian)); if (!SCM_UNBNDP (obj)) return scm_guard (guardian, obj, @@ -266,7 +266,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p) if (throw_p) scm_misc_error ("guard", "object is already greedily guarded: ~A", - SCM_LIST1 (obj)); + scm_list_1 (obj)); else return SCM_BOOL_F; } @@ -401,7 +401,8 @@ SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, if (DESTROYED_P (g)) { SCM_ALLOW_INTS; - SCM_MISC_ERROR ("guardian is already destroyed: ~A", SCM_LIST1 (guardian)); + SCM_MISC_ERROR ("guardian is already destroyed: ~A", + scm_list_1 (guardian)); } if (GREEDY_P (g)) diff --git a/libguile/hooks.c b/libguile/hooks.c index 120ef1287..e57aeb6d5 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -252,7 +252,7 @@ SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); SCM_SET_HOOK_PROCEDURES (hook, (!SCM_UNBNDP (append_p) && !SCM_FALSEP (append_p) - ? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc))) + ? scm_append_x (scm_list_2 (rest, scm_list_1 (proc))) : scm_cons (proc, rest))); return SCM_UNSPECIFIED; } @@ -294,7 +294,7 @@ SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, SCM_VALIDATE_HOOK (1,hook); if (scm_ilength (args) != SCM_HOOK_ARITY (hook)) SCM_MISC_ERROR ("Hook ~S requires ~A arguments", - SCM_LIST2 (hook,SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); + scm_list_2 (hook, SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); scm_c_run_hook (hook, args); return SCM_UNSPECIFIED; } diff --git a/libguile/list.c b/libguile/list.c index 043444aa3..f39c99c91 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -60,8 +60,54 @@ /* creating lists */ +#define SCM_I_CONS(cell,x,y) \ +do { \ + SCM_NEWCELL (cell); \ + SCM_SET_CELL_OBJECT_0 (cell, x); \ + SCM_SET_CELL_OBJECT_1 (cell, y); \ +} while (0) + +SCM +scm_list_1 (SCM e1) +{ + SCM c1; + SCM_I_CONS (c1, e1, SCM_EOL); + return c1; +} + +SCM +scm_list_2 (SCM e1, SCM e2) +{ + SCM c1, c2; + SCM_I_CONS (c2, e2, SCM_EOL); + SCM_I_CONS (c1, e1, c2); + return c1; +} + +SCM +scm_list_3 (SCM e1, SCM e2, SCM e3) +{ + SCM c1, c2, c3; + SCM_I_CONS (c3, e3, SCM_EOL); + SCM_I_CONS (c2, e2, c3); + SCM_I_CONS (c1, e1, c2); + return c1; +} + +SCM +scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4) +{ + return scm_cons2 (e1, e2, scm_list_2 (e3, e4)); +} + +SCM +scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5) +{ + return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5)); +} + SCM -scm_listify (SCM elt, ...) +scm_list_n (SCM elt, ...) { va_list foo; SCM answer = SCM_EOL; @@ -286,7 +332,7 @@ SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0, tortoise = SCM_CDR(tortoise); } while (! SCM_EQ_P (hare, tortoise)); - SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst)); + SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME @@ -315,7 +361,7 @@ SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0, tortoise = SCM_CDR (tortoise); } while (! SCM_EQ_P (hare, tortoise)); - SCM_MISC_ERROR ("Circular structure in position 1: ~S", SCM_LIST1 (lst)); + SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst)); } #undef FUNC_NAME diff --git a/libguile/list.h b/libguile/list.h index 4493816ee..ba8601974 100644 --- a/libguile/list.h +++ b/libguile/list.h @@ -48,26 +48,13 @@ -#define SCM_LIST0 SCM_EOL -#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) -#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) -#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2))) -#define SCM_LIST4(e0, e1, e2, e3)\ - scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3))) -#define SCM_LIST5(e0, e1, e2, e3, e4)\ - scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4))) -#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\ - scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5))) -#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\ - scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6))) -#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\ - scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7))) -#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\ - scm_cons ((e0),\ - SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8))) - +extern SCM scm_list_1 (SCM e1); +extern SCM scm_list_2 (SCM e1, SCM e2); +extern SCM scm_list_3 (SCM e1, SCM e2, SCM e3); +extern SCM scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4); +extern SCM scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5); +extern SCM scm_list_n (SCM elt, ...); extern SCM scm_list_head (SCM lst, SCM k); -extern SCM scm_listify (SCM elt, ...); extern SCM scm_list (SCM objs); extern SCM scm_cons_star (SCM arg, SCM objs); extern SCM scm_null_p (SCM x); @@ -103,6 +90,26 @@ extern void scm_init_list (void); #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_LIST0 SCM_EOL +#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL) +#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL) +#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2))) +#define SCM_LIST4(e0, e1, e2, e3)\ + scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3))) +#define SCM_LIST5(e0, e1, e2, e3, e4)\ + scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4))) +#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\ + scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5))) +#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\ + scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6))) +#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\ + scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7))) +#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\ + scm_cons ((e0),\ + SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8))) + +#define scm_listify scm_list_n + extern SCM scm_sloppy_memq (SCM x, SCM lst); extern SCM scm_sloppy_memv (SCM x, SCM lst); extern SCM scm_sloppy_member (SCM x, SCM lst); diff --git a/libguile/load.c b/libguile/load.c index 8cb726a04..8c9d16b30 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -243,9 +243,9 @@ scm_init_load_path () SCM path = SCM_EOL; #ifdef SCM_LIBRARY_DIR - path = SCM_LIST3 (scm_makfrom0str (SCM_SITE_DIR), - scm_makfrom0str (SCM_LIBRARY_DIR), - scm_makfrom0str (SCM_PKGDATA_DIR)); + path = scm_list_3 (scm_makfrom0str (SCM_SITE_DIR), + scm_makfrom0str (SCM_LIBRARY_DIR), + scm_makfrom0str (SCM_PKGDATA_DIR)); #endif /* SCM_LIBRARY_DIR */ path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path); @@ -453,7 +453,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0, SCM_MISC_ERROR ((absolute ? "Unable to load file ~S" : "Unable to find file ~S in load path"), - SCM_LIST1 (filename)); + scm_list_1 (filename)); } return scm_primitive_load (full_filename); @@ -507,12 +507,12 @@ init_build_info () void scm_init_load () { - scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr)); + scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr)); scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL)); scm_loc_load_extensions = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions", - SCM_LIST2 (scm_makfrom0str (".scm"), - scm_nullstr))); + scm_list_2 (scm_makfrom0str (".scm"), + scm_nullstr))); scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F)); init_build_info (); diff --git a/libguile/modules.c b/libguile/modules.c index dd912cf2d..55d63d75f 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -170,7 +170,7 @@ scm_c_define_module (const char *name, void (*init)(void *), void *data) { SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var), - SCM_LIST1 (convert_module_name (name))); + scm_list_1 (convert_module_name (name))); if (init) scm_c_call_with_current_module (module, (SCM (*)(void*))init, data); return module; @@ -180,7 +180,7 @@ void scm_c_use_module (const char *name) { scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var), - SCM_LIST1 (convert_module_name (name))); + scm_list_1 (convert_module_name (name))); } static SCM module_export_x_var; @@ -440,7 +440,7 @@ scm_sym2var (SCM sym, SCM proc, SCM definep) } if (var != SCM_BOOL_F && !SCM_VARIABLEP (var)) - SCM_MISC_ERROR ("~S is not bound to a variable", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym)); return var; } @@ -461,7 +461,7 @@ scm_module_lookup (SCM module, SCM sym) var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); if (SCM_FALSEP (var)) - SCM_MISC_ERROR ("unbound variable: ~S", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym)); return var; } #undef FUNC_NAME @@ -478,7 +478,7 @@ scm_lookup (SCM sym) SCM var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F); if (SCM_FALSEP (var)) - scm_misc_error ("scm_lookup", "unbound variable: ~S", SCM_LIST1 (sym)); + scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym)); return var; } @@ -639,7 +639,7 @@ scm_post_boot_init_modules () #if SCM_DEBUG_DEPRECATED == 0 - module_prefix = PERM (SCM_LIST2 (scm_sym_app, scm_sym_modules)); + module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules)); make_modules_in_var = PERM (scm_c_lookup ("make-modules-in")); root_module_lookup_closure = PERM (scm_module_lookup_closure (SCM_VARIABLE_REF (the_root_module_var))); @@ -669,7 +669,7 @@ scm_module_full_name (SCM name) if (SCM_EQ_P (SCM_CAR (name), scm_sym_app)) return name; else - return scm_append (SCM_LIST2 (module_prefix, name)); + return scm_append (scm_list_2 (module_prefix, name)); } SCM diff --git a/libguile/net_db.c b/libguile/net_db.c index 974ba888c..8bf5a312a 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -260,7 +260,7 @@ SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0, entry = getnetbyaddr (netnum, AF_INET); } if (!entry) - SCM_SYSERROR_MSG ("no such network ~A", SCM_LIST1 (net), errno); + SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), errno); ve[0] = scm_mem2string (entry->n_name, strlen (entry->n_name)); ve[1] = scm_makfromstrs (-1, entry->n_aliases); ve[2] = SCM_MAKINUM (entry->n_addrtype + 0L); @@ -310,7 +310,7 @@ SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0, entry = getprotobynumber (protonum); } if (!entry) - SCM_SYSERROR_MSG ("no such protocol ~A", SCM_LIST1 (protocol), errno); + SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), errno); ve[0] = scm_mem2string (entry->p_name, strlen (entry->p_name)); ve[1] = scm_makfromstrs (-1, entry->p_aliases); ve[2] = SCM_MAKINUM (entry->p_proto + 0L); @@ -374,7 +374,7 @@ SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0, entry = getservbyport (htons (SCM_INUM (name)), SCM_STRING_CHARS (protocol)); } if (!entry) - SCM_SYSERROR_MSG("no such service ~A", SCM_LIST1 (name), errno); + SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), errno); return scm_return_entry (entry); } #undef FUNC_NAME diff --git a/libguile/objects.c b/libguile/objects.c index 07a46e752..888da56dd 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -344,19 +344,19 @@ scm_call_generic_0 (SCM gf) SCM scm_call_generic_1 (SCM gf, SCM a1) { - return scm_apply_generic (gf, SCM_LIST1 (a1)); + return scm_apply_generic (gf, scm_list_1 (a1)); } SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2) { - return scm_apply_generic (gf, SCM_LIST2 (a1, a2)); + return scm_apply_generic (gf, scm_list_2 (a1, a2)); } SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3) { - return scm_apply_generic (gf, SCM_LIST3 (a1, a2, a3)); + return scm_apply_generic (gf, scm_list_3 (a1, a2, a3)); } SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0, @@ -460,7 +460,7 @@ scm_i_make_class_object (SCM meta, SCM layout = scm_make_struct_layout (layout_string); c = scm_make_struct (meta, SCM_INUM0, - SCM_LIST4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM_SET_CLASS_FLAGS (c, flags); return c; } @@ -493,7 +493,7 @@ SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0, /* Convert symbol->string */ pl = scm_mem2string (SCM_SYMBOL_CHARS (pl), SCM_SYMBOL_LENGTH (pl)); return scm_i_make_class_object (SCM_STRUCT_VTABLE (class), - scm_string_append (SCM_LIST2 (pl, layout)), + scm_string_append (scm_list_2 (pl, layout)), SCM_CLASS_FLAGS (class)); } #undef FUNC_NAME @@ -503,16 +503,16 @@ scm_init_objects () { SCM ms = scm_makfrom0str (SCM_METACLASS_STANDARD_LAYOUT); SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM os = scm_makfrom0str (SCM_METACLASS_OPERATOR_LAYOUT); SCM ot = scm_make_vtable_vtable (os, SCM_INUM0, - SCM_LIST3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL)); SCM es = scm_makfrom0str (SCM_ENTITY_LAYOUT); SCM el = scm_make_struct_layout (es); SCM et = scm_make_struct (mt, SCM_INUM0, - SCM_LIST4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); + scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL)); scm_c_define ("<class>", mt); scm_metaclass_standard = mt; diff --git a/libguile/options.c b/libguile/options.c index ffdb0ff72..84dbd369c 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -190,7 +190,7 @@ scm_options (SCM arg, scm_t_option options[], int n, const char *s) #ifndef SCM_RECKLESS scm_must_free ((char *) flags); scm_misc_error (s, "Unknown mode flag: ~S", - SCM_LIST1 (SCM_CAR (new_mode))); + scm_list_1 (SCM_CAR (new_mode))); #endif cont: new_mode = SCM_CDR (new_mode); diff --git a/libguile/pairs.c b/libguile/pairs.c index 24d1aec07..0a77e2baf 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -68,7 +68,7 @@ void scm_error_pair_access (SCM non_pair) { running = 1; scm_simple_format (scm_current_error_port (), - message, SCM_LIST1 (non_pair)); + message, scm_list_1 (non_pair)); abort (); } } diff --git a/libguile/ports.c b/libguile/ports.c index 68951a416..a62c4236e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -483,7 +483,7 @@ scm_remove_from_port_table (SCM port) long i = p->entry; if (i >= scm_t_portable_size) - SCM_MISC_ERROR ("Port not in table: ~S", SCM_LIST1 (port)); + SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port)); if (p->putback_buf) scm_must_free (p->putback_buf); scm_must_free (p); diff --git a/libguile/print.c b/libguile/print.c index 9159f996b..37eddea02 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -973,16 +973,15 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, start = p + 1; continue; default: - scm_misc_error (s_scm_simple_format, - "FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", - SCM_LIST1 (SCM_MAKE_CHAR (*p))); + SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", + scm_list_1 (SCM_MAKE_CHAR (*p))); } if (!SCM_CONSP (args)) - scm_misc_error (s_scm_simple_format, "FORMAT: Missing argument for ~~~A", - SCM_LIST1 (SCM_MAKE_CHAR (*p))); + SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", + scm_list_1 (SCM_MAKE_CHAR (*p))); scm_lfwrite (start, p - start - 1, destination); scm_prin1 (SCM_CAR (args), destination, writingp); @@ -992,8 +991,8 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, scm_lfwrite (start, p - start, destination); if (args != SCM_EOL) - scm_misc_error (s_scm_simple_format, - "FORMAT: ~A superfluous arguments", SCM_LIST1 (scm_length (args))); + SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", + scm_list_1 (scm_length (args))); if (fReturnString) answer = scm_strport_to_string (destination); @@ -1110,7 +1109,7 @@ scm_init_print () scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS); vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); - type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); + type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout)); scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); diff --git a/libguile/procprop.c b/libguile/procprop.c index 7bfc96b3a..4186a8142 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -155,9 +155,7 @@ scm_i_procedure_arity (SCM proc) default: return SCM_BOOL_F; } - return SCM_LIST3 (SCM_MAKINUM (a), - SCM_MAKINUM (o), - SCM_BOOL(r)); + return scm_list_3 (SCM_MAKINUM (a), SCM_MAKINUM (o), SCM_BOOL(r)); } static SCM @@ -167,7 +165,7 @@ scm_stand_in_scm_proc(SCM proc) answer = scm_assoc (proc, scm_stand_in_procs); if (SCM_FALSEP (answer)) { - answer = scm_closure (SCM_LIST2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); + answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL); scm_stand_in_procs = scm_acons (proc, answer, scm_stand_in_procs); } else diff --git a/libguile/read.c b/libguile/read.c index a7e690a1e..f93fa70c4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -153,7 +153,7 @@ scm_flush_ws (SCM port, const char *eoferr) if (!SCM_FALSEP (SCM_FILENAME (port))) scm_misc_error (eoferr, "end of file in ~A", - SCM_LIST1 (SCM_FILENAME (port))); + scm_list_1 (SCM_FILENAME (port))); else scm_misc_error (eoferr, "end of file", SCM_EOL); } @@ -457,7 +457,7 @@ scm_lreadr (SCM *tok_buf,SCM port,SCM *copy) } unkshrp: scm_misc_error (s_scm_read, "Unknown # object: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (c))); + scm_list_1 (SCM_MAKE_CHAR (c))); } case '"': diff --git a/libguile/script.c b/libguile/script.c index 7c7c3f162..0c4810446 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -565,11 +565,8 @@ scm_compile_shell_switches (int argc, char **argv) if (scm_ilength (srfis) <= 0) scm_shell_usage (1, "invalid SRFI specification"); srfis = scm_reverse_x (srfis, SCM_UNDEFINED); - tail = scm_cons (scm_listify - (sym_use_srfis, - scm_listify (scm_sym_quote, - srfis, SCM_UNDEFINED), - SCM_UNDEFINED), + tail = scm_cons (scm_list_2 (sym_use_srfis, + scm_list_2 (scm_sym_quote, srfis)), tail); } diff --git a/libguile/smob.c b/libguile/smob.c index 8105df7db..6d3c586e1 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -200,7 +200,7 @@ scm_smob_apply_1_030 (SCM smob, SCM a1) static SCM scm_smob_apply_1_001 (SCM smob, SCM a1) { - return SCM_SMOB_APPLY1 (smob, SCM_LIST1 (a1)); + return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1)); } static SCM @@ -230,13 +230,13 @@ scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2) static SCM scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2) { - return SCM_SMOB_APPLY1 (smob, SCM_LIST2 (a1, a2)); + return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2)); } static SCM scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2) { - return SCM_SMOB_APPLY2 (smob, a1, SCM_LIST1 (a2)); + return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2)); } static SCM diff --git a/libguile/socket.c b/libguile/socket.c index 82d03fbc4..a0b852b77 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -970,7 +970,7 @@ scm_addr_vector (const struct sockaddr *address, const char *proc) #endif default: scm_misc_error (proc, "Unrecognised address family: ~A", - SCM_LIST1 (SCM_MAKINUM (fam))); + scm_list_1 (SCM_MAKINUM (fam))); } return result; } diff --git a/libguile/strings.c b/libguile/strings.c index b37309b14..f0d162d43 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -50,7 +50,9 @@ #include "libguile/chars.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/deprecation.h" #include "libguile/validate.h" + /* {Strings} diff --git a/libguile/struct.c b/libguile/struct.c index 7f5227c36..e241a3f35 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -90,7 +90,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, len = SCM_STRING_LENGTH (fields); if (len % 2 == 1) SCM_MISC_ERROR ("odd length field specification: ~S", - SCM_LIST1 (fields)); + scm_list_1 (fields)); field_desc = SCM_STRING_CHARS (fields); @@ -108,7 +108,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x]))); + scm_list_1 (SCM_MAKE_CHAR (field_desc[x]))); } switch (field_desc[x + 1]) @@ -131,14 +131,14 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized ref specification: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x + 1]))); + scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1]))); } #if 0 if (field_desc[x] == 'd') { if (field_desc[x + 2] != '-') SCM_MISC_ERROR ("missing dash field at position ~A", - SCM_LIST1 (SCM_MAKINUM (x / 2))); + scm_list_1 (SCM_MAKINUM (x / 2))); x += 2; goto recheck_ref; } @@ -539,7 +539,8 @@ SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, SCM_VALIDATE_INUM (2, tail_array_size); SCM_VALIDATE_REST_ARGUMENT (init); - fields = scm_string_append (SCM_LIST2 (required_vtable_fields, user_fields)); + fields = scm_string_append (scm_list_2 (required_vtable_fields, + user_fields)); layout = scm_make_struct_layout (fields); basic_size = SCM_SYMBOL_LENGTH (layout) / 2; tail_elts = SCM_INUM (tail_array_size); @@ -601,13 +602,13 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, if ((ref == 'R') || (ref == 'W')) field_type = 'u'; else - SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); } } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); switch (field_type) { @@ -633,7 +634,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_type))); + scm_list_1 (SCM_MAKE_CHAR (field_type))); } return answer; @@ -673,12 +674,12 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, field_type = fields_desc[p * 2]; set_x = fields_desc [p * 2 + 1]; if (set_x != 'w') - SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); } else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W') field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2]; else - SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos)); + SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); switch (field_type) { @@ -705,7 +706,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, default: SCM_MISC_ERROR ("unrecognized field type: ~S", - SCM_LIST1 (SCM_MAKE_CHAR (field_type))); + scm_list_1 (SCM_MAKE_CHAR (field_type))); } return val; diff --git a/libguile/symbols-deprecated.c b/libguile/symbols-deprecated.c index 63dfdbd0d..6151a4494 100644 --- a/libguile/symbols-deprecated.c +++ b/libguile/symbols-deprecated.c @@ -112,7 +112,7 @@ scm_sym2ovcell (SCM sym, SCM obarray) answer = scm_sym2ovcell_soft (sym, obarray); if (!SCM_FALSEP (answer)) return answer; - SCM_MISC_ERROR ("uninterned symbol: ~S", SCM_LIST1 (sym)); + SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym)); return SCM_UNSPECIFIED; /* not reached */ } #undef FUNC_NAME diff --git a/libguile/unif.c b/libguile/unif.c index 0e7319b7a..6feb7e6d6 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2222,7 +2222,8 @@ SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0)) return ra; else - badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst)); + badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", + scm_list_1 (lst)); } #undef FUNC_NAME diff --git a/libguile/variable.c b/libguile/variable.c index 2a6da8c89..7e61680eb 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -130,7 +130,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, SCM_VALIDATE_VARIABLE (1, var); val = SCM_VARIABLE_REF (var); if (val == SCM_UNDEFINED) - SCM_MISC_ERROR ("variable is unbound: ~S", SCM_LIST1 (var)); + SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var)); return val; } #undef FUNC_NAME diff --git a/libguile/vectors.c b/libguile/vectors.c index 89822ebdd..7f4cdaa88 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -244,10 +244,10 @@ scm_vector_set_x (SCM v, SCM k, SCM obj) #define FUNC_NAME s_vector_set_x { SCM_GASSERTn (SCM_VECTORP (v), - g_vector_set_x, SCM_LIST3 (v, k, obj), + g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG1, s_vector_set_x); SCM_GASSERTn (SCM_INUMP (k), - g_vector_set_x, SCM_LIST3 (v, k, obj), + g_vector_set_x, scm_list_3 (v, k, obj), SCM_ARG2, s_vector_set_x); SCM_ASSERT_RANGE (2, k, SCM_INUM (k) < SCM_VECTOR_LENGTH (v) && SCM_INUM (k) >= 0); SCM_VELTS(v)[(long) SCM_INUM(k)] = obj; |