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

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

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

revision 1.57 by mdj, Fri Jan 10 12:58:40 2003 UTC revision 1.58 by mdj, Thu Mar 6 12:50:41 2003 UTC
# Line 1682  SCM_DEFINE (scm_primitive_generic_generi Line 1682  SCM_DEFINE (scm_primitive_generic_generi
1682  {  {
1683    if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))    if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
1684      {      {
1685        SCM gf = *SCM_SUBR_GENERIC (subr);        if (!*SCM_SUBR_GENERIC (subr))
1686        if (gf)          scm_enable_primitive_generic_x (scm_list_1 (subr));
1687          return gf;        return *SCM_SUBR_GENERIC (subr);
1688      }      }
1689    SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);    SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
1690  }  }
1691  #undef FUNC_NAME  #undef FUNC_NAME
1692    
1693    typedef struct t_extension {
1694      struct t_extension *next;
1695      SCM extended;
1696      SCM extension;
1697    } t_extension;
1698    
1699    static t_extension *extensions = 0;
1700    
1701    SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
1702    
1703    void
1704    scm_c_extend_primitive_generic (SCM extended, SCM extension)
1705    {
1706      if (goops_loaded_p)
1707        {
1708          SCM gf, gext;
1709          if (!*SCM_SUBR_GENERIC (extended))
1710            scm_enable_primitive_generic_x (scm_list_1 (extended));
1711          gf = *SCM_SUBR_GENERIC (extended);
1712          gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
1713                             gf,
1714                             SCM_SNAME (extension));
1715          *SCM_SUBR_GENERIC (extension) = gext;
1716        }
1717      else
1718        {
1719          t_extension *e = scm_malloc (sizeof (t_extension));
1720          t_extension **loc = &extensions;
1721          /* Make sure that extensions are placed before their own
1722           * extensions in the extensions list.  O(N^2) algorithm, but
1723           * extensions of primitive generics are rare.
1724           */
1725          while (*loc && extension != (*loc)->extended)
1726            loc = &(*loc)->next;
1727          e->next = *loc;
1728          e->extended = extended;
1729          e->extension = extension;
1730          *loc = e;
1731        }
1732    }
1733    
1734    static void
1735    setup_extended_primitive_generics ()
1736    {
1737      while (extensions)
1738        {
1739          t_extension *e = extensions;
1740          scm_c_extend_primitive_generic (e->extended, e->extension);
1741          extensions = e->next;
1742          free (e);
1743        }
1744    }
1745    
1746  /******************************************************************************  /******************************************************************************
1747   *   *
1748   * Protocol for calling a generic fumction   * Protocol for calling a generic fumction
# Line 2694  SCM_DEFINE (scm_sys_goops_loaded, "%goop Line 2747  SCM_DEFINE (scm_sys_goops_loaded, "%goop
2747    var_compute_applicable_methods =    var_compute_applicable_methods =
2748      scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,      scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
2749                   SCM_BOOL_F);                   SCM_BOOL_F);
2750      setup_extended_primitive_generics ();
2751    return SCM_UNSPECIFIED;    return SCM_UNSPECIFIED;
2752  }  }
2753  #undef FUNC_NAME  #undef FUNC_NAME

Legend:
Removed from v.1.57  
changed lines
  Added in v.1.58

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