procprop.c 5.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216
  1. /* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
  2. *
  3. * This library is free software; you can redistribute it and/or
  4. * modify it under the terms of the GNU Lesser General Public License
  5. * as published by the Free Software Foundation; either version 3 of
  6. * the License, or (at your option) any later version.
  7. *
  8. * This library is distributed in the hope that it will be useful, but
  9. * WITHOUT ANY WARRANTY; without even the implied warranty of
  10. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. * Lesser General Public License for more details.
  12. *
  13. * You should have received a copy of the GNU Lesser General Public
  14. * License along with this library; if not, write to the Free Software
  15. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. * 02110-1301 USA
  17. */
  18. #ifdef HAVE_CONFIG_H
  19. # include <config.h>
  20. #endif
  21. #include "libguile/_scm.h"
  22. #include "libguile/alist.h"
  23. #include "libguile/eval.h"
  24. #include "libguile/procs.h"
  25. #include "libguile/gsubr.h"
  26. #include "libguile/smob.h"
  27. #include "libguile/root.h"
  28. #include "libguile/vectors.h"
  29. #include "libguile/weak-table.h"
  30. #include "libguile/programs.h"
  31. #include "libguile/validate.h"
  32. #include "libguile/procprop.h"
  33. SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
  34. SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  35. static SCM overrides;
  36. static SCM arity_overrides;
  37. int
  38. scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
  39. {
  40. SCM o;
  41. o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F);
  42. if (scm_is_true (o))
  43. {
  44. *req = scm_to_int (scm_car (o));
  45. *opt = scm_to_int (scm_cadr (o));
  46. *rest = scm_is_true (scm_caddr (o));
  47. return 1;
  48. }
  49. while (!SCM_PROGRAM_P (proc))
  50. {
  51. if (SCM_STRUCTP (proc))
  52. {
  53. if (!SCM_STRUCT_APPLICABLE_P (proc))
  54. return 0;
  55. proc = SCM_STRUCT_PROCEDURE (proc);
  56. }
  57. else if (SCM_HAS_TYP7 (proc, scm_tc7_smob))
  58. {
  59. if (!SCM_SMOB_APPLICABLE_P (proc))
  60. return 0;
  61. proc = scm_i_smob_apply_trampoline (proc);
  62. }
  63. else
  64. return 0;
  65. }
  66. return scm_i_program_arity (proc, req, opt, rest);
  67. }
  68. SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!",
  69. 4, 0, 0, (SCM proc, SCM req, SCM opt, SCM rest),
  70. "")
  71. #define FUNC_NAME s_scm_set_procedure_minimum_arity_x
  72. {
  73. int t SCM_UNUSED;
  74. SCM_VALIDATE_PROC (1, proc);
  75. SCM_VALIDATE_INT_COPY (2, req, t);
  76. SCM_VALIDATE_INT_COPY (3, opt, t);
  77. SCM_VALIDATE_BOOL (4, rest);
  78. scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest));
  79. return SCM_UNDEFINED;
  80. }
  81. #undef FUNC_NAME
  82. SCM_DEFINE (scm_procedure_minimum_arity, "procedure-minimum-arity", 1, 0, 0,
  83. (SCM proc),
  84. "Return the \"minimum arity\" of a procedure.\n\n"
  85. "If the procedure has only one arity, that arity is returned\n"
  86. "as a list of three values: the number of required arguments,\n"
  87. "the number of optional arguments, and a boolean indicating\n"
  88. "whether or not the procedure takes rest arguments.\n\n"
  89. "For a case-lambda procedure, the arity returned is the one\n"
  90. "with the lowest minimum number of arguments, and the highest\n"
  91. "maximum number of arguments.\n\n"
  92. "If it was not possible to determine the arity of the procedure,\n"
  93. "@code{#f} is returned.")
  94. #define FUNC_NAME s_scm_procedure_minimum_arity
  95. {
  96. int req, opt, rest;
  97. if (scm_i_procedure_arity (proc, &req, &opt, &rest))
  98. return scm_list_3 (scm_from_int (req),
  99. scm_from_int (opt),
  100. scm_from_bool (rest));
  101. else
  102. return SCM_BOOL_F;
  103. }
  104. #undef FUNC_NAME
  105. SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
  106. (SCM proc),
  107. "Return @var{proc}'s property list.")
  108. #define FUNC_NAME s_scm_procedure_properties
  109. {
  110. SCM ret;
  111. SCM_VALIDATE_PROC (1, proc);
  112. ret = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
  113. if (scm_is_false (ret))
  114. {
  115. if (SCM_PROGRAM_P (proc))
  116. ret = scm_i_program_properties (proc);
  117. else
  118. ret = SCM_EOL;
  119. }
  120. return ret;
  121. }
  122. #undef FUNC_NAME
  123. SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
  124. (SCM proc, SCM alist),
  125. "Set @var{proc}'s property list to @var{alist}.")
  126. #define FUNC_NAME s_scm_set_procedure_properties_x
  127. {
  128. SCM_VALIDATE_PROC (1, proc);
  129. scm_weak_table_putq_x (overrides, proc, alist);
  130. return SCM_UNSPECIFIED;
  131. }
  132. #undef FUNC_NAME
  133. SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
  134. (SCM proc, SCM key),
  135. "Return the property of @var{proc} with name @var{key}.")
  136. #define FUNC_NAME s_scm_procedure_property
  137. {
  138. SCM_VALIDATE_PROC (1, proc);
  139. return scm_assq_ref (scm_procedure_properties (proc), key);
  140. }
  141. #undef FUNC_NAME
  142. SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
  143. (SCM proc, SCM key, SCM val),
  144. "In @var{proc}'s property list, set the property named @var{key} to\n"
  145. "@var{val}.")
  146. #define FUNC_NAME s_scm_set_procedure_property_x
  147. {
  148. SCM props;
  149. SCM_VALIDATE_PROC (1, proc);
  150. scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
  151. props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F);
  152. if (scm_is_false (props))
  153. {
  154. if (SCM_PROGRAM_P (proc))
  155. props = scm_i_program_properties (proc);
  156. else
  157. props = SCM_EOL;
  158. }
  159. scm_weak_table_putq_x (overrides, proc, scm_assq_set_x (props, key, val));
  160. scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
  161. return SCM_UNSPECIFIED;
  162. }
  163. #undef FUNC_NAME
  164. void
  165. scm_init_procprop ()
  166. {
  167. overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
  168. arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
  169. #include "libguile/procprop.x"
  170. }
  171. /*
  172. Local Variables:
  173. c-file-style: "gnu"
  174. End:
  175. */