/[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.300 by dirk, Sun Apr 27 11:06:14 2003 UTC revision 1.301 by dirk, Sun Apr 27 12:06:48 2003 UTC
# Line 452  scm_m_body (SCM op, SCM xorig, const cha Line 452  scm_m_body (SCM op, SCM xorig, const cha
452  }  }
453    
454    
455  SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);  /* Start of the memoizers for the standard R5RS builtin macros.  */
 SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);  
   
 SCM  
 scm_m_quote (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);  
   return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));  
 }  
   
   
 SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);  
 SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);  
   
 SCM  
 scm_m_begin (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);  
   return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));  
 }  
   
   
 SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);  
 SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);  
   
 SCM  
 scm_m_if (SCM xorig, SCM env SCM_UNUSED)  
 {  
   long len = scm_ilength (SCM_CDR (xorig));  
   SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);  
   return scm_cons (SCM_IM_IF, SCM_CDR (xorig));  
 }  
   
   
 /* Will go into the RnRS module when Guile is factorized.  
 SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, 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 xorig, SCM env SCM_UNUSED)  
 {  
   SCM x = SCM_CDR (xorig);  
   SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x);  
   SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x);  
   return scm_cons (SCM_IM_SET_X, x);  
 }  
456    
457    
458  SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);  SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
# Line 516  scm_m_and (SCM xorig, SCM env SCM_UNUSED Line 470  scm_m_and (SCM xorig, SCM env SCM_UNUSED
470  }  }
471    
472    
473  SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);  SCM_SYNTAX (s_begin, "begin", scm_makmmacro, scm_m_begin);
474  SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);  SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
475    
476  SCM  SCM
477  scm_m_or (SCM xorig, SCM env SCM_UNUSED)  scm_m_begin (SCM xorig, SCM env SCM_UNUSED)
478  {  {
479    long len = scm_ilength (SCM_CDR (xorig));    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) >= 0, scm_s_expression, s_begin);
480    SCM_ASSYNT (len >= 0, scm_s_test, s_or);    return scm_cons (SCM_IM_BEGIN, SCM_CDR (xorig));
   if (len >= 1)  
     return scm_cons (SCM_IM_OR, SCM_CDR (xorig));  
   else  
     return SCM_BOOL_F;  
481  }  }
482    
483    
# Line 585  scm_m_cond (SCM xorig, SCM env SCM_UNUSE Line 535  scm_m_cond (SCM xorig, SCM env SCM_UNUSE
535  }  }
536    
537    
538  SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);  SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
539  SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);  SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
540    
541  /* Return true if OBJ is `eq?' to one of the elements of LIST or to the  /* Guile provides an extension to R5RS' define syntax to represent function
542   * cdr of the last cons.  (Thus, LIST is not required to be a proper   * currying in a compact way.  With this extension, it is allowed to write
543   * list and OBJ can also be found in the improper ending.) */   * (define <nested-variable> <body>), where <nested-variable> has of one of
544  static int   * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),  
545  scm_c_improper_memq (SCM obj, SCM list)   * (<variable> <formals>) or (<variable> . <formal>).  As in R5RS, <formals>
546     * should be either a sequence of zero or more variables, or a sequence of one
547     * or more variables followed by a space-delimited period and another
548     * variable.  Each level of argument nesting wraps the <body> within another
549     * lambda expression.  For example, the following forms are allowed, each one
550     * followed by an equivalent, more explicit implementation.
551     * Example 1:
552     *   (define ((a b . c) . d) <body>)  is equivalent to
553     *   (define a (lambda (b . c) (lambda d <body>)))
554     * Example 2:
555     *   (define (((a) b) c . d) <body>)  is equivalent to
556     *   (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
557     */
558    /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
559     * module that does not implement this extension.  */
560    SCM
561    scm_m_define (SCM x, SCM env)
562  {  {
563    for (; SCM_CONSP (list); list = SCM_CDR (list))    SCM name;
564      x = SCM_CDR (x);
565      SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);
566      name = SCM_CAR (x);
567      x = SCM_CDR (x);
568      while (SCM_CONSP (name))
569      {      {
570        if (SCM_EQ_P (SCM_CAR (list), obj))        /* This while loop realizes function currying by variable nesting. */
571          return 1;        SCM formals = SCM_CDR (name);
572          x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));
573          name = SCM_CAR (name);
574      }      }
575    return SCM_EQ_P (list, obj);    SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);
576  }    SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);
577      if (SCM_TOP_LEVEL (env))
 SCM  
 scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM formals;  
   SCM x = SCM_CDR (xorig);  
   
   SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);  
   
   formals = SCM_CAR (x);  
   while (SCM_CONSP (formals))  
578      {      {
579        SCM formal = SCM_CAR (formals);        SCM var;
580        SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);        x = scm_eval_car (x, env);
581        if (scm_c_improper_memq (formal, SCM_CDR (formals)))        if (SCM_REC_PROCNAMES_P)
582          scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);          {
583        formals = SCM_CDR (formals);            SCM tmp = x;
584              while (SCM_MACROP (tmp))
585                tmp = SCM_MACRO_CODE (tmp);
586              if (SCM_CLOSUREP (tmp)
587                  /* Only the first definition determines the name. */
588                  && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))
589                scm_set_procedure_property_x (tmp, scm_sym_name, name);
590            }
591          var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);
592          SCM_VARIABLE_SET (var, x);
593          return SCM_UNSPECIFIED;
594      }      }
595    if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))    else
596      scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);      return scm_cons2 (SCM_IM_DEFINE, name, x);
   
   return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),  
                     scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));  
597  }  }
598    
599    
600  SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);  SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);
601  SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);  SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
602    
603  /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers  /* Promises are implemented as closures with an empty parameter list.  Thus,
604   * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*).  */   * (delay <expression>) is transformed into (#@delay '() <expression>), where
605     * the empty list represents the empty parameter list.  This representation
606     * allows for easy creation of the closure during evaluation.  */
607  SCM  SCM
608  scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)  scm_m_delay (SCM xorig, SCM env SCM_UNUSED)
609  {  {
610    SCM bindings;    SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);
611    SCM x = SCM_CDR (xorig);    return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));
   SCM vars = SCM_EOL;  
   SCM *varloc = &vars;  
   
   SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);  
   
   bindings = SCM_CAR (x);  
   SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);  
   while (!SCM_NULLP (bindings))  
     {  
       SCM binding = SCM_CAR (bindings);  
       SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);  
       SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);  
       *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));  
       varloc = SCM_CDRLOC (SCM_CDR (*varloc));  
       bindings = SCM_CDR (bindings);  
     }  
   
   return scm_cons2 (SCM_IM_LETSTAR, vars,  
                     scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));  
612  }  }
613    
614    
# Line 720  scm_m_do (SCM xorig, SCM env SCM_UNUSED) Line 673  scm_m_do (SCM xorig, SCM env SCM_UNUSED)
673  }  }
674    
675    
676  SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);  SCM_SYNTAX (s_if, "if", scm_makmmacro, scm_m_if);
677  SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);  SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
   
 /* 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_CONSP (form))  
     {  
       SCM tmp = SCM_CAR (form);  
       if (SCM_EQ_P (tmp, scm_sym_quasiquote))  
         {  
           SCM args = SCM_CDR (form);  
           SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);  
           return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));  
         }  
       else if (SCM_EQ_P (tmp, scm_sym_unquote))  
         {  
           SCM args = SCM_CDR (form);  
           SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);  
           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_CONSP (tmp)  
                && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))  
         {  
           SCM args = SCM_CDR (tmp);  
           SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);  
           if (depth - 1 == 0)  
             {  
               SCM list = scm_eval_car (args, env);  
               SCM rest = SCM_CDR (form);  
               SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);  
               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_VECTORP (form))  
     {  
       size_t i = SCM_VECTOR_LENGTH (form);  
       SCM const *const data = SCM_VELTS (form);  
       SCM tmp = SCM_EOL;  
       while (i != 0)  
         tmp = scm_cons (data[--i], tmp);  
       scm_remember_upto_here_1 (form);  
       return scm_vector (iqq (tmp, env, depth));  
     }  
   else  
     return form;  
 }  
   
 SCM  
 scm_m_quasiquote (SCM xorig, SCM env)  
 {  
   SCM x = SCM_CDR (xorig);  
   SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);  
   return iqq (SCM_CAR (x), env, 1);  
 }  
   
   
 SCM_SYNTAX (s_delay, "delay", scm_makmmacro, scm_m_delay);  
 SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);  
678    
 /* Promises are implemented as closures with an empty parameter list.  Thus,  
  * (delay <expression>) is transformed into (#@delay '() <expression>), where  
  * the empty list represents the empty parameter list.  This representation  
  * allows for easy creation of the closure during evaluation.  */  
679  SCM  SCM
680  scm_m_delay (SCM xorig, SCM env SCM_UNUSED)  scm_m_if (SCM xorig, SCM env SCM_UNUSED)
681  {  {
682    SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_delay);    long len = scm_ilength (SCM_CDR (xorig));
683    return scm_cons2 (SCM_IM_DELAY, SCM_EOL, SCM_CDR (xorig));    SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
684      return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
685  }  }
686    
687    
688  SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x);  SCM_SYNTAX (s_lambda, "lambda", scm_makmmacro, scm_m_lambda);
689  SCM_SYMBOL (scm_sym_setter, "setter");  SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
690    
691  SCM  /* Return true if OBJ is `eq?' to one of the elements of LIST or to the
692  scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)   * cdr of the last cons.  (Thus, LIST is not required to be a proper
693     * list and OBJ can also be found in the improper ending.) */
694    static int
695    scm_c_improper_memq (SCM obj, SCM list)
696  {  {
697    SCM x = SCM_CDR (xorig);    for (; SCM_CONSP (list); list = SCM_CDR (list))
698    SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x);      {
699    if (SCM_SYMBOLP (SCM_CAR (x)))        if (SCM_EQ_P (SCM_CAR (list), obj))
700      return scm_cons (SCM_IM_SET_X, x);          return 1;
701    else if (SCM_CONSP (SCM_CAR (x)))      }
702      return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),    return SCM_EQ_P (list, obj);
                      scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));  
   else  
     scm_misc_error (s_set_x, scm_s_variable, SCM_EOL);  
703  }  }
704    
   
 SCM_SYNTAX (s_future, "future", scm_makmmacro, 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 <expression>) is transformed into  
  * (#@future '() <expression>), where the empty list represents the  
  * empty parameter list.  This representation allows for easy creation  
  * of the closure during evaluation.  */  
705  SCM  SCM
706  scm_m_future (SCM xorig, SCM env SCM_UNUSED)  scm_m_lambda (SCM xorig, SCM env SCM_UNUSED)
707  {  {
708    SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);    SCM formals;
709    return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));    SCM x = SCM_CDR (xorig);
 }  
   
710    
711  SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);    SCM_ASSYNT (SCM_CONSP (x), scm_s_formals, s_lambda);
 SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);  
712    
713  /* Guile provides an extension to R5RS' define syntax to represent function    formals = SCM_CAR (x);
714   * currying in a compact way.  With this extension, it is allowed to write    while (SCM_CONSP (formals))
  * (define <nested-variable> <body>), where <nested-variable> has of one of  
  * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),    
  * (<variable> <formals>) or (<variable> . <formal>).  As in R5RS, <formals>  
  * 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 <body> 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) <body>)  is equivalent to  
  *   (define a (lambda (b . c) (lambda d <body>)))  
  * Example 2:  
  *   (define (((a) b) c . d) <body>)  is equivalent to  
  *   (define a (lambda () (lambda (b) (lambda (c . d) <body>))))  
  */  
 /* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS  
  * module that does not implement this extension.  */  
 SCM  
 scm_m_define (SCM x, SCM env)  
 {  
   SCM name;  
   x = SCM_CDR (x);  
   SCM_ASSYNT (scm_ilength (x) >= 2, scm_s_expression, s_define);  
   name = SCM_CAR (x);  
   x = SCM_CDR (x);  
   while (SCM_CONSP (name))  
     {  
       /* This while loop realizes function currying by variable nesting. */  
       SCM formals = SCM_CDR (name);  
       x = scm_list_1 (scm_cons2 (scm_sym_lambda, formals, x));  
       name = SCM_CAR (name);  
     }  
   SCM_ASSYNT (SCM_SYMBOLP (name), scm_s_variable, s_define);  
   SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_define);  
   if (SCM_TOP_LEVEL (env))  
715      {      {
716        SCM var;        SCM formal = SCM_CAR (formals);
717        x = scm_eval_car (x, env);        SCM_ASSYNT (SCM_SYMBOLP (formal), scm_s_formals, s_lambda);
718        if (SCM_REC_PROCNAMES_P)        if (scm_c_improper_memq (formal, SCM_CDR (formals)))
719          {          scm_misc_error (s_lambda, scm_s_duplicate_formals, SCM_EOL);
720            SCM tmp = x;        formals = SCM_CDR (formals);
           while (SCM_MACROP (tmp))  
             tmp = SCM_MACRO_CODE (tmp);  
           if (SCM_CLOSUREP (tmp)  
               /* Only the first definition determines the name. */  
               && SCM_FALSEP (scm_procedure_property (tmp, scm_sym_name)))  
             scm_set_procedure_property_x (tmp, scm_sym_name, name);  
         }  
       var = scm_sym2var (name, scm_env_top_level (env), SCM_BOOL_T);  
       SCM_VARIABLE_SET (var, x);  
       return SCM_UNSPECIFIED;  
721      }      }
722    else    if (!SCM_NULLP (formals) && !SCM_SYMBOLP (formals))
723      return scm_cons2 (SCM_IM_DEFINE, name, x);      scm_misc_error (s_lambda, scm_s_formals, SCM_EOL);
724    
725      return scm_cons2 (SCM_IM_LAMBDA, SCM_CAR (x),
726                        scm_m_body (SCM_IM_LAMBDA, SCM_CDR (x), s_lambda));
727  }  }
728    
729    
# Line 932  transform_bindings (SCM bindings, SCM *r Line 757  transform_bindings (SCM bindings, SCM *r
757  }  }
758    
759    
 SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);  
 SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);  
   
 SCM  
 scm_m_letrec (SCM xorig, SCM env)  
 {  
   SCM x = SCM_CDR (xorig);  
   SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);  
     
   if (SCM_NULLP (SCM_CAR (x)))  
     {  
       /* null binding, let* faster */  
       SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);  
       return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);  
     }  
   else  
     {  
       SCM rvars, inits, body;  
       transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");  
       body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");  
       return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));  
     }  
 }  
   
   
760  SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);  SCM_SYNTAX(s_let, "let", scm_makmmacro, scm_m_let);
761  SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);  SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
762    
# Line 1027  scm_m_let (SCM xorig, SCM env) Line 827  scm_m_let (SCM xorig, SCM env)
827  }  }
828    
829    
830  SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply);  SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
831  SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);  SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
 SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);  
832    
833  SCM  /* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vk and initializers
834  scm_m_apply (SCM xorig, SCM env SCM_UNUSED)   * i1 .. ik is transformed into the form (#@let* (v1 i1 v2 i2 ...) body*).  */
835    SCM
836    scm_m_letstar (SCM xorig, SCM env SCM_UNUSED)
837  {  {
838    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);    SCM bindings;
839    return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));    SCM x = SCM_CDR (xorig);
840  }    SCM vars = SCM_EOL;
841      SCM *varloc = &vars;
842    
843      SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letstar);
844    
845  SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont);    bindings = SCM_CAR (x);
846  SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);    SCM_ASSYNT (scm_ilength (bindings) >= 0, scm_s_bindings, s_letstar);
847      while (!SCM_NULLP (bindings))
848        {
849          SCM binding = SCM_CAR (bindings);
850          SCM_ASSYNT (scm_ilength (binding) == 2, scm_s_bindings, s_letstar);
851          SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (binding)), scm_s_variable, s_letstar);
852          *varloc = scm_list_2 (SCM_CAR (binding), SCM_CADR (binding));
853          varloc = SCM_CDRLOC (SCM_CDR (*varloc));
854          bindings = SCM_CDR (bindings);
855        }
856    
857      return scm_cons2 (SCM_IM_LETSTAR, vars,
858                        scm_m_body (SCM_IM_LETSTAR, SCM_CDR (x), s_letstar));
859    }
860    
861    
862    SCM_SYNTAX(s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
863    SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
864    
865  SCM  SCM
866  scm_m_cont (SCM xorig, SCM env SCM_UNUSED)  scm_m_letrec (SCM xorig, SCM env)
867  {  {
868    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,    SCM x = SCM_CDR (xorig);
869                scm_s_expression, s_atcall_cc);    SCM_ASSYNT (SCM_CONSP (x), scm_s_bindings, s_letrec);
870    return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));    
871      if (SCM_NULLP (SCM_CAR (x)))
872        {
873          /* null binding, let* faster */
874          SCM body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), s_letrec);
875          return scm_m_letstar (scm_cons2 (SCM_CAR (xorig), SCM_EOL, body), env);
876        }
877      else
878        {
879          SCM rvars, inits, body;
880          transform_bindings (SCM_CAR (x), &rvars, &inits, "letrec");
881          body = scm_m_body (SCM_IM_LETREC, SCM_CDR (x), "letrec");
882          return scm_cons2 (SCM_IM_LETREC, rvars, scm_cons (inits, body));
883        }
884  }  }
885    
 #if SCM_ENABLE_ELISP  
886    
887  SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);  SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
888    SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
889    
890  SCM  SCM
891  scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)  scm_m_or (SCM xorig, SCM env SCM_UNUSED)
892  {  {
893    long len = scm_ilength (SCM_CDR (xorig));    long len = scm_ilength (SCM_CDR (xorig));
894    SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond");    SCM_ASSYNT (len >= 0, scm_s_test, s_or);
895    return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));    if (len >= 1)
896        return scm_cons (SCM_IM_OR, SCM_CDR (xorig));
897      else
898        return SCM_BOOL_F;
899  }  }
900    
 SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);  
901    
902  SCM  SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
903  scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)  SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
904    
905    /* Internal function to handle a quasiquotation:  'form' is the parameter in
906     * the call (quasiquotation form), 'env' is the environment where unquoted
907     * expressions will be evaluated, and 'depth' is the current quasiquotation
908     * nesting level and is known to be greater than zero.  */
909    static SCM
910    iqq (SCM form, SCM env, unsigned long int depth)
911  {  {
912    SCM x = SCM_CDR (xorig), var;    if (SCM_CONSP (form))
   SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");  
   var = scm_symbol_fref (SCM_CAR (x));  
   /* Passing the symbol name as the `subr' arg here isn't really  
      right, but without it it can be very difficult to work out from  
      the error message which function definition was missing.  In any  
      case, we shouldn't really use SCM_ASSYNT here at all, but instead  
      something equivalent to (signal void-function (list SYM)) in  
      Elisp. */  
   SCM_ASSYNT (SCM_VARIABLEP (var),  
               "Symbol's function definition is void",  
               SCM_SYMBOL_CHARS (SCM_CAR (x)));  
   /* Support `defalias'. */  
   while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))  
913      {      {
914        var = scm_symbol_fref (SCM_VARIABLE_REF (var));        SCM tmp = SCM_CAR (form);
915        SCM_ASSYNT (SCM_VARIABLEP (var),        if (SCM_EQ_P (tmp, scm_sym_quasiquote))
916                    "Symbol's function definition is void",          {
917                    SCM_SYMBOL_CHARS (SCM_CAR (x)));            SCM args = SCM_CDR (form);
918              SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
919              return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
920            }
921          else if (SCM_EQ_P (tmp, scm_sym_unquote))
922            {
923              SCM args = SCM_CDR (form);
924              SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
925              if (depth - 1 == 0)
926                return scm_eval_car (args, env);
927              else
928                return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
929            }
930          else if (SCM_CONSP (tmp)
931                   && SCM_EQ_P (SCM_CAR (tmp), scm_sym_uq_splicing))
932            {
933              SCM args = SCM_CDR (tmp);
934              SCM_ASSYNT (scm_ilength (args) == 1, scm_s_expression, s_quasiquote);
935              if (depth - 1 == 0)
936                {
937                  SCM list = scm_eval_car (args, env);
938                  SCM rest = SCM_CDR (form);
939                  SCM_ASSYNT (scm_ilength (list) >= 0, s_splicing, s_quasiquote);
940                  return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
941                }
942              else
943                return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
944                                 iqq (SCM_CDR (form), env, depth));
945            }
946          else
947            return scm_cons (iqq (SCM_CAR (form), env, depth),
948                             iqq (SCM_CDR (form), env, depth));
949      }      }
950    /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the    else if (SCM_VECTORP (form))
      former allows for automatically picking up redefinitions of the  
      corresponding symbol. */  
   SCM_SETCAR (x, var);  
   /* If the variable contains a procedure, leave the  
      `transformer-macro' in place so that the procedure's arguments  
      get properly transformed, and change the initial @fop to  
      SCM_IM_APPLY. */  
   if (!SCM_MACROP (SCM_VARIABLE_REF (var)))  
951      {      {
952        SCM_SETCAR (xorig, SCM_IM_APPLY);        size_t i = SCM_VECTOR_LENGTH (form);
953        return xorig;        SCM const *const data = SCM_VELTS (form);
954          SCM tmp = SCM_EOL;
955          while (i != 0)
956            tmp = scm_cons (data[--i], tmp);
957          scm_remember_upto_here_1 (form);
958          return scm_vector (iqq (tmp, env, depth));
959      }      }
960    /* Otherwise (the variable contains a macro), the arguments should    else
961       not be transformed, so cut the `transformer-macro' out and return      return form;
962       the resulting expression starting with the variable. */  }
963    SCM_SETCDR (x, SCM_CDADR (x));  
964    return x;  SCM
965    scm_m_quasiquote (SCM xorig, SCM env)
966    {
967      SCM x = SCM_CDR (xorig);
968      SCM_ASSYNT (scm_ilength (x) == 1, scm_s_expression, s_quasiquote);
969      return iqq (SCM_CAR (x), env, 1);
970    }
971    
972    
973    SCM_SYNTAX (s_quote, "quote", scm_makmmacro, scm_m_quote);
974    SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
975    
976    SCM
977    scm_m_quote (SCM xorig, SCM env SCM_UNUSED)
978    {
979      SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, s_quote);
980      return scm_cons (SCM_IM_QUOTE, SCM_CDR (xorig));
981    }
982    
983    
984    /* Will go into the RnRS module when Guile is factorized.
985    SCM_SYNTAX (s_set_x, "set!", scm_makmmacro, scm_m_set_x); */
986    static const char s_set_x[] = "set!";
987    SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
988    
989    SCM
990    scm_m_set_x (SCM xorig, SCM env SCM_UNUSED)
991    {
992      SCM x = SCM_CDR (xorig);
993      SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, s_set_x);
994      SCM_ASSYNT (SCM_SYMBOLP (SCM_CAR (x)), scm_s_variable, s_set_x);
995      return scm_cons (SCM_IM_SET_X, x);
996    }
997    
998    
999    /* Start of the memoizers for non-R5RS builtin macros.  */
1000    
1001    
1002    SCM_SYNTAX (s_atapply, "@apply", scm_makmmacro, scm_m_apply);
1003    SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
1004    SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
1005    
1006    SCM
1007    scm_m_apply (SCM xorig, SCM env SCM_UNUSED)
1008    {
1009      SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2, scm_s_expression, s_atapply);
1010      return scm_cons (SCM_IM_APPLY, SCM_CDR (xorig));
1011  }  }
1012    
 #endif /* SCM_ENABLE_ELISP */  
1013    
1014  /* (@bind ((var exp) ...) body ...)  /* (@bind ((var exp) ...) body ...)
1015    
# Line 1163  scm_m_atbind (SCM xorig, SCM env) Line 1064  scm_m_atbind (SCM xorig, SCM env)
1064                               SCM_CDDR (xorig)));                               SCM_CDDR (xorig)));
1065  }  }
1066    
 SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref);  
1067    
1068  SCM  SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_makmmacro, scm_m_cont);
1069  scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)  SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
1070  #define FUNC_NAME s_atslot_ref  
1071    
1072    SCM
1073    scm_m_cont (SCM xorig, SCM env SCM_UNUSED)
1074  {  {
1075    SCM x = SCM_CDR (xorig);    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
1076    SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);                scm_s_expression, s_atcall_cc);
1077    SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));    return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
   return scm_cons (SCM_IM_SLOT_REF, x);  
1078  }  }
 #undef FUNC_NAME  
1079    
1080    
1081  SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x);  SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);
1082    SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
1083    
1084  SCM  SCM
1085  scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)  scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)
 #define FUNC_NAME s_atslot_set_x  
1086  {  {
1087    SCM x = SCM_CDR (xorig);    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,
1088    SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);                scm_s_expression, s_at_call_with_values);
1089    SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));    return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));
   return scm_cons (SCM_IM_SLOT_SET_X, x);  
1090  }  }
 #undef FUNC_NAME  
1091    
1092    
1093  SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch);  SCM_SYNTAX (s_atdispatch, "@dispatch", scm_makmmacro, scm_m_atdispatch);
# Line 1219  scm_m_atdispatch (SCM xorig, SCM env) Line 1118  scm_m_atdispatch (SCM xorig, SCM env)
1118  #undef FUNC_NAME  #undef FUNC_NAME
1119    
1120    
1121  SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_makmmacro, scm_m_at_call_with_values);  SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
1122  SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);  SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
1123    
1124    /* Like promises, futures are implemented as closures with an empty
1125     * parameter list.  Thus, (future <expression>) is transformed into
1126     * (#@future '() <expression>), where the empty list represents the
1127     * empty parameter list.  This representation allows for easy creation
1128     * of the closure during evaluation.  */
1129  SCM  SCM
1130  scm_m_at_call_with_values (SCM xorig, SCM env SCM_UNUSED)  scm_m_future (SCM xorig, SCM env SCM_UNUSED)
1131  {  {
1132    SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 2,    SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
1133                scm_s_expression, s_at_call_with_values);    return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));
   return scm_cons (SCM_IM_CALL_WITH_VALUES, SCM_CDR (xorig));  
1134  }  }
1135    
1136    
1137    SCM_SYNTAX (s_gset_x, "set!", scm_makmmacro, scm_m_generalized_set_x);
1138    SCM_SYMBOL (scm_sym_setter, "setter");
1139    
1140    SCM
1141    scm_m_generalized_set_x (SCM xorig, SCM env SCM_UNUSED)
1142    {
1143      SCM x = SCM_CDR (xorig);
1144      SCM_ASSYNT (2 == scm_ilength (x), scm_s_expression, s_set_x);
1145      if (SCM_SYMBOLP (SCM_CAR (x)))
1146        return scm_cons (SCM_IM_SET_X, x);
1147      else if (SCM_CONSP (SCM_CAR (x)))
1148        return scm_cons (scm_list_2 (scm_sym_setter, SCM_CAAR (x)),
1149                         scm_append (scm_list_2 (SCM_CDAR (x), SCM_CDR (x))));
1150      else
1151        scm_misc_error (s_set_x, scm_s_variable, SCM_EOL);
1152    }
1153    
1154    
1155    SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_makmmacro, scm_m_atslot_ref);
1156    
1157    SCM
1158    scm_m_atslot_ref (SCM xorig, SCM env SCM_UNUSED)
1159    #define FUNC_NAME s_atslot_ref
1160    {
1161      SCM x = SCM_CDR (xorig);
1162      SCM_ASSYNT (scm_ilength (x) == 2, scm_s_expression, FUNC_NAME);
1163      SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
1164      return scm_cons (SCM_IM_SLOT_REF, x);
1165    }
1166    #undef FUNC_NAME
1167    
1168    
1169    SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_makmmacro, scm_m_atslot_set_x);
1170    
1171    SCM
1172    scm_m_atslot_set_x (SCM xorig, SCM env SCM_UNUSED)
1173    #define FUNC_NAME s_atslot_set_x
1174    {
1175      SCM x = SCM_CDR (xorig);
1176      SCM_ASSYNT (scm_ilength (x) == 3, scm_s_expression, FUNC_NAME);
1177      SCM_VALIDATE_INUM (SCM_ARG2, SCM_CADR (x));
1178      return scm_cons (SCM_IM_SLOT_SET_X, x);
1179    }
1180    #undef FUNC_NAME
1181    
1182    
1183    #if SCM_ENABLE_ELISP
1184    
1185    SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
1186    
1187    SCM
1188    scm_m_nil_cond (SCM xorig, SCM env SCM_UNUSED)
1189    {
1190      long len = scm_ilength (SCM_CDR (xorig));
1191      SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "nil-cond");
1192      return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
1193    }
1194    
1195    
1196    SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
1197    
1198    SCM
1199    scm_m_atfop (SCM xorig, SCM env SCM_UNUSED)
1200    {
1201      SCM x = SCM_CDR (xorig), var;
1202      SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
1203      var = scm_symbol_fref (SCM_CAR (x));
1204      /* Passing the symbol name as the `subr' arg here isn't really
1205         right, but without it it can be very difficult to work out from
1206         the error message which function definition was missing.  In any
1207         case, we shouldn't really use SCM_ASSYNT here at all, but instead
1208         something equivalent to (signal void-function (list SYM)) in
1209         Elisp. */
1210      SCM_ASSYNT (SCM_VARIABLEP (var),
1211                  "Symbol's function definition is void",
1212                  SCM_SYMBOL_CHARS (SCM_CAR (x)));
1213      /* Support `defalias'. */
1214      while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))
1215        {
1216          var = scm_symbol_fref (SCM_VARIABLE_REF (var));
1217          SCM_ASSYNT (SCM_VARIABLEP (var),
1218                      "Symbol's function definition is void",
1219                      SCM_SYMBOL_CHARS (SCM_CAR (x)));
1220        }
1221      /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1222         former allows for automatically picking up redefinitions of the
1223         corresponding symbol. */
1224      SCM_SETCAR (x, var);
1225      /* If the variable contains a procedure, leave the
1226         `transformer-macro' in place so that the procedure's arguments
1227         get properly transformed, and change the initial @fop to
1228         SCM_IM_APPLY. */
1229      if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
1230        {
1231          SCM_SETCAR (xorig, SCM_IM_APPLY);
1232          return xorig;
1233        }
1234      /* Otherwise (the variable contains a macro), the arguments should
1235         not be transformed, so cut the `transformer-macro' out and return
1236         the resulting expression starting with the variable. */
1237      SCM_SETCDR (x, SCM_CDADR (x));
1238      return x;
1239    }
1240    
1241    #endif /* SCM_ENABLE_ELISP */
1242    
1243    
1244  SCM  SCM
1245  scm_m_expand_body (SCM xorig, SCM env)  scm_m_expand_body (SCM xorig, SCM env)
1246  {  {

Legend:
Removed from v.1.300  
changed lines
  Added in v.1.301

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