X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/dff98306223ad8f434e1713795b0b376f5ae1708..461bffb131fef926638069b4525190f971ce8c5e:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index a14653f91..50a5663eb 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,43 +1,19 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc. * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ @@ -52,10 +28,13 @@ /* SECTION: This code is compiled once. */ -#ifndef DEVAL +#if HAVE_CONFIG_H +# include +#endif -/* We need this to get the definitions for HAVE_ALLOCA_H, etc. */ -#include "libguile/scmconfig.h" +#include "libguile/__scm.h" + +#ifndef DEVAL /* AIX requires this to be the first thing in the file. The #pragma directive is indented so pre-ANSI compilers will ignore it, rather @@ -75,41 +54,399 @@ char *alloca (); #endif #include "libguile/_scm.h" +#include "libguile/alist.h" +#include "libguile/async.h" +#include "libguile/continuations.h" #include "libguile/debug.h" +#include "libguile/deprecation.h" #include "libguile/dynwind.h" -#include "libguile/alist.h" #include "libguile/eq.h" -#include "libguile/continuations.h" -#include "libguile/throw.h" -#include "libguile/smob.h" -#include "libguile/macros.h" -#include "libguile/procprop.h" -#include "libguile/hashtab.h" -#include "libguile/hash.h" -#include "libguile/srcprop.h" -#include "libguile/stackchk.h" -#include "libguile/objects.h" -#include "libguile/async.h" #include "libguile/feature.h" +#include "libguile/fluids.h" +#include "libguile/futures.h" +#include "libguile/goops.h" +#include "libguile/hash.h" +#include "libguile/hashtab.h" +#include "libguile/lang.h" +#include "libguile/list.h" +#include "libguile/macros.h" #include "libguile/modules.h" +#include "libguile/objects.h" #include "libguile/ports.h" +#include "libguile/procprop.h" #include "libguile/root.h" -#include "libguile/vectors.h" -#include "libguile/fluids.h" -#include "libguile/goops.h" +#include "libguile/smob.h" +#include "libguile/srcprop.h" +#include "libguile/stackchk.h" +#include "libguile/strings.h" +#include "libguile/throw.h" +#include "libguile/validate.h" #include "libguile/values.h" +#include "libguile/vectors.h" -#include "libguile/validate.h" #include "libguile/eval.h" -#include "libguile/lang.h" -#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ - do { \ - if (SCM_EQ_P ((x), SCM_EOL)) \ - scm_misc_error (NULL, scm_s_expression, SCM_EOL); \ - } while (0) +static SCM canonicalize_define (SCM expr); + + + +/* {Syntax Errors} + * + * This section defines the message strings for the syntax errors that can be + * detected during memoization and the functions and macros that shall be + * called by the memoizer code to signal syntax errors. */ + + +/* Syntax errors that can be detected during memoization: */ + +/* Circular or improper lists do not form valid scheme expressions. If a + * circular list or an improper list is detected in a place where a scheme + * expression is expected, a 'Bad expression' error is signalled. */ +static const char s_bad_expression[] = "Bad expression"; + +/* If a form is detected that holds a different number of expressions than are + * required in that context, a 'Missing or extra expression' error is + * signalled. */ +static const char s_expression[] = "Missing or extra expression in"; + +/* If a form is detected that holds less expressions than are required in that + * context, a 'Missing expression' error is signalled. */ +static const char s_missing_expression[] = "Missing expression in"; + +/* If a form is detected that holds more expressions than are allowed in that + * context, an 'Extra expression' error is signalled. */ +static const char s_extra_expression[] = "Extra expression in"; + +/* The empty combination '()' is not allowed as an expression in scheme. If + * it is detected in a place where an expression is expected, an 'Illegal + * empty combination' error is signalled. Note: If you encounter this error + * message, it is very likely that you intended to denote the empty list. To + * do so, you need to quote the empty list like (quote ()) or '(). */ +static const char s_empty_combination[] = "Illegal empty combination"; + +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. If a body with an empty sequence of + * expressions is detected, a 'Missing body expression' error is signalled. + */ +static const char s_missing_body_expression[] = "Missing body expression in"; + +/* A body may hold an arbitrary number of internal defines, followed by a + * non-empty sequence of expressions. Each the definitions and the + * expressions may be grouped arbitraryly with begin, but it is not allowed to + * mix definitions and expressions. If a define form in a body mixes + * definitions and expressions, a 'Mixed definitions and expressions' error is + * signalled. + */ +static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; + +/* Case or cond expressions must have at least one clause. If a case or cond + * expression without any clauses is detected, a 'Missing clauses' error is + * signalled. */ +static const char s_missing_clauses[] = "Missing clauses"; + +/* If there is an 'else' clause in a case or a cond statement, it must be the + * last clause. If after the 'else' case clause further clauses are detected, + * a 'Misplaced else clause' error is signalled. */ +static const char s_misplaced_else_clause[] = "Misplaced else clause"; + +/* If a case clause is detected that is not in the format + * ( ...) + * a 'Bad case clause' error is signalled. */ +static const char s_bad_case_clause[] = "Bad case clause"; + +/* If a case clause is detected where the element is neither a + * proper list nor (in case of the last clause) the syntactic keyword 'else', + * a 'Bad case labels' error is signalled. Note: If you encounter this error + * for an else-clause which seems to be syntactically correct, check if 'else' + * is really a syntactic keyword in that context. If 'else' is bound in the + * local or global environment, it is not considered a syntactic keyword, but + * will be treated as any other variable. */ +static const char s_bad_case_labels[] = "Bad case labels"; + +/* In a case statement all labels have to be distinct. If in a case statement + * a label occurs more than once, a 'Duplicate case label' error is + * signalled. */ +static const char s_duplicate_case_label[] = "Duplicate case label"; + +/* If a cond clause is detected that is not in one of the formats + * ( ...) or (else ...) + * a 'Bad cond clause' error is signalled. */ +static const char s_bad_cond_clause[] = "Bad cond clause"; + +/* If a cond clause is detected that uses the alternate '=>' form, but does + * not hold a recipient element for the test result, a 'Missing recipient' + * error is signalled. */ +static const char s_missing_recipient[] = "Missing recipient in"; + +/* If in a position where a variable name is required some other object is + * detected, a 'Bad variable' error is signalled. */ +static const char s_bad_variable[] = "Bad variable"; + +/* Bindings for forms like 'let' and 'do' have to be given in a proper, + * possibly empty list. If any other object is detected in a place where a + * list of bindings was required, a 'Bad bindings' error is signalled. */ +static const char s_bad_bindings[] = "Bad bindings"; + +/* Depending on the syntactic context, a binding has to be in the format + * ( ) or ( ). + * If anything else is detected in a place where a binding was expected, a + * 'Bad binding' error is signalled. */ +static const char s_bad_binding[] = "Bad binding"; + +/* Some syntactic forms don't allow variable names to appear more than once in + * a list of bindings. If such a situation is nevertheless detected, a + * 'Duplicate binding' error is signalled. */ +static const char s_duplicate_binding[] = "Duplicate binding"; + +/* If the exit form of a 'do' expression is not in the format + * ( ...) + * a 'Bad exit clause' error is signalled. */ +static const char s_bad_exit_clause[] = "Bad exit clause"; + +/* The formal function arguments of a lambda expression have to be either a + * single symbol or a non-cyclic list. For anything else a 'Bad formals' + * error is signalled. */ +static const char s_bad_formals[] = "Bad formals"; + +/* If in a lambda expression something else than a symbol is detected at a + * place where a formal function argument is required, a 'Bad formal' error is + * signalled. */ +static const char s_bad_formal[] = "Bad formal"; + +/* If in the arguments list of a lambda expression an argument name occurs + * more than once, a 'Duplicate formal' error is signalled. */ +static const char s_duplicate_formal[] = "Duplicate formal"; + +/* If the evaluation of an unquote-splicing expression gives something else + * than a proper list, a 'Non-list result for unquote-splicing' error is + * signalled. */ +static const char s_splicing[] = "Non-list result for unquote-splicing"; + +/* If something else than an exact integer is detected as the argument for + * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */ +static const char s_bad_slot_number[] = "Bad slot number"; + + +/* Signal a syntax error. We distinguish between the form that caused the + * error and the enclosing expression. The error message will print out as + * shown in the following pattern. The file name and line number are only + * given when they can be determined from the erroneous form or from the + * enclosing expression. + * + * : In procedure memoization: + * : In file , line : in . */ + +SCM_SYMBOL (syntax_error_key, "syntax-error"); + +/* The prototype is needed to indicate that the function does not return. */ +static void +syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; + +static void +syntax_error (const char* const msg, const SCM form, const SCM expr) +{ + const SCM msg_string = scm_makfrom0str (msg); + SCM filename = SCM_BOOL_F; + SCM linenr = SCM_BOOL_F; + const char *format; + SCM args; + + if (SCM_CONSP (form)) + { + filename = scm_source_property (form, scm_sym_filename); + linenr = scm_source_property (form, scm_sym_line); + } + + if (SCM_FALSEP (filename) && SCM_FALSEP (linenr) && SCM_CONSP (expr)) + { + filename = scm_source_property (expr, scm_sym_filename); + linenr = scm_source_property (expr, scm_sym_line); + } + + if (!SCM_UNBNDP (expr)) + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S in expression ~S."; + args = scm_list_5 (filename, linenr, msg_string, form, expr); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S in expression ~S."; + args = scm_list_4 (linenr, msg_string, form, expr); + } + else + { + format = "~A ~S in expression ~S."; + args = scm_list_3 (msg_string, form, expr); + } + } + else + { + if (!SCM_FALSEP (filename)) + { + format = "In file ~S, line ~S: ~A ~S."; + args = scm_list_4 (filename, linenr, msg_string, form); + } + else if (!SCM_FALSEP (linenr)) + { + format = "In line ~S: ~A ~S."; + args = scm_list_3 (linenr, msg_string, form); + } + else + { + format = "~A ~S."; + args = scm_list_2 (msg_string, form); + } + } + + scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); +} + + +/* Shortcut macros to simplify syntax error handling. */ +#define ASSERT_SYNTAX(cond, message, form) \ + { if (!(cond)) syntax_error (message, form, SCM_UNDEFINED); } +#define ASSERT_SYNTAX_2(cond, message, form, expr) \ + { if (!(cond)) syntax_error (message, form, expr); } + + + +/* {Ilocs} + * + * Ilocs are memoized references to variables in local environment frames. + * They are represented as three values: The relative offset of the + * environment frame, the number of the binding within that frame, and a + * boolean value indicating whether the binding is the last binding in the + * frame. + */ +#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) +#define SCM_IDINC (0x00100000L) +#define SCM_IDSTMSK (-SCM_IDINC) +#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \ + SCM_PACK ( \ + ((frame_nr) << 8) \ + + ((binding_nr) << 20) \ + + ((last_p) ? SCM_ICDR : 0) \ + + scm_tc8_iloc ) + +#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1) + +SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp); +SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0, + (SCM frame, SCM binding, SCM cdrp), + "Return a new iloc with frame offset @var{frame}, binding\n" + "offset @var{binding} and the cdr flag @var{cdrp}.") +#define FUNC_NAME s_scm_dbg_make_iloc +{ + SCM_VALIDATE_INUM (1, frame); + SCM_VALIDATE_INUM (2, binding); + return SCM_MAKE_ILOC (SCM_INUM (frame), + SCM_INUM (binding), + !SCM_FALSEP (cdrp)); +} +#undef FUNC_NAME + +SCM scm_dbg_iloc_p (SCM obj); +SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is an iloc.") +#define FUNC_NAME s_scm_dbg_iloc_p +{ + return SCM_BOOL (SCM_ILOCP (obj)); +} +#undef FUNC_NAME + +#endif + + + +/* The function lookup_symbol is used during memoization: Lookup the symbol + * in the environment. If there is no binding for the symbol, SCM_UNDEFINED + * is returned. If the symbol is a syntactic keyword, the macro object to + * which the symbol is bound is returned. If the symbol is a global variable, + * the variable object to which the symbol is bound is returned. Finally, if + * the symbol is a local variable the corresponding iloc object is returned. + */ + +/* A helper function for lookup_symbol: Try to find the symbol in the top + * level environment frame. The function returns SCM_UNDEFINED if the symbol + * is unbound, it returns a macro object if the symbol is a syntactic keyword + * and it returns a variable object if the symbol is a global variable. */ +static SCM +lookup_global_symbol (const SCM symbol, const SCM top_level) +{ + const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F); + if (SCM_FALSEP (variable)) + { + return SCM_UNDEFINED; + } + else + { + const SCM value = SCM_VARIABLE_REF (variable); + if (SCM_MACROP (value)) + return value; + else + return variable; + } +} + +static SCM +lookup_symbol (const SCM symbol, const SCM env) +{ + SCM frame_idx; + unsigned int frame_nr; + + for (frame_idx = env, frame_nr = 0; + !SCM_NULLP (frame_idx); + frame_idx = SCM_CDR (frame_idx), ++frame_nr) + { + const SCM frame = SCM_CAR (frame_idx); + if (SCM_CONSP (frame)) + { + /* frame holds a local environment frame */ + SCM symbol_idx; + unsigned int symbol_nr; + + for (symbol_idx = SCM_CAR (frame), symbol_nr = 0; + SCM_CONSP (symbol_idx); + symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr) + { + if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol)) + /* found the symbol, therefore return the iloc */ + return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0); + } + if (SCM_EQ_P (symbol_idx, symbol)) + /* found the symbol as the last element of the current frame */ + return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1); + } + else + { + /* no more local environment frames */ + return lookup_global_symbol (symbol, frame); + } + } + + return lookup_global_symbol (symbol, SCM_BOOL_F); +} + + +/* Return true if the symbol is - from the point of view of a macro + * transformer - a literal in the sense specified in chapter "pattern + * language" of R5RS. In the code below, however, we don't match the + * definition of R5RS exactly: It returns true if the identifier has no + * binding or if it is a syntactic keyword. */ +static int +literal_p (const SCM symbol, const SCM env) +{ + const SCM value = lookup_symbol (symbol, env); + if (SCM_UNBNDP (value) || SCM_MACROP (value)) + return 1; + else + return 0; +} @@ -123,18 +460,11 @@ char *alloca (); * Originally, it is defined to scm_ceval, but is redefined to * scm_deval during the second pass. * - * SIDEVAL corresponds to SCM_CEVAL, but is used in situations where - * only side effects of expressions matter. All immediates are - * ignored. - * * SCM_EVALIM is used when it is known that the expression is an * immediate. (This macro never calls an evaluator.) * * EVALCAR evaluates the car of an expression. * - * EVALCELLCAR is like EVALCAR, but is used when it is known that the - * car is a lisp cell. - * * The following macros should be used in code which is read once * (where the choice of evaluator is dynamic): * @@ -150,37 +480,75 @@ char *alloca (); */ #define SCM_CEVAL scm_ceval -#define SIDEVAL(x, env) if (SCM_NIMP (x)) SCM_CEVAL((x), (env)) -#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \ - ? *scm_lookupcar (x, env, 1) \ - : SCM_CEVAL (SCM_CAR (x), env)) +#define SCM_EVALIM2(x) \ + ((SCM_EQ_P ((x), SCM_EOL) \ + ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \ + : 0), \ + (x)) + +#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \ + ? *scm_ilookup ((x), env) \ + : SCM_EVALIM2(x)) + +#define SCM_XEVAL(x, env) (SCM_IMP (x) \ + ? SCM_EVALIM2(x) \ + : (*scm_ceval_ptr) ((x), (env))) + +#define SCM_XEVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \ + ? SCM_EVALIM (SCM_CAR (x), env) \ + : (SCM_SYMBOLP (SCM_CAR (x)) \ + ? *scm_lookupcar (x, env, 1) \ + : (*scm_ceval_ptr) (SCM_CAR (x), env))) #define EVALCAR(x, env) (SCM_IMP (SCM_CAR (x)) \ ? SCM_EVALIM (SCM_CAR (x), env) \ - : EVALCELLCAR (x, env)) + : (SCM_SYMBOLP (SCM_CAR (x)) \ + ? *scm_lookupcar (x, env, 1) \ + : SCM_CEVAL (SCM_CAR (x), env))) -#define EXTEND_ENV SCM_EXTEND_ENV +SCM_REC_MUTEX (source_mutex); -#ifdef MEMOIZE_LOCALS +/* Lookup a given local variable in an environment. The local variable is + * given as an iloc, that is a triple , where frame + * indicates the relative number of the environment frame (counting upwards + * from the innermost environment frame), binding indicates the number of the + * binding within the frame, and last? (which is extracted from the iloc using + * the macro SCM_ICDRP) indicates whether the binding forms the binding at the + * very end of the improper list of bindings. */ SCM * scm_ilookup (SCM iloc, SCM env) { - register long ir = SCM_IFRAME (iloc); - register SCM er = env; - for (; 0 != ir; --ir) - er = SCM_CDR (er); - er = SCM_CAR (er); - for (ir = SCM_IDIST (iloc); 0 != ir; --ir) - er = SCM_CDR (er); + unsigned int frame_nr = SCM_IFRAME (iloc); + unsigned int binding_nr = SCM_IDIST (iloc); + SCM frames = env; + SCM bindings; + + for (; 0 != frame_nr; --frame_nr) + frames = SCM_CDR (frames); + + bindings = SCM_CAR (frames); + for (; 0 != binding_nr; --binding_nr) + bindings = SCM_CDR (bindings); + if (SCM_ICDRP (iloc)) - return SCM_CDRLOC (er); - return SCM_CARLOC (SCM_CDR (er)); + return SCM_CDRLOC (bindings); + return SCM_CARLOC (SCM_CDR (bindings)); +} + + +SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); + +static void error_unbound_variable (SCM symbol) SCM_NORETURN; +static void +error_unbound_variable (SCM symbol) +{ + scm_error (scm_unbound_variable_key, NULL, + "Unbound variable: ~S", + scm_list_1 (symbol), SCM_BOOL_F); } -#endif -#ifdef USE_THREADS /* The Lookup Car Race - by Eva Luator @@ -241,7 +609,7 @@ scm_ilookup (SCM iloc, SCM env) arbitrary amount of time or even deadlock. But with the current solution a lot of unnecessary work is potentially done. */ -/* SCM_LOOKUPCAR1 is was SCM_LOOKUPCAR used to be but is allowed to +/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to return NULL to indicate a failed lookup due to some race conditions between threads. This only happens when VLOC is the first cell of a special form that will eventually be memoized (like `let', etc.) @@ -255,23 +623,12 @@ scm_ilookup (SCM iloc, SCM env) for NULL. I think I've found the only places where this applies. */ -#endif /* USE_THREADS */ - -SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); - -#ifdef USE_THREADS static SCM * scm_lookupcar1 (SCM vloc, SCM genv, int check) -#else -SCM * -scm_lookupcar (SCM vloc, SCM genv, int check) -#endif { SCM env = genv; register SCM *al, fl, var = SCM_CAR (vloc); -#ifdef MEMOIZE_LOCALS register SCM iloc = SCM_ILOC00; -#endif for (; SCM_NIMP (env); env = SCM_CDR (env)) { if (!SCM_CONSP (SCM_CAR (env))) @@ -283,13 +640,9 @@ scm_lookupcar (SCM vloc, SCM genv, int check) { if (SCM_EQ_P (fl, var)) { -#ifdef MEMOIZE_LOCALS -#ifdef USE_THREADS if (! SCM_EQ_P (SCM_CAR (vloc), var)) goto race; -#endif SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR); -#endif return SCM_CDRLOC (*al); } else @@ -298,29 +651,19 @@ scm_lookupcar (SCM vloc, SCM genv, int check) al = SCM_CDRLOC (*al); if (SCM_EQ_P (SCM_CAR (fl), var)) { -#ifdef MEMOIZE_LOCALS -#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ if (SCM_UNBNDP (SCM_CAR (*al))) { env = SCM_EOL; goto errout; } -#endif -#ifdef USE_THREADS if (!SCM_EQ_P (SCM_CAR (vloc), var)) goto race; -#endif SCM_SETCAR (vloc, iloc); -#endif return SCM_CARLOC (*al); } -#ifdef MEMOIZE_LOCALS iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC); -#endif } -#ifdef MEMOIZE_LOCALS iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC)); -#endif } { SCM top_thunk, real_var; @@ -336,16 +679,13 @@ scm_lookupcar (SCM vloc, SCM genv, int check) if (SCM_FALSEP (real_var)) goto errout; -#ifndef SCM_RECKLESS if (!SCM_NULLP (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var))) { errout: if (check) { if (SCM_NULLP (env)) - scm_error (scm_unbound_variable_key, NULL, - "Unbound variable: ~S", - scm_list_1 (var), SCM_BOOL_F); + error_unbound_variable (var); else scm_misc_error (NULL, "Damaged environment: ~S", scm_list_1 (var)); @@ -358,9 +698,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) return &undef_object; } } -#endif -#ifdef USE_THREADS if (!SCM_EQ_P (SCM_CAR (vloc), var)) { /* Some other thread has changed the very cell we are working @@ -370,10 +708,8 @@ scm_lookupcar (SCM vloc, SCM genv, int check) var = SCM_CAR (vloc); if (SCM_VARIABLEP (var)) return SCM_VARIABLE_LOC (var); -#ifdef MEMOIZE_LOCALS if (SCM_ITAG7 (var) == SCM_ITAG7 (SCM_ILOC00)) return scm_ilookup (var, genv); -#endif /* We can't cope with anything else than variables and ilocs. When a special form has been memoized (i.e. `let' into `#@let') we return NULL and expect the calling function to do the right @@ -381,14 +717,12 @@ scm_lookupcar (SCM vloc, SCM genv, int check) the dispatch on the car of the form. */ return NULL; } -#endif /* USE_THREADS */ SCM_SETCAR (vloc, real_var); return SCM_VARIABLE_LOC (real_var); } } -#ifdef USE_THREADS SCM * scm_lookupcar (SCM vloc, SCM genv, int check) { @@ -397,43 +731,6 @@ scm_lookupcar (SCM vloc, SCM genv, int check) abort (); return loc; } -#endif - -#define unmemocar scm_unmemocar - -SCM_SYMBOL (sym_three_question_marks, "???"); - -SCM -scm_unmemocar (SCM form, SCM env) -{ - if (!SCM_CONSP (form)) - return form; - else - { - SCM c = SCM_CAR (form); - if (SCM_VARIABLEP (c)) - { - SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); - if (SCM_FALSEP (sym)) - sym = sym_three_question_marks; - SCM_SETCAR (form, sym); - } -#ifdef MEMOIZE_LOCALS - else if (SCM_ILOCP (c)) - { - unsigned long int ir; - - for (ir = SCM_IFRAME (c); ir != 0; --ir) - env = SCM_CDR (env); - env = SCM_CAAR (env); - for (ir = SCM_IDIST (c); ir != 0; --ir) - env = SCM_CDR (env); - SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); - } -#endif - return form; - } -} SCM @@ -443,343 +740,952 @@ scm_eval_car (SCM pair, SCM env) } -/* - * The following rewrite expressions and - * some memoized forms have different syntax - */ - -const char scm_s_expression[] = "missing or extra expression"; -const char scm_s_test[] = "bad test"; -const char scm_s_body[] = "bad body"; -const char scm_s_bindings[] = "bad bindings"; -const char scm_s_duplicate_bindings[] = "duplicate bindings"; -const char scm_s_variable[] = "bad variable"; -const char scm_s_clauses[] = "bad or missing clauses"; -const char scm_s_formals[] = "bad formals"; -const char scm_s_duplicate_formals[] = "duplicate formals"; -static const char s_splicing[] = "bad (non-list) result for unquote-splicing"; - -SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); -SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); -SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); -SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); -SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); - -SCM scm_f_apply; - -#ifdef DEBUG_EXTENSIONS -SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); -SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); -#endif +/* Rewrite the body (which is given as the list of expressions forming the + * body) into its internal form. The internal form of a body ( ...) is + * just the body itself, but prefixed with an ISYM that denotes to what kind + * of outer construct this body belongs: ( ...). A lambda body + * starts with SCM_IM_LAMBDA, for example, a body of a let starts with + * SCM_IM_LET, etc. The one exception is a body that belongs to a letrec that + * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE + * (instead of SCM_IM_LETREC). + * + * It is assumed that the calling expression has already made sure that the + * body is a proper list. */ +static SCM +m_body (SCM op, SCM exprs) +{ + /* Don't add another ISYM if one is present already. */ + if (SCM_ISYMP (SCM_CAR (exprs))) + return exprs; + else + return scm_cons (op, exprs); +} -/* Check that the body denoted by XORIG is valid and rewrite it into - its internal form. The internal form of a body is just the body - itself, but prefixed with an ISYM that denotes to what kind of - outer construct this body belongs. A lambda body starts with - SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET, - etc. The one exception is a body that belongs to a letrec that has - been formed by rewriting internal defines: it starts with - SCM_IM_DEFINE. */ -/* XXX - Besides controlling the rewriting of internal defines, the - additional ISYM could be used for improved error messages. - This is not done yet. */ +/* The function m_expand_body memoizes a proper list of expressions forming a + * body. This function takes care of dealing with internal defines and + * transforming them into an equivalent letrec expression. */ +/* This is a helper function for m_expand_body. It helps to figure out whether + * an expression denotes a syntactic keyword. */ static SCM -scm_m_body (SCM op, SCM xorig, const char *what) +try_macro_lookup (const SCM expr, const SCM env) { - SCM_ASSYNT (scm_ilength (xorig) >= 1, scm_s_body, what); - - /* Don't add another ISYM if one is present already. */ - if (SCM_ISYMP (SCM_CAR (xorig))) - return xorig; - - /* Retain possible doc string. */ - if (!SCM_CONSP (SCM_CAR (xorig))) + if (SCM_SYMBOLP (expr)) { - if (!SCM_NULLP (SCM_CDR (xorig))) - return scm_cons (SCM_CAR (xorig), - scm_m_body (op, SCM_CDR (xorig), what)); - return xorig; + const SCM value = lookup_symbol (expr, env); + return value; + } + else + { + return SCM_UNDEFINED; } - - return scm_cons (op, xorig); } +/* This is a helper function for m_expand_body. It expands user macros, + * because for the correct translation of a body we need to know whether they + * expand to a definition. */ +static SCM +expand_user_macros (SCM expr, const SCM env) +{ + while (SCM_CONSP (expr)) + { + const SCM car_expr = SCM_CAR (expr); + const SCM new_car = expand_user_macros (car_expr, env); + const SCM value = try_macro_lookup (new_car, env); -SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote); -SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); + if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2) + { + /* User macros transform code into code. */ + expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env); + /* We need to reiterate on the transformed code. */ + } + else + { + /* No user macro: return. */ + SCM_SETCAR (expr, new_car); + return expr; + } + } -SCM -scm_m_quote (SCM xorig, SCM env SCM_UNUSED) -{ - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote); - return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig)); + return expr; } +/* This is a helper function for m_expand_body. It determines if a given form + * represents an application of a given built-in macro. The built-in macro to + * check for is identified by its syntactic keyword. The form is an + * application of the given macro if looking up the car of the form in the + * given environment actually returns the built-in macro. */ +static int +is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env) +{ + if (SCM_CONSP (form)) + { + const SCM car_form = SCM_CAR (form); + const SCM value = try_macro_lookup (car_form, env); + if (SCM_BUILTIN_MACRO_P (value)) + { + const SCM macro_name = scm_macro_name (value); + return SCM_EQ_P (macro_name, syntactic_keyword); + } + } -SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin); -SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); + return 0; +} -SCM -scm_m_begin (SCM xorig, SCM env SCM_UNUSED) +static SCM +m_expand_body (const SCM forms, const SCM env) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin); - return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig)); -} + /* The first body form can be skipped since it is known to be the ISYM that + * was prepended to the body by m_body. */ + SCM cdr_forms = SCM_CDR (forms); + SCM form_idx = cdr_forms; + SCM definitions = SCM_EOL; + SCM sequence = SCM_EOL; + + /* According to R5RS, the list of body forms consists of two parts: a number + * (maybe zero) of definitions, followed by a non-empty sequence of + * expressions. Each the definitions and the expressions may be grouped + * arbitrarily with begin, but it is not allowed to mix definitions and + * expressions. The task of the following loop therefore is to split the + * list of body forms into the list of definitions and the sequence of + * expressions. */ + while (!SCM_NULLP (form_idx)) + { + const SCM form = SCM_CAR (form_idx); + const SCM new_form = expand_user_macros (form, env); + if (is_system_macro_p (scm_sym_define, new_form, env)) + { + definitions = scm_cons (new_form, definitions); + form_idx = SCM_CDR (form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_form, env)) + { + /* We have encountered a group of forms. This has to be either a + * (possibly empty) group of (possibly further grouped) definitions, + * or a non-empty group of (possibly further grouped) + * expressions. */ + const SCM grouped_forms = SCM_CDR (new_form); + unsigned int found_definition = 0; + unsigned int found_expression = 0; + SCM grouped_form_idx = grouped_forms; + while (!found_expression && !SCM_NULLP (grouped_form_idx)) + { + const SCM inner_form = SCM_CAR (grouped_form_idx); + const SCM new_inner_form = expand_user_macros (inner_form, env); + if (is_system_macro_p (scm_sym_define, new_inner_form, env)) + { + found_definition = 1; + definitions = scm_cons (new_inner_form, definitions); + grouped_form_idx = SCM_CDR (grouped_form_idx); + } + else if (is_system_macro_p (scm_sym_begin, new_inner_form, env)) + { + const SCM inner_group = SCM_CDR (new_inner_form); + grouped_form_idx + = scm_append (scm_list_2 (inner_group, + SCM_CDR (grouped_form_idx))); + } + else + { + /* The group marks the start of the expressions of the body. + * We have to make sure that within the same group we have + * not encountered a definition before. */ + ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form); + found_expression = 1; + grouped_form_idx = SCM_EOL; + } + } + + /* We have finished processing the group. If we have not yet + * encountered an expression we continue processing the forms of the + * body to collect further definition forms. Otherwise, the group + * marks the start of the sequence of expressions of the body. */ + if (!found_expression) + { + form_idx = SCM_CDR (form_idx); + } + else + { + sequence = form_idx; + form_idx = SCM_EOL; + } + } + else + { + /* We have detected a form which is no definition. This marks the + * start of the sequence of expressions of the body. */ + sequence = form_idx; + form_idx = SCM_EOL; + } + } + /* FIXME: forms does not hold information about the file location. */ + ASSERT_SYNTAX (SCM_CONSP (sequence), s_missing_body_expression, cdr_forms); -SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if); -SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); + if (!SCM_NULLP (definitions)) + { + SCM definition_idx; + SCM letrec_tail; + SCM letrec_expression; + SCM new_letrec_expression; + SCM new_body; + + SCM bindings = SCM_EOL; + for (definition_idx = definitions; + !SCM_NULLP (definition_idx); + definition_idx = SCM_CDR (definition_idx)) + { + const SCM definition = SCM_CAR (definition_idx); + const SCM canonical_definition = canonicalize_define (definition); + const SCM binding = SCM_CDR (canonical_definition); + bindings = scm_cons (binding, bindings); + }; + + letrec_tail = scm_cons (bindings, sequence); + /* FIXME: forms does not hold information about the file location. */ + letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail); + new_letrec_expression = scm_m_letrec (letrec_expression, env); + new_body = scm_list_1 (new_letrec_expression); + return new_body; + } + else + { + SCM_SETCAR (forms, SCM_CAR (sequence)); + SCM_SETCDR (forms, SCM_CDR (sequence)); + return forms; + } +} + +#if (SCM_ENABLE_DEPRECATED == 1) +/* Deprecated in guile 1.7.0 on 2003-11-09. */ SCM -scm_m_if (SCM xorig, SCM env SCM_UNUSED) +scm_m_expand_body (SCM exprs, SCM env) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if); - return scm_cons (SCM_IM_IF, SCM_CDR (xorig)); + scm_c_issue_deprecation_warning + ("`scm_m_expand_body' is deprecated."); + return m_expand_body (exprs, env); } +#endif -/* Will go into the RnRS module when Guile is factorized. -SCM_SYNTAX (scm_s_set_x,"set!", scm_makmmacro, scm_m_set_x); */ -const char scm_s_set_x[] = "set!"; -SCM_GLOBAL_SYMBOL (scm_sym_set_x, scm_s_set_x); -SCM -scm_m_set_x (SCM xorig, SCM env SCM_UNUSED) -{ - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, scm_s_set_x); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, scm_s_set_x); - return scm_cons (SCM_IM_SET_X, x); -} +/* Start of the memoizers for the standard R5RS builtin macros. */ -SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and); +SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and); SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); SCM -scm_m_and (SCM xorig, SCM env SCM_UNUSED) +scm_m_and (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, scm_s_test, s_and); - if (len >= 1) - return scm_cons (SCM_IM_AND, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + + if (length == 0) + { + /* Special case: (and) is replaced by #t. */ + return SCM_BOOL_T; + } else - return SCM_BOOL_T; + { + SCM_SETCAR (expr, SCM_IM_AND); + return expr; + } } -SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or); -SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); +SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin); +SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); SCM -scm_m_or (SCM xorig, SCM env SCM_UNUSED) +scm_m_begin (SCM expr, SCM env SCM_UNUSED) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 0, scm_s_test, s_or); - if (len >= 1) - return scm_cons (SCM_IM_OR, SCM_CDR (xorig)); - else - return SCM_BOOL_F; + const SCM cdr_expr = SCM_CDR (expr); + /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS. + * That means, there should be a distinction between uses of begin where an + * empty clause is OK and where it is not. */ + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + + SCM_SETCAR (expr, SCM_IM_BEGIN); + return expr; } -SCM_SYNTAX (s_case, "case", scm_makmmacro, scm_m_case); +SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); +SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); SCM -scm_m_case (SCM xorig, SCM env SCM_UNUSED) +scm_m_case (SCM expr, SCM env) { SCM clauses; - SCM cdrx = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (cdrx) >= 2, scm_s_clauses, s_case); - clauses = SCM_CDR (cdrx); + SCM all_labels = SCM_EOL; + + /* Check, whether 'else is a literal, i. e. not bound to a value. */ + const int else_literal_p = literal_p (scm_sym_else, env); + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr); + + clauses = SCM_CDR (cdr_expr); while (!SCM_NULLP (clauses)) { - SCM clause = SCM_CAR (clauses); - SCM_ASSYNT (scm_ilength (clause) >= 2, scm_s_clauses, s_case); - SCM_ASSYNT (scm_ilength (SCM_CAR (clause)) >= 0 - || (SCM_EQ_P (scm_sym_else, SCM_CAR (clause)) - && SCM_NULLP (SCM_CDR (clauses))), - scm_s_clauses, s_case); + SCM labels; + + const SCM clause = SCM_CAR (clauses); + ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2, + s_bad_case_clause, clause, expr); + + labels = SCM_CAR (clause); + if (SCM_CONSP (labels)) + { + ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0, + s_bad_case_labels, labels, expr); + all_labels = scm_append_x (scm_list_2 (labels, all_labels)); + } + else if (SCM_NULLP (labels)) + { + /* The list of labels is empty. According to R5RS this is allowed. + * It means that the sequence of expressions will never be executed. + * Therefore, as an optimization, we could remove the whole + * clause. */ + } + else + { + ASSERT_SYNTAX_2 (SCM_EQ_P (labels, scm_sym_else) && else_literal_p, + s_bad_case_labels, labels, expr); + ASSERT_SYNTAX_2 (SCM_NULLP (SCM_CDR (clauses)), + s_misplaced_else_clause, clause, expr); + } + + /* build the new clause */ + if (SCM_EQ_P (labels, scm_sym_else)) + SCM_SETCAR (clause, SCM_IM_ELSE); + clauses = SCM_CDR (clauses); } - return scm_cons (SCM_IM_CASE, cdrx); + + /* Check whether all case labels are distinct. */ + for (; !SCM_NULLP (all_labels); all_labels = SCM_CDR (all_labels)) + { + const SCM label = SCM_CAR (all_labels); + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (label, SCM_CDR (all_labels))), + s_duplicate_case_label, label, expr); + } + + SCM_SETCAR (expr, SCM_IM_CASE); + return expr; } -SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond); +SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond); SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond); +SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); SCM -scm_m_cond (SCM xorig, SCM env SCM_UNUSED) +scm_m_cond (SCM expr, SCM env) { - SCM cdrx = SCM_CDR (xorig); - SCM clauses = cdrx; - SCM_ASSYNT (scm_ilength (clauses) >= 1, scm_s_clauses, s_cond); - while (!SCM_NULLP (clauses)) + /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */ + const int else_literal_p = literal_p (scm_sym_else, env); + const int arrow_literal_p = literal_p (scm_sym_arrow, env); + + const SCM clauses = SCM_CDR (expr); + SCM clause_idx; + + ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr); + + for (clause_idx = clauses; + !SCM_NULLP (clause_idx); + clause_idx = SCM_CDR (clause_idx)) { - SCM clause = SCM_CAR (clauses); - long len = scm_ilength (clause); - SCM_ASSYNT (len >= 1, scm_s_clauses, s_cond); - if (SCM_EQ_P (scm_sym_else, SCM_CAR (clause))) + SCM test; + + const SCM clause = SCM_CAR (clause_idx); + const long length = scm_ilength (clause); + ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr); + + test = SCM_CAR (clause); + if (SCM_EQ_P (test, scm_sym_else) && else_literal_p) { - int last_clause_p = SCM_NULLP (SCM_CDR (clauses)); - SCM_ASSYNT (len >= 2 && last_clause_p, "bad ELSE clause", s_cond); + const int last_clause_p = SCM_NULLP (SCM_CDR (clause_idx)); + ASSERT_SYNTAX_2 (length >= 2, + s_bad_cond_clause, clause, expr); + ASSERT_SYNTAX_2 (last_clause_p, + s_misplaced_else_clause, clause, expr); + SCM_SETCAR (clause, SCM_IM_ELSE); } - else if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CADR (clause))) + else if (length >= 2 + && SCM_EQ_P (SCM_CADR (clause), scm_sym_arrow) + && arrow_literal_p) + { + ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr); + ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr); + SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW); + } + } + + SCM_SETCAR (expr, SCM_IM_COND); + return expr; +} + + +SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define); +SCM_GLOBAL_SYMBOL (scm_sym_define, s_define); + +/* Guile provides an extension to R5RS' define syntax to represent function + * currying in a compact way. With this extension, it is allowed to write + * (define ), where has of one of + * the forms ( ), ( . ), + * ( ) or ( . ). As in R5RS, + * should be either a sequence of zero or more variables, or a sequence of one + * or more variables followed by a space-delimited period and another + * variable. Each level of argument nesting wraps the within another + * lambda expression. For example, the following forms are allowed, each one + * followed by an equivalent, more explicit implementation. + * Example 1: + * (define ((a b . c) . d) ) is equivalent to + * (define a (lambda (b . c) (lambda d ))) + * Example 2: + * (define (((a) b) c . d) ) is equivalent to + * (define a (lambda () (lambda (b) (lambda (c . d) )))) + */ +/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS + * module that does not implement this extension. */ +static SCM +canonicalize_define (const SCM expr) +{ + SCM body; + SCM variable; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + body = SCM_CDR (cdr_expr); + variable = SCM_CAR (cdr_expr); + while (SCM_CONSP (variable)) + { + /* This while loop realizes function currying by variable nesting. + * Variable is known to be a nested-variable. In every iteration of the + * loop another level of lambda expression is created, starting with the + * innermost one. Note that we don't check for duplicate formals here: + * This will be done by the memoizer of the lambda expression. */ + const SCM formals = SCM_CDR (variable); + const SCM tail = scm_cons (formals, body); + + /* Add source properties to each new lambda expression: */ + const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail); + + body = scm_list_1 (lambda); + variable = SCM_CAR (variable); + } + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); + + SCM_SETCAR (cdr_expr, variable); + SCM_SETCDR (cdr_expr, body); + return expr; +} + +SCM +scm_m_define (SCM expr, SCM env) +{ + SCM canonical_definition; + SCM cdr_canonical_definition; + SCM body; + + canonical_definition = canonicalize_define (expr); + cdr_canonical_definition = SCM_CDR (canonical_definition); + body = SCM_CDR (cdr_canonical_definition); + + if (SCM_TOP_LEVEL (env)) + { + SCM var; + const SCM variable = SCM_CAR (cdr_canonical_definition); + const SCM value = scm_eval_car (body, env); + if (SCM_REC_PROCNAMES_P) { - SCM_ASSYNT (len > 2, "missing recipient", s_cond); - SCM_ASSYNT (len == 3, "bad recipient", s_cond); + SCM tmp = value; + while (SCM_MACROP (tmp)) + tmp = SCM_MACRO_CODE (tmp); + if (SCM_CLOSUREP (tmp) + /* Only the first definition determines the name. */ + && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) + scm_set_procedure_property_x (tmp, scm_sym_name, variable); } - clauses = SCM_CDR (clauses); + var = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); + SCM_VARIABLE_SET (var, value); + return SCM_UNSPECIFIED; + } + else + { + SCM_SETCAR (canonical_definition, SCM_IM_DEFINE); + return canonical_definition; + } +} + + +/* This is a helper function for forms ( ) that are + * transformed into (#@ '() ) in order to allow + * for easy creation of a thunk (i. e. a closure without arguments) using the + * ('() ) tail of the memoized form. */ +static SCM +memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED) +{ + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr)); + + return expr; +} + + +SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); + +/* Promises are implemented as closures with an empty parameter list. Thus, + * (delay ) is transformed into (#@delay '() ), where + * the empty list represents the empty parameter list. This representation + * allows for easy creation of the closure during evaluation. */ +SCM +scm_m_delay (SCM expr, SCM env) +{ + const SCM new_expr = memoize_as_thunk_prototype (expr, env); + SCM_SETCAR (new_expr, SCM_IM_DELAY); + return new_expr; +} + + +SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); +SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); + +/* DO gets the most radically altered syntax. The order of the vars is + * reversed here. During the evaluation this allows for simple consing of the + * results of the inits and steps: + + (do (( ) + ( ) + ... ) + ( ) + ) + + ;; becomes + + (#@do ( ... ) + (varn ... var2 var1) + ( ) + () + ... ) ;; missing steps replaced by var + */ +SCM +scm_m_do (SCM expr, SCM env SCM_UNUSED) +{ + SCM variables = SCM_EOL; + SCM init_forms = SCM_EOL; + SCM step_forms = SCM_EOL; + SCM binding_idx; + SCM cddr_expr; + SCM exit_clause; + SCM commands; + SCM tail; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + /* Collect variables, init and step forms. */ + binding_idx = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0, + s_bad_bindings, binding_idx, expr); + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + { + const SCM binding = SCM_CAR (binding_idx); + const long length = scm_ilength (binding); + ASSERT_SYNTAX_2 (length == 2 || length == 3, + s_bad_binding, binding, expr); + + { + const SCM name = SCM_CAR (binding); + const SCM init = SCM_CADR (binding); + const SCM step = (length == 2) ? name : SCM_CADDR (binding); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, variables)), + s_duplicate_binding, name, expr); + + variables = scm_cons (name, variables); + init_forms = scm_cons (init, init_forms); + step_forms = scm_cons (step, step_forms); + } } - return scm_cons (SCM_IM_COND, cdrx); + init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED); + step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED); + + /* Memoize the test form and the exit sequence. */ + cddr_expr = SCM_CDR (cdr_expr); + exit_clause = SCM_CAR (cddr_expr); + ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1, + s_bad_exit_clause, exit_clause, expr); + + commands = SCM_CDR (cddr_expr); + tail = scm_cons2 (exit_clause, commands, step_forms); + tail = scm_cons2 (init_forms, variables, tail); + SCM_SETCAR (expr, SCM_IM_DO); + SCM_SETCDR (expr, tail); + return expr; +} + + +SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if); +SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); + +SCM +scm_m_if (SCM expr, SCM env SCM_UNUSED) +{ + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); + SCM_SETCAR (expr, SCM_IM_IF); + return expr; } -SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda); +SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda); SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); -/* Return true if OBJ is `eq?' to one of the elements of LIST or to the - * cdr of the last cons. (Thus, LIST is not required to be a proper - * list and OBJ can also be found in the improper ending.) */ +/* A helper function for memoize_lambda to support checking for duplicate + * formal arguments: Return true if OBJ is `eq?' to one of the elements of + * LIST or to the cdr of the last cons. Therefore, LIST may have any of the + * forms that a formal argument can have: + * , ( ...), ( ... . ) */ static int -scm_c_improper_memq (SCM obj, SCM list) +c_improper_memq (SCM obj, SCM list) { for (; SCM_CONSP (list); list = SCM_CDR (list)) { if (SCM_EQ_P (SCM_CAR (list), obj)) - return 1; + return 1; } return SCM_EQ_P (list, obj); } SCM -scm_m_lambda (SCM xorig, SCM env SCM_UNUSED) +scm_m_lambda (SCM expr, SCM env SCM_UNUSED) { SCM formals; - SCM x = SCM_CDR (xorig); + SCM formals_idx; + SCM cddr_expr; + int documentation; + SCM body; + SCM new_body; + + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); + + /* Before iterating the list of formal arguments, make sure the formals + * actually are given as either a symbol or a non-cyclic list. */ + formals = SCM_CAR (cdr_expr); + if (SCM_CONSP (formals)) + { + /* Dirk:FIXME:: We should check for a cyclic list of formals, and if + * detected, report a 'Bad formals' error. */ + } + else + { + ASSERT_SYNTAX_2 (SCM_SYMBOLP (formals) || SCM_NULLP (formals), + s_bad_formals, formals, expr); + } + + /* Now iterate the list of formal arguments to check if all formals are + * symbols, and that there are no duplicates. */ + formals_idx = formals; + while (SCM_CONSP (formals_idx)) + { + const SCM formal = SCM_CAR (formals_idx); + const SCM next_idx = SCM_CDR (formals_idx); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (formal), s_bad_formal, formal, expr); + ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx), + s_duplicate_formal, formal, expr); + formals_idx = next_idx; + } + ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx), + s_bad_formal, formals_idx, expr); + + /* Memoize the body. Keep a potential documentation string. */ + /* Dirk:FIXME:: We should probably extract the documentation string to + * some external database. Otherwise it will slow down execution, since + * the documentation string will have to be skipped with every execution + * of the closure. */ + cddr_expr = SCM_CDR (cdr_expr); + documentation = (length >= 3 && SCM_STRINGP (SCM_CAR (cddr_expr))); + body = documentation ? SCM_CDR (cddr_expr) : cddr_expr; + new_body = m_body (SCM_IM_LAMBDA, body); + + SCM_SETCAR (expr, SCM_IM_LAMBDA); + if (documentation) + SCM_SETCDR (cddr_expr, new_body); + else + SCM_SETCDR (cdr_expr, new_body); + return expr; +} - SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda); - formals = SCM_CAR (x); - while (SCM_CONSP (formals)) +/* Check if the format of the bindings is (( ) ...). */ +static void +check_bindings (const SCM bindings, const SCM expr) +{ + SCM binding_idx; + + ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0, + s_bad_bindings, bindings, expr); + + binding_idx = bindings; + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) { - SCM formal = SCM_CAR (formals); - SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda); - if (scm_c_improper_memq (formal, SCM_CDR (formals))) - scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL); - formals = SCM_CDR (formals); + SCM name; /* const */ + + const SCM binding = SCM_CAR (binding_idx); + ASSERT_SYNTAX_2 (scm_ilength (binding) == 2, + s_bad_binding, binding, expr); + + name = SCM_CAR (binding); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (name), s_bad_variable, name, expr); } - if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals)) - scm_misc_error (s_lambda, scm_s_formals, SCM_EOL); +} - return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x), - scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda)); + +/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are + * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the + * variables are returned in a list with their order reversed, and the init + * forms are returned in a list in the same order as they are given in the + * bindings. If a duplicate variable name is detected, an error is + * signalled. */ +static void +transform_bindings ( + const SCM bindings, const SCM expr, + SCM *const rvarptr, SCM *const initptr ) +{ + SCM rvariables = SCM_EOL; + SCM rinits = SCM_EOL; + SCM binding_idx = bindings; + for (; !SCM_NULLP (binding_idx); binding_idx = SCM_CDR (binding_idx)) + { + const SCM binding = SCM_CAR (binding_idx); + const SCM cdr_binding = SCM_CDR (binding); + const SCM name = SCM_CAR (binding); + ASSERT_SYNTAX_2 (SCM_FALSEP (scm_c_memq (name, rvariables)), + s_duplicate_binding, name, expr); + rvariables = scm_cons (name, rvariables); + rinits = scm_cons (SCM_CAR (cdr_binding), rinits); + } + *rvarptr = rvariables; + *initptr = scm_reverse_x (rinits, SCM_UNDEFINED); } -SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar); -SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); +SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let); +SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); + +/* This function is a helper function for memoize_let. It transforms + * (let name ((var init) ...) body ...) into + * ((letrec ((name (lambda (var ...) body ...))) name) init ...) + * and memoizes the expression. It is assumed that the caller has checked + * that name is a symbol and that there are bindings and a body. */ +static SCM +memoize_named_let (const SCM expr, const SCM env SCM_UNUSED) +{ + SCM rvariables; + SCM variables; + SCM inits; + + const SCM cdr_expr = SCM_CDR (expr); + const SCM name = SCM_CAR (cdr_expr); + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM bindings = SCM_CAR (cddr_expr); + check_bindings (bindings, expr); + + transform_bindings (bindings, expr, &rvariables, &inits); + variables = scm_reverse_x (rvariables, SCM_UNDEFINED); + + { + const SCM let_body = SCM_CDR (cddr_expr); + const SCM lambda_body = m_body (SCM_IM_LET, let_body); + const SCM lambda_tail = scm_cons (variables, lambda_body); + const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail); + + const SCM rvar = scm_list_1 (name); + const SCM init = scm_list_1 (lambda_form); + const SCM body = m_body (SCM_IM_LET, scm_list_1 (name)); + const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body)); + const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail); + return scm_cons_source (expr, letrec_form, inits); + } +} -/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers - * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*). */ +/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers + * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */ SCM -scm_m_letstar (SCM xorig, SCM env SCM_UNUSED) +scm_m_let (SCM expr, SCM env) { SCM bindings; - SCM x = SCM_CDR (xorig); - SCM vars = SCM_EOL; - SCM *varloc = &vars; - SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar); + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar); - while (!SCM_NULLP (bindings)) + bindings = SCM_CAR (cdr_expr); + if (SCM_SYMBOLP (bindings)) { - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar); - *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding)); - varloc = SCM_CDRLOC (SCM_CDR (*varloc)); - bindings = SCM_CDR (bindings); + ASSERT_SYNTAX (length >= 3, s_missing_expression, expr); + return memoize_named_let (expr, env); } - return scm_cons2 (SCM_IM_LETSTAR, vars, - scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar)); + check_bindings (bindings, expr); + if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings))) + { + /* Special case: no bindings or single binding => let* is faster. */ + const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); + return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env); + } + else + { + /* plain let */ + SCM rvariables; + SCM inits; + transform_bindings (bindings, expr, &rvariables, &inits); + + { + const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr)); + const SCM new_tail = scm_cons2 (rvariables, inits, new_body); + SCM_SETCAR (expr, SCM_IM_LET); + SCM_SETCDR (expr, new_tail); + return expr; + } + } } -/* DO gets the most radically altered syntax. The order of the vars is - * reversed here. In contrast, the order of the inits and steps is reversed - * during the evaluation: +SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar); +SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); - (do (( ) - ( ) - ... ) - ( ) - ) +/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers + * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */ +SCM +scm_m_letstar (SCM expr, SCM env SCM_UNUSED) +{ + SCM binding_idx; + SCM new_body; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + binding_idx = SCM_CAR (cdr_expr); + check_bindings (binding_idx, expr); + + /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The + * transformation is done in place. At the beginning of one iteration of + * the loop the variable binding_idx holds the form + * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ), + * where P1, P2 and P3 indicate the pairs, that are relevant for the + * transformation. P1 and P2 are modified in the loop, P3 remains + * untouched. After the execution of the loop, P1 will hold + * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) ) + * and binding_idx will hold P3. */ + while (!SCM_NULLP (binding_idx)) + { + const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */ + const SCM binding = SCM_CAR (binding_idx); + const SCM name = SCM_CAR (binding); + const SCM cdr_binding = SCM_CDR (binding); - ;; becomes + SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */ + SCM_SETCAR (binding_idx, name); /* update P1 */ + SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */ - (#@do (varn ... var2 var1) - ( ... ) - ( ) - () - ... ) ;; missing steps replaced by var - */ + binding_idx = cdr_binding_idx; /* continue with P3 */ + } -SCM_SYNTAX(s_do, "do", scm_makmmacro, scm_m_do); -SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); + new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr)); + SCM_SETCAR (expr, SCM_IM_LETSTAR); + /* the bindings have been changed in place */ + SCM_SETCDR (cdr_expr, new_body); + return expr; +} + + +SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); +SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); SCM -scm_m_do (SCM xorig, SCM env SCM_UNUSED) +scm_m_letrec (SCM expr, SCM env) { SCM bindings; - SCM x = SCM_CDR (xorig); - SCM vars = SCM_EOL; - SCM inits = SCM_EOL; - SCM *initloc = &inits; - SCM steps = SCM_EOL; - SCM *steploc = &steps; - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_test, "do"); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, "do"); - while (!SCM_NULLP (bindings)) + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + + bindings = SCM_CAR (cdr_expr); + if (SCM_NULLP (bindings)) { - SCM binding = SCM_CAR (bindings); - long len = scm_ilength (binding); - SCM_ASSYNT (len == 2 || len == 3, scm_s_bindings, "do"); - { - SCM name = SCM_CAR (binding); - SCM init = SCM_CADR (binding); - SCM step = (len == 2) ? name : SCM_CADDR (binding); - SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, "do"); - vars = scm_cons (name, vars); - *initloc = scm_list_1 (init); - initloc = SCM_CDRLOC (*initloc); - *steploc = scm_list_1 (step); - steploc = SCM_CDRLOC (*steploc); - bindings = SCM_CDR (bindings); - } + /* no bindings, let* is executed faster */ + SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); + return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env); + } + else + { + SCM rvariables; + SCM inits; + SCM new_body; + + check_bindings (bindings, expr); + transform_bindings (bindings, expr, &rvariables, &inits); + new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr)); + return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body)); + } +} + + +SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or); +SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); + +SCM +scm_m_or (SCM expr, SCM env SCM_UNUSED) +{ + const SCM cdr_expr = SCM_CDR (expr); + const long length = scm_ilength (cdr_expr); + + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + + if (length == 0) + { + /* Special case: (or) is replaced by #f. */ + return SCM_BOOL_F; + } + else + { + SCM_SETCAR (expr, SCM_IM_OR); + return expr; } - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (SCM_CAR (x)) >= 1, scm_s_test, "do"); - x = scm_cons2 (SCM_CAR (x), SCM_CDR (x), steps); - x = scm_cons2 (vars, inits, x); - return scm_cons (SCM_IM_DO, x); } SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); +SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); +SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); /* Internal function to handle a quasiquotation: 'form' is the parameter in * the call (quasiquotation form), 'env' is the environment where unquoted @@ -790,17 +1696,17 @@ iqq (SCM form, SCM env, unsigned long int depth) { if (SCM_CONSP (form)) { - SCM tmp = SCM_CAR (form); + const SCM tmp = SCM_CAR (form); if (SCM_EQ_P (tmp, scm_sym_quasiquote)) { - SCM args = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + const SCM args = SCM_CDR (form); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1)); } else if (SCM_EQ_P (tmp, scm_sym_unquote)) { - SCM args = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + const SCM args = SCM_CDR (form); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); if (depth - 1 == 0) return scm_eval_car (args, env); else @@ -809,13 +1715,14 @@ iqq (SCM form, SCM env, unsigned long int depth) else if (SCM_CONSP (tmp) && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing)) { - SCM args = SCM_CDR (tmp); - SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote); + const SCM args = SCM_CDR (tmp); + ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); if (depth - 1 == 0) { - SCM list = scm_eval_car (args, env); - SCM rest = SCM_CDR (form); - SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote); + const SCM list = scm_eval_car (args, env); + const SCM rest = SCM_CDR (form); + ASSERT_SYNTAX_2 (scm_ilength (list) >= 0, + s_splicing, list, form); return scm_append (scm_list_2 (list, iqq (rest, env, depth))); } else @@ -829,7 +1736,7 @@ iqq (SCM form, SCM env, unsigned long int depth) else if (SCM_VECTORP (form)) { size_t i = SCM_VECTOR_LENGTH (form); - SCM *data = SCM_VELTS (form); + SCM const *const data = SCM_VELTS (form); SCM tmp = SCM_EOL; while (i != 0) tmp = scm_cons (data[--i], tmp); @@ -841,421 +1748,374 @@ iqq (SCM form, SCM env, unsigned long int depth) } SCM -scm_m_quasiquote (SCM xorig, SCM env) +scm_m_quasiquote (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote); - return iqq (SCM_CAR (x), env, 1); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + return iqq (SCM_CAR (cdr_expr), env, 1); } -SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay); -SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); +SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote); +SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); -/* Promises are implemented as closures with an empty parameter list. Thus, - * (delay ) is transformed into (#@delay '() ), where - * the empty list represents the empty parameter list. This representation - * allows for easy creation of the closure during evaluation. */ SCM -scm_m_delay (SCM xorig, SCM env SCM_UNUSED) +scm_m_quote (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay); - return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig)); + SCM quotee; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + quotee = SCM_CAR (cdr_expr); + if (SCM_IMP (quotee) && !SCM_NULLP (quotee)) + return quotee; + else if (SCM_VECTORP (quotee)) + return quotee; +#if 0 + /* The following optimization would be possible if all variable references + * were resolved during memoization: */ + else if (SCM_SYMBOLP (quotee)) + return quotee; +#endif + SCM_SETCAR (expr, SCM_IM_QUOTE); + return expr; } -SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define); -SCM_GLOBAL_SYMBOL(scm_sym_define, s_define); +/* Will go into the RnRS module when Guile is factorized. +SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */ +static const char s_set_x[] = "set!"; +SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x); -/* Guile provides an extension to R5RS' define syntax to represent function - * currying in a compact way. With this extension, it is allowed to write - * (define ), where has of one of - * the forms ( ), ( . ), - * ( ) or ( . ). As in R5RS, - * should be either a sequence of zero or more variables, or a sequence of one - * or more variables followed by a space-delimited period and another - * variable. Each level of argument nesting wraps the within another - * lambda expression. For example, the following forms are allowed, each one - * followed by an equivalent, more explicit implementation. - * Example 1: - * (define ((a b . c) . d) ) is equivalent to - * (define a (lambda (b . c) (lambda d ))) - * Example 2: - * (define (((a) b) c . d) ) is equivalent to - * (define a (lambda () (lambda (b) (lambda (c . d) )))) - */ -/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS - * module that does not implement this extension. */ SCM -scm_m_define (SCM x, SCM env) +scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM name; - x = SCM_CDR (x); - SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define); - name = SCM_CAR (x); - x = SCM_CDR (x); - while (SCM_CONSP (name)) - { - /* This while loop realizes function currying by variable nesting. */ - SCM formals = SCM_CDR (name); - x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x)); - name = SCM_CAR (name); - } - SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define); - SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define); - if (SCM_TOP_LEVEL (env)) - { - SCM var; - x = scm_eval_car (x, env); - if (SCM_REC_PROCNAMES_P) - { - SCM tmp = x; - while (SCM_MACROP (tmp)) - tmp = SCM_MACRO_CODE (tmp); - if (SCM_CLOSUREP (tmp) - /* Only the first definition determines the name. */ - && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name))) - scm_set_procedure_property_x (tmp, scm_sym_name, name); - } - var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T); - SCM_VARIABLE_SET (var, x); - return SCM_UNSPECIFIED; - } - else - return scm_cons2 (SCM_IM_DEFINE, name, x); -} + SCM variable; + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + variable = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); -/* The bindings ((v1 i1) (v2 i2) ... (vn in)) are transformed to the lists - * (vn ... v2 v1) and (i1 i2 ... in). That is, the list of variables is - * reversed here, the list of inits gets reversed during evaluation. */ -static void -transform_bindings (SCM bindings, SCM *rvarloc, SCM *initloc, const char *what) -{ - SCM rvars = SCM_EOL; - *rvarloc = SCM_EOL; - *initloc = SCM_EOL; - - SCM_ASSYNT (scm_ilength (bindings) >= 1, scm_s_bindings, what); + SCM_SETCAR (expr, SCM_IM_SET_X); + return expr; +} - do - { - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, what); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, what); - if (scm_c_improper_memq (SCM_CAR (binding), rvars)) - scm_misc_error (what, scm_s_duplicate_bindings, SCM_EOL); - rvars = scm_cons (SCM_CAR (binding), rvars); - *initloc = scm_list_1 (SCM_CADR (binding)); - initloc = SCM_CDRLOC (*initloc); - bindings = SCM_CDR (bindings); - } - while (!SCM_NULLP (bindings)); - *rvarloc = rvars; -} +/* Start of the memoizers for non-R5RS builtin macros. */ -SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec); -SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); +SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply); +SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); +SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); SCM -scm_m_letrec (SCM xorig, SCM env) +scm_m_apply (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec); - - if (SCM_NULLP (SCM_CAR (x))) - { - /* null binding, let* faster */ - SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec); - return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env); - } - else - { - SCM rvars, inits, body; - transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec"); - body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec"); - return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); - } + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr); + + SCM_SETCAR (expr, SCM_IM_APPLY); + return expr; } -SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let); -SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); +SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); + +/* FIXME: The following explanation should go into the documentation: */ +/* (@bind ((var init) ...) body ...) will assign the values of the `init's to + * the global variables named by `var's (symbols, not evaluated), creating + * them if they don't exist, executes body, and then restores the previous + * values of the `var's. Additionally, whenever control leaves body, the + * values of the `var's are saved and restored when control returns. It is an + * error when a symbol appears more than once among the `var's. All `init's + * are evaluated before any `var' is set. + * + * Think of this as `let' for dynamic scope. + */ +/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into + * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...). + * + * FIXME - also implement `@bind*'. + */ SCM -scm_m_let (SCM xorig, SCM env) +scm_m_atbind (SCM expr, SCM env) { - SCM x = SCM_CDR (xorig); - SCM temp; - - SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let); - temp = SCM_CAR (x); - if (SCM_NULLP (temp) - || (scm_ilength (temp) == 1 && SCM_CONSP (SCM_CAR (temp)))) - { - /* null or single binding, let* is faster */ - SCM bindings = temp; - SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (x), s_let); - return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), bindings, body), env); - } - else if (SCM_CONSP (temp)) + SCM bindings; + SCM rvariables; + SCM inits; + SCM variable_idx; + + const SCM top_level = scm_env_top_level (env); + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr); + bindings = SCM_CAR (cdr_expr); + check_bindings (bindings, expr); + transform_bindings (bindings, expr, &rvariables, &inits); + + for (variable_idx = rvariables; + !SCM_NULLP (variable_idx); + variable_idx = SCM_CDR (variable_idx)) { - /* plain let */ - SCM bindings = temp; - SCM rvars, inits, body; - transform_bindings (bindings, &rvars, &inits, "let"); - body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); - return scm_cons2 (SCM_IM_LET, rvars, scm_cons (inits, body)); + /* The first call to scm_sym2var will look beyond the current module, + * while the second call wont. */ + const SCM variable = SCM_CAR (variable_idx); + SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F); + if (SCM_FALSEP (new_variable)) + new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); + SCM_SETCAR (variable_idx, new_variable); } - else - { - /* named let: Transform (let name ((var init) ...) body ...) into - * ((letrec ((name (lambda (var ...) body ...))) name) init ...) */ - - SCM name = temp; - SCM vars = SCM_EOL; - SCM *varloc = &vars; - SCM inits = SCM_EOL; - SCM *initloc = &inits; - SCM bindings; - - SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_bindings, s_let); - x = SCM_CDR (x); - SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_let); - bindings = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_let); - while (!SCM_NULLP (bindings)) - { /* vars and inits both in order */ - SCM binding = SCM_CAR (bindings); - SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_let); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_let); - *varloc = scm_list_1 (SCM_CAR (binding)); - varloc = SCM_CDRLOC (*varloc); - *initloc = scm_list_1 (SCM_CADR (binding)); - initloc = SCM_CDRLOC (*initloc); - bindings = SCM_CDR (bindings); - } - { - SCM lambda_body = scm_m_body (SCM_IM_LET, SCM_CDR (x), "let"); - SCM lambda_form = scm_cons2 (scm_sym_lambda, vars, lambda_body); - SCM rvar = scm_list_1 (name); - SCM init = scm_list_1 (lambda_form); - SCM body = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let"); - SCM letrec = scm_cons2 (SCM_IM_LETREC, rvar, scm_cons (init, body)); - return scm_cons (letrec, inits); - } - } + SCM_SETCAR (expr, SCM_IM_BIND); + SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits)); + return expr; } -SCM_SYNTAX (s_atapply,"@apply", scm_makmmacro, scm_m_apply); -SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply); -SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1); +SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont); +SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc); SCM -scm_m_apply (SCM xorig, SCM env SCM_UNUSED) +scm_m_cont (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply); - return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig)); -} + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + SCM_SETCAR (expr, SCM_IM_CONT); + return expr; +} -SCM_SYNTAX(s_atcall_cc,"@call-with-current-continuation", scm_makmmacro, scm_m_cont); -SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc,s_atcall_cc); +SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values); +SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); -SCM -scm_m_cont (SCM xorig, SCM env SCM_UNUSED) +SCM +scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, - scm_s_expression, s_atcall_cc); - return scm_cons (SCM_IM_CONT, SCM_CDR (xorig)); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES); + return expr; } -#ifdef SCM_ENABLE_ELISP -SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond); +SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future); +SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); +/* Like promises, futures are implemented as closures with an empty + * parameter list. Thus, (future ) is transformed into + * (#@future '() ), where the empty list represents the + * empty parameter list. This representation allows for easy creation + * of the closure during evaluation. */ SCM -scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED) +scm_m_future (SCM expr, SCM env) { - long len = scm_ilength (SCM_CDR (xorig)); - SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond"); - return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig)); + const SCM new_expr = memoize_as_thunk_prototype (expr, env); + SCM_SETCAR (new_expr, SCM_IM_FUTURE); + return new_expr; } -SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop); -SCM -scm_m_atfop (SCM xorig, SCM env SCM_UNUSED) +SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); +SCM_SYMBOL (scm_sym_setter, "setter"); + +SCM +scm_m_generalized_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig), var; - SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop"); - var = scm_symbol_fref (SCM_CAR (x)); - /* Passing the symbol name as the `subr' arg here isn't really - right, but without it it can be very difficult to work out from - the error message which function definition was missing. In any - case, we shouldn't really use SCM_ASSYNT here at all, but instead - something equivalent to (signal void-function (list SYM)) in - Elisp. */ - SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", - SCM_SYMBOL_CHARS (SCM_CAR (x))); - /* Support `defalias'. */ - while (SCM_SYMBOLP (SCM_VARIABLE_REF (var))) + SCM target; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + + target = SCM_CAR (cdr_expr); + if (!SCM_CONSP (target)) { - var = scm_symbol_fref (SCM_VARIABLE_REF (var)); - SCM_ASSYNT (SCM_VARIABLEP (var), - "Symbol's function definition is void", - SCM_SYMBOL_CHARS (SCM_CAR (x))); + /* R5RS usage */ + return scm_m_set_x (expr, env); } - /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the - former allows for automatically picking up redefinitions of the - corresponding symbol. */ - SCM_SETCAR (x, var); - /* If the variable contains a procedure, leave the - `transformer-macro' in place so that the procedure's arguments - get properly transformed, and change the initial @fop to - SCM_IM_APPLY. */ - if (!SCM_MACROP (SCM_VARIABLE_REF (var))) + else { - SCM_SETCAR (xorig, SCM_IM_APPLY); - return xorig; - } - /* Otherwise (the variable contains a macro), the arguments should - not be transformed, so cut the `transformer-macro' out and return - the resulting expression starting with the variable. */ - SCM_SETCDR (x, SCM_CDADR (x)); - return x; -} + /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */ -#endif /* SCM_ENABLE_ELISP */ + const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target)); + const SCM setter_proc = scm_cons_source (expr, scm_sym_setter, setter_proc_tail); + + const SCM cddr_expr = SCM_CDR (cdr_expr); + const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target), cddr_expr)); -/* (@bind ((var exp) ...) body ...) + SCM_SETCAR (expr, setter_proc); + SCM_SETCDR (expr, setter_args); + return expr; + } +} - This will assign the values of the `exp's to the global variables - named by `var's (symbols, not evaluated), creating them if they - don't exist, executes body, and then restores the previous values of - the `var's. Additionally, whenever control leaves body, the values - of the `var's are saved and restored when control returns. It is an - error when a symbol appears more than once among the `var's. - All `exp's are evaluated before any `var' is set. - Think of this as `let' for dynamic scope. +/* @slot-ref is bound privately in the (oop goops) module from goops.c. As + * soon as the module system allows us to more freely create bindings in + * arbitrary modules during the startup phase, the code from goops.c should be + * moved here. */ +SCM +scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) +{ + SCM slot_nr; - It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...). + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr); + slot_nr = SCM_CADR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); - XXX - also implement `@bind*'. -*/ + SCM_SETCAR (expr, SCM_IM_SLOT_REF); + return expr; +} -SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind); +/* @slot-set! is bound privately in the (oop goops) module from goops.c. As + * soon as the module system allows us to more freely create bindings in + * arbitrary modules during the startup phase, the code from goops.c should be + * moved here. */ SCM -scm_m_atbind (SCM xorig, SCM env) +scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig); - SCM top_level = scm_env_top_level (env); - SCM vars = SCM_EOL, var; - SCM exps = SCM_EOL; + SCM slot_nr; - SCM_ASSYNT (scm_ilength (x) > 1, scm_s_expression, s_atbind); + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr); + slot_nr = SCM_CADR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); - x = SCM_CAR (x); - while (SCM_NIMP (x)) - { - SCM rest; - SCM sym_exp = SCM_CAR (x); - SCM_ASSYNT (scm_ilength (sym_exp) == 2, scm_s_bindings, s_atbind); - SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (sym_exp)), scm_s_bindings, s_atbind); - x = SCM_CDR (x); - for (rest = x; SCM_NIMP (rest); rest = SCM_CDR (rest)) - if (SCM_EQ_P (SCM_CAR (sym_exp), SCM_CAAR (rest))) - scm_misc_error (s_atbind, scm_s_duplicate_bindings, SCM_EOL); - /* The first call to scm_sym2var will look beyond the current - module, while the second call wont. */ - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_F); - if (SCM_FALSEP (var)) - var = scm_sym2var (SCM_CAR (sym_exp), top_level, SCM_BOOL_T); - vars = scm_cons (var, vars); - exps = scm_cons (SCM_CADR (sym_exp), exps); - } - return scm_cons (SCM_IM_BIND, - scm_cons (scm_cons (scm_reverse_x (vars, SCM_EOL), exps), - SCM_CDDR (xorig))); + SCM_SETCAR (expr, SCM_IM_SLOT_SET_X); + return expr; } -SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values); -SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values); +#if SCM_ENABLE_ELISP + +static const char s_defun[] = "Symbol's function definition is void"; + +SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond); + +/* nil-cond expressions have the form + * (nil-cond COND VAL COND VAL ... ELSEVAL) */ SCM -scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED) +scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED) { - SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, - scm_s_expression, s_at_call_with_values); - return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig)); + const long length = scm_ilength (SCM_CDR (expr)); + ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr); + + SCM_SETCAR (expr, SCM_IM_NIL_COND); + return expr; } + +SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop); + +/* The @fop-macro handles procedure and macro applications for elisp. The + * input expression must have the form + * (@fop (transformer-macro ...)) + * where must be a symbol. The expression is transformed into the + * memoized form of either + * (apply (transformer-macro ...)) + * if the value of var (across all aliasing) is not a macro, or + * ( ...) + * if var is a macro. */ SCM -scm_m_expand_body (SCM xorig, SCM env) +scm_m_atfop (SCM expr, SCM env SCM_UNUSED) { - SCM x = SCM_CDR (xorig), defs = SCM_EOL; - char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; + SCM location; + SCM symbol; - while (SCM_NIMP (x)) - { - SCM form = SCM_CAR (x); - if (!SCM_CONSP (form)) - break; - if (!SCM_SYMBOLP (SCM_CAR (form))) - break; + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr); - form = scm_macroexp (scm_cons_source (form, - SCM_CAR (form), - SCM_CDR (form)), - env); + symbol = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (symbol), s_bad_variable, symbol, expr); - if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) - { - defs = scm_cons (SCM_CDR (form), defs); - x = SCM_CDR (x); - } - else if (!SCM_IMP (defs)) - { - break; - } - else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form))) - { - x = scm_append (scm_list_2 (SCM_CDR (form), SCM_CDR (x))); - } - else - { - x = scm_cons (form, SCM_CDR (x)); - break; - } + location = scm_symbol_fref (symbol); + ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr); + + /* The elisp function `defalias' allows to define aliases for symbols. To + * look up such definitions, the chain of symbol definitions has to be + * followed up to the terminal symbol. */ + while (SCM_SYMBOLP (SCM_VARIABLE_REF (location))) + { + const SCM alias = SCM_VARIABLE_REF (location); + location = scm_symbol_fref (alias); + ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr); } - if (!SCM_NULLP (defs)) + /* Memoize the value location belonging to the terminal symbol. */ + SCM_SETCAR (cdr_expr, location); + + if (!SCM_MACROP (SCM_VARIABLE_REF (location))) { - SCM rvars, inits, body, letrec; - transform_bindings (defs, &rvars, &inits, what); - body = scm_m_body (SCM_IM_DEFINE, x, what); - letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body)); - SCM_SETCAR (xorig, letrec); - SCM_SETCDR (xorig, SCM_EOL); + /* Since the location does not contain a macro, the form is a procedure + * application. Replace `@fop' by `@apply' and transform the expression + * including the `transformer-macro'. */ + SCM_SETCAR (expr, SCM_IM_APPLY); + return expr; } else { - SCM_ASSYNT (SCM_CONSP (x), scm_s_body, what); - SCM_SETCAR (xorig, SCM_CAR (x)); - SCM_SETCDR (xorig, SCM_CDR (x)); + /* Since the location contains a macro, the arguments should not be + * transformed, so the `transformer-macro' is cut out. The resulting + * expression starts with the memoized variable, that is at the cdr of + * the input expression. */ + SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr)); + return cdr_expr; } +} - return xorig; +#endif /* SCM_ENABLE_ELISP */ + + +/* Start of the memoizers for deprecated macros. */ + + +#if (SCM_ENABLE_DEPRECATED == 1) + +SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine); + +SCM +scm_m_undefine (SCM expr, SCM env) +{ + SCM variable; + SCM location; + + const SCM cdr_expr = SCM_CDR (expr); + ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); + + variable = SCM_CAR (cdr_expr); + ASSERT_SYNTAX_2 (SCM_SYMBOLP (variable), s_bad_variable, variable, expr); + location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F); + ASSERT_SYNTAX_2 (!SCM_FALSEP (location) + && !SCM_UNBNDP (SCM_VARIABLE_REF (location)), + "variable already unbound ", variable, expr); + SCM_VARIABLE_SET (location, SCM_UNDEFINED); + return SCM_UNSPECIFIED; } +#endif + + +#if (SCM_ENABLE_DEPRECATED == 1) + SCM scm_macroexp (SCM x, SCM env) { @@ -1269,7 +2129,6 @@ scm_macroexp (SCM x, SCM env) if (!SCM_SYMBOLP (orig_sym)) return x; -#ifdef USE_THREADS { SCM *proc_ptr = scm_lookupcar1 (x, env, 0); if (proc_ptr == NULL) @@ -1279,14 +2138,12 @@ scm_macroexp (SCM x, SCM env) } proc = *proc_ptr; } -#else - proc = *scm_lookupcar (x, env, 0); -#endif /* Only handle memoizing macros. `Acros' and `macros' are really special forms and should not be evaluated here. */ - if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2) + if (!SCM_MACROP (proc) + || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc))) return x; SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ @@ -1303,6 +2160,19 @@ scm_macroexp (SCM x, SCM env) goto macro_tail; } +#endif + +/*****************************************************************************/ +/*****************************************************************************/ +/* The definitions for unmemoization start here. */ +/*****************************************************************************/ +/*****************************************************************************/ + +#define SCM_BIT7(x) (127 & SCM_UNPACK (x)) + +SCM_SYMBOL (sym_three_question_marks, "???"); + + /* scm_unmemocopy takes a memoized expression together with its * environment and rewrites it to its original form. Thus, it is the * inversion of the rewrite rules above. The procedure is not @@ -1318,62 +2188,105 @@ scm_macroexp (SCM x, SCM env) * This ought to change. */ -#define SCM_BIT8(x) (127 & SCM_UNPACK (x)) - static SCM -build_binding_list (SCM names, SCM inits) +build_binding_list (SCM rnames, SCM rinits) { SCM bindings = SCM_EOL; - while (!SCM_NULLP (names)) + while (!SCM_NULLP (rnames)) { - SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits)); + SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits)); bindings = scm_cons (binding, bindings); - names = SCM_CDR (names); - inits = SCM_CDR (inits); + rnames = SCM_CDR (rnames); + rinits = SCM_CDR (rinits); } return bindings; } + +static SCM +unmemocar (SCM form, SCM env) +{ + if (!SCM_CONSP (form)) + return form; + else + { + SCM c = SCM_CAR (form); + if (SCM_VARIABLEP (c)) + { + SCM sym = scm_module_reverse_lookup (scm_env_module (env), c); + if (SCM_FALSEP (sym)) + sym = sym_three_question_marks; + SCM_SETCAR (form, sym); + } + else if (SCM_ILOCP (c)) + { + unsigned long int ir; + + for (ir = SCM_IFRAME (c); ir != 0; --ir) + env = SCM_CDR (env); + env = SCM_CAAR (env); + for (ir = SCM_IDIST (c); ir != 0; --ir) + env = SCM_CDR (env); + SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env)); + } + return form; + } +} + + +#if (SCM_ENABLE_DEPRECATED == 1) + +SCM +scm_unmemocar (SCM form, SCM env) +{ + return unmemocar (form, env); +} + +#endif + + static SCM unmemocopy (SCM x, SCM env) { SCM ls, z; -#ifdef DEBUG_EXTENSIONS SCM p; -#endif - if (!SCM_CONSP (x)) + + if (SCM_VECTORP (x)) + { + return scm_list_2 (scm_sym_quote, x); + } + else if (!SCM_CONSP (x)) return x; -#ifdef DEBUG_EXTENSIONS + p = scm_whash_lookup (scm_source_whash, x); -#endif switch (SCM_ITAG7 (SCM_CAR (x))) { - case SCM_BIT8(SCM_IM_AND): + case SCM_BIT7 (SCM_IM_AND): ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_BEGIN): + case SCM_BIT7 (SCM_IM_BEGIN): ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_CASE): + case SCM_BIT7 (SCM_IM_CASE): ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_COND): + case SCM_BIT7 (SCM_IM_COND): ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; - case SCM_BIT8 (SCM_IM_DO): + case SCM_BIT7 (SCM_IM_DO): { - /* format: (#@do (nk nk-1 ...) (i1 ... ik) (test) (body) s1 ... sk), - * where nx is the name of a local variable, ix is an initializer for + /* format: (#@do (i1 ... ik) (nk nk-1 ...) (test) (body) s1 ... sk), + * where ix is an initializer for a local variable, nx is the name of * the local variable, test is the test clause of the do loop, body is * the body of the do loop and sx are the step clauses for the local * variables. */ SCM names, inits, test, memoized_body, steps, bindings; - x = SCM_CDR (x); - names = SCM_CAR (x); x = SCM_CDR (x); inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); - env = EXTEND_ENV (names, SCM_EOL, env); + x = SCM_CDR (x); + names = SCM_CAR (x); + env = SCM_EXTEND_ENV (names, SCM_EOL, env); x = SCM_CDR (x); test = unmemocopy (SCM_CAR (x), env); x = SCM_CDR (x); @@ -1402,46 +2315,46 @@ unmemocopy (SCM x, SCM env) x = scm_cons (SCM_BOOL_F, memoized_body); break; } - case SCM_BIT8(SCM_IM_IF): + case SCM_BIT7 (SCM_IM_IF): ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); break; - case SCM_BIT8 (SCM_IM_LET): + case SCM_BIT7 (SCM_IM_LET): { /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...), * where nx is the name of a local variable, ix is an initializer for * the local variable and by are the body clauses. */ - SCM names, inits, bindings; + SCM rnames, rinits, bindings; x = SCM_CDR (x); - names = SCM_CAR (x); + rnames = SCM_CAR (x); x = SCM_CDR (x); - inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); - env = EXTEND_ENV (names, SCM_EOL, env); + rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); - bindings = build_binding_list (names, inits); + bindings = build_binding_list (rnames, rinits); z = scm_cons (bindings, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_let, z); break; } - case SCM_BIT8 (SCM_IM_LETREC): + case SCM_BIT7 (SCM_IM_LETREC): { - /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...), - * where nx is the name of a local variable, ix is an initializer for + /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...), + * where vx is the name of a local variable, ix is an initializer for * the local variable and by are the body clauses. */ - SCM names, inits, bindings; + SCM rnames, rinits, bindings; x = SCM_CDR (x); - names = SCM_CAR (x); - env = EXTEND_ENV (names, SCM_EOL, env); + rnames = SCM_CAR (x); + env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); x = SCM_CDR (x); - inits = scm_reverse (unmemocopy (SCM_CAR (x), env)); + rinits = scm_reverse (unmemocopy (SCM_CAR (x), env)); - bindings = build_binding_list (names, inits); + bindings = build_binding_list (rnames, rinits); z = scm_cons (bindings, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_letrec, z); break; } - case SCM_BIT8(SCM_IM_LETSTAR): + case SCM_BIT7 (SCM_IM_LETSTAR): { SCM b, y; x = SCM_CDR (x); @@ -1449,19 +2362,20 @@ unmemocopy (SCM x, SCM env) y = SCM_EOL; if SCM_IMP (b) { - env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); + env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env); goto letstar; } y = z = scm_acons (SCM_CAR (b), unmemocar ( scm_cons (unmemocopy (SCM_CADR (b), env), SCM_EOL), env), SCM_UNSPECIFIED); - env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); + env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); b = SCM_CDDR (b); if (SCM_IMP (b)) { SCM_SETCDR (y, SCM_EOL); - ls = scm_cons (scm_sym_let, z = scm_cons (y, SCM_UNSPECIFIED)); + z = scm_cons (y, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_let, z); break; } do @@ -1471,47 +2385,48 @@ unmemocopy (SCM x, SCM env) scm_list_1 (unmemocopy (SCM_CADR (b), env)), env), SCM_UNSPECIFIED)); z = SCM_CDR (z); - env = EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); + env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env); b = SCM_CDDR (b); } while (SCM_NIMP (b)); SCM_SETCDR (z, SCM_EOL); letstar: - ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); + z = scm_cons (y, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_letstar, z); break; } - case SCM_BIT8(SCM_IM_OR): + case SCM_BIT7 (SCM_IM_OR): ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_LAMBDA): + case SCM_BIT7 (SCM_IM_LAMBDA): x = SCM_CDR (x); z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED); ls = scm_cons (scm_sym_lambda, z); - env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); + env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); break; - case SCM_BIT8(SCM_IM_QUOTE): + case SCM_BIT7 (SCM_IM_QUOTE): ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_SET_X): + case SCM_BIT7 (SCM_IM_SET_X): ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; - case SCM_BIT8(SCM_IM_DEFINE): - { - SCM n; - x = SCM_CDR (x); - n = SCM_CAR (x); - z = scm_cons (n, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_define, z); - if (!SCM_NULLP (env)) - SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAAR (env))); - break; - } - case SCM_BIT8(SCM_MAKISYM (0)): + case SCM_BIT7 (SCM_MAKISYM (0)): z = SCM_CAR (x); - if (!SCM_ISYMP (z)) - goto unmemo; switch (SCM_ISYMNUM (z)) { + case (SCM_ISYMNUM (SCM_IM_DEFINE)): + { + SCM n; + x = SCM_CDR (x); + n = SCM_CAR (x); + z = scm_cons (n, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_define, z); + if (!SCM_NULLP (env)) + env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), + SCM_CDAR (env)), + SCM_CDR (env)); + break; + } case (SCM_ISYMNUM (SCM_IM_APPLY)): ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); goto loop; @@ -1522,13 +2437,19 @@ unmemocopy (SCM x, SCM env) ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED); x = SCM_CDR (x); goto loop; + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED); + x = SCM_CDR (x); + goto loop; case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED); goto loop; + case (SCM_ISYMNUM (SCM_IM_ELSE)): + ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED); + goto loop; default: /* appease the Sun compiler god: */ ; } - unmemo: default: ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), SCM_UNSPECIFIED), @@ -1545,17 +2466,19 @@ loop: SCM_SETCDR (z, unmemocar (copy, env)); z = SCM_CDR (z); } + else if (SCM_EQ_P (form, SCM_IM_ARROW)) + { + SCM_SETCDR (z, scm_cons (scm_sym_arrow, SCM_UNSPECIFIED)); + z = SCM_CDR (z); + } x = SCM_CDR (x); } SCM_SETCDR (z, x); -#ifdef DEBUG_EXTENSIONS if (!SCM_FALSEP (p)) scm_whash_insert (scm_source_whash, ls, p); -#endif return ls; } - SCM scm_unmemocopy (SCM x, SCM env) { @@ -1567,9 +2490,25 @@ scm_unmemocopy (SCM x, SCM env) return unmemocopy (x, env); } -#ifndef SCM_RECKLESS -int +/*****************************************************************************/ +/*****************************************************************************/ +/* The definitions for execution start here. */ +/*****************************************************************************/ +/*****************************************************************************/ + +SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame"); +SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace"); + +/* A function object to implement "apply" for non-closure functions. */ +static SCM f_apply; +/* An endless list consisting of # objects: */ +static SCM undefineds; + + +int scm_badargsp (SCM formals, SCM args) { while (!SCM_NULLP (formals)) @@ -1584,24 +2523,6 @@ scm_badargsp (SCM formals, SCM args) return !SCM_NULLP (args) ? 1 : 0; } -#endif - -static int -scm_badformalsp (SCM closure, int n) -{ - SCM formals = SCM_CLOSURE_FORMALS (closure); - while (!SCM_NULLP (formals)) - { - if (!SCM_CONSP (formals)) - return 0; - if (n == 0) - return 1; - --n; - formals = SCM_CDR (formals); - } - return n; -} - SCM scm_eval_args (SCM l, SCM env, SCM proc) @@ -1615,13 +2536,12 @@ scm_eval_args (SCM l, SCM env, SCM proc) lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } -#ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) scm_wrong_num_args (proc); -#endif return results; } + SCM scm_eval_body (SCM code, SCM env) { @@ -1634,7 +2554,11 @@ scm_eval_body (SCM code, SCM env) { if (SCM_ISYMP (SCM_CAR (code))) { - code = scm_m_expand_body (code, env); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (code))) + code = m_expand_body (code, env); + scm_rec_mutex_unlock (&source_mutex); goto again; } } @@ -1646,7 +2570,6 @@ scm_eval_body (SCM code, SCM env) return SCM_XEVALCAR (code, env); } - #endif /* !DEVAL */ @@ -1680,7 +2603,7 @@ scm_eval_body (SCM code, SCM env) #define ENTER_APPLY \ do { \ SCM_SET_ARGSREADY (debug);\ - if (CHECK_APPLY && SCM_TRAPS_P)\ + if (scm_check_apply_p && SCM_TRAPS_P)\ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\ {\ SCM tmp, tail = SCM_BOOL(SCM_TRACED_FRAME_P (debug)); \ @@ -1725,10 +2648,6 @@ SCM (*scm_ceval_ptr) (SCM x, SCM env); * any stack swaps. */ -#ifndef USE_THREADS -scm_t_debug_frame *scm_last_debug_frame; -#endif - /* scm_debug_eframe_size is the number of slots available for pseudo * stack frames at each real stack frame. */ @@ -1779,7 +2698,7 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, (SCM setting), "Option interface for the evaluation options. Instead of using\n" "this procedure directly, use the procedures @code{eval-enable},\n" - "@code{eval-disable}, @code{eval-set!} and @var{eval-options}.") + "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.") #define FUNC_NAME s_scm_eval_options_interface { SCM ans; @@ -1794,6 +2713,7 @@ SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, (SCM setting), "Option interface for the evaluator trap options.") @@ -1811,6 +2731,7 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, } #undef FUNC_NAME + static SCM deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { @@ -1823,10 +2744,8 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) lloc = SCM_CDRLOC (*lloc); l = SCM_CDR (l); } -#ifdef SCM_CAUTIOUS if (!SCM_NULLP (l)) scm_wrong_num_args (proc); -#endif return *results; } @@ -1842,11 +2761,15 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc) #define UPDATE_TOPLEVEL_ENV(env) \ do { \ SCM p = scm_current_module_lookup_closure (); \ - if (p != SCM_CAR(env)) \ + if (p != SCM_CAR (env)) \ env = scm_top_level_env (p); \ } while (0) +#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \ + ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x) + + /* This is the evaluator. Like any real monster, it has three heads: * * scm_ceval is the non-debugging evaluator, scm_deval is the debugging @@ -1890,7 +2813,7 @@ scm_deval (SCM x, SCM env) SCM SCM_CEVAL (SCM x, SCM env) { - SCM proc, arg1, arg2, orig_sym; + SCM proc, arg1; #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info *debug_info_end; @@ -1909,8 +2832,7 @@ SCM_CEVAL (SCM x, SCM env) scm_last_debug_frame = &debug; #endif #ifdef EVAL_STACK_CHECKING - if (scm_stack_checking_enabled_p - && SCM_STACK_OVERFLOW_P ((SCM_STACKITEM *) &proc)) + if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc)) { #ifdef DEVAL debug.info->e.exp = x; @@ -1924,8 +2846,6 @@ SCM_CEVAL (SCM x, SCM env) goto start; #endif -loopnoap: - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); loop: #ifdef DEVAL SCM_CLEAR_ARGSREADY (debug); @@ -1938,8 +2858,7 @@ loop: * * For this to be the case, however, it is necessary that primitive * special forms which jump back to `loop', `begin' or some similar - * label call PREP_APPLY. A convenient way to do this is to jump to - * `loopnoap' or `cdrxnoap'. + * label call PREP_APPLY. */ else if (++debug.info >= debug_info_end) { @@ -1950,52 +2869,49 @@ loop: start: debug.info->e.exp = x; debug.info->e.env = env; - if (CHECK_ENTRY && SCM_TRAPS_P) - if (SCM_ENTER_FRAME_P || (SCM_BREAKPOINTS_P && SRCBRKP (x))) - { - SCM tail = SCM_BOOL(SCM_TAILRECP (debug)); - SCM_SET_TAILREC (debug); - if (SCM_CHEAPTRAPS_P) - arg1 = scm_make_debugobj (&debug); - else - { - int first; - SCM val = scm_make_continuation (&first); - - if (first) - arg1 = val; - else - { - x = val; - if (SCM_IMP (x)) - RETURN (x); - else - /* This gives the possibility for the debugger to - modify the source expression before evaluation. */ - goto dispatch; - } - } - SCM_TRAPS_P = 0; - scm_call_4 (SCM_ENTER_FRAME_HDLR, - scm_sym_enter_frame, - arg1, - tail, - scm_unmemocopy (x, env)); - SCM_TRAPS_P = 1; - } + if (scm_check_entry_p && SCM_TRAPS_P) + { + if (SCM_ENTER_FRAME_P + || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x))) + { + SCM stackrep; + SCM tail = SCM_BOOL (SCM_TAILRECP (debug)); + SCM_SET_TAILREC (debug); + if (SCM_CHEAPTRAPS_P) + stackrep = scm_make_debugobj (&debug); + else + { + int first; + SCM val = scm_make_continuation (&first); + + if (first) + stackrep = val; + else + { + x = val; + if (SCM_IMP (x)) + RETURN (x); + else + /* This gives the possibility for the debugger to + modify the source expression before evaluation. */ + goto dispatch; + } + } + SCM_TRAPS_P = 0; + scm_call_4 (SCM_ENTER_FRAME_HDLR, + scm_sym_enter_frame, + stackrep, + tail, + scm_unmemocopy (x, env)); + SCM_TRAPS_P = 1; + } + } #endif -#if defined (USE_THREADS) || defined (DEVAL) dispatch: -#endif SCM_TICK; switch (SCM_TYP7 (x)) { - case scm_tc7_symbol: - /* Only happens when called at top level. */ - x = scm_cons (x, SCM_UNDEFINED); - RETURN (*scm_lookupcar (x, env, 1)); - - case SCM_BIT8 (SCM_IM_AND): + case SCM_BIT7 (SCM_IM_AND): x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { @@ -2008,16 +2924,12 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case SCM_BIT8 (SCM_IM_BEGIN): - if (SCM_NULLP (SCM_CDR (x))) + case SCM_BIT7 (SCM_IM_BEGIN): + x = SCM_CDR (x); + if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); - /* (currently unused) - cdrxnoap: */ PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - /* (currently unused) - cdrxbegin: */ - x = SCM_CDR (x); begin: /* If we are on toplevel with a lookup closure, we need to sync @@ -2036,9 +2948,6 @@ dispatch: else goto nontoplevel_begin; - nontoplevel_cdrxnoap: - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - x = SCM_CDR (x); nontoplevel_begin: while (!SCM_NULLP (SCM_CDR (x))) { @@ -2047,7 +2956,11 @@ dispatch: { if (SCM_ISYMP (form)) { - x = scm_m_expand_body (x, env); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (x))) + x = m_expand_body (x, env); + scm_rec_mutex_unlock (&source_mutex); goto nontoplevel_begin; } else @@ -2080,7 +2993,7 @@ dispatch: } - case SCM_BIT8 (SCM_IM_CASE): + case SCM_BIT7 (SCM_IM_CASE): x = SCM_CDR (x); { SCM key = EVALCAR (x, env); @@ -2089,7 +3002,7 @@ dispatch: { SCM clause = SCM_CAR (x); SCM labels = SCM_CAR (clause); - if (SCM_EQ_P (labels, scm_sym_else)) + if (SCM_EQ_P (labels, SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -2112,12 +3025,12 @@ dispatch: RETURN (SCM_UNSPECIFIED); - case SCM_BIT8 (SCM_IM_COND): + case SCM_BIT7 (SCM_IM_COND): x = SCM_CDR (x); while (!SCM_NULLP (x)) { SCM clause = SCM_CAR (x); - if (SCM_EQ_P (SCM_CAR (clause), scm_sym_else)) + if (SCM_EQ_P (SCM_CAR (clause), SCM_IM_ELSE)) { x = SCM_CDR (clause); PREP_APPLY (SCM_UNDEFINED, SCM_EOL); @@ -2131,7 +3044,7 @@ dispatch: x = SCM_CDR (clause); if (SCM_NULLP (x)) RETURN (arg1); - else if (!SCM_EQ_P (SCM_CAR (x), scm_sym_arrow)) + else if (!SCM_EQ_P (SCM_CAR (x), SCM_IM_ARROW)) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -2140,13 +3053,9 @@ dispatch: { proc = SCM_CDR (x); proc = EVALCAR (proc, env); - SCM_ASRTGO (!SCM_IMP (proc), badfun); PREP_APPLY (proc, scm_list_1 (arg1)); ENTER_APPLY; - if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) - goto umwrongnumargs; - else - goto evap1; + goto evap1; } } x = SCM_CDR (x); @@ -2155,20 +3064,21 @@ dispatch: RETURN (SCM_UNSPECIFIED); - case SCM_BIT8 (SCM_IM_DO): + case SCM_BIT7 (SCM_IM_DO): x = SCM_CDR (x); { /* Compute the initialization values and the initial environment. */ - SCM init_forms = SCM_CADR (x); + SCM init_forms = SCM_CAR (x); SCM init_values = SCM_EOL; while (!SCM_NULLP (init_forms)) { init_values = scm_cons (EVALCAR (init_forms, env), init_values); init_forms = SCM_CDR (init_forms); } - env = EXTEND_ENV (SCM_CAR (x), init_values, env); + x = SCM_CDR (x); + env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); } - x = SCM_CDDR (x); + x = SCM_CDR (x); { SCM test_form = SCM_CAR (x); SCM body_forms = SCM_CADR (x); @@ -2211,7 +3121,9 @@ dispatch: SCM value = EVALCAR (temp_forms, env); step_values = scm_cons (value, step_values); } - env = EXTEND_ENV (SCM_CAAR (env), step_values, SCM_CDR (env)); + env = SCM_EXTEND_ENV (SCM_CAAR (env), + step_values, + SCM_CDR (env)); } test_result = EVALCAR (test_form, env); @@ -2224,15 +3136,14 @@ dispatch: goto nontoplevel_begin; - case SCM_BIT8 (SCM_IM_IF): + case SCM_BIT7 (SCM_IM_IF): x = SCM_CDR (x); { SCM test_result = EVALCAR (x, env); - if (!SCM_FALSEP (test_result) && !SCM_NILP (test_result)) - x = SCM_CDR (x); - else + x = SCM_CDR (x); /* then expression */ + if (SCM_FALSEP (test_result) || SCM_NILP (test_result)) { - x = SCM_CDDR (x); + x = SCM_CDR (x); /* else expression */ if (SCM_NULLP (x)) RETURN (SCM_UNSPECIFIED); } @@ -2241,7 +3152,7 @@ dispatch: goto carloop; - case SCM_BIT8 (SCM_IM_LET): + case SCM_BIT7 (SCM_IM_LET): x = SCM_CDR (x); { SCM init_forms = SCM_CADR (x); @@ -2252,15 +3163,16 @@ dispatch: init_forms = SCM_CDR (init_forms); } while (!SCM_NULLP (init_forms)); - env = EXTEND_ENV (SCM_CAR (x), init_values, env); + env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env); } - x = SCM_CDR (x); - goto nontoplevel_cdrxnoap; + x = SCM_CDDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8 (SCM_IM_LETREC): + case SCM_BIT7 (SCM_IM_LETREC): x = SCM_CDR (x); - env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); + env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env); x = SCM_CDR (x); { SCM init_forms = SCM_CAR (x); @@ -2273,31 +3185,35 @@ dispatch: while (!SCM_NULLP (init_forms)); SCM_SETCDR (SCM_CAR (env), init_values); } - goto nontoplevel_cdrxnoap; + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8 (SCM_IM_LETSTAR): + case SCM_BIT7 (SCM_IM_LETSTAR): x = SCM_CDR (x); { SCM bindings = SCM_CAR (x); if (SCM_NULLP (bindings)) - env = EXTEND_ENV (SCM_EOL, SCM_EOL, env); + env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env); else { do { SCM name = SCM_CAR (bindings); SCM init = SCM_CDR (bindings); - env = EXTEND_ENV (name, EVALCAR (init, env), env); + env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env); bindings = SCM_CDR (init); } while (!SCM_NULLP (bindings)); } } - goto nontoplevel_cdrxnoap; + x = SCM_CDR (x); + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto nontoplevel_begin; - case SCM_BIT8 (SCM_IM_OR): + case SCM_BIT7 (SCM_IM_OR): x = SCM_CDR (x); while (!SCM_NULLP (SCM_CDR (x))) { @@ -2311,25 +3227,23 @@ dispatch: goto carloop; - case SCM_BIT8 (SCM_IM_LAMBDA): + case SCM_BIT7 (SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case SCM_BIT8 (SCM_IM_QUOTE): + case SCM_BIT7 (SCM_IM_QUOTE): RETURN (SCM_CADR (x)); - case SCM_BIT8 (SCM_IM_SET_X): + case SCM_BIT7 (SCM_IM_SET_X): x = SCM_CDR (x); { SCM *location; SCM variable = SCM_CAR (x); - if (SCM_VARIABLEP (variable)) - location = SCM_VARIABLE_LOC (variable); -#ifdef MEMOIZE_LOCALS - else if (SCM_ILOCP (variable)) + if (SCM_ILOCP (variable)) location = scm_ilookup (variable, env); -#endif + else if (SCM_VARIABLEP (variable)) + location = SCM_VARIABLE_LOC (variable); else /* (SCM_SYMBOLP (variable)) is known to be true */ location = scm_lookupcar (x, env, 1); x = SCM_CDR (x); @@ -2338,67 +3252,68 @@ dispatch: RETURN (SCM_UNSPECIFIED); - case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */ - scm_misc_error (NULL, "Bad define placement", SCM_EOL); - - /* new syntactic forms go here. */ - case SCM_BIT8 (SCM_MAKISYM (0)): + case SCM_BIT7 (SCM_MAKISYM (0)): proc = SCM_CAR (x); - SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch (SCM_ISYMNUM (proc)) { + case (SCM_ISYMNUM (SCM_IM_DEFINE)): + /* Top level defines are handled directly by the memoizer and thus + * will never generate memoized code with SCM_IM_DEFINE. Internal + * defines which occur at valid positions will be transformed into + * letrec expressions. Thus, whenever the executor detects + * SCM_IM_DEFINE, this must come from an internal definition at an + * illegal position. */ + scm_misc_error (NULL, "Bad define placement", SCM_EOL); + + case (SCM_ISYMNUM (SCM_IM_APPLY)): - proc = SCM_CDR (x); - proc = EVALCAR (proc, env); - SCM_ASRTGO (!SCM_IMP (proc), badfun); + x = SCM_CDR (x); + proc = EVALCAR (x, env); + PREP_APPLY (proc, SCM_EOL); + x = SCM_CDR (x); + arg1 = EVALCAR (x, env); + + apply_proc: + /* Go here to tail-apply a procedure. PROC is the procedure and + * ARG1 is the list of arguments. PREP_APPLY must have been called + * before jumping to apply_proc. */ if (SCM_CLOSUREP (proc)) { - PREP_APPLY (proc, SCM_EOL); - arg1 = SCM_CDDR (x); - arg1 = EVALCAR (arg1, env); - apply_closure: - /* Go here to tail-call a closure. PROC is the closure - and ARG1 is the list of arguments. Do not forget to - call PREP_APPLY. */ - { - SCM formals = SCM_CLOSURE_FORMALS (proc); + SCM formals = SCM_CLOSURE_FORMALS (proc); #ifdef DEVAL - debug.info->a.args = arg1; -#endif -#ifndef SCM_RECKLESS - if (scm_badargsp (formals, arg1)) - goto wrongnumargs; + debug.info->a.args = arg1; #endif - ENTER_APPLY; - /* Copy argument list */ - if (SCM_NULL_OR_NIL_P (arg1)) - env = EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); - else - { - SCM args = scm_list_1 (SCM_CAR (arg1)); - SCM tail = args; - arg1 = SCM_CDR (arg1); - while (!SCM_NULL_OR_NIL_P (arg1)) - { - SCM new_tail = scm_list_1 (SCM_CAR (arg1)); - SCM_SETCDR (tail, new_tail); - tail = new_tail; - arg1 = SCM_CDR (arg1); - } - env = EXTEND_ENV (formals, args, SCM_ENV (proc)); - } - - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } + if (scm_badargsp (formals, arg1)) + scm_wrong_num_args (proc); + ENTER_APPLY; + /* Copy argument list */ + if (SCM_NULL_OR_NIL_P (arg1)) + env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + else + { + SCM args = scm_list_1 (SCM_CAR (arg1)); + SCM tail = args; + arg1 = SCM_CDR (arg1); + while (!SCM_NULL_OR_NIL_P (arg1)) + { + SCM new_tail = scm_list_1 (SCM_CAR (arg1)); + SCM_SETCDR (tail, new_tail); + tail = new_tail; + arg1 = SCM_CDR (arg1); + } + env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc)); + } + + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; } else { - proc = scm_f_apply; - goto evapply; + ENTER_APPLY; + RETURN (SCM_APPLY (proc, arg1, SCM_EOL)); } @@ -2407,50 +3322,35 @@ dispatch: int first; SCM val = scm_make_continuation (&first); - if (first) - arg1 = val; - else + if (!first) RETURN (val); + else + { + arg1 = val; + proc = SCM_CDR (x); + proc = scm_eval_car (proc, env); + PREP_APPLY (proc, scm_list_1 (arg1)); + ENTER_APPLY; + goto evap1; + } } - proc = SCM_CDR (x); - proc = scm_eval_car (proc, env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); - PREP_APPLY (proc, scm_list_1 (arg1)); - ENTER_APPLY; - if (SCM_CLOSUREP(proc) && scm_badformalsp (proc, 1)) - goto umwrongnumargs; - goto evap1; + case (SCM_ISYMNUM (SCM_IM_DELAY)): RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); - case (SCM_ISYMNUM (SCM_IM_DISPATCH)): - { - /* If not done yet, evaluate the operand forms. The result is a - * list of arguments stored in arg1, which is used to perform the - * function dispatch. */ - SCM operand_forms = SCM_CADR (x); - PREP_APPLY (SCM_UNDEFINED, SCM_EOL); - if (SCM_ILOCP (operand_forms)) - arg1 = *scm_ilookup (operand_forms, env); - else if (SCM_VARIABLEP (operand_forms)) - arg1 = SCM_VARIABLE_REF (operand_forms); - else if (!SCM_CONSP (operand_forms)) - arg1 = *scm_lookupcar (SCM_CDR (x), env, 1); - else - { - SCM tail = arg1 = scm_list_1 (EVALCAR (operand_forms, env)); - operand_forms = SCM_CDR (operand_forms); - while (!SCM_NULLP (operand_forms)) - { - SCM new_tail = scm_list_1 (EVALCAR (operand_forms, env)); - SCM_SETCDR (tail, new_tail); - tail = new_tail; - operand_forms = SCM_CDR (operand_forms); - } - } - } + case (SCM_ISYMNUM (SCM_IM_FUTURE)): + RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env))); + + + /* PLACEHOLDER for case (SCM_ISYMNUM (SCM_IM_DISPATCH)): The + following code (type_dispatch) is intended to be the tail + of the case clause for the internal macro + SCM_IM_DISPATCH. Please don't remove it from this + location without discussing it with Mikael + */ + /* The type dispatch code is duplicated below * (c.f. objects.c:scm_mcache_compute_cmethod) since that * cuts down execution time for type dispatch to 50%. */ @@ -2572,7 +3472,7 @@ dispatch: apply_cmethod: /* inputs: z, arg1 */ { SCM formals = SCM_CMETHOD_FORMALS (z); - env = EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); + env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); x = SCM_CMETHOD_BODY (z); goto nontoplevel_begin; } @@ -2600,7 +3500,7 @@ dispatch: } -#ifdef SCM_ENABLE_ELISP +#if SCM_ENABLE_ELISP case (SCM_ISYMNUM (SCM_IM_NIL_COND)): { @@ -2637,10 +3537,8 @@ dispatch: x = SCM_CDR (x); vars = SCM_CAAR (x); exps = SCM_CDAR (x); - vals = SCM_EOL; - - while (SCM_NIMP (exps)) + while (!SCM_NULLP (exps)) { vals = scm_cons (EVALCAR (exps, env), vals); exps = SCM_CDR (exps); @@ -2666,35 +3564,41 @@ dispatch: case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)): { - proc = SCM_CDR (x); - x = EVALCAR (proc, env); - proc = SCM_CDR (proc); - proc = EVALCAR (proc, env); - arg1 = SCM_APPLY (x, SCM_EOL, SCM_EOL); + SCM producer; + + x = SCM_CDR (x); + producer = EVALCAR (x, env); + x = SCM_CDR (x); + proc = EVALCAR (x, env); /* proc is the consumer. */ + arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL); if (SCM_VALUESP (arg1)) - arg1 = scm_struct_ref (arg1, SCM_INUM0); + { + /* The list of arguments is not copied. Rather, it is assumed + * that this has been done by the 'values' procedure. */ + arg1 = scm_struct_ref (arg1, SCM_INUM0); + } else - arg1 = scm_list_1 (arg1); - if (SCM_CLOSUREP (proc)) - { - PREP_APPLY (proc, arg1); - goto apply_closure; - } - return SCM_APPLY (proc, arg1, SCM_EOL); + { + arg1 = scm_list_1 (arg1); + } + PREP_APPLY (proc, arg1); + goto apply_proc; } default: - goto badfun; + goto evapply; } + default: proc = x; - badfun: - scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); + goto evapply; + + case scm_tc7_vector: case scm_tc7_wvect: -#ifdef HAVE_ARRAYS +#if SCM_HAVE_ARRAYS case scm_tc7_bvect: case scm_tc7_byvect: case scm_tc7_svect: @@ -2703,10 +3607,11 @@ dispatch: case scm_tc7_fvect: case scm_tc7_dvect: case scm_tc7_cvect: -#ifdef HAVE_LONG_LONGS +#if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: #endif #endif + case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: case scm_tcs_closures: @@ -2716,26 +3621,22 @@ dispatch: case scm_tcs_struct: RETURN (x); + case scm_tc7_symbol: + /* Only happens when called at top level. */ + x = scm_cons (x, SCM_UNDEFINED); + RETURN (*scm_lookupcar (x, env, 1)); + case scm_tc7_variable: RETURN (SCM_VARIABLE_REF(x)); -#ifdef MEMOIZE_LOCALS - case SCM_BIT8(SCM_ILOC00): + case SCM_BIT7 (SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS - goto checkargs; -#endif -#endif - break; -#endif /* ifdef MEMOIZE_LOCALS */ + goto checkmacro; case scm_tcs_cons_nimcar: - orig_sym = SCM_CAR (x); - if (SCM_SYMBOLP (orig_sym)) + if (SCM_SYMBOLP (SCM_CAR (x))) { -#ifdef USE_THREADS + SCM orig_sym = SCM_CAR (x); { SCM *location = scm_lookupcar1 (x, env, 1); if (location == NULL) @@ -2745,21 +3646,12 @@ dispatch: } proc = *location; } -#else - proc = *scm_lookupcar (x, env, 1); -#endif - if (SCM_IMP (proc)) - { - SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of - lookupcar */ - goto badfun; - } if (SCM_MACROP (proc)) { SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */ - handle_a_macro: + handle_a_macro: /* inputs: x, env, proc */ #ifdef DEVAL /* Set a flag during macro expansion so that macro application frames can be deleted from the backtrace. */ @@ -2773,6 +3665,7 @@ dispatch: #endif switch (SCM_MACRO_TYPE (proc)) { + case 3: case 2: if (scm_ilength (arg1) <= 0) arg1 = scm_list_2 (SCM_IM_BEGIN, arg1); @@ -2794,10 +3687,19 @@ dispatch: SCM_SETCAR (x, SCM_CAR (arg1)); SCM_SETCDR (x, SCM_CDR (arg1)); SCM_ALLOW_INTS; - goto loopnoap; + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; +#if SCM_ENABLE_DEPRECATED == 1 case 1: - if (SCM_NIMP (x = arg1)) - goto loopnoap; + x = arg1; + if (SCM_NIMP (x)) + { + PREP_APPLY (SCM_UNDEFINED, SCM_EOL); + goto loop; + } + else + RETURN (arg1); +#endif case 0: RETURN (arg1); } @@ -2805,38 +3707,19 @@ dispatch: } else proc = SCM_CEVAL (SCM_CAR (x), env); - SCM_ASRTGO (!SCM_IMP (proc), badfun); -#ifndef SCM_RECKLESS -#ifdef SCM_CAUTIOUS - checkargs: -#endif - if (SCM_CLOSUREP (proc)) - { - arg2 = SCM_CLOSURE_FORMALS (proc); - arg1 = SCM_CDR (x); - while (!SCM_NULLP (arg2)) - { - if (!SCM_CONSP (arg2)) - goto evapply; - if (SCM_IMP (arg1)) - goto umwrongnumargs; - arg2 = SCM_CDR (arg2); - arg1 = SCM_CDR (arg1); - } - if (!SCM_NULLP (arg1)) - goto umwrongnumargs; - } - else if (SCM_MACROP (proc)) + + checkmacro: + if (SCM_MACROP (proc)) goto handle_a_macro; -#endif } -evapply: +evapply: /* inputs: x, proc */ PREP_APPLY (proc, SCM_EOL); if (SCM_NULLP (SCM_CDR (x))) { ENTER_APPLY; evap0: + SCM_ASRTGO (!SCM_IMP (proc), badfun); switch (SCM_TYP7 (proc)) { /* no arguments given */ case scm_tc7_subr_0: @@ -2868,12 +3751,16 @@ evapply: #endif if (!SCM_CLOSUREP (proc)) goto evap0; - if (scm_badformalsp (proc, 0)) - goto umwrongnumargs; + /* fallthrough */ case scm_tcs_closures: - x = SCM_CLOSURE_BODY (proc); - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc)); - goto nontoplevel_begin; + { + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_CONSP (formals)) + goto umwrongnumargs; + x = SCM_CLOSURE_BODY (proc); + env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc)); + goto nontoplevel_begin; + } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) { @@ -2881,9 +3768,7 @@ evapply: arg1 = SCM_EOL; goto type_dispatch; } - else if (!SCM_I_OPERATORP (proc)) - goto badfun; - else + else if (SCM_I_OPERATORP (proc)) { arg1 = proc; proc = (SCM_I_ENTITYP (proc) @@ -2893,462 +3778,457 @@ evapply: debug.info->a.proc = proc; debug.info->a.args = scm_list_1 (arg1); #endif - if (SCM_NIMP (proc)) - goto evap1; - else - goto badfun; + goto evap1; } + else + goto badfun; case scm_tc7_subr_1: case scm_tc7_subr_2: case scm_tc7_subr_2o: + case scm_tc7_dsubr: case scm_tc7_cxr: case scm_tc7_subr_3: case scm_tc7_lsubr_2: umwrongnumargs: unmemocar (x, env); - wrongnumargs: scm_wrong_num_args (proc); default: - /* handle macros here */ - goto badfun; + badfun: + scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc)); } } /* must handle macros by here */ x = SCM_CDR (x); -#ifdef SCM_CAUTIOUS if (SCM_CONSP (x)) arg1 = EVALCAR (x, env); else - goto wrongnumargs; -#else - arg1 = EVALCAR (x, env); -#endif + scm_wrong_num_args (proc); #ifdef DEVAL debug.info->a.args = scm_list_1 (arg1); #endif x = SCM_CDR (x); - if (SCM_NULLP (x)) - { - ENTER_APPLY; - evap1: - switch (SCM_TYP7 (proc)) - { /* have one argument in arg1 */ - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); - case scm_tc7_subr_1: - case scm_tc7_subr_1o: - RETURN (SCM_SUBRF (proc) (arg1)); - case scm_tc7_cxr: - if (SCM_SUBRF (proc)) + { + SCM arg2; + if (SCM_NULLP (x)) + { + ENTER_APPLY; + evap1: /* inputs: proc, arg1 */ + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have one argument in arg1 */ + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_dsubr: + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } + else if (SCM_BIGP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + } + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + case scm_tc7_cxr: { - if (SCM_INUMP (arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); - } - else if (SCM_REALP (arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); - } -#ifdef SCM_BIGDIG - else if (SCM_BIGP (arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); - } -#endif - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); + do + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, + SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); + pattern >>= 2; + } while (pattern); + RETURN (arg1); } - proc = SCM_SNAME (proc); - { - char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; - while ('c' != *--chrs) - { - SCM_ASSERT (SCM_CONSP (arg1), - arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); - arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); - } - RETURN (arg1); - } - case scm_tc7_rpsubr: - RETURN (SCM_BOOL_T); - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); - case scm_tc7_lsubr: + case scm_tc7_rpsubr: + RETURN (SCM_BOOL_T); + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); + case scm_tc7_lsubr: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); #else - RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); + RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1))); #endif - case scm_tc7_smob: - 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_smob: + 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); #ifdef DEVAL - debug.info->a.args = scm_cons (arg1, debug.info->a.args); - debug.info->a.proc = proc; + debug.info->a.args = scm_cons (arg1, debug.info->a.args); + debug.info->a.proc = proc; #endif - goto evap2; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); + goto evap2; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); #ifdef DEVAL - debug.info->a.proc = proc; + debug.info->a.proc = proc; #endif - if (!SCM_CLOSUREP (proc)) - goto evap1; - if (scm_badformalsp (proc, 1)) - goto umwrongnumargs; - case scm_tcs_closures: - /* clos1: */ - x = SCM_CLOSURE_BODY (proc); + if (!SCM_CLOSUREP (proc)) + goto evap1; + /* fallthrough */ + case scm_tcs_closures: + { + /* clos1: */ + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) + || (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals)))) + goto umwrongnumargs; + x = SCM_CLOSURE_BODY (proc); #ifdef DEVAL - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc)); + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); #else - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_list_1 (arg1), SCM_ENV (proc)); + env = SCM_EXTEND_ENV (formals, + scm_list_1 (arg1), + SCM_ENV (proc)); #endif - goto nontoplevel_begin; - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); + goto nontoplevel_begin; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - arg1 = debug.info->a.args; + arg1 = debug.info->a.args; #else - arg1 = scm_list_1 (arg1); + arg1 = scm_list_1 (arg1); #endif - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) - goto badfun; - else - { - arg2 = arg1; - arg1 = proc; - proc = (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc)); + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + { + arg2 = arg1; + arg1 = proc; + proc = (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc)); #ifdef DEVAL - debug.info->a.args = scm_cons (arg1, debug.info->a.args); - debug.info->a.proc = proc; -#endif - if (SCM_NIMP (proc)) - goto evap2; - else - goto badfun; - } - case scm_tc7_subr_2: - case scm_tc7_subr_0: - case scm_tc7_subr_3: - case scm_tc7_lsubr_2: - goto wrongnumargs; - default: - goto badfun; - } - } -#ifdef SCM_CAUTIOUS - if (SCM_IMP (x)) - goto wrongnumargs; - else if (SCM_CONSP (x)) - { - if (SCM_IMP (SCM_CAR (x))) - arg2 = SCM_EVALIM (SCM_CAR (x), env); - else - arg2 = EVALCELLCAR (x, env); - } - else - goto wrongnumargs; -#else - arg2 = EVALCAR (x, env); + debug.info->a.args = scm_cons (arg1, debug.info->a.args); + debug.info->a.proc = proc; #endif - { /* have two or more arguments */ + goto evap2; + } + else + goto badfun; + case scm_tc7_subr_2: + case scm_tc7_subr_0: + case scm_tc7_subr_3: + case scm_tc7_lsubr_2: + scm_wrong_num_args (proc); + default: + goto badfun; + } + } + if (SCM_CONSP (x)) + arg2 = EVALCAR (x, env); + else + scm_wrong_num_args (proc); + + { /* have two or more arguments */ #ifdef DEVAL - debug.info->a.args = scm_list_2 (arg1, arg2); + debug.info->a.args = scm_list_2 (arg1, arg2); #endif - x = SCM_CDR (x); - if (SCM_NULLP (x)) { - ENTER_APPLY; - evap2: - switch (SCM_TYP7 (proc)) - { /* have two arguments */ - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - RETURN (SCM_SUBRF (proc) (arg1, arg2)); - case scm_tc7_lsubr: + x = SCM_CDR (x); + if (SCM_NULLP (x)) { + ENTER_APPLY; + evap2: + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have two arguments */ + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_lsubr: #ifdef DEVAL - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); #else - RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); + RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2))); #endif - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); - case scm_tc7_rpsubr: - case scm_tc7_asubr: - RETURN (SCM_SUBRF (proc) (arg1, arg2)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); - cclon: - case scm_tc7_cclo: + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL)); + case scm_tc7_rpsubr: + case scm_tc7_asubr: + RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2)); + cclon: + case scm_tc7_cclo: #ifdef DEVAL - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons (proc, debug.info->a.args), - SCM_EOL)); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); #else - RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_eval_args (x, - env, - proc))), - SCM_EOL)); + RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); #endif - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { - x = SCM_ENTITY_PROCEDURE (proc); + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { + x = SCM_ENTITY_PROCEDURE (proc); #ifdef DEVAL - arg1 = debug.info->a.args; + arg1 = debug.info->a.args; #else - arg1 = scm_list_2 (arg1, arg2); + arg1 = scm_list_2 (arg1, arg2); #endif - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) - goto badfun; - else - { - operatorn: + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + { + operatorn: #ifdef DEVAL - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), - scm_cons (proc, debug.info->a.args), - SCM_EOL)); + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons (proc, debug.info->a.args), + SCM_EOL)); #else - RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) - ? SCM_ENTITY_PROCEDURE (proc) - : SCM_OPERATOR_PROCEDURE (proc), - scm_cons2 (proc, arg1, - scm_cons (arg2, - scm_eval_args (x, - env, - proc))), - SCM_EOL)); + RETURN (SCM_APPLY (SCM_I_ENTITYP (proc) + ? SCM_ENTITY_PROCEDURE (proc) + : SCM_OPERATOR_PROCEDURE (proc), + scm_cons2 (proc, arg1, + scm_cons (arg2, + scm_eval_args (x, + env, + proc))), + SCM_EOL)); #endif - } - case scm_tc7_subr_0: - case scm_tc7_cxr: - case scm_tc7_subr_1o: - case scm_tc7_subr_1: - case scm_tc7_subr_3: - goto wrongnumargs; - default: - goto badfun; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); + } + else + goto badfun; + case scm_tc7_subr_0: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_1o: + case scm_tc7_subr_1: + case scm_tc7_subr_3: + scm_wrong_num_args (proc); + default: + goto badfun; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); #ifdef DEVAL - debug.info->a.proc = proc; + debug.info->a.proc = proc; #endif - if (!SCM_CLOSUREP (proc)) - goto evap2; - if (scm_badformalsp (proc, 2)) - goto umwrongnumargs; - case scm_tcs_closures: - /* clos2: */ + if (!SCM_CLOSUREP (proc)) + goto evap2; + /* fallthrough */ + case scm_tcs_closures: + { + /* clos2: */ + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) + || (SCM_CONSP (formals) + && (SCM_NULLP (SCM_CDR (formals)) + || (SCM_CONSP (SCM_CDR (formals)) + && SCM_CONSP (SCM_CDDR (formals)))))) + goto umwrongnumargs; #ifdef DEVAL - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - debug.info->a.args, - SCM_ENV (proc)); + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); #else - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - scm_list_2 (arg1, arg2), SCM_ENV (proc)); -#endif - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; - } - } -#ifdef SCM_CAUTIOUS - if (SCM_IMP (x) || !SCM_CONSP (x)) - goto wrongnumargs; + env = SCM_EXTEND_ENV (formals, + scm_list_2 (arg1, arg2), + SCM_ENV (proc)); #endif + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } + } + } + if (!SCM_CONSP (x)) + scm_wrong_num_args (proc); #ifdef DEVAL - debug.info->a.args = scm_cons2 (arg1, arg2, - deval_args (x, env, proc, SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); + debug.info->a.args = scm_cons2 (arg1, arg2, + deval_args (x, env, proc, + SCM_CDRLOC (SCM_CDR (debug.info->a.args)))); #endif - ENTER_APPLY; - evap3: - switch (SCM_TYP7 (proc)) - { /* have 3 or more arguments */ + ENTER_APPLY; + evap3: + SCM_ASRTGO (!SCM_IMP (proc), badfun); + switch (SCM_TYP7 (proc)) + { /* have 3 or more arguments */ #ifdef DEVAL - case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, arg2, - SCM_CADDR (debug.info->a.args))); - case scm_tc7_asubr: -#ifdef BUILTIN_RPASUBR - arg1 = SCM_SUBRF(proc)(arg1, arg2); - arg2 = SCM_CDDR (debug.info->a.args); - do - { - arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); - arg2 = SCM_CDR (arg2); - } - while (SCM_NIMP (arg2)); - RETURN (arg1); -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_rpsubr: -#ifdef BUILTIN_RPASUBR - if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) - RETURN (SCM_BOOL_F); - arg1 = SCM_CDDR (debug.info->a.args); - do - { - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) - RETURN (SCM_BOOL_F); - arg2 = SCM_CAR (arg1); - arg1 = SCM_CDR (arg1); - } - while (SCM_NIMP (arg1)); - RETURN (SCM_BOOL_T); -#else /* BUILTIN_RPASUBR */ - RETURN (SCM_APPLY (proc, arg1, - scm_acons (arg2, - SCM_CDDR (debug.info->a.args), - SCM_EOL))); -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, - SCM_CDDR (debug.info->a.args))); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (debug.info->a.args)); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - 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_pws: - proc = SCM_PROCEDURE (proc); - debug.info->a.proc = proc; - if (!SCM_CLOSUREP (proc)) - goto evap3; - if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args)) - goto umwrongnumargs; - case scm_tcs_closures: - SCM_SET_ARGSREADY (debug); - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - debug.info->a.args, - SCM_ENV (proc)); - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; + case scm_tc7_subr_3: + if (!SCM_NULLP (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CADDR (debug.info->a.args))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF(proc)(arg1, arg2); + arg2 = SCM_CDDR (debug.info->a.args); + do + { + arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2)); + arg2 = SCM_CDR (arg2); + } + while (SCM_NIMP (arg2)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + arg1 = SCM_CDDR (debug.info->a.args); + do + { + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1)))) + RETURN (SCM_BOOL_F); + arg2 = SCM_CAR (arg1); + arg1 = SCM_CDR (arg1); + } + while (SCM_NIMP (arg1)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, + SCM_CDDR (debug.info->a.args))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (debug.info->a.args)); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + 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_pws: + proc = SCM_PROCEDURE (proc); + debug.info->a.proc = proc; + if (!SCM_CLOSUREP (proc)) + goto evap3; + /* fallthrough */ + case scm_tcs_closures: + { + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) + || (SCM_CONSP (formals) + && (SCM_NULLP (SCM_CDR (formals)) + || (SCM_CONSP (SCM_CDR (formals)) + && scm_badargsp (SCM_CDDR (formals), x))))) + goto umwrongnumargs; + SCM_SET_ARGSREADY (debug); + env = SCM_EXTEND_ENV (formals, + debug.info->a.args, + SCM_ENV (proc)); + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; + } #else /* DEVAL */ - case scm_tc7_subr_3: - SCM_ASRTGO (SCM_NULLP (SCM_CDR (x)), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); - case scm_tc7_asubr: -#ifdef BUILTIN_RPASUBR - arg1 = SCM_SUBRF (proc) (arg1, arg2); - do - { - arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); - x = SCM_CDR(x); - } - while (SCM_NIMP (x)); - RETURN (arg1); -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_rpsubr: -#ifdef BUILTIN_RPASUBR - if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) - RETURN (SCM_BOOL_F); - do + case scm_tc7_subr_3: + if (!SCM_NULLP (SCM_CDR (x))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env))); + case scm_tc7_asubr: + arg1 = SCM_SUBRF (proc) (arg1, arg2); + do + { + arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env)); + x = SCM_CDR(x); + } + while (SCM_NIMP (x)); + RETURN (arg1); + case scm_tc7_rpsubr: + if (SCM_FALSEP (SCM_SUBRF (proc) (arg1, arg2))) + RETURN (SCM_BOOL_F); + do + { + arg1 = EVALCAR (x, env); + if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) + RETURN (SCM_BOOL_F); + arg2 = arg1; + x = SCM_CDR (x); + } + while (SCM_NIMP (x)); + RETURN (SCM_BOOL_T); + case scm_tc7_lsubr_2: + RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); + case scm_tc7_lsubr: + RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, + arg2, + scm_eval_args (x, env, proc)))); + case scm_tc7_smob: + if (!SCM_SMOB_APPLICABLE_P (proc)) + goto badfun; + RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, + scm_eval_args (x, env, proc))); + case scm_tc7_cclo: + goto cclon; + case scm_tc7_pws: + proc = SCM_PROCEDURE (proc); + if (!SCM_CLOSUREP (proc)) + goto evap3; + /* fallthrough */ + case scm_tcs_closures: { - arg1 = EVALCAR (x, env); - if (SCM_FALSEP (SCM_SUBRF (proc) (arg2, arg1))) - RETURN (SCM_BOOL_F); - arg2 = arg1; - x = SCM_CDR (x); + const SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) + || (SCM_CONSP (formals) + && (SCM_NULLP (SCM_CDR (formals)) + || (SCM_CONSP (SCM_CDR (formals)) + && scm_badargsp (SCM_CDDR (formals), x))))) + goto umwrongnumargs; + env = SCM_EXTEND_ENV (formals, + scm_cons2 (arg1, + arg2, + scm_eval_args (x, env, proc)), + SCM_ENV (proc)); + x = SCM_CLOSURE_BODY (proc); + goto nontoplevel_begin; } - while (SCM_NIMP (x)); - RETURN (SCM_BOOL_T); -#else /* BUILTIN_RPASUBR */ - RETURN (SCM_APPLY (proc, arg1, - scm_acons (arg2, - scm_eval_args (x, env, proc), - SCM_EOL))); -#endif /* BUILTIN_RPASUBR */ - case scm_tc7_lsubr_2: - RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc))); - case scm_tc7_lsubr: - RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1, - arg2, - scm_eval_args (x, env, proc)))); - case scm_tc7_smob: - if (!SCM_SMOB_APPLICABLE_P (proc)) - goto badfun; - RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2, - scm_eval_args (x, env, proc))); - case scm_tc7_cclo: - goto cclon; - case scm_tc7_pws: - proc = SCM_PROCEDURE (proc); - if (!SCM_CLOSUREP (proc)) - goto evap3; - { - SCM formals = SCM_CLOSURE_FORMALS (proc); - if (SCM_NULLP (formals) - || (SCM_CONSP (formals) - && (SCM_NULLP (SCM_CDR (formals)) - || (SCM_CONSP (SCM_CDR (formals)) - && scm_badargsp (SCM_CDDR (formals), x))))) - goto umwrongnumargs; - } - case scm_tcs_closures: -#ifdef DEVAL - SCM_SET_ARGSREADY (debug); -#endif - env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), - scm_cons2 (arg1, - arg2, - scm_eval_args (x, env, proc)), - SCM_ENV (proc)); - x = SCM_CLOSURE_BODY (proc); - goto nontoplevel_begin; #endif /* DEVAL */ - case scm_tcs_struct: - if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) - { + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + { #ifdef DEVAL - arg1 = debug.info->a.args; + arg1 = debug.info->a.args; #else - arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); + arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc)); #endif - x = SCM_ENTITY_PROCEDURE (proc); - goto type_dispatch; - } - else if (!SCM_I_OPERATORP (proc)) + x = SCM_ENTITY_PROCEDURE (proc); + goto type_dispatch; + } + else if (SCM_I_OPERATORP (proc)) + goto operatorn; + else + goto badfun; + case scm_tc7_subr_2: + case scm_tc7_subr_1o: + case scm_tc7_subr_2o: + case scm_tc7_subr_0: + case scm_tc7_dsubr: + case scm_tc7_cxr: + case scm_tc7_subr_1: + scm_wrong_num_args (proc); + default: goto badfun; - else - goto operatorn; - case scm_tc7_subr_2: - case scm_tc7_subr_1o: - case scm_tc7_subr_2o: - case scm_tc7_subr_0: - case scm_tc7_cxr: - case scm_tc7_subr_1: - goto wrongnumargs; - default: - goto badfun; - } + } + } } #ifdef DEVAL exit: - if (CHECK_EXIT && SCM_TRAPS_P) + if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); @@ -3358,7 +4238,7 @@ exit: { int first; SCM val = scm_make_continuation (&first); - + if (first) arg1 = val; else @@ -3384,6 +4264,7 @@ ret: #ifndef DEVAL + /* Simple procedure calls */ @@ -3477,7 +4358,7 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0, #define FUNC_NAME s_scm_nconc2last { SCM *lloc; - SCM_VALIDATE_NONEMPTYLIST (1,lst); + SCM_VALIDATE_NONEMPTYLIST (1, lst); lloc = &lst; while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be SCM_NULL_OR_NIL_P, but not @@ -3507,7 +4388,7 @@ scm_apply (SCM proc, SCM arg1, SCM args) #if 0 SCM scm_dapply (SCM proc, SCM arg1, SCM args) -{ /* empty */ } +{} #endif @@ -3524,7 +4405,6 @@ scm_dapply (SCM proc, SCM arg1, SCM args) SCM SCM_APPLY (SCM proc, SCM arg1, SCM args) { -#ifdef DEBUG_EXTENSIONS #ifdef DEVAL scm_t_debug_frame debug; scm_t_debug_info debug_vect_body; @@ -3537,7 +4417,6 @@ SCM_APPLY (SCM proc, SCM arg1, SCM args) #else if (SCM_DEBUGGINGP) return scm_dapply (proc, arg1, args); -#endif #endif SCM_ASRTGO (SCM_NIMP (proc), badproc); @@ -3607,54 +4486,59 @@ tail: args = SCM_NULLP (args) ? SCM_UNDEFINED : SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_2: - SCM_ASRTGO (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)), - wrongnumargs); + if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args))) + scm_wrong_num_args (proc); args = SCM_CAR (args); RETURN (SCM_SUBRF (proc) (arg1, args)); case scm_tc7_subr_0: - SCM_ASRTGO (SCM_UNBNDP (arg1), wrongnumargs); - RETURN (SCM_SUBRF (proc) ()); + if (!SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) ()); case scm_tc7_subr_1: - SCM_ASRTGO (!SCM_UNBNDP (arg1), wrongnumargs); + if (SCM_UNBNDP (arg1)) + scm_wrong_num_args (proc); case scm_tc7_subr_1o: - SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1)); + if (!SCM_NULLP (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1)); + case scm_tc7_dsubr: + if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) + scm_wrong_num_args (proc); + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } + else if (SCM_BIGP (arg1)) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); case scm_tc7_cxr: - SCM_ASRTGO (!SCM_UNBNDP (arg1) && SCM_NULLP (args), wrongnumargs); - if (SCM_SUBRF (proc)) - { - if (SCM_INUMP (arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); - } - else if (SCM_REALP (arg1)) - { - RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); - } -#ifdef SCM_BIGDIG - else if (SCM_BIGP (arg1)) - RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); -#endif - SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, - SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); - } - proc = SCM_SNAME (proc); + if (SCM_UNBNDP (arg1) || !SCM_NULLP (args)) + scm_wrong_num_args (proc); { - char *chrs = SCM_SYMBOL_CHARS (proc) + SCM_SYMBOL_LENGTH (proc) - 1; - while ('c' != *--chrs) - { - SCM_ASSERT (SCM_CONSP (arg1), - arg1, SCM_ARG1, SCM_SYMBOL_CHARS (proc)); - arg1 = ('a' == *chrs) ? SCM_CAR (arg1) : SCM_CDR (arg1); - } - RETURN (arg1); + unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); + do + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, + SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); + pattern >>= 2; + } while (pattern); + RETURN (arg1); } case scm_tc7_subr_3: - SCM_ASRTGO (!SCM_NULLP (args) - && !SCM_NULLP (SCM_CDR (args)) - && SCM_NULLP (SCM_CDDR (args)), - wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); + if (SCM_NULLP (args) + || SCM_NULLP (SCM_CDR (args)) + || !SCM_NULLP (SCM_CDDR (args))) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args))); case scm_tc7_lsubr: #ifdef DEVAL RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args)); @@ -3662,8 +4546,10 @@ tail: RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args))); #endif case scm_tc7_lsubr_2: - SCM_ASRTGO (SCM_CONSP (args), wrongnumargs); - RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); + if (!SCM_CONSP (args)) + scm_wrong_num_args (proc); + else + RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args))); case scm_tc7_asubr: if (SCM_NULLP (args)) RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); @@ -3692,10 +4578,8 @@ tail: #else arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)); #endif -#ifndef SCM_RECKLESS if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)) - goto wrongnumargs; -#endif + scm_wrong_num_args (proc); /* Copy argument list */ if (SCM_IMP (arg1)) @@ -3703,26 +4587,31 @@ tail: else { SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED); - while (arg1 = SCM_CDR (arg1), SCM_CONSP (arg1)) + for (arg1 = SCM_CDR (arg1); SCM_CONSP (arg1); arg1 = SCM_CDR (arg1)) { - SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), - SCM_UNSPECIFIED)); + SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED)); tl = SCM_CDR (tl); } SCM_SETCDR (tl, arg1); } - args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc)); + args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + args, + SCM_ENV (proc)); proc = SCM_CLOSURE_BODY (proc); again: - arg1 = proc; - while (!SCM_NULLP (arg1 = SCM_CDR (arg1))) + arg1 = SCM_CDR (proc); + while (!SCM_NULLP (arg1)) { if (SCM_IMP (SCM_CAR (proc))) { if (SCM_ISYMP (SCM_CAR (proc))) { - proc = scm_m_expand_body (proc, args); + scm_rec_mutex_lock (&source_mutex); + /* check for race condition */ + if (SCM_ISYMP (SCM_CAR (proc))) + proc = m_expand_body (proc, args); + scm_rec_mutex_unlock (&source_mutex); goto again; } else @@ -3731,6 +4620,7 @@ tail: else SCM_CEVAL (SCM_CAR (proc), args); proc = arg1; + arg1 = SCM_CDR (proc); } RETURN (EVALCAR (proc, args)); case scm_tc7_smob: @@ -3773,10 +4663,9 @@ tail: #endif RETURN (scm_apply_generic (proc, args)); } - else if (!SCM_I_OPERATORP (proc)) - goto badproc; - else + else if (SCM_I_OPERATORP (proc)) { + /* operator */ #ifdef DEVAL args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args); #else @@ -3795,16 +4684,15 @@ tail: else goto badproc; } - wrongnumargs: - scm_wrong_num_args (proc); + else + goto badproc; default: badproc: scm_wrong_type_arg ("apply", SCM_ARG1, proc); - RETURN (arg1); } #ifdef DEVAL exit: - if (CHECK_EXIT && SCM_TRAPS_P) + if (scm_check_exit_p && SCM_TRAPS_P) if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug))) { SCM_CLEAR_TRACED_FRAME (debug); @@ -3839,6 +4727,332 @@ ret: #ifndef DEVAL +/* Trampolines + * + * Trampolines make it possible to move procedure application dispatch + * outside inner loops. The motivation was clean implementation of + * efficient replacements of R5RS primitives in SRFI-1. + * + * The semantics is clear: scm_trampoline_N returns an optimized + * version of scm_call_N (or NULL if the procedure isn't applicable + * on N args). + * + * Applying the optimization to map and for-each increased efficiency + * noticeably. For example, (map abs ls) is now 8 times faster than + * before. + */ + +static SCM +call_subr0_0 (SCM proc) +{ + return SCM_SUBRF (proc) (); +} + +static SCM +call_subr1o_0 (SCM proc) +{ + return SCM_SUBRF (proc) (SCM_UNDEFINED); +} + +static SCM +call_lsubr_0 (SCM proc) +{ + return SCM_SUBRF (proc) (SCM_EOL); +} + +SCM +scm_i_call_closure_0 (SCM proc) +{ + const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + SCM_EOL, + SCM_ENV (proc)); + const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env); + return result; +} + +scm_t_trampoline_0 +scm_trampoline_0 (SCM proc) +{ + scm_t_trampoline_0 trampoline; + + if (SCM_IMP (proc)) + return NULL; + + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_0: + trampoline = call_subr0_0; + break; + case scm_tc7_subr_1o: + trampoline = call_subr1o_0; + break; + case scm_tc7_lsubr: + trampoline = call_lsubr_0; + break; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (SCM_NULLP (formals) || !SCM_CONSP (formals)) + trampoline = scm_i_call_closure_0; + else + return NULL; + break; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + trampoline = scm_call_generic_0; + else if (SCM_I_OPERATORP (proc)) + trampoline = scm_call_0; + else + return NULL; + break; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0; + else + return NULL; + break; + case scm_tc7_asubr: + case scm_tc7_rpsubr: + case scm_tc7_cclo: + case scm_tc7_pws: + trampoline = scm_call_0; + break; + default: + return NULL; /* not applicable on zero arguments */ + } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_0. */ + if (SCM_DEBUGGINGP) + return scm_call_0; + else + return trampoline; +} + +static SCM +call_subr1_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (arg1); +} + +static SCM +call_subr2o_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED); +} + +static SCM +call_lsubr_1 (SCM proc, SCM arg1) +{ + return SCM_SUBRF (proc) (scm_list_1 (arg1)); +} + +static SCM +call_dsubr_1 (SCM proc, SCM arg1) +{ + if (SCM_INUMP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); + } + else if (SCM_REALP (arg1)) + { + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)))); + } + else if (SCM_BIGP (arg1)) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)))); + SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, + SCM_ARG1, SCM_SYMBOL_CHARS (SCM_SNAME (proc))); +} + +static SCM +call_cxr_1 (SCM proc, SCM arg1) +{ + unsigned char pattern = (scm_t_bits) SCM_SUBRF (proc); + do + { + SCM_ASSERT (SCM_CONSP (arg1), arg1, SCM_ARG1, + SCM_SYMBOL_CHARS (SCM_SNAME (proc))); + arg1 = (pattern & 1) ? SCM_CAR (arg1) : SCM_CDR (arg1); + pattern >>= 2; + } while (pattern); + return arg1; +} + +static SCM +call_closure_1 (SCM proc, SCM arg1) +{ + const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_1 (arg1), + SCM_ENV (proc)); + const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env); + return result; +} + +scm_t_trampoline_1 +scm_trampoline_1 (SCM proc) +{ + scm_t_trampoline_1 trampoline; + + if (SCM_IMP (proc)) + return NULL; + + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_1: + case scm_tc7_subr_1o: + trampoline = call_subr1_1; + break; + case scm_tc7_subr_2o: + trampoline = call_subr2o_1; + break; + case scm_tc7_lsubr: + trampoline = call_lsubr_1; + break; + case scm_tc7_dsubr: + trampoline = call_dsubr_1; + break; + case scm_tc7_cxr: + trampoline = call_cxr_1; + break; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_NULLP (formals) + && (!SCM_CONSP (formals) || !SCM_CONSP (SCM_CDR (formals)))) + trampoline = call_closure_1; + else + return NULL; + break; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + trampoline = scm_call_generic_1; + else if (SCM_I_OPERATORP (proc)) + trampoline = scm_call_1; + else + return NULL; + break; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1; + else + return NULL; + break; + case scm_tc7_asubr: + case scm_tc7_rpsubr: + case scm_tc7_cclo: + case scm_tc7_pws: + trampoline = scm_call_1; + break; + default: + return NULL; /* not applicable on one arg */ + } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_1. */ + if (SCM_DEBUGGINGP) + return scm_call_1; + else + return trampoline; +} + +static SCM +call_subr2_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (arg1, arg2); +} + +static SCM +call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL); +} + +static SCM +call_lsubr_2 (SCM proc, SCM arg1, SCM arg2) +{ + return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)); +} + +static SCM +call_closure_2 (SCM proc, SCM arg1, SCM arg2) +{ + const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), + scm_list_2 (arg1, arg2), + SCM_ENV (proc)); + const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env); + return result; +} + +scm_t_trampoline_2 +scm_trampoline_2 (SCM proc) +{ + scm_t_trampoline_2 trampoline; + + if (SCM_IMP (proc)) + return NULL; + + switch (SCM_TYP7 (proc)) + { + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + case scm_tc7_rpsubr: + case scm_tc7_asubr: + trampoline = call_subr2_2; + break; + case scm_tc7_lsubr_2: + trampoline = call_lsubr2_2; + break; + case scm_tc7_lsubr: + trampoline = call_lsubr_2; + break; + case scm_tcs_closures: + { + SCM formals = SCM_CLOSURE_FORMALS (proc); + if (!SCM_NULLP (formals) + && (!SCM_CONSP (formals) + || (!SCM_NULLP (SCM_CDR (formals)) + && (!SCM_CONSP (SCM_CDR (formals)) + || !SCM_CONSP (SCM_CDDR (formals)))))) + trampoline = call_closure_2; + else + return NULL; + break; + } + case scm_tcs_struct: + if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC) + trampoline = scm_call_generic_2; + else if (SCM_I_OPERATORP (proc)) + trampoline = scm_call_2; + else + return NULL; + break; + case scm_tc7_smob: + if (SCM_SMOB_APPLICABLE_P (proc)) + trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2; + else + return NULL; + break; + case scm_tc7_cclo: + case scm_tc7_pws: + trampoline = scm_call_2; + break; + default: + return NULL; /* not applicable on two args */ + } + /* We only reach this point if a valid trampoline was determined. */ + + /* If debugging is enabled, we want to see all calls to proc on the stack. + * Thus, we replace the trampoline shortcut with scm_call_2. */ + if (SCM_DEBUGGINGP) + return scm_call_2; + else + return trampoline; +} + /* Typechecking for multi-argument MAP and FOR-EACH. Verify that each element of the vector ARGV, except for the first, @@ -3852,7 +5066,7 @@ check_map_args (SCM argv, SCM args, const char *who) { - SCM *ve = SCM_VELTS (argv); + SCM const *ve = SCM_VELTS (argv); long i; for (i = SCM_VECTOR_LENGTH (argv) - 1; i >= 1; i--) @@ -3868,7 +5082,7 @@ check_map_args (SCM argv, } if (elt_len != len) - scm_out_of_range (who, ve[i]); + scm_out_of_range_pos (who, ve[i], SCM_MAKINUM (i + 2)); } scm_remember_upto_here_1 (argv); @@ -3891,7 +5105,7 @@ scm_map (SCM proc, SCM arg1, SCM args) long i, len; SCM res = SCM_EOL; SCM *pres = &res; - SCM *ve = &args; /* Keep args from being optimized away. */ + SCM const *ve = &args; /* Keep args from being optimized away. */ len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, @@ -3899,19 +5113,40 @@ scm_map (SCM proc, SCM arg1, SCM args) SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map); + while (SCM_NIMP (arg1)) + { + *pres = scm_list_1 (call (proc, SCM_CAR (arg1))); + pres = SCM_CDRLOC (*pres); + arg1 = SCM_CDR (arg1); + } + return res; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map); + SCM_GASSERTn (len2 >= 0, + g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); while (SCM_NIMP (arg1)) { - *pres = scm_list_1 (scm_apply (proc, SCM_CAR (arg1), scm_listofnull)); + *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2))); pres = SCM_CDRLOC (*pres); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return res; } - args = scm_vector (arg1 = scm_cons (arg1, args)); + arg1 = scm_cons (arg1, args); + args = scm_vector (arg1); ve = SCM_VELTS (args); -#ifndef SCM_RECKLESS check_map_args (args, len, g_map, proc, arg1, s_map); -#endif while (1) { arg1 = SCM_EOL; @@ -3920,7 +5155,7 @@ scm_map (SCM proc, SCM arg1, SCM args) if (SCM_IMP (ve[i])) return res; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - ve[i] = SCM_CDR (ve[i]); + SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); } *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL)); pres = SCM_CDRLOC (*pres); @@ -3935,7 +5170,7 @@ SCM scm_for_each (SCM proc, SCM arg1, SCM args) #define FUNC_NAME s_for_each { - SCM *ve = &args; /* Keep args from being optimized away. */ + SCM const *ve = &args; /* Keep args from being optimized away. */ long i, len; len = scm_ilength (arg1); SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args), @@ -3943,18 +5178,38 @@ scm_for_each (SCM proc, SCM arg1, SCM args) SCM_VALIDATE_REST_ARGUMENT (args); if (SCM_NULLP (args)) { + scm_t_trampoline_1 call = scm_trampoline_1 (proc); + SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each); + while (SCM_NIMP (arg1)) + { + call (proc, SCM_CAR (arg1)); + arg1 = SCM_CDR (arg1); + } + return SCM_UNSPECIFIED; + } + if (SCM_NULLP (SCM_CDR (args))) + { + SCM arg2 = SCM_CAR (args); + int len2 = scm_ilength (arg2); + scm_t_trampoline_2 call = scm_trampoline_2 (proc); + SCM_GASSERTn (call, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each); + SCM_GASSERTn (len2 >= 0, g_for_each, + scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each); + if (len2 != len) + SCM_OUT_OF_RANGE (3, arg2); while (SCM_NIMP (arg1)) { - scm_apply (proc, SCM_CAR (arg1), scm_listofnull); + call (proc, SCM_CAR (arg1), SCM_CAR (arg2)); arg1 = SCM_CDR (arg1); + arg2 = SCM_CDR (arg2); } return SCM_UNSPECIFIED; } - args = scm_vector (arg1 = scm_cons (arg1, args)); + arg1 = scm_cons (arg1, args); + args = scm_vector (arg1); ve = SCM_VELTS (args); -#ifndef SCM_RECKLESS check_map_args (args, len, g_for_each, proc, arg1, s_for_each); -#endif while (1) { arg1 = SCM_EOL; @@ -3963,7 +5218,7 @@ scm_for_each (SCM proc, SCM arg1, SCM args) if (SCM_IMP (ve[i])) return SCM_UNSPECIFIED; arg1 = scm_cons (SCM_CAR (ve[i]), arg1); - ve[i] = SCM_CDR (ve[i]); + SCM_VECTOR_SET (args, i, SCM_CDR (ve[i])); } scm_apply (proc, arg1, SCM_EOL); } @@ -3987,10 +5242,17 @@ scm_t_bits scm_tc16_promise; SCM scm_makprom (SCM code) { - SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code)); + SCM_RETURN_NEWSMOB2 (scm_tc16_promise, + SCM_UNPACK (code), + scm_make_rec_mutex ()); } - +static size_t +promise_free (SCM promise) +{ + scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise)); + return 0; +} static int promise_print (SCM exp, SCM port, scm_print_state *pstate) @@ -3998,33 +5260,32 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; } - SCM_DEFINE (scm_force, "force", 1, 0, 0, - (SCM x), + (SCM promise), "If the promise @var{x} has not been computed yet, compute and\n" "return @var{x}, otherwise just return the previously computed\n" "value.") #define FUNC_NAME s_scm_force { - SCM_VALIDATE_SMOB (1, x, promise); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM_VALIDATE_SMOB (1, promise, promise); + scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x)); - if (!((1L << 16) & SCM_CELL_WORD_0 (x))) + SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise)); + if (!SCM_PROMISE_COMPUTED_P (promise)) { - SCM_DEFER_INTS; - SCM_SET_CELL_OBJECT_1 (x, ans); - SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16)); - SCM_ALLOW_INTS; + SCM_SET_PROMISE_DATA (promise, ans); + SCM_SET_PROMISE_COMPUTED (promise); } } - return SCM_CELL_OBJECT_1 (x); + scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise)); + return SCM_PROMISE_DATA (promise); } #undef FUNC_NAME @@ -4075,7 +5336,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, unsigned long i = SCM_VECTOR_LENGTH (obj); ans = scm_c_make_vector (i, SCM_UNSPECIFIED); while (i--) - SCM_VELTS (ans)[i] = scm_copy_tree (SCM_VELTS (obj)[i]); + SCM_VECTOR_SET (ans, i, scm_copy_tree (SCM_VELTS (obj)[i])); return ans; } if (!SCM_CONSP (obj)) @@ -4083,7 +5344,7 @@ SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0, ans = tl = scm_cons_source (obj, scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED); - while (obj = SCM_CDR (obj), SCM_CONSP (obj)) + for (obj = SCM_CDR (obj); SCM_CONSP (obj); obj = SCM_CDR (obj)) { SCM_SETCDR (tl, scm_cons (scm_copy_tree (SCM_CAR (obj)), SCM_UNSPECIFIED)); @@ -4242,11 +5503,8 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0, /* At this point, scm_deval and scm_dapply are generated. */ -#ifdef DEBUG_EXTENSIONS -# define DEVAL -# include "eval.c" -#endif - +#define DEVAL +#include "eval.c" void @@ -4261,20 +5519,20 @@ scm_init_eval () scm_tc16_promise = scm_make_smob_type ("promise", 0); scm_set_smob_mark (scm_tc16_promise, scm_markcdr); + scm_set_smob_free (scm_tc16_promise, promise_free); scm_set_smob_print (scm_tc16_promise, promise_print); - /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */ - scm_undefineds = scm_list_1 (SCM_UNDEFINED); - SCM_SETCDR (scm_undefineds, scm_undefineds); - scm_listofnull = scm_list_1 (SCM_EOL); + undefineds = scm_list_1 (SCM_UNDEFINED); + SCM_SETCDR (undefineds, undefineds); + scm_permanent_object (undefineds); - scm_f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply); + scm_listofnull = scm_list_1 (SCM_EOL); - /* acros */ - /* end of acros */ + f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply); + scm_permanent_object (f_apply); #include "libguile/eval.x" - + scm_add_feature ("delay"); }