[Guile-commits] 01/06: Assignment conversion in the interpreter

[Andy Wingo]

wingo pushed a commit to branch wip-closure-conversion
in repository guile.

commit 7974c57937104b0617d93fa492d3bd323b053f20
Author: Andy Wingo <address@hidden>
Date:   Thu Dec 4 15:07:01 2014 +0100

    Assignment conversion in the interpreter
    
    * libguile/expand.c (compute_assigned, convert_assignment)
      (scm_convert_assignment): New functions.
    
    * libguile/expand.h: Declare scm_convert_assignment.
    
    * libguile/memoize.c (scm_memoize_expression): Do assignment conversion
      before memoization.
    
    * test-suite/tests/syntax.test ("letrec"): Detection of unbound letrec
      variables now works.
---
 libguile/expand.c            |  399 +++++++++++++++++++++++++++++++++++++++++-
 libguile/expand.h            |    4 +-
 libguile/memoize.c           |    2 +-
 test-suite/tests/syntax.test |   31 ++--
 4 files changed, 414 insertions(+), 22 deletions(-)

diff --git a/libguile/expand.c b/libguile/expand.c
index 7d6a6ed..1d511e6 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013
+/* Copyright (C) 
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
  * Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
@@ -45,6 +45,7 @@
 SCM scm_exp_vtable_vtable;
 static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
 static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
+static SCM const_unbound;
 static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
 static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
 
@@ -99,6 +100,10 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
 #define CDDDR(x) SCM_CDDDR(x)
 #define CADDDR(x) SCM_CADDDR(x)
 
+/* Abbreviate SCM_EXPANDED_REF.  */
+#define REF(x,type,field) \
+  (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+
 
 static const char s_bad_expression[] = "Bad expression";
 static const char s_expression[] = "Missing or extra expression in";
@@ -1176,7 +1181,392 @@ SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 
0, 0,
 #undef FUNC_NAME
 
 
- 
+
+
+static void
+compute_assigned (SCM exp, SCM assigned)
+{
+  if (scm_is_null (exp) || scm_is_false (exp))
+    return;
+
+  if (scm_is_pair (exp))
+    {
+      compute_assigned (CAR (exp), assigned);
+      compute_assigned (CDR (exp), assigned);
+      return;
+    }
+
+  if (!SCM_EXPANDED_P (exp))
+    abort ();
+
+  switch (SCM_EXPANDED_TYPE (exp))
+    {
+    case SCM_EXPANDED_VOID:
+    case SCM_EXPANDED_CONST:
+    case SCM_EXPANDED_PRIMITIVE_REF:
+    case SCM_EXPANDED_LEXICAL_REF:
+    case SCM_EXPANDED_MODULE_REF:
+    case SCM_EXPANDED_TOPLEVEL_REF:
+      return;
+
+    case SCM_EXPANDED_LEXICAL_SET:
+      scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T);
+      compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned);
+      return;
+
+    case SCM_EXPANDED_MODULE_SET:
+      compute_assigned (REF (exp, MODULE_SET, EXP), assigned);
+      return;
+
+    case SCM_EXPANDED_TOPLEVEL_SET:
+      compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned);
+      return;
+
+    case SCM_EXPANDED_TOPLEVEL_DEFINE:
+      compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned);
+      return;
+
+    case SCM_EXPANDED_CONDITIONAL:
+      compute_assigned (REF (exp, CONDITIONAL, TEST), assigned);
+      compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned);
+      compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned);
+      return;
+
+    case SCM_EXPANDED_CALL:
+      compute_assigned (REF (exp, CALL, PROC), assigned);
+      compute_assigned (REF (exp, CALL, ARGS), assigned);
+      return;
+
+    case SCM_EXPANDED_PRIMCALL:
+      compute_assigned (REF (exp, PRIMCALL, ARGS), assigned);
+      return;
+
+    case SCM_EXPANDED_SEQ:
+      compute_assigned (REF (exp, SEQ, HEAD), assigned);
+      compute_assigned (REF (exp, SEQ, TAIL), assigned);
+      return;
+
+    case SCM_EXPANDED_LAMBDA:
+      compute_assigned (REF (exp, LAMBDA, BODY), assigned);
+      return;
+
+    case SCM_EXPANDED_LAMBDA_CASE:
+      compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned);
+      compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned);
+      compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+      return;
+
+    case SCM_EXPANDED_LET:
+      compute_assigned (REF (exp, LET, VALS), assigned);
+      compute_assigned (REF (exp, LET, BODY), assigned);
+      return;
+
+    case SCM_EXPANDED_LETREC:
+      {
+        SCM syms = REF (exp, LETREC, GENSYMS);
+        /* We lower letrec in this same pass, so mark these variables as
+           assigned.  */
+        for (; scm_is_pair (syms); syms = CDR (syms))
+          scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T);
+      }
+      compute_assigned (REF (exp, LETREC, VALS), assigned);
+      compute_assigned (REF (exp, LETREC, BODY), assigned);
+      return;
+
+    default:
+      abort ();
+    }
+}
+
+static SCM
+box_value (SCM exp)
+{
+  return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
+                   scm_list_1 (exp));
+}
+
+static SCM
+box_lexical (SCM name, SCM sym)
+{
+  return LEXICAL_SET (SCM_BOOL_F, name, sym,
+                      box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
+}
+
+static SCM
+init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
+{
+  return CONDITIONAL (src,
+                      PRIMCALL (src,
+                                scm_from_latin1_symbol ("eq?"),
+                                scm_list_2 (LEXICAL_REF (src, name, sym),
+                                            const_unbound)),
+                      LEXICAL_SET (src, name, sym, init),
+                      VOID_ (src));
+}
+
+static SCM
+init_boxes (SCM names, SCM syms, SCM vals, SCM body)
+{
+  if (scm_is_null (names)) return body;
+
+  return SEQ (SCM_BOOL_F,
+              PRIMCALL
+              (SCM_BOOL_F,
+               scm_from_latin1_symbol ("variable-set!"),
+               scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
+                           CAR (vals))),
+              init_boxes (CDR (names), CDR (syms), CDR (vals), body));
+}
+
+static SCM
+convert_assignment (SCM exp, SCM assigned)
+{
+  if (scm_is_null (exp) || scm_is_false (exp))
+    return exp;
+
+  if (scm_is_pair (exp))
+    return scm_cons (convert_assignment (CAR (exp), assigned),
+                     convert_assignment (CDR (exp), assigned));
+
+  if (!SCM_EXPANDED_P (exp))
+    abort ();
+
+  switch (SCM_EXPANDED_TYPE (exp))
+    {
+    case SCM_EXPANDED_VOID:
+    case SCM_EXPANDED_CONST:
+    case SCM_EXPANDED_PRIMITIVE_REF:
+    case SCM_EXPANDED_MODULE_REF:
+    case SCM_EXPANDED_TOPLEVEL_REF:
+      return exp;
+
+    case SCM_EXPANDED_LEXICAL_REF:
+      {
+        SCM sym = REF (exp, LEXICAL_REF, GENSYM);
+
+        if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+          return PRIMCALL
+            (REF (exp, LEXICAL_REF, SRC),
+             scm_from_latin1_symbol ("variable-ref"),
+             scm_list_1 (exp));
+        return exp;
+      }
+
+    case SCM_EXPANDED_LEXICAL_SET:
+      return PRIMCALL
+        (REF (exp, LEXICAL_SET, SRC),
+         scm_from_latin1_symbol ("variable-set!"),
+         scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
+                                  REF (exp, LEXICAL_SET, NAME),
+                                  REF (exp, LEXICAL_SET, GENSYM)),
+                     convert_assignment (REF (exp, LEXICAL_SET, EXP),
+                                         assigned)));
+
+    case SCM_EXPANDED_MODULE_SET:
+      return MODULE_SET
+        (REF (exp, MODULE_SET, SRC),
+         REF (exp, MODULE_SET, MOD),
+         REF (exp, MODULE_SET, NAME),
+         REF (exp, MODULE_SET, PUBLIC),
+         convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
+
+    case SCM_EXPANDED_TOPLEVEL_SET:
+      return TOPLEVEL_SET
+        (REF (exp, TOPLEVEL_SET, SRC),
+          REF (exp, TOPLEVEL_SET, NAME),
+          convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
+
+    case SCM_EXPANDED_TOPLEVEL_DEFINE:
+      return TOPLEVEL_DEFINE
+        (REF (exp, TOPLEVEL_DEFINE, SRC),
+         REF (exp, TOPLEVEL_DEFINE, NAME),
+         convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
+                             assigned));
+
+    case SCM_EXPANDED_CONDITIONAL:
+      return CONDITIONAL
+        (REF (exp, CONDITIONAL, SRC),
+         convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
+         convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
+         convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
+
+    case SCM_EXPANDED_CALL:
+      return CALL
+        (REF (exp, CALL, SRC),
+         convert_assignment (REF (exp, CALL, PROC), assigned),
+         convert_assignment (REF (exp, CALL, ARGS), assigned));
+
+    case SCM_EXPANDED_PRIMCALL:
+      return PRIMCALL
+        (REF (exp, PRIMCALL, SRC),
+         REF (exp, PRIMCALL, NAME),
+         convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
+
+    case SCM_EXPANDED_SEQ:
+      return SEQ
+        (REF (exp, SEQ, SRC),
+         convert_assignment (REF (exp, SEQ, HEAD), assigned),
+         convert_assignment (REF (exp, SEQ, TAIL), assigned));
+
+    case SCM_EXPANDED_LAMBDA:
+      return LAMBDA
+        (REF (exp, LAMBDA, SRC),
+         REF (exp, LAMBDA, META),
+         convert_assignment (REF (exp, LAMBDA, BODY), assigned));
+
+    case SCM_EXPANDED_LAMBDA_CASE:
+      {
+        SCM src, req, opt, rest, kw, inits, syms, body, alt;
+        SCM namewalk, symwalk, new_inits, seq;
+
+        /* Box assigned formals.  Since initializers can capture
+           previous formals, we convert initializers to be in the body
+           instead of in the "header".  */
+
+        src = REF (exp, LAMBDA_CASE, SRC);
+        req = REF (exp, LAMBDA_CASE, REQ);
+        opt = REF (exp, LAMBDA_CASE, OPT);
+        rest = REF (exp, LAMBDA_CASE, REST);
+        kw = REF (exp, LAMBDA_CASE, KW);
+        inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned);
+        syms = REF (exp, LAMBDA_CASE, GENSYMS);
+        body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned);
+        alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+
+        new_inits = scm_make_list (scm_length (inits), const_unbound);
+                                             
+        seq = SCM_EOL, symwalk = syms;
+
+        /* Required arguments may need boxing.  */
+        for (namewalk = req;
+             scm_is_pair (namewalk);
+             namewalk = CDR (namewalk), symwalk = CDR (symwalk))
+          {
+            SCM name = CAR (namewalk), sym = CAR (symwalk);
+            if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+              seq = scm_cons (box_lexical (name, sym), seq);
+          }
+        /* Optional arguments may need initialization and/or boxing.  */
+        for (namewalk = opt;
+             scm_is_pair (namewalk);
+             namewalk = CDR (namewalk), symwalk = CDR (symwalk),
+               inits = CDR (inits))
+          {
+            SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
+            seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
+            if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+              seq = scm_cons (box_lexical (name, sym), seq);
+          }
+        /* Rest arguments may need boxing.  */
+        if (scm_is_true (rest))
+          {
+            SCM sym = CAR (symwalk);
+            symwalk = CDR (symwalk);
+            if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+              seq = scm_cons (box_lexical (rest, sym), seq);
+          }
+        /* The rest of the arguments, if any, are keyword arguments,
+           which may need initialization and/or boxing.  */
+        for (;
+             scm_is_pair (symwalk);
+             symwalk = CDR (symwalk), inits = CDR (inits))
+          {
+            SCM sym = CAR (symwalk), init = CAR (inits);
+            seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
+            if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+              seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
+          }
+
+        for (; scm_is_pair (seq); seq = CDR (seq))
+          body = SEQ (src, CAR (seq), body);
+
+        return LAMBDA_CASE
+          (src, req, opt, rest, kw, new_inits, syms, body, alt);
+      }
+
+    case SCM_EXPANDED_LET:
+      {
+        SCM src, names, syms, vals, body, new_vals, walk;
+        
+        src = REF (exp, LET, SRC);
+        names = REF (exp, LET, NAMES);
+        syms = REF (exp, LET, GENSYMS);
+        vals = convert_assignment (REF (exp, LET, VALS), assigned);
+        body = convert_assignment (REF (exp, LET, BODY), assigned);
+
+        for (new_vals = SCM_EOL, walk = syms;
+             scm_is_pair (vals);
+             vals = CDR (vals), walk = CDR (walk))
+          {
+            SCM sym = CAR (walk), val = CAR (vals);
+            if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+              new_vals = scm_cons (box_value (val), new_vals);
+            else
+              new_vals = scm_cons (val, new_vals);
+          }
+        new_vals = scm_reverse (new_vals);
+
+        return LET (src, names, syms, new_vals, body);
+      }
+
+    case SCM_EXPANDED_LETREC:
+      {
+        SCM src, names, syms, vals, unbound, boxes, body;
+
+        src = REF (exp, LETREC, SRC);
+        names = REF (exp, LETREC, NAMES);
+        syms = REF (exp, LETREC, GENSYMS);
+        vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
+        body = convert_assignment (REF (exp, LETREC, BODY), assigned);
+
+        unbound = PRIMCALL (SCM_BOOL_F,
+                            scm_from_latin1_symbol ("make-undefined-variable"),
+                            SCM_EOL);
+        boxes = scm_make_list (scm_length (names), unbound);
+
+        if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
+          return LET
+            (src, names, syms, boxes,
+             init_boxes (names, syms, vals, body));
+        else
+          {
+            SCM walk, tmps = SCM_EOL, inits = SCM_EOL;
+
+            for (walk = syms; scm_is_pair (walk); walk = CDR (walk))
+              {
+                SCM tmp = scm_gensym (SCM_UNDEFINED);
+                tmps = scm_cons (tmp, tmps);
+                inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
+                                  inits);
+              }
+            tmps = scm_reverse (tmps);
+            inits = scm_reverse (inits);
+
+            return LET
+              (src, names, syms, boxes,
+               SEQ (src,
+                    LET (src, names, tmps, vals,
+                         init_boxes (names, syms, inits, VOID_ (src))),
+                    body));
+          }
+      }
+
+    default:
+      abort ();
+    }
+}
+
+SCM
+scm_convert_assignment (SCM exp)
+{
+  SCM assigned = scm_c_make_hash_table (0);
+
+  compute_assigned (exp, assigned);
+  return convert_assignment (exp, assigned);
+}
+
+
+
 
 #define DEFINE_NAMES(type)                                              \
   {                                                                     \
@@ -1245,6 +1635,11 @@ scm_init_expand ()
   while (n--)
     exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
 
+  const_unbound =
+    CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
+
+  scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
+
   scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
   
 #include "libguile/expand.x"
diff --git a/libguile/expand.h b/libguile/expand.h
index 8a578ae..9c2732d 100644
--- a/libguile/expand.h
+++ b/libguile/expand.h
@@ -3,7 +3,7 @@
 #ifndef SCM_EXPAND_H
 #define SCM_EXPAND_H
 
-/* Copyright (C) 2010, 2011, 2013
+/* Copyright (C) 2010, 2011, 2013, 2014
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -337,6 +337,8 @@ enum
 SCM_INTERNAL SCM scm_macroexpand (SCM exp);
 SCM_INTERNAL SCM scm_macroexpanded_p (SCM exp);
 
+SCM_INTERNAL SCM scm_convert_assignment (SCM exp);
+
 SCM_INTERNAL void scm_init_expand (void);
 
 
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 5c7129f..36766e8 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -569,7 +569,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 
1, 0, 0,
 #define FUNC_NAME s_scm_memoize_expression
 {
   SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
-  return memoize (exp, SCM_BOOL_F);
+  return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
 }
 #undef FUNC_NAME
 
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 6c2891c..825261b 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -87,6 +87,8 @@
 (define exception:zero-expression-sequence
   "sequence of zero expressions")
 
+(define exception:variable-ref
+  '(misc-error . "variable is unbound"))
 
 ;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
 (define-syntax pass-if-syntax-error
@@ -413,14 +415,11 @@
 
   (with-test-prefix "bindings"
 
-    (pass-if-syntax-error "initial bindings are undefined"
-      exception:used-before-defined
-      (let ((x 1))
-        ;; FIXME: the memoizer does initialize the var to undefined, but
-        ;; the Scheme evaluator has no way of checking what's an
-        ;; undefined value. Not sure how to do this.
-        (throw 'unresolved)
-       (letrec ((x 1) (y x)) y))))
+    (pass-if-exception "initial bindings are undefined"
+      exception:variable-ref
+      (eval '(let ((x 1))
+               (letrec ((x 1) (y x)) y))
+            (interaction-environment))))
 
   (with-test-prefix "bad bindings"
 
@@ -492,14 +491,10 @@
 
   (with-test-prefix "bindings"
 
-    (pass-if-syntax-error "initial bindings are undefined"
-      exception:used-before-defined
-      (begin
-        ;; FIXME: the memoizer does initialize the var to undefined, but
-        ;; the Scheme evaluator has no way of checking what's an
-        ;; undefined value. Not sure how to do this.
-        (throw 'unresolved)
-       (letrec* ((x y) (y 1)) y))))
+    (pass-if-exception "initial bindings are undefined"
+      exception:variable-ref
+      (eval '(letrec* ((x y) (y 1)) y)
+            (interaction-environment))))
 
   (with-test-prefix "bad bindings"
 
@@ -568,8 +563,8 @@
            (interaction-environment))))
 
   (with-test-prefix "referencing previous values"
-    (pass-if (equal? (letrec ((a (cons 'foo 'bar))
-                              (b a))
+    (pass-if (equal? (letrec* ((a (cons 'foo 'bar))
+                               (b a))
                        b)
                      '(foo . bar)))
     (pass-if (equal? (let ()