/[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.281 by mdj, Mon Dec 9 13:42:58 2002 UTC revision 1.282 by mdj, Sun Dec 15 14:24:34 2002 UTC
# Line 152  char *alloca (); Line 152  char *alloca ();
152    
153  #define EXTEND_ENV SCM_EXTEND_ENV  #define EXTEND_ENV SCM_EXTEND_ENV
154    
155  SCM_REC_CRITICAL_SECTION (source);  SCM_REC_MUTEX (source_mutex);
 #define SOURCE_SECTION_START SCM_REC_CRITICAL_SECTION_START (source);  
 #define SOURCE_SECTION_END SCM_REC_CRITICAL_SECTION_END (source);  
156    
157  SCM *  SCM *
158  scm_ilookup (SCM iloc, SCM env)  scm_ilookup (SCM iloc, SCM env)
# Line 820  scm_m_delay (SCM xorig, SCM env SCM_UNUS Line 818  scm_m_delay (SCM xorig, SCM env SCM_UNUS
818  }  }
819    
820    
821    SCM_SYNTAX (s_future, "future", scm_makmmacro, scm_m_future);
822    SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
823    
824    /* Like promises, futures are implemented as closures with an empty
825     * parameter list.  Thus, (future <expression>) is transformed into
826     * (#@future '() <expression>), where the empty list represents the
827     * empty parameter list.  This representation allows for easy creation
828     * of the closure during evaluation.  */
829    SCM
830    scm_m_future (SCM xorig, SCM env SCM_UNUSED)
831    {
832      SCM_ASSYNT (scm_ilength (xorig) == 2, scm_s_expression, s_future);
833      return scm_cons2 (SCM_IM_FUTURE, SCM_EOL, SCM_CDR (xorig));
834    }
835    
836    
837  SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);  SCM_SYNTAX(s_define, "define", scm_makmmacro, scm_m_define);
838  SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);  SCM_GLOBAL_SYMBOL(scm_sym_define, s_define);
839    
# Line 1476  unmemocopy (SCM x, SCM env) Line 1490  unmemocopy (SCM x, SCM env)
1490            ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);            ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
1491            x = SCM_CDR (x);            x = SCM_CDR (x);
1492            goto loop;            goto loop;
1493            case (SCM_ISYMNUM (SCM_IM_FUTURE)):
1494              ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
1495              x = SCM_CDR (x);
1496              goto loop;
1497          case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):          case (SCM_ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
1498            ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);            ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
1499            goto loop;            goto loop;
# Line 1584  scm_eval_body (SCM code, SCM env) Line 1602  scm_eval_body (SCM code, SCM env)
1602          {          {
1603            if (SCM_ISYMP (SCM_CAR (code)))            if (SCM_ISYMP (SCM_CAR (code)))
1604              {              {
1605                SOURCE_SECTION_START;                scm_rec_mutex_lock (&source_mutex);
1606                /* check for race condition */                /* check for race condition */
1607                if (SCM_ISYMP (SCM_CAR (code)))                if (SCM_ISYMP (SCM_CAR (code)))
1608                  code = scm_m_expand_body (code, env);                  code = scm_m_expand_body (code, env);
1609                SOURCE_SECTION_END;                scm_rec_mutex_unlock (&source_mutex);
1610                goto again;                goto again;
1611              }              }
1612          }          }
# Line 1987  dispatch: Line 2005  dispatch:
2005              {              {
2006                if (SCM_ISYMP (form))                if (SCM_ISYMP (form))
2007                  {                  {
2008                    SOURCE_SECTION_START;                    scm_rec_mutex_lock (&source_mutex);
2009                    /* check for race condition */                    /* check for race condition */
2010                    if (SCM_ISYMP (SCM_CAR (x)))                    if (SCM_ISYMP (SCM_CAR (x)))
2011                      x = scm_m_expand_body (x, env);                      x = scm_m_expand_body (x, env);
2012                    SOURCE_SECTION_END;                    scm_rec_mutex_unlock (&source_mutex);
2013                    goto nontoplevel_begin;                    goto nontoplevel_begin;
2014                  }                  }
2015                else                else
# Line 2373  dispatch: Line 2391  dispatch:
2391            RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));            RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
2392    
2393    
2394            case (SCM_ISYMNUM (SCM_IM_FUTURE)):
2395              RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
2396    
2397    
2398          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):          case (SCM_ISYMNUM (SCM_IM_DISPATCH)):
2399            {            {
2400              /* If not done yet, evaluate the operand forms.  The result is a              /* If not done yet, evaluate the operand forms.  The result is a
# Line 3646  tail: Line 3668  tail:
3668              {              {
3669                if (SCM_ISYMP (SCM_CAR (proc)))                if (SCM_ISYMP (SCM_CAR (proc)))
3670                  {                  {
3671                    SOURCE_SECTION_START;                    scm_rec_mutex_lock (&source_mutex);
3672                    /* check for race condition */                    /* check for race condition */
3673                    if (SCM_ISYMP (SCM_CAR (proc)))                    if (SCM_ISYMP (SCM_CAR (proc)))
3674                      proc = scm_m_expand_body (proc, args);                      proc = scm_m_expand_body (proc, args);
3675                    SOURCE_SECTION_END;                    scm_rec_mutex_unlock (&source_mutex);
3676                    goto again;                    goto again;
3677                  }                  }
3678                else                else
# Line 4139  scm_t_bits scm_tc16_promise; Line 4161  scm_t_bits scm_tc16_promise;
4161  SCM  SCM
4162  scm_makprom (SCM code)  scm_makprom (SCM code)
4163  {  {
4164    SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code));    SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
4165                           SCM_UNPACK (code),
4166                           scm_make_rec_mutex ());
4167  }  }
4168    
4169    static size_t
4170    promise_free (SCM promise)
4171    {
4172      scm_rec_mutex_free (SCM_PROMISE_MUTEX (promise));
4173      return 0;
4174    }
4175    
4176  static int  static int
4177  promise_print (SCM exp, SCM port, scm_print_state *pstate)  promise_print (SCM exp, SCM port, scm_print_state *pstate)
# Line 4150  promise_print (SCM exp, SCM port, scm_pr Line 4179  promise_print (SCM exp, SCM port, scm_pr
4179    int writingp = SCM_WRITINGP (pstate);    int writingp = SCM_WRITINGP (pstate);
4180    scm_puts ("#<promise ", port);    scm_puts ("#<promise ", port);
4181    SCM_SET_WRITINGP (pstate, 1);    SCM_SET_WRITINGP (pstate, 1);
4182    scm_iprin1 (SCM_CELL_OBJECT_1 (exp), port, pstate);    scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
4183    SCM_SET_WRITINGP (pstate, writingp);    SCM_SET_WRITINGP (pstate, writingp);
4184    scm_putc ('>', port);    scm_putc ('>', port);
4185    return !0;    return !0;
4186  }  }
4187    
   
4188  SCM_DEFINE (scm_force, "force", 1, 0, 0,  SCM_DEFINE (scm_force, "force", 1, 0, 0,
4189              (SCM x),              (SCM promise),
4190              "If the promise @var{x} has not been computed yet, compute and\n"              "If the promise @var{x} has not been computed yet, compute and\n"
4191              "return @var{x}, otherwise just return the previously computed\n"              "return @var{x}, otherwise just return the previously computed\n"
4192              "value.")              "value.")
4193  #define FUNC_NAME s_scm_force  #define FUNC_NAME s_scm_force
4194  {  {
4195    SCM_VALIDATE_SMOB (1, x, promise);    SCM_VALIDATE_SMOB (1, promise, promise);
4196    if (!((1L << 16) & SCM_CELL_WORD_0 (x)))    scm_rec_mutex_lock (SCM_PROMISE_MUTEX (promise));
4197      if (!SCM_PROMISE_COMPUTED_P (promise))
4198      {      {
4199        SCM ans = scm_call_0 (SCM_CELL_OBJECT_1 (x));        SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
4200        if (!((1L << 16) & SCM_CELL_WORD_0 (x)))        if (!SCM_PROMISE_COMPUTED_P (promise))
4201          {          {
4202            SCM_DEFER_INTS;            SCM_SET_PROMISE_DATA (promise, ans);
4203            SCM_SET_CELL_OBJECT_1 (x, ans);            SCM_SET_PROMISE_COMPUTED (promise);
           SCM_SET_CELL_WORD_0 (x, SCM_CELL_WORD_0 (x) | (1L << 16));  
           SCM_ALLOW_INTS;  
4204          }          }
4205      }      }
4206    return SCM_CELL_OBJECT_1 (x);    scm_rec_mutex_unlock (SCM_PROMISE_MUTEX (promise));
4207      return SCM_PROMISE_DATA (promise);
4208  }  }
4209  #undef FUNC_NAME  #undef FUNC_NAME
4210    
# Line 4413  scm_init_eval () Line 4441  scm_init_eval ()
4441        
4442    scm_tc16_promise = scm_make_smob_type ("promise", 0);    scm_tc16_promise = scm_make_smob_type ("promise", 0);
4443    scm_set_smob_mark (scm_tc16_promise, scm_markcdr);    scm_set_smob_mark (scm_tc16_promise, scm_markcdr);
4444      scm_set_smob_free (scm_tc16_promise, promise_free);
4445    scm_set_smob_print (scm_tc16_promise, promise_print);    scm_set_smob_print (scm_tc16_promise, promise_print);
4446    
4447    /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */    /* Dirk:Fixme:: make scm_undefineds local to eval.c: it's only used here. */

Legend:
Removed from v.1.281  
changed lines
  Added in v.1.282

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