* eval.c (scm_m_body, scm_m_lambda): Documentation strings are not

handled in scm_m_body any more, but rather in scm_m_lambda.

	(scm_m_body, memoize_named_let, scm_m_let, scm_m_letstar,
	scm_m_letrec, scm_m_expand_body): Check for validity is done by
	calling functions of scm_m_body.

	(scm_m_lambda): Avoid unnecessary consing when creating the
	memoized code.

libguile/ChangeLog

@@ -1,3 +1,15 @@
+2003-11-01  Dirk Herrmann  <D.Herrmann@tu-bs.de>
+
+	* eval.c (scm_m_body, scm_m_lambda): Documentation strings are not
+	handled in scm_m_body any more, but rather in scm_m_lambda.
+
+	(scm_m_body, memoize_named_let, scm_m_let, scm_m_letstar,
+	scm_m_letrec, scm_m_expand_body): Check for validity is done by
+	calling functions of scm_m_body.
+
+	(scm_m_lambda): Avoid unnecessary consing when creating the
+	memoized code.
+
 2003-11-01  Dirk Herrmann  <D.Herrmann@tu-bs.de>
 
 	* eval.c (s_expression): Added comment.

libguile/eval.c

@@ -672,38 +672,25 @@ SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
 SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
 
 
-/* Check that the body denoted by XORIG is valid and rewrite it into
+/* Rewrite the body (which is given as the list of expressions forming the
-   its internal form.  The internal form of a body is just the body
+ * body) into its internal form.  The internal form of a body (<expr> ...) is
-   itself, but prefixed with an ISYM that denotes to what kind of
+ * just the body itself, but prefixed with an ISYM that denotes to what kind
-   outer construct this body belongs.  A lambda body starts with
+ * of outer construct this body belongs: (<ISYM> <expr> ...).  A lambda body
-   SCM_IM_LAMBDA, for example, a body of a let starts with SCM_IM_LET,
+ * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
-   etc.  The one exception is a body that belongs to a letrec that has
+ * SCM_IM_LET, etc.  The one exception is a body that belongs to a letrec that
-   been formed by rewriting internal defines: it starts with
+ * has been formed by rewriting internal defines: It starts with SCM_IM_DEFINE
-   SCM_IM_DEFINE. */
+ * (instead of SCM_IM_LETREC).
-
+ *
-/* XXX - Besides controlling the rewriting of internal defines, the
+ * It is assumed that the calling expression has already made sure that the
-         additional ISYM could be used for improved error messages.
+ * body is a proper list.  */
-         This is not done yet.  */
-
 static SCM
-scm_m_body (SCM op, SCM xorig, const char *what)
+scm_m_body (SCM op, SCM exprs)
 {
-  SCM_ASSYNT (scm_ilength (xorig) >= 1, s_body, what);
-
   /* Don't add another ISYM if one is present already. */
-  if (SCM_ISYMP (SCM_CAR (xorig)))
+  if (SCM_ISYMP (SCM_CAR (exprs)))
-    return xorig;
+    return exprs;
-
+  else
-  /* Retain possible doc string. */
+    return scm_cons (op, exprs);
-  if (!SCM_CONSP (SCM_CAR (xorig)))
-    {
-      if (!SCM_NULLP (SCM_CDR (xorig)))
-	return scm_cons (SCM_CAR (xorig),
-			 scm_m_body (op, SCM_CDR (xorig), what));
-      return xorig;
-    }
-
-  return scm_cons (op, xorig);
 }
 
 
@@ -1101,6 +1088,10 @@ 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);
@@ -1136,8 +1127,22 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
   ASSERT_SYNTAX_2 (SCM_NULLP (formals_idx) || SCM_SYMBOLP (formals_idx),
                    s_bad_formal, formals_idx, expr);
 
-  return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (cdr_expr),
+  /* Memoize the body.  Keep a potential documentation string.  */
-		    scm_m_body (SCM_IM_LAMBDA, SCM_CDR (cdr_expr), s_lambda));
+  /* 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 = scm_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;
 }
 
 
@@ -1220,13 +1225,13 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
 
   {
     const SCM let_body = SCM_CDR (cddr_expr);
-    const SCM lambda_body = scm_m_body (SCM_IM_LET, let_body, "let");
+    const SCM lambda_body = scm_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 = scm_m_body (SCM_IM_LET, scm_list_1 (name), "let");
+    const SCM body = scm_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);
@@ -1256,7 +1261,7 @@ scm_m_let (SCM expr, SCM env)
   if (SCM_NULLP (bindings) || SCM_NULLP (SCM_CDR (bindings)))
     {
       /* Special case: no bindings or single binding => let* is faster. */
-      const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), s_let);
+      const SCM body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
       return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
     }
   else
@@ -1267,7 +1272,7 @@ scm_m_let (SCM expr, SCM env)
       transform_bindings (bindings, expr, &rvariables, &inits);
 
       {
-        const SCM new_body = scm_m_body (SCM_IM_LET, SCM_CDR (cdr_expr), "let");
+        const SCM new_body = scm_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);
@@ -1305,7 +1310,7 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
     }
   new_bindings = scm_reverse_x (new_bindings, SCM_UNDEFINED);
 
-  new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr), s_letstar);
+  new_body = scm_m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
   return scm_cons2 (SCM_IM_LETSTAR, new_bindings, new_body);
 }
 
@@ -1326,7 +1331,7 @@ scm_m_letrec (SCM expr, SCM env)
   if (SCM_NULLP (bindings))
     {
       /* no bindings, let* is executed faster */
-      SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), s_letrec);
+      SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
       return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
     }
   else
@@ -1337,7 +1342,7 @@ scm_m_letrec (SCM expr, SCM env)
 
       check_bindings (bindings, expr);
       transform_bindings (bindings, expr, &rvariables, &inits);
-      new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr), "letrec");
+      new_body = scm_m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
       return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
     }
 }
@@ -1841,7 +1846,7 @@ scm_m_expand_body (SCM xorig, SCM env)
       SCM rvars, inits, body, letrec;
       check_bindings (defs, xorig);
       transform_bindings (defs, xorig, &rvars, &inits);
-      body = scm_m_body (SCM_IM_DEFINE, x, what);
+      body = scm_m_body (SCM_IM_DEFINE, x);
       letrec = scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
       SCM_SETCAR (xorig, letrec);
       SCM_SETCDR (xorig, SCM_EOL);