/[guile]/guile/guile-core/libguile/eval.c
ViewVC logotype

Diff of /guile/guile-core/libguile/eval.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.334 by dirk, Wed Oct 22 20:16:41 2003 UTC revision 1.335 by dirk, Sat Oct 25 07:00:50 2003 UTC
# Line 633  literal_p (const SCM symbol, const SCM e Line 633  literal_p (const SCM symbol, const SCM e
633      return 0;      return 0;
634  }  }
635    
 #define unmemocar scm_unmemocar  
   
 SCM_SYMBOL (sym_three_question_marks, "???");  
   
 SCM  
 scm_unmemocar (SCM form, SCM env)  
 {  
   if (!SCM_CONSP (form))  
     return form;  
   else  
     {  
       SCM c = SCM_CAR (form);  
       if (SCM_VARIABLEP (c))  
         {  
           SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);  
           if (SCM_FALSEP (sym))  
             sym = sym_three_question_marks;  
           SCM_SETCAR (form, sym);  
         }  
       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;  
     }  
 }  
   
636    
637  SCM  SCM
638  scm_eval_car (SCM pair, SCM env)  scm_eval_car (SCM pair, SCM env)
# Line 1925  static SCM f_apply; Line 1891  static SCM f_apply;
1891  /* An endless list consisting of #<undefined> objects:  */  /* An endless list consisting of #<undefined> objects:  */
1892  static SCM undefineds;  static SCM undefineds;
1893    
1894    
1895  /* scm_unmemocopy takes a memoized expression together with its  /* scm_unmemocopy takes a memoized expression together with its
1896   * environment and rewrites it to its original form.  Thus, it is the   * environment and rewrites it to its original form.  Thus, it is the
1897   * inversion of the rewrite rules above.  The procedure is not   * inversion of the rewrite rules above.  The procedure is not
# Line 1941  static SCM undefineds; Line 1908  static SCM undefineds;
1908   */   */
1909    
1910  static SCM  static SCM
1911  build_binding_list (SCM names, SCM inits)  build_binding_list (SCM rnames, SCM rinits)
1912  {  {
1913    SCM bindings = SCM_EOL;    SCM bindings = SCM_EOL;
1914    while (!SCM_NULLP (names))    while (!SCM_NULLP (rnames))
1915      {      {
1916        SCM binding = scm_list_2 (SCM_CAR (names), SCM_CAR (inits));        SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
1917        bindings = scm_cons (binding, bindings);        bindings = scm_cons (binding, bindings);
1918        names = SCM_CDR (names);        rnames = SCM_CDR (rnames);
1919        inits = SCM_CDR (inits);        rinits = SCM_CDR (rinits);
1920      }      }
1921    return bindings;    return bindings;
1922  }  }
1923    
1924    
1925    SCM_SYMBOL (sym_three_question_marks, "???");
1926    
1927    #define unmemocar scm_unmemocar
1928    
1929    SCM
1930    scm_unmemocar (SCM form, SCM env)
1931    {
1932      if (!SCM_CONSP (form))
1933        return form;
1934      else
1935        {
1936          SCM c = SCM_CAR (form);
1937          if (SCM_VARIABLEP (c))
1938            {
1939              SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
1940              if (SCM_FALSEP (sym))
1941                sym = sym_three_question_marks;
1942              SCM_SETCAR (form, sym);
1943            }
1944          else if (SCM_ILOCP (c))
1945            {
1946              unsigned long int ir;
1947    
1948              for (ir = SCM_IFRAME (c); ir != 0; --ir)
1949                env = SCM_CDR (env);
1950              env = SCM_CAAR (env);
1951              for (ir = SCM_IDIST (c); ir != 0; --ir)
1952                env = SCM_CDR (env);
1953              SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
1954            }
1955          return form;
1956        }
1957    }
1958    
1959  static SCM  static SCM
1960  unmemocopy (SCM x, SCM env)  unmemocopy (SCM x, SCM env)
1961  {  {
# Line 2032  unmemocopy (SCM x, SCM env) Line 2034  unmemocopy (SCM x, SCM env)
2034          /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),          /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
2035           * where nx is the name of a local variable, ix is an initializer for           * where nx is the name of a local variable, ix is an initializer for
2036           * the local variable and by are the body clauses.  */           * the local variable and by are the body clauses.  */
2037          SCM names, inits, bindings;          SCM rnames, rinits, bindings;
2038    
2039          x = SCM_CDR (x);          x = SCM_CDR (x);
2040          names = SCM_CAR (x);          rnames = SCM_CAR (x);
2041          x = SCM_CDR (x);          x = SCM_CDR (x);
2042          inits = scm_reverse (unmemocopy (SCM_CAR (x), env));          rinits = scm_reverse (unmemocopy (SCM_CAR (x), env));
2043          env = SCM_EXTEND_ENV (names, SCM_EOL, env);          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
2044    
2045          bindings = build_binding_list (names, inits);          bindings = build_binding_list (rnames, rinits);
2046          z = scm_cons (bindings, SCM_UNSPECIFIED);          z = scm_cons (bindings, SCM_UNSPECIFIED);
2047          ls = scm_cons (scm_sym_let, z);          ls = scm_cons (scm_sym_let, z);
2048          break;          break;
2049        }        }
2050      case SCM_BIT7 (SCM_IM_LETREC):      case SCM_BIT7 (SCM_IM_LETREC):
2051        {        {
2052          /* format: (#@letrec (nk nk-1 ...) (i1 ... ik) b1 ...),          /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
2053           * where nx is the name of a local variable, ix is an initializer for           * where vx is the name of a local variable, ix is an initializer for
2054           * the local variable and by are the body clauses.  */           * the local variable and by are the body clauses.  */
2055          SCM names, inits, bindings;          SCM rnames, rinits, bindings;
2056    
2057          x = SCM_CDR (x);          x = SCM_CDR (x);
2058          names = SCM_CAR (x);          rnames = SCM_CAR (x);
2059          env = SCM_EXTEND_ENV (names, SCM_EOL, env);          env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
2060          x = SCM_CDR (x);          x = SCM_CDR (x);
2061          inits = scm_reverse (unmemocopy (SCM_CAR (x), env));          rinits = scm_reverse (unmemocopy (SCM_CAR (x), env));
2062    
2063          bindings = build_binding_list (names, inits);          bindings = build_binding_list (rnames, rinits);
2064          z = scm_cons (bindings, SCM_UNSPECIFIED);          z = scm_cons (bindings, SCM_UNSPECIFIED);
2065          ls = scm_cons (scm_sym_letrec, z);          ls = scm_cons (scm_sym_letrec, z);
2066          break;          break;
# Line 5166  scm_init_eval () Line 5168  scm_init_eval ()
5168    scm_permanent_object (f_apply);    scm_permanent_object (f_apply);
5169    
5170  #include "libguile/eval.x"  #include "libguile/eval.x"
5171      
5172    scm_add_feature ("delay");    scm_add_feature ("delay");
5173  }  }
5174    

Legend:
Removed from v.1.334  
changed lines
  Added in v.1.335

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26