From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: ludo@chbouib.org (Ludovic =?iso-8859-1?Q?Court=E8s?=) Newsgroups: gmane.lisp.guile.devel Subject: Re: Evaluator cleanup Date: Sun, 25 Feb 2007 09:57:24 +0100 Message-ID: <87vehqmx6z.fsf@chbouib.org> References: <87irdrplpq.fsf@chbouib.org> <87y7mnchmy.fsf@ossau.uklinux.net> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: sea.gmane.org 1172393888 9515 80.91.229.12 (25 Feb 2007 08:58:08 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Sun, 25 Feb 2007 08:58:08 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Feb 25 09:58:01 2007 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1HLFCe-0004Oj-Ah for guile-devel@m.gmane.org; Sun, 25 Feb 2007 09:57:59 +0100 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1HLFCd-0003vs-3S for guile-devel@m.gmane.org; Sun, 25 Feb 2007 03:57:55 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1HLFCY-0003vn-Ie for guile-devel@gnu.org; Sun, 25 Feb 2007 03:57:50 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1HLFCU-0003vS-Uh for guile-devel@gnu.org; Sun, 25 Feb 2007 03:57:49 -0500 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1HLFCU-0003vP-RF for guile-devel@gnu.org; Sun, 25 Feb 2007 03:57:46 -0500 Original-Received: from main.gmane.org ([80.91.229.2] helo=ciao.gmane.org) by monty-python.gnu.org with esmtps (TLS-1.0:RSA_AES_256_CBC_SHA:32) (Exim 4.52) id 1HLFCT-0006jK-Et for guile-devel@gnu.org; Sun, 25 Feb 2007 03:57:46 -0500 Original-Received: from list by ciao.gmane.org with local (Exim 4.43) id 1HLFCQ-0000nN-86 for guile-devel@gnu.org; Sun, 25 Feb 2007 09:57:42 +0100 Original-Received: from adh419.fdn.fr ([80.67.176.9]) by main.gmane.org with esmtp (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sun, 25 Feb 2007 09:57:42 +0100 Original-Received: from ludo by adh419.fdn.fr with local (Gmexim 0.1 (Debian)) id 1AlnuQ-0007hv-00 for ; Sun, 25 Feb 2007 09:57:42 +0100 X-Injected-Via-Gmane: http://gmane.org/ Original-Lines: 2055 Original-X-Complaints-To: usenet@sea.gmane.org X-Gmane-NNTP-Posting-Host: adh419.fdn.fr X-URL: http://www.laas.fr/~lcourtes/ X-Revolutionary-Date: 7 =?iso-8859-1?Q?Vent=F4se?= an 215 de la =?iso-8859-1?Q?R=E9volution?= X-PGP-Key-ID: 0xEB1F5364 X-PGP-Key: http://www.laas.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 821D 815D 902A 7EAB 5CEE D120 7FBA 3D4F EB1F 5364 X-OS: i486-pc-linux-gnu User-Agent: Gnus/5.110006 (No Gnus v0.6) Emacs/21.4 (gnu/linux) Cancel-Lock: sha1:1LDyh9/236k/TbWS8++qtoFOuMU= X-detected-kernel: Linux 2.6, seldom 2.4 (older, 4) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:6555 Archived-At: --=-=-= Hi, Neil Jerram writes: > Can you say more about how your change despaghettifies the code? I > can see that it makes eval.c shorter - but what else? That's it. :-) It make `eval.c' clearer IMO ("only" 2000 lines!) by logically separating the various pieces: the `SCM_SYNTAX' declarations (that remain in `eval.c'), the memoizers and unmemoizers. I've attached the patch against `eval.c' for reference. >> It adds two files, `eval-memoize.i.c' and >> `eval-unmemoize.i.c', > > Do these need to be .i.c - i.e. implying that they need to be > #included? Can't they be normal .c files? No, because some of them are `static' (all the `unmemoize_' functions for instance) and should remain so, and some could be subject to inlining. > I assume the memoizer and the unmemoizer for a particular kind of > expression need to be consistent with each other - is that right? Right. > If so, it seems to me that putting them in separate files might > increase the likelihood of future mistakes. Not sure about this. The alternative would be to keep both in a single file, but that would lead to a long file with mixed memoizing/unmemoizing logic, and with a load of helper functions for both. Would that be preferable? Thanks, Ludovic. --=-=-= Content-Type: text/x-patch Content-Disposition: inline; filename*=us-ascii''%2c%2cdiff Content-Description: The patch --- orig/libguile/Makefile.am +++ mod/libguile/Makefile.am @@ -228,7 +228,8 @@ cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top libgettext.h + scmconfig.h.top libgettext.h \ + eval.i.c eval-memoize.i.c eval-unmemoize.i.c # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi --- orig/libguile/eval.c +++ mod/libguile/eval.c @@ -1,6 +1,6 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006 - * Free Software Foundation, Inc. - * +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, + * 2006,2007 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either @@ -88,7 +88,6 @@ static SCM unmemoize_exprs (SCM expr, SCM env); -static SCM canonicalize_define (SCM expr); static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check); static SCM unmemoize_builtin_macro (SCM expr, SCM env); static void ceval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol); @@ -535,115 +534,6 @@ SCM_SYMBOL (sym_three_question_marks, "???"); -static SCM -unmemoize_expression (const SCM expr, const SCM env) -{ - if (SCM_ILOCP (expr)) - { - SCM frame_idx; - unsigned long int frame_nr; - SCM symbol_idx; - unsigned long int symbol_nr; - - for (frame_idx = env, frame_nr = SCM_IFRAME (expr); - frame_nr != 0; - frame_idx = SCM_CDR (frame_idx), --frame_nr) - ; - for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr); - symbol_nr != 0; - symbol_idx = SCM_CDR (symbol_idx), --symbol_nr) - ; - return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx); - } - else if (SCM_VARIABLEP (expr)) - { - const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr); - return scm_is_true (sym) ? sym : sym_three_question_marks; - } - else if (scm_is_simple_vector (expr)) - { - return scm_list_2 (scm_sym_quote, expr); - } - else if (!scm_is_pair (expr)) - { - return expr; - } - else if (SCM_ISYMP (SCM_CAR (expr))) - { - return unmemoize_builtin_macro (expr, env); - } - else - { - return unmemoize_exprs (expr, env); - } -} - - -static SCM -unmemoize_exprs (const SCM exprs, const SCM env) -{ - SCM r_result = SCM_EOL; - SCM expr_idx = exprs; - SCM um_expr; - - /* Note that due to the current lazy memoizer we may find partially memoized - * code during execution. In such code we have to expect improper lists of - * expressions: On the one hand, for such code syntax checks have not yet - * fully been performed, on the other hand, there may be even legal code - * like '(a . b) appear as an improper list of expressions as long as the - * quote expression is still in its unmemoized form. For this reason, the - * following code handles improper lists of expressions until memoization - * and execution have been completely separated. */ - for (; scm_is_pair (expr_idx); expr_idx = SCM_CDR (expr_idx)) - { - const SCM expr = SCM_CAR (expr_idx); - - /* In partially memoized code, lists of expressions that stem from a - * body form may start with an ISYM if the body itself has not yet been - * memoized. This isym is just an internal marker to indicate that the - * body still needs to be memoized. An isym may occur at the very - * beginning of the body or after one or more comment strings. It is - * dropped during unmemoization. */ - if (!SCM_ISYMP (expr)) - { - um_expr = unmemoize_expression (expr, env); - r_result = scm_cons (um_expr, r_result); - } - } - um_expr = unmemoize_expression (expr_idx, env); - if (!scm_is_null (r_result)) - { - const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED); - SCM_SETCDR (r_result, um_expr); - return result; - } - else - { - return um_expr; - } -} - - -/* 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. - * - * 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); -} - - /* 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. The list of @@ -720,127 +610,6 @@ return 0; } -static void -m_expand_body (const SCM forms, const SCM env) -{ - /* 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_is_null (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_is_null (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_is_pair (sequence), s_missing_body_expression, cdr_forms); - - if (!scm_is_null (definitions)) - { - SCM definition_idx; - SCM letrec_tail; - SCM letrec_expression; - SCM new_letrec_expression; - - SCM bindings = SCM_EOL; - for (definition_idx = definitions; - !scm_is_null (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); - SCM_SETCAR (forms, new_letrec_expression); - SCM_SETCDR (forms, SCM_EOL); - } - else - { - SCM_SETCAR (forms, SCM_CAR (sequence)); - SCM_SETCDR (forms, SCM_CDR (sequence)); - } -} static SCM macroexp (SCM x, SCM env) @@ -896,1652 +665,131 @@ goto macro_tail; } -/* Start of the memoizers for the standard R5RS builtin macros. */ - + +/* Standard R5RS built-in macros. */ SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and); SCM_GLOBAL_SYMBOL (scm_sym_and, s_and); -SCM -scm_m_and (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: (and) is replaced by #t. */ - return SCM_BOOL_T; - } - else - { - SCM_SETCAR (expr, SCM_IM_AND); - return expr; - } -} - -static SCM -unmemoize_and (const SCM expr, const SCM env) -{ - return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env)); -} - - SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin); SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin); -SCM -scm_m_begin (SCM expr, SCM env SCM_UNUSED) -{ - 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; -} - -static SCM -unmemoize_begin (const SCM expr, const SCM env) -{ - return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env)); -} - - 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 expr, SCM env) -{ - SCM clauses; - 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_is_null (clauses)) - { - 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_is_pair (labels)) - { - ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0, - s_bad_case_labels, labels, expr); - all_labels = scm_append (scm_list_2 (labels, all_labels)); - } - else if (scm_is_null (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_is_eq (labels, scm_sym_else) && else_literal_p, - s_bad_case_labels, labels, expr); - ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)), - s_misplaced_else_clause, clause, expr); - } - - /* build the new clause */ - if (scm_is_eq (labels, scm_sym_else)) - SCM_SETCAR (clause, SCM_IM_ELSE); - - clauses = SCM_CDR (clauses); - } - - /* Check whether all case labels are distinct. */ - for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels)) - { - const SCM label = SCM_CAR (all_labels); - ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))), - s_duplicate_case_label, label, expr); - } - - SCM_SETCAR (expr, SCM_IM_CASE); - return expr; -} - -static SCM -unmemoize_case (const SCM expr, const SCM env) -{ - const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env); - SCM um_clauses = SCM_EOL; - SCM clause_idx; - - for (clause_idx = SCM_CDDR (expr); - !scm_is_null (clause_idx); - clause_idx = SCM_CDR (clause_idx)) - { - const SCM clause = SCM_CAR (clause_idx); - const SCM labels = SCM_CAR (clause); - const SCM exprs = SCM_CDR (clause); - - const SCM um_exprs = unmemoize_exprs (exprs, env); - const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE)) - ? scm_sym_else - : scm_i_finite_list_copy (labels); - const SCM um_clause = scm_cons (um_labels, um_exprs); +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, "=>"); - um_clauses = scm_cons (um_clause, um_clauses); - } - um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED); +SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define); +SCM_GLOBAL_SYMBOL (scm_sym_define, s_define); - return scm_cons2 (scm_sym_case, um_key_expr, um_clauses); -} +SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); +SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); +SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); -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_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if); +SCM_GLOBAL_SYMBOL (scm_sym_if, s_if); -SCM -scm_m_cond (SCM expr, SCM env) -{ - /* 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); +SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda); +SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); - const SCM clauses = SCM_CDR (expr); - SCM clause_idx; +SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let); +SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); - ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr); - ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr); +SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); +SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); - for (clause_idx = clauses; - !scm_is_null (clause_idx); - clause_idx = SCM_CDR (clause_idx)) - { - SCM test; +SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar); +SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); - const SCM clause = SCM_CAR (clause_idx); - const long length = scm_ilength (clause); - ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr); +SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or); +SCM_GLOBAL_SYMBOL (scm_sym_or, s_or); - test = SCM_CAR (clause); - if (scm_is_eq (test, scm_sym_else) && else_literal_p) - { - const int last_clause_p = scm_is_null (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 (length >= 2 - && scm_is_eq (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); - } - /* SRFI 61 extended cond */ - else if (length >= 3 - && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow) - && arrow_literal_p) - { - ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr); - ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr); - SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW); - } - } +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"); - SCM_SETCAR (expr, SCM_IM_COND); - return expr; -} +SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote); +SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); -static SCM -unmemoize_cond (const SCM expr, const SCM env) -{ - SCM um_clauses = SCM_EOL; - SCM clause_idx; - for (clause_idx = SCM_CDR (expr); - !scm_is_null (clause_idx); - clause_idx = SCM_CDR (clause_idx)) - { - const SCM clause = SCM_CAR (clause_idx); - const SCM sequence = SCM_CDR (clause); - const SCM test = SCM_CAR (clause); - SCM um_test; - SCM um_sequence; - SCM um_clause; +/* 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); - if (scm_is_eq (test, SCM_IM_ELSE)) - um_test = scm_sym_else; - else - um_test = unmemoize_expression (test, env); + +/* Non-R5RS built-in macros. */ - if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence), - SCM_IM_ARROW)) - { - const SCM target = SCM_CADR (sequence); - const SCM um_target = unmemoize_expression (target, env); - um_sequence = scm_list_2 (scm_sym_arrow, um_target); - } - else - { - um_sequence = unmemoize_exprs (sequence, env); - } +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); - um_clause = scm_cons (um_test, um_sequence); - um_clauses = scm_cons (um_clause, um_clauses); - } - um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED); +SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind); - return scm_cons (scm_sym_cond, um_clauses); -} +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_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_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define); -SCM_GLOBAL_SYMBOL (scm_sym_define, s_define); +#if 0 -/* 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) )))) +/* See futures.h for a comment why futures are not enabled. */ -/* 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_is_pair (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); +SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future); +SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); - body = scm_list_1 (lambda); - variable = SCM_CAR (variable); - } - ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); - ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); +#endif - SCM_SETCAR (cdr_expr, variable); - SCM_SETCDR (cdr_expr, body); - return expr; -} +SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x); +SCM_SYMBOL (scm_sym_setter, "setter"); -/* According to section 5.2.1 of R5RS we first have to make sure that the - * variable is bound, and then perform the (set! variable expression) - * operation. This means, that within the expression we may already assign - * values to variable: (define foo (begin (set! foo 1) (+ foo 1))) */ -SCM -scm_m_define (SCM expr, SCM env) -{ - ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr); - { - const SCM canonical_definition = canonicalize_define (expr); - const SCM cdr_canonical_definition = SCM_CDR (canonical_definition); - const SCM variable = SCM_CAR (cdr_canonical_definition); - const SCM location - = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T); - const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env); +/* @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_SYMBOL (sym_atslot_ref, "@slot-ref"); - if (SCM_REC_PROCNAMES_P) - { - SCM tmp = value; - while (SCM_MACROP (tmp)) - tmp = SCM_MACRO_CODE (tmp); - if (scm_is_true (scm_procedure_p (tmp)) - /* Only the first definition determines the name. */ - && scm_is_false (scm_procedure_property (tmp, scm_sym_name))) - scm_set_procedure_property_x (tmp, scm_sym_name, variable); - } - SCM_VARIABLE_SET (location, value); +/* @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_SYMBOL (sym_atslot_set_x, "@slot-set!"); - return SCM_UNSPECIFIED; - } -} +#if SCM_ENABLE_ELISP -/* 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); +static const char s_defun[] = "Symbol's function definition is void"; - SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr)); +SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond); +SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop); - return expr; -} +#endif /* SCM_ENABLE_ELISP */ +#if (SCM_ENABLE_DEPRECATED == 1) -SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay); -SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); +SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine); -/* 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; -} +#endif -static SCM -unmemoize_delay (const SCM expr, const SCM env) -{ - const SCM thunk_expr = SCM_CADDR (expr); - return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env)); -} + +/* Memoizers and unmemoizers of the built-in macros. */ -SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); -SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); +#include "eval-memoize.i.c" +#include "eval-unmemoize.i.c" -/* 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_is_null (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_is_symbol (name), s_bad_variable, name, expr); - ASSERT_SYNTAX_2 (scm_is_false (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); - } - } - 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; -} - -static SCM -unmemoize_do (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM rnames = SCM_CAR (cddr_expr); - const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env); - const SCM cdddr_expr = SCM_CDR (cddr_expr); - const SCM exit_sequence = SCM_CAR (cdddr_expr); - const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env); - const SCM cddddr_expr = SCM_CDR (cdddr_expr); - const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env); - - /* build transformed binding list */ - SCM um_names = scm_reverse (rnames); - SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env); - SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env); - SCM um_bindings = SCM_EOL; - while (!scm_is_null (um_names)) - { - const SCM name = SCM_CAR (um_names); - const SCM init = SCM_CAR (um_inits); - SCM step = SCM_CAR (um_steps); - step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step); - - um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings); - - um_names = SCM_CDR (um_names); - um_inits = SCM_CDR (um_inits); - um_steps = SCM_CDR (um_steps); - } - um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED); - - return scm_cons (scm_sym_do, - scm_cons2 (um_bindings, um_exit_sequence, um_body)); -} - - -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; -} - -static SCM -unmemoize_if (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env); - const SCM cdddr_expr = SCM_CDR (cddr_expr); - - if (scm_is_null (cdddr_expr)) - { - return scm_list_3 (scm_sym_if, um_condition, um_then); - } - else - { - const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env); - return scm_list_4 (scm_sym_if, um_condition, um_then, um_else); - } -} - - -SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda); -SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); - -/* 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 -c_improper_memq (SCM obj, SCM list) -{ - for (; scm_is_pair (list); list = SCM_CDR (list)) - { - if (scm_is_eq (SCM_CAR (list), obj)) - return 1; - } - return scm_is_eq (list, obj); -} - -SCM -scm_m_lambda (SCM expr, SCM env SCM_UNUSED) -{ - SCM formals; - 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_is_pair (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_is_symbol (formals) || scm_is_null (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_is_pair (formals_idx)) - { - const SCM formal = SCM_CAR (formals_idx); - const SCM next_idx = SCM_CDR (formals_idx); - ASSERT_SYNTAX_2 (scm_is_symbol (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_is_null (formals_idx) || scm_is_symbol (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_is_string (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; -} - -static SCM -unmemoize_lambda (const SCM expr, const SCM env) -{ - const SCM formals = SCM_CADR (expr); - const SCM body = SCM_CDDR (expr); - - const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env); - const SCM um_formals = scm_i_finite_list_copy (formals); - const SCM um_body = unmemoize_exprs (body, new_env); - - return scm_cons2 (scm_sym_lambda, um_formals, um_body); -} - - -/* 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_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx)) - { - 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_is_symbol (name), s_bad_variable, name, expr); - } -} - - -/* 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_is_null (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_is_false (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_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 .. vn and initializers - * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */ -SCM -scm_m_let (SCM expr, SCM env) -{ - SCM bindings; - - 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 (cdr_expr); - if (scm_is_symbol (bindings)) - { - ASSERT_SYNTAX (length >= 3, s_missing_expression, expr); - return memoize_named_let (expr, env); - } - - check_bindings (bindings, expr); - if (scm_is_null (bindings) || scm_is_null (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; - } - } -} - -static SCM -build_binding_list (SCM rnames, SCM rinits) -{ - SCM bindings = SCM_EOL; - while (!scm_is_null (rnames)) - { - const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits)); - bindings = scm_cons (binding, bindings); - rnames = SCM_CDR (rnames); - rinits = SCM_CDR (rinits); - } - return bindings; -} - -static SCM -unmemoize_let (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM um_rnames = SCM_CAR (cdr_expr); - const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env); - const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED); - const SCM um_bindings = build_binding_list (um_rnames, um_rinits); - const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env); - - return scm_cons2 (scm_sym_let, um_bindings, um_body); -} - - -SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec); -SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec); - -SCM -scm_m_letrec (SCM expr, SCM env) -{ - SCM 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_is_null (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)); - } -} - -static SCM -unmemoize_letrec (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM um_rnames = SCM_CAR (cdr_expr); - const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env); - const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED); - const SCM um_bindings = build_binding_list (um_rnames, um_rinits); - const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env); - - return scm_cons2 (scm_sym_letrec, um_bindings, um_body); -} - - - -SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar); -SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); - -/* (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_is_null (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); - - SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */ - SCM_SETCAR (binding_idx, name); /* update P1 */ - SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */ - - binding_idx = cdr_binding_idx; /* continue with P3 */ - } - - 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; -} - -static SCM -unmemoize_letstar (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM body = SCM_CDR (cdr_expr); - SCM bindings = SCM_CAR (cdr_expr); - SCM um_bindings = SCM_EOL; - SCM extended_env = env; - SCM um_body; - - while (!scm_is_null (bindings)) - { - const SCM variable = SCM_CAR (bindings); - const SCM init = SCM_CADR (bindings); - const SCM um_init = unmemoize_expression (init, extended_env); - um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings); - extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env); - bindings = SCM_CDDR (bindings); - } - um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED); - - um_body = unmemoize_exprs (body, extended_env); - - return scm_cons2 (scm_sym_letstar, um_bindings, um_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; - } -} - -static SCM -unmemoize_or (const SCM expr, const SCM env) -{ - return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env)); -} - - -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 - * expressions will be evaluated, and 'depth' is the current quasiquotation - * nesting level and is known to be greater than zero. */ -static SCM -iqq (SCM form, SCM env, unsigned long int depth) -{ - if (scm_is_pair (form)) - { - const SCM tmp = SCM_CAR (form); - if (scm_is_eq (tmp, scm_sym_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_is_eq (tmp, scm_sym_unquote)) - { - 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 - return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1)); - } - else if (scm_is_pair (tmp) - && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing)) - { - const SCM args = SCM_CDR (tmp); - ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form); - if (depth - 1 == 0) - { - 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 - return scm_cons (iqq (SCM_CAR (form), env, depth - 1), - iqq (SCM_CDR (form), env, depth)); - } - else - return scm_cons (iqq (SCM_CAR (form), env, depth), - iqq (SCM_CDR (form), env, depth)); - } - else if (scm_is_vector (form)) - return scm_vector (iqq (scm_vector_to_list (form), env, depth)); - else - return form; -} - -SCM -scm_m_quasiquote (SCM expr, SCM 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) == 1, s_expression, expr); - return iqq (SCM_CAR (cdr_expr), env, 1); -} - - -SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote); -SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote); - -SCM -scm_m_quote (SCM expr, SCM env SCM_UNUSED) -{ - 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 (is_self_quoting_p (quotee)) - return quotee; - - SCM_SETCAR (expr, SCM_IM_QUOTE); - SCM_SETCDR (expr, quotee); - return expr; -} - -static SCM -unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED) -{ - return scm_list_2 (scm_sym_quote, SCM_CDR (expr)); -} - - -/* 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); - -SCM -scm_m_set_x (SCM expr, SCM env SCM_UNUSED) -{ - SCM variable; - SCM new_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); - - /* Memoize the variable form. */ - ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); - new_variable = lookup_symbol (variable, env); - /* Leave the memoization of unbound symbols to lazy memoization: */ - if (SCM_UNBNDP (new_variable)) - new_variable = variable; - - SCM_SETCAR (expr, SCM_IM_SET_X); - SCM_SETCAR (cdr_expr, new_variable); - return expr; -} - -static SCM -unmemoize_set_x (const SCM expr, const SCM env) -{ - return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env)); -} - - -/* Start of the memoizers for non-R5RS builtin macros. */ - - -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_apply (SCM expr, 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) == 2, s_missing_expression, expr); - - SCM_SETCAR (expr, SCM_IM_APPLY); - return expr; -} - -static SCM -unmemoize_apply (const SCM expr, const SCM env) -{ - return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env)); -} - - -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_atbind (SCM expr, SCM env) -{ - 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_is_null (variable_idx); - variable_idx = SCM_CDR (variable_idx)) - { - /* 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_is_false (new_variable)) - new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T); - SCM_SETCAR (variable_idx, new_variable); - } - - SCM_SETCAR (expr, SCM_IM_BIND); - SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits)); - return expr; -} - - -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_cont (SCM expr, 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_SETCAR (expr, SCM_IM_CONT); - return expr; -} - -static SCM -unmemoize_atcall_cc (const SCM expr, const SCM env) -{ - return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env)); -} - - -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_at_call_with_values (SCM expr, 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) == 2, s_expression, expr); - - SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES); - return expr; -} - -static SCM -unmemoize_at_call_with_values (const SCM expr, const SCM env) -{ - return scm_list_2 (scm_sym_at_call_with_values, - unmemoize_exprs (SCM_CDR (expr), env)); -} - -#if 0 - -/* See futures.h for a comment why futures are not enabled. - */ - -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_future (SCM expr, SCM env) -{ - const SCM new_expr = memoize_as_thunk_prototype (expr, env); - SCM_SETCAR (new_expr, SCM_IM_FUTURE); - return new_expr; -} - -static SCM -unmemoize_future (const SCM expr, const SCM env) -{ - const SCM thunk_expr = SCM_CADDR (expr); - return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env)); -} - -#endif - -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 target, exp_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_is_pair (target)) - { - /* R5RS usage */ - return scm_m_set_x (expr, env); - } - else - { - /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */ - /* Macroexpanding the target might return things of the form - (begin ). In that case, must be a symbol or a - variable and we memoize to (set! ...). - */ - exp_target = macroexp (target, env); - if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN) - && !scm_is_null (SCM_CDR (exp_target)) - && scm_is_null (SCM_CDDR (exp_target))) - { - exp_target= SCM_CADR (exp_target); - ASSERT_SYNTAX_2 (scm_is_symbol (exp_target) - || SCM_VARIABLEP (exp_target), - s_bad_variable, exp_target, expr); - return scm_cons (SCM_IM_SET_X, scm_cons (exp_target, - SCM_CDR (cdr_expr))); - } - else - { - 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)); - - SCM_SETCAR (expr, setter_proc); - SCM_SETCDR (expr, setter_args); - return expr; - } - } -} - - -/* @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_SYMBOL (sym_atslot_ref, "@slot-ref"); - -SCM -scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED) -{ - SCM slot_nr; - - 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_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); - - SCM_SETCAR (expr, SCM_IM_SLOT_REF); - SCM_SETCDR (cdr_expr, slot_nr); - return expr; -} - -static SCM -unmemoize_atslot_ref (const SCM expr, const SCM env) -{ - const SCM instance = SCM_CADR (expr); - const SCM um_instance = unmemoize_expression (instance, env); - const SCM slot_nr = SCM_CDDR (expr); - return scm_list_3 (sym_atslot_ref, um_instance, slot_nr); -} - - -/* @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_SYMBOL (sym_atslot_set_x, "@slot-set!"); - -SCM -scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED) -{ - SCM slot_nr; - - 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_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr); - - SCM_SETCAR (expr, SCM_IM_SLOT_SET_X); - return expr; -} - -static SCM -unmemoize_atslot_set_x (const SCM expr, const SCM env) -{ - const SCM cdr_expr = SCM_CDR (expr); - const SCM instance = SCM_CAR (cdr_expr); - const SCM um_instance = unmemoize_expression (instance, env); - const SCM cddr_expr = SCM_CDR (cdr_expr); - const SCM slot_nr = SCM_CAR (cddr_expr); - const SCM cdddr_expr = SCM_CDR (cddr_expr); - const SCM value = SCM_CAR (cdddr_expr); - const SCM um_value = unmemoize_expression (value, env); - return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value); -} - - -#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_nil_cond (SCM expr, SCM env SCM_UNUSED) -{ - 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_atfop (SCM expr, SCM env SCM_UNUSED) -{ - SCM location; - SCM symbol; - - 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); - - symbol = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr); - - 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_is_symbol (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); - } - - /* Memoize the value location belonging to the terminal symbol. */ - SCM_SETCAR (cdr_expr, location); - - if (!SCM_MACROP (SCM_VARIABLE_REF (location))) - { - /* 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 - { - /* 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; - } -} - -#endif /* SCM_ENABLE_ELISP */ - - -static SCM -unmemoize_builtin_macro (const SCM expr, const SCM env) -{ - switch (ISYMNUM (SCM_CAR (expr))) - { - case (ISYMNUM (SCM_IM_AND)): - return unmemoize_and (expr, env); - - case (ISYMNUM (SCM_IM_BEGIN)): - return unmemoize_begin (expr, env); - - case (ISYMNUM (SCM_IM_CASE)): - return unmemoize_case (expr, env); - - case (ISYMNUM (SCM_IM_COND)): - return unmemoize_cond (expr, env); - - case (ISYMNUM (SCM_IM_DELAY)): - return unmemoize_delay (expr, env); - - case (ISYMNUM (SCM_IM_DO)): - return unmemoize_do (expr, env); - - case (ISYMNUM (SCM_IM_IF)): - return unmemoize_if (expr, env); - - case (ISYMNUM (SCM_IM_LAMBDA)): - return unmemoize_lambda (expr, env); - - case (ISYMNUM (SCM_IM_LET)): - return unmemoize_let (expr, env); - - case (ISYMNUM (SCM_IM_LETREC)): - return unmemoize_letrec (expr, env); - - case (ISYMNUM (SCM_IM_LETSTAR)): - return unmemoize_letstar (expr, env); - - case (ISYMNUM (SCM_IM_OR)): - return unmemoize_or (expr, env); - - case (ISYMNUM (SCM_IM_QUOTE)): - return unmemoize_quote (expr, env); - - case (ISYMNUM (SCM_IM_SET_X)): - return unmemoize_set_x (expr, env); - - case (ISYMNUM (SCM_IM_APPLY)): - return unmemoize_apply (expr, env); - - case (ISYMNUM (SCM_IM_BIND)): - return unmemoize_exprs (expr, env); /* FIXME */ - - case (ISYMNUM (SCM_IM_CONT)): - return unmemoize_atcall_cc (expr, env); - - case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)): - return unmemoize_at_call_with_values (expr, env); - -#if 0 - /* See futures.h for a comment why futures are not enabled. - */ - case (ISYMNUM (SCM_IM_FUTURE)): - return unmemoize_future (expr, env); -#endif - - case (ISYMNUM (SCM_IM_SLOT_REF)): - return unmemoize_atslot_ref (expr, env); - - case (ISYMNUM (SCM_IM_SLOT_SET_X)): - return unmemoize_atslot_set_x (expr, env); - - case (ISYMNUM (SCM_IM_NIL_COND)): - return unmemoize_exprs (expr, env); /* FIXME */ - - default: - return unmemoize_exprs (expr, env); /* FIXME */ - } -} - - -/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression - * respectively a memoized body together with its environment and rewrite it - * to its original form. Thus, these functions are the inversion of the - * rewrite rules above. The procedure is not optimized for speed. It's used - * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1. - * - * Unmemoizing is not a reliable process. You cannot in general expect to get - * the original source back. - * - * However, GOOPS currently relies on this for method compilation. This ought - * to change. */ - -SCM -scm_i_unmemocopy_expr (SCM expr, SCM env) -{ - const SCM source_properties = scm_whash_lookup (scm_source_whash, expr); - const SCM um_expr = unmemoize_expression (expr, env); - - if (scm_is_true (source_properties)) - scm_whash_insert (scm_source_whash, um_expr, source_properties); - - return um_expr; -} - -SCM -scm_i_unmemocopy_body (SCM forms, SCM env) -{ - const SCM source_properties = scm_whash_lookup (scm_source_whash, forms); - const SCM um_forms = unmemoize_exprs (forms, env); - - if (scm_is_true (source_properties)) - scm_whash_insert (scm_source_whash, um_forms, source_properties); - - return um_forms; -} - - -#if (SCM_ENABLE_DEPRECATED == 1) - -/* Deprecated in guile 1.7.0 on 2003-11-09. */ -SCM -scm_m_expand_body (SCM exprs, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_m_expand_body' is deprecated."); - m_expand_body (exprs, env); - return exprs; -} - - -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); - - scm_c_issue_deprecation_warning - ("`undefine' is deprecated.\n"); - - variable = SCM_CAR (cdr_expr); - ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); - location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F); - ASSERT_SYNTAX_2 (scm_is_true (location) - && !SCM_UNBNDP (SCM_VARIABLE_REF (location)), - "variable already unbound ", variable, expr); - SCM_VARIABLE_SET (location, SCM_UNDEFINED); - return SCM_UNSPECIFIED; -} - -SCM -scm_macroexp (SCM x, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_macroexp' is deprecated."); - return macroexp (x, env); -} - -#endif - - -#if (SCM_ENABLE_DEPRECATED == 1) - -SCM -scm_unmemocar (SCM form, SCM env) -{ - scm_c_issue_deprecation_warning - ("`scm_unmemocar' is deprecated."); - - if (!scm_is_pair (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_is_false (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; - } -} - -#endif + /*****************************************************************************/ /*****************************************************************************/ /* The definitions for execution start here. */ --=-=-= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ Guile-devel mailing list Guile-devel@gnu.org http://lists.gnu.org/mailman/listinfo/guile-devel --=-=-=--