/[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.344 by dirk, Sat Nov 15 12:43:00 2003 UTC revision 1.345 by dirk, Sun Nov 16 10:47:45 2003 UTC
# Line 219  static const char s_bad_formal[] = "Bad Line 219  static const char s_bad_formal[] = "Bad
219   * more than once, a 'Duplicate formal' error is signalled.  */   * more than once, a 'Duplicate formal' error is signalled.  */
220  static const char s_duplicate_formal[] = "Duplicate formal";  static const char s_duplicate_formal[] = "Duplicate formal";
221    
222    /* If the evaluation of an unquote-splicing expression gives something else
223     * than a proper list, a 'Non-list result for unquote-splicing' error is
224     * signalled.  */
225    static const char s_splicing[] = "Non-list result for unquote-splicing";
226    
227  /* If something else than an exact integer is detected as the argument for  /* If something else than an exact integer is detected as the argument for
228   * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled.  */   * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled.  */
229  static const char s_bad_slot_number[] = "Bad slot number";  static const char s_bad_slot_number[] = "Bad slot number";
# Line 358  SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", Line 363  SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?",
363    
364    
365    
366  #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \  /* The function lookup_symbol is used during memoization:  Lookup the symbol
367    ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)   * in the environment.  If there is no binding for the symbol, SCM_UNDEFINED
368     * is returned.  If the symbol is a syntactic keyword, the macro object to
369     * which the symbol is bound is returned.  If the symbol is a global variable,
370     * the variable object to which the symbol is bound is returned.  Finally, if
371     * the symbol is a local variable the corresponding iloc object is returned.
372     */
373    
374    /* A helper function for lookup_symbol: Try to find the symbol in the top
375     * level environment frame.  The function returns SCM_UNDEFINED if the symbol
376     * is unbound, it returns a macro object if the symbol is a syntactic keyword
377     * and it returns a variable object if the symbol is a global variable.  */
378    static SCM
379    lookup_global_symbol (const SCM symbol, const SCM top_level)
380    {
381      const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
382      if (SCM_FALSEP (variable))
383        {
384          return SCM_UNDEFINED;
385        }
386      else
387        {
388          const SCM value = SCM_VARIABLE_REF (variable);
389          if (SCM_MACROP (value))
390            return value;
391          else
392            return variable;
393        }
394    }
395    
396    static SCM
397    lookup_symbol (const SCM symbol, const SCM env)
398    {
399      SCM frame_idx;
400      unsigned int frame_nr;
401    
402      for (frame_idx = env, frame_nr = 0;
403           !SCM_NULLP (frame_idx);
404           frame_idx = SCM_CDR (frame_idx), ++frame_nr)
405        {
406          const SCM frame = SCM_CAR (frame_idx);
407          if (SCM_CONSP (frame))
408            {
409              /* frame holds a local environment frame */
410              SCM symbol_idx;
411              unsigned int symbol_nr;
412    
413              for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
414                   SCM_CONSP (symbol_idx);
415                   symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
416                {
417                  if (SCM_EQ_P (SCM_CAR (symbol_idx), symbol))
418                    /* found the symbol, therefore return the iloc */
419                    return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
420                }
421              if (SCM_EQ_P (symbol_idx, symbol))
422                /* found the symbol as the last element of the current frame */
423                return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
424            }
425          else
426            {
427              /* no more local environment frames */
428              return lookup_global_symbol (symbol, frame);
429            }
430        }
431    
432      return lookup_global_symbol (symbol, SCM_BOOL_F);
433    }
434    
435    
436    /* Return true if the symbol is - from the point of view of a macro
437     * transformer - a literal in the sense specified in chapter "pattern
438     * language" of R5RS.  In the code below, however, we don't match the
439     * definition of R5RS exactly:  It returns true if the identifier has no
440     * binding or if it is a syntactic keyword.  */
441    static int
442    literal_p (const SCM symbol, const SCM env)
443    {
444      const SCM value = lookup_symbol (symbol, env);
445      if (SCM_UNBNDP (value) || SCM_MACROP (value))
446        return 1;
447      else
448        return 0;
449    }
450    
451    
452    
# Line 423  SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", Line 510  SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?",
510  SCM_REC_MUTEX (source_mutex);  SCM_REC_MUTEX (source_mutex);
511    
512    
 static const char s_test[] = "bad test";  
 static const char s_bindings[] = "bad bindings";  
 static const char s_duplicate_bindings[] = "duplicate bindings";  
 static const char s_variable[] = "bad variable";  
 static const char s_splicing[] = "bad (non-list) result for unquote-splicing";  
   
   
513  /* Lookup a given local variable in an environment.  The local variable is  /* Lookup a given local variable in an environment.  The local variable is
514   * given as an iloc, that is a triple <frame, binding, last?>, where frame   * given as an iloc, that is a triple <frame, binding, last?>, where frame
515   * indicates the relative number of the environment frame (counting upwards   * indicates the relative number of the environment frame (counting upwards
# Line 652  scm_lookupcar (SCM vloc, SCM genv, int c Line 732  scm_lookupcar (SCM vloc, SCM genv, int c
732    return loc;    return loc;
733  }  }
734    
 /* Return true if the symbol is - from the point of view of a macro  
  * transformer - a literal in the sense specified in chapter "pattern  
  * language" of R5RS.  In the code below, however, we don't match the  
  * definition of R5RS exactly:  It returns true if the identifier has no  
  * binding or if it is a syntactic keyword.  */  
 static int  
 literal_p (const SCM symbol, const SCM env)  
 {  
   const SCM x = scm_cons (symbol, SCM_UNDEFINED);  
   const SCM value = *scm_lookupcar (x, env, 0);  
   if (SCM_UNBNDP (value) || SCM_MACROP (value))  
     return 1;  
   else  
     return 0;  
 }  
   
735    
736  SCM  SCM
737  scm_eval_car (SCM pair, SCM env)  scm_eval_car (SCM pair, SCM env)
# Line 676  scm_eval_car (SCM pair, SCM env) Line 740  scm_eval_car (SCM pair, SCM env)
740  }  }
741    
742    
 /*  
  * The following rewrite expressions and  
  * some memoized forms have different syntax  
  */  
   
 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");  
 SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");  
 SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");  
   
 SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");  
 SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");  
 SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");  
 SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");  
   
743    
744  /* Rewrite the body (which is given as the list of expressions forming the  /* Rewrite the body (which is given as the list of expressions forming the
745   * body) into its internal form.  The internal form of a body (<expr> ...) is   * body) into its internal form.  The internal form of a body (<expr> ...) is
# Line 724  try_macro_lookup (const SCM expr, const Line 774  try_macro_lookup (const SCM expr, const
774  {  {
775    if (SCM_SYMBOLP (expr))    if (SCM_SYMBOLP (expr))
776      {      {
777        const SCM tmp_pair = scm_list_1 (expr);        const SCM value = lookup_symbol (expr, env);
       const SCM value = *scm_lookupcar1 (tmp_pair, env, 0);  
778        return value;        return value;
779      }      }
780    else    else
# Line 969  scm_m_begin (SCM expr, SCM env SCM_UNUSE Line 1018  scm_m_begin (SCM expr, SCM env SCM_UNUSE
1018    
1019  SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);  SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
1020  SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);  SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
1021    SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
1022    
1023  SCM  SCM
1024  scm_m_case (SCM expr, SCM env)  scm_m_case (SCM expr, SCM env)
# Line 1618  scm_m_or (SCM expr, SCM env SCM_UNUSED) Line 1668  scm_m_or (SCM expr, SCM env SCM_UNUSED)
1668    
1669  SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);  SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
1670  SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);  SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
1671    SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
1672    SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
1673    
1674  /* Internal function to handle a quasiquotation:  'form' is the parameter in  /* Internal function to handle a quasiquotation:  'form' is the parameter in
1675   * the call (quasiquotation form), 'env' is the environment where unquoted   * the call (quasiquotation form), 'env' is the environment where unquoted
# Line 2046  scm_m_undefine (SCM expr, SCM env) Line 2098  scm_m_undefine (SCM expr, SCM env)
2098  #endif  #endif
2099    
2100    
2101    #if (SCM_ENABLE_DEPRECATED == 1)
2102    
2103  SCM  SCM
2104  scm_macroexp (SCM x, SCM env)  scm_macroexp (SCM x, SCM env)
2105  {  {
# Line 2090  scm_macroexp (SCM x, SCM env) Line 2144  scm_macroexp (SCM x, SCM env)
2144    goto macro_tail;    goto macro_tail;
2145  }  }
2146    
2147    #endif
2148    
2149    /*****************************************************************************/
2150    /*****************************************************************************/
2151    /*               The definitions for unmemoization start here.               */
2152    /*****************************************************************************/
2153    /*****************************************************************************/
2154    
2155  #define SCM_BIT7(x) (127 & SCM_UNPACK (x))  #define SCM_BIT7(x) (127 & SCM_UNPACK (x))
2156    
2157  /* A function object to implement "apply" for non-closure functions.  */  SCM_SYMBOL (sym_three_question_marks, "???");
 static SCM f_apply;  
 /* An endless list consisting of #<undefined> objects:  */  
 static SCM undefineds;  
2158    
2159    
2160  /* scm_unmemocopy takes a memoized expression together with its  /* scm_unmemocopy takes a memoized expression together with its
# Line 2128  build_binding_list (SCM rnames, SCM rini Line 2187  build_binding_list (SCM rnames, SCM rini
2187  }  }
2188    
2189    
2190  SCM_SYMBOL (sym_three_question_marks, "???");  static SCM
2191    unmemocar (SCM form, SCM env)
 #define unmemocar scm_unmemocar  
   
 SCM  
 scm_unmemocar (SCM form, SCM env)  
2192  {  {
2193    if (!SCM_CONSP (form))    if (!SCM_CONSP (form))
2194      return form;      return form;
# Line 2162  scm_unmemocar (SCM form, SCM env) Line 2217  scm_unmemocar (SCM form, SCM env)
2217      }      }
2218  }  }
2219    
2220    
2221    #if (SCM_ENABLE_DEPRECATED == 1)
2222    
2223    SCM
2224    scm_unmemocar (SCM form, SCM env)
2225    {
2226      return unmemocar (form, env);
2227    }
2228    
2229    #endif
2230    
2231    
2232  static SCM  static SCM
2233  unmemocopy (SCM x, SCM env)  unmemocopy (SCM x, SCM env)
2234  {  {
# Line 2396  loop: Line 2463  loop:
2463    return ls;    return ls;
2464  }  }
2465    
   
2466  SCM  SCM
2467  scm_unmemocopy (SCM x, SCM env)  scm_unmemocopy (SCM x, SCM env)
2468  {  {
# Line 2409  scm_unmemocopy (SCM x, SCM env) Line 2475  scm_unmemocopy (SCM x, SCM env)
2475  }  }
2476    
2477    
2478  int  /*****************************************************************************/
2479    /*****************************************************************************/
2480    /*                 The definitions for execution start here.                 */
2481    /*****************************************************************************/
2482    /*****************************************************************************/
2483    
2484    SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
2485    SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
2486    SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
2487    SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
2488    
2489    /* A function object to implement "apply" for non-closure functions.  */
2490    static SCM f_apply;
2491    /* An endless list consisting of #<undefined> objects:  */
2492    static SCM undefineds;
2493    
2494    
2495    int
2496  scm_badargsp (SCM formals, SCM args)  scm_badargsp (SCM formals, SCM args)
2497  {  {
2498    while (!SCM_NULLP (formals))    while (!SCM_NULLP (formals))
# Line 2667  deval_args (SCM l, SCM env, SCM proc, SC Line 2750  deval_args (SCM l, SCM env, SCM proc, SC
2750    } while (0)    } while (0)
2751    
2752    
2753    #define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
2754      ASSERT_SYNTAX (!SCM_EQ_P ((x), SCM_EOL), s_empty_combination, x)
2755    
2756    
2757  /* This is the evaluator.  Like any real monster, it has three heads:  /* This is the evaluator.  Like any real monster, it has three heads:
2758   *   *
2759   * scm_ceval is the non-debugging evaluator, scm_deval is the debugging   * scm_ceval is the non-debugging evaluator, scm_deval is the debugging

Legend:
Removed from v.1.344  
changed lines
  Added in v.1.345

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