/[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.253 by dirk, Thu Jan 10 21:57:03 2002 UTC revision 1.254 by ossau, Tue Jan 22 23:31:38 2002 UTC
# Line 100  char *alloca (); Line 100  char *alloca ();
100    
101  #include "libguile/validate.h"  #include "libguile/validate.h"
102  #include "libguile/eval.h"  #include "libguile/eval.h"
103    #include "libguile/lang.h"
104    
105    
106    
# Line 537  SCM Line 538  SCM
538  scm_m_if (SCM xorig, SCM env SCM_UNUSED)  scm_m_if (SCM xorig, SCM env SCM_UNUSED)
539  {  {
540    long len = scm_ilength (SCM_CDR (xorig));    long len = scm_ilength (SCM_CDR (xorig));
541    SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, "if");    SCM_ASSYNT (len >= 2 && len <= 3, scm_s_expression, s_if);
542    return scm_cons (SCM_IM_IF, SCM_CDR (xorig));    return scm_cons (SCM_IM_IF, SCM_CDR (xorig));
543  }  }
544    
# Line 1073  scm_m_cont (SCM xorig, SCM env SCM_UNUSE Line 1074  scm_m_cont (SCM xorig, SCM env SCM_UNUSE
1074    return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));    return scm_cons (SCM_IM_CONT, SCM_CDR (xorig));
1075  }  }
1076    
1077  /* Multi-language support */  #ifdef SCM_ENABLE_ELISP
   
 SCM_GLOBAL_SYMBOL (scm_lisp_nil, "nil");  
 SCM_GLOBAL_SYMBOL (scm_lisp_t, "t");  
1078    
1079  SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);  SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
1080    
# Line 1088  scm_m_nil_cond (SCM xorig, SCM env SCM_U Line 1086  scm_m_nil_cond (SCM xorig, SCM env SCM_U
1086    return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));    return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
1087  }  }
1088    
 SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);  
   
 SCM  
 scm_m_nil_ify (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "nil-ify");  
   return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));  
 }  
   
 SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);  
   
 SCM  
 scm_m_t_ify (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "t-ify");  
   return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));  
 }  
   
 SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);  
   
 SCM  
 scm_m_0_cond (SCM xorig, SCM env SCM_UNUSED)  
 {  
   long len = scm_ilength (SCM_CDR (xorig));  
   SCM_ASSYNT (len >= 1 && (len & 1) == 1, scm_s_expression, "0-cond");  
   return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));  
 }  
   
 SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);  
   
 SCM  
 scm_m_0_ify (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "0-ify");  
   return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));  
 }  
   
 SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);  
   
 SCM  
 scm_m_1_ify (SCM xorig, SCM env SCM_UNUSED)  
 {  
   SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1, scm_s_expression, "1-ify");  
   return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));  
 }  
   
1089  SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);  SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
1090    
1091  SCM  SCM
# Line 1142  scm_m_atfop (SCM xorig, SCM env SCM_UNUS Line 1094  scm_m_atfop (SCM xorig, SCM env SCM_UNUS
1094    SCM x = SCM_CDR (xorig), var;    SCM x = SCM_CDR (xorig), var;
1095    SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");    SCM_ASSYNT (scm_ilength (x) >= 1, scm_s_expression, "@fop");
1096    var = scm_symbol_fref (SCM_CAR (x));    var = scm_symbol_fref (SCM_CAR (x));
1097      /* Passing the symbol name as the `subr' arg here isn't really
1098         right, but without it it can be very difficult to work out from
1099         the error message which function definition was missing.  In any
1100         case, we shouldn't really use SCM_ASSYNT here at all, but instead
1101         something equivalent to (signal void-function (list SYM)) in
1102         Elisp. */
1103    SCM_ASSYNT (SCM_VARIABLEP (var),    SCM_ASSYNT (SCM_VARIABLEP (var),
1104                "Symbol's function definition is void", NULL);                "Symbol's function definition is void",
1105                  SCM_SYMBOL_CHARS (SCM_CAR (x)));
1106      /* Support `defalias'. */
1107      while (SCM_SYMBOLP (SCM_VARIABLE_REF (var)))
1108        {
1109          var = scm_symbol_fref (SCM_VARIABLE_REF (var));
1110          SCM_ASSYNT (SCM_VARIABLEP (var),
1111                      "Symbol's function definition is void",
1112                      SCM_SYMBOL_CHARS (SCM_CAR (x)));
1113        }
1114      /* Use `var' here rather than `SCM_VARIABLE_REF (var)' because the
1115         former allows for automatically picking up redefinitions of the
1116         corresponding symbol. */
1117    SCM_SETCAR (x, var);    SCM_SETCAR (x, var);
1118      /* If the variable contains a procedure, leave the
1119         `transformer-macro' in place so that the procedure's arguments
1120         get properly transformed, and change the initial @fop to
1121         SCM_IM_APPLY. */
1122      if (!SCM_MACROP (SCM_VARIABLE_REF (var)))
1123        {
1124          SCM_SETCAR (xorig, SCM_IM_APPLY);
1125          return xorig;
1126        }
1127      /* Otherwise (the variable contains a macro), the arguments should
1128         not be transformed, so cut the `transformer-macro' out and return
1129         the resulting expression starting with the variable. */
1130      SCM_SETCDR (x, SCM_CDADR (x));
1131    return x;    return x;
1132  }  }
1133    
1134    #endif /* SCM_ENABLE_ELISP */
1135    
1136  /* (@bind ((var exp) ...) body ...)  /* (@bind ((var exp) ...) body ...)
1137    
1138    This will assign the values of the `exp's to the global variables    This will assign the values of the `exp's to the global variables
# Line 1158  scm_m_atfop (SCM xorig, SCM env SCM_UNUS Line 1143  scm_m_atfop (SCM xorig, SCM env SCM_UNUS
1143    error when a symbol appears more than once among the `var's.    error when a symbol appears more than once among the `var's.
1144    All `exp's are evaluated before any `var' is set.    All `exp's are evaluated before any `var' is set.
1145    
1146    This of this as `let' for dynamic scope.    Think of this as `let' for dynamic scope.
1147    
1148    It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).    It is memoized into (#@bind ((var ...) . (reversed-val ...)) body ...).
1149    
# Line 1325  scm_macroexp (SCM x, SCM env) Line 1310  scm_macroexp (SCM x, SCM env)
1310   * generating the source for a stackframe in a backtrace, and in   * generating the source for a stackframe in a backtrace, and in
1311   * display_expression.   * display_expression.
1312   *   *
1313   * Unmemoizing is not a realiable process.  You can not in general   * Unmemoizing is not a reliable process.  You cannot in general
1314   * expect to get the original source back.   * expect to get the original source back.
1315   *   *
1316   * However, GOOPS currently relies on this for method compilation.   * However, GOOPS currently relies on this for method compilation.
# Line 2018  dispatch: Line 2003  dispatch:
2003        x = SCM_CDR (x);        x = SCM_CDR (x);
2004        while (!SCM_NULLP (SCM_CDR (x)))        while (!SCM_NULLP (SCM_CDR (x)))
2005          {          {
2006            if (SCM_FALSEP (EVALCAR (x, env)))            if (SCM_FALSEP (t.arg1 = EVALCAR (x, env)) || SCM_NILP (t.arg1))
2007              RETURN (SCM_BOOL_F);              RETURN (SCM_BOOL_F);
2008            else            else
2009              x = SCM_CDR (x);              x = SCM_CDR (x);
# Line 2129  dispatch: Line 2114  dispatch:
2114                goto begin;                goto begin;
2115              }              }
2116            t.arg1 = EVALCAR (proc, env);            t.arg1 = EVALCAR (proc, env);
2117            if (!SCM_FALSEP (t.arg1))            if (!SCM_FALSEP (t.arg1) && !SCM_NILP (t.arg1))
2118              {              {
2119                x = SCM_CDR (proc);                x = SCM_CDR (proc);
2120                if (SCM_NULLP (x))                if (SCM_NULLP (x))
# Line 2164  dispatch: Line 2149  dispatch:
2149          }          }
2150        env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);        env = EXTEND_ENV (SCM_CAR (x), t.arg1, env);
2151        x = SCM_CDDR (x);        x = SCM_CDDR (x);
2152        while (proc = SCM_CAR (x), SCM_FALSEP (EVALCAR (proc, env)))        while (proc = SCM_CAR (x),
2153                 SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) || SCM_NILP (t.arg1))
2154          {          {
2155            for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))            for (proc = SCM_CADR (x); SCM_NIMP (proc); proc = SCM_CDR (proc))
2156              {              {
# Line 2186  dispatch: Line 2172  dispatch:
2172    
2173      case SCM_BIT8(SCM_IM_IF):      case SCM_BIT8(SCM_IM_IF):
2174        x = SCM_CDR (x);        x = SCM_CDR (x);
2175        if (!SCM_FALSEP (EVALCAR (x, env)))        if (!SCM_FALSEP (t.arg1 = EVALCAR (x, env)) && !SCM_NILP (t.arg1))
2176          x = SCM_CDR (x);          x = SCM_CDR (x);
2177        else if (SCM_IMP (x = SCM_CDDR (x)))        else if (SCM_IMP (x = SCM_CDDR (x)))
2178          RETURN (SCM_UNSPECIFIED);          RETURN (SCM_UNSPECIFIED);
# Line 2249  dispatch: Line 2235  dispatch:
2235        while (!SCM_NULLP (SCM_CDR (x)))        while (!SCM_NULLP (SCM_CDR (x)))
2236          {          {
2237            SCM val = EVALCAR (x, env);            SCM val = EVALCAR (x, env);
2238            if (!SCM_FALSEP (val))            if (!SCM_FALSEP (val) && !SCM_NILP (val))
2239              RETURN (val);              RETURN (val);
2240            else            else
2241              x = SCM_CDR (x);              x = SCM_CDR (x);
# Line 2477  dispatch: Line 2463  dispatch:
2463            SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))]            SCM_STRUCT_DATA (t.arg1) [SCM_INUM (SCM_CAR (x))]
2464              = SCM_UNPACK (EVALCAR (proc, env));              = SCM_UNPACK (EVALCAR (proc, env));
2465            RETURN (SCM_UNSPECIFIED);            RETURN (SCM_UNSPECIFIED);
2466    
2467    #ifdef SCM_ENABLE_ELISP
2468                        
2469          case (SCM_ISYMNUM (SCM_IM_NIL_COND)):          case (SCM_ISYMNUM (SCM_IM_NIL_COND)):
2470            proc = SCM_CDR (x);            proc = SCM_CDR (x);
2471            while (SCM_NIMP (x = SCM_CDR (proc)))            while (SCM_NIMP (x = SCM_CDR (proc)))
2472              {              {
2473                if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))                if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
2474                      || SCM_EQ_P (t.arg1, scm_lisp_nil)))                      || SCM_NILP (t.arg1)
2475                  {                      || SCM_NULLP (t.arg1)))
                   if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))  
                     RETURN (t.arg1);  
                   PREP_APPLY (SCM_UNDEFINED, SCM_EOL);  
                   goto carloop;  
                 }  
               proc = SCM_CDR (x);  
             }  
           x = proc;  
           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);  
           goto carloop;  
   
         case (SCM_ISYMNUM (SCM_IM_NIL_IFY)):  
           x = SCM_CDR (x);  
           RETURN ((SCM_FALSEP (proc = EVALCAR (x, env)) || SCM_NULLP (proc))  
                   ? scm_lisp_nil  
                   : proc);  
               
         case (SCM_ISYMNUM (SCM_IM_T_IFY)):  
           x = SCM_CDR (x);  
           RETURN (!SCM_FALSEP (EVALCAR (x, env)) ? scm_lisp_t : scm_lisp_nil);  
               
         case (SCM_ISYMNUM (SCM_IM_0_COND)):  
           proc = SCM_CDR (x);  
           while (SCM_NIMP (x = SCM_CDR (proc)))  
             {  
               if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))  
                     || SCM_EQ_P (t.arg1, SCM_INUM0)))  
2476                  {                  {
2477                    if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))                    if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
2478                      RETURN (t.arg1);                      RETURN (t.arg1);
# Line 2524  dispatch: Line 2485  dispatch:
2485            PREP_APPLY (SCM_UNDEFINED, SCM_EOL);            PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
2486            goto carloop;            goto carloop;
2487    
2488          case (SCM_ISYMNUM (SCM_IM_0_IFY)):  #endif /* SCM_ENABLE_ELISP */
           x = SCM_CDR (x);  
           RETURN (SCM_FALSEP (proc = EVALCAR (x, env))  
                   ? SCM_INUM0  
                   : proc);  
               
         case (SCM_ISYMNUM (SCM_IM_1_IFY)):  
           x = SCM_CDR (x);  
           RETURN (!SCM_FALSEP (EVALCAR (x, env))  
                   ? SCM_MAKINUM (1)  
                   : SCM_INUM0);  
2489    
2490          case (SCM_ISYMNUM (SCM_IM_BIND)):          case (SCM_ISYMNUM (SCM_IM_BIND)):
2491            {            {
# Line 2568  dispatch: Line 2519  dispatch:
2519    
2520              RETURN (proc);              RETURN (proc);
2521            }            }
2522              
2523          case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):          case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
2524            {            {
2525              proc = SCM_CDR (x);              proc = SCM_CDR (x);
# Line 3388  SCM_DEFINE (scm_nconc2last, "apply:nconc Line 3339  SCM_DEFINE (scm_nconc2last, "apply:nconc
3339    SCM *lloc;    SCM *lloc;
3340    SCM_VALIDATE_NONEMPTYLIST (1,lst);    SCM_VALIDATE_NONEMPTYLIST (1,lst);
3341    lloc = &lst;    lloc = &lst;
3342    while (!SCM_NULLP (SCM_CDR (*lloc)))    while (!SCM_NULLP (SCM_CDR (*lloc))) /* Perhaps should be
3343                                              SCM_NULL_OR_NIL_P, but not
3344                                              needed in 99.99% of cases,
3345                                              and it could seriously hurt
3346                                              performance. - Neil */
3347      lloc = SCM_CDRLOC (*lloc);      lloc = SCM_CDRLOC (*lloc);
3348    SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);    SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
3349    *lloc = SCM_CAR (*lloc);    *lloc = SCM_CAR (*lloc);
# Line 3846  scm_for_each (SCM proc, SCM arg1, SCM ar Line 3801  scm_for_each (SCM proc, SCM arg1, SCM ar
3801    SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),    SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
3802                  SCM_ARG2, s_for_each);                  SCM_ARG2, s_for_each);
3803    SCM_VALIDATE_REST_ARGUMENT (args);    SCM_VALIDATE_REST_ARGUMENT (args);
3804    if SCM_NULLP (args)    if (SCM_NULLP (args))
3805      {      {
3806        while SCM_NIMP (arg1)        while (SCM_NIMP (arg1))
3807          {          {
3808            scm_apply (proc, SCM_CAR (arg1), scm_listofnull);            scm_apply (proc, SCM_CAR (arg1), scm_listofnull);
3809            arg1 = SCM_CDR (arg1);            arg1 = SCM_CDR (arg1);
# Line 3865  scm_for_each (SCM proc, SCM arg1, SCM ar Line 3820  scm_for_each (SCM proc, SCM arg1, SCM ar
3820        arg1 = SCM_EOL;        arg1 = SCM_EOL;
3821        for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)        for (i = SCM_VECTOR_LENGTH (args) - 1; i >= 0; i--)
3822          {          {
3823            if SCM_IMP            if (SCM_IMP (ve[i]))
3824              (ve[i]) return SCM_UNSPECIFIED;              return SCM_UNSPECIFIED;
3825            arg1 = scm_cons (SCM_CAR (ve[i]), arg1);            arg1 = scm_cons (SCM_CAR (ve[i]), arg1);
3826            ve[i] = SCM_CDR (ve[i]);            ve[i] = SCM_CDR (ve[i]);
3827          }          }
# Line 4182  scm_init_eval () Line 4137  scm_init_eval ()
4137  #ifndef SCM_MAGIC_SNARFER  #ifndef SCM_MAGIC_SNARFER
4138  #include "libguile/eval.x"  #include "libguile/eval.x"
4139  #endif  #endif
   
   scm_c_define ("nil", scm_lisp_nil);  
   scm_c_define ("t", scm_lisp_t);  
4140        
4141    scm_add_feature ("delay");    scm_add_feature ("delay");
4142  }  }

Legend:
Removed from v.1.253  
changed lines
  Added in v.1.254

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