modules.c 26 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037
  1. /* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,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 <stdarg.h>
  22. #include "libguile/_scm.h"
  23. #include "libguile/eval.h"
  24. #include "libguile/smob.h"
  25. #include "libguile/procprop.h"
  26. #include "libguile/vectors.h"
  27. #include "libguile/hashtab.h"
  28. #include "libguile/struct.h"
  29. #include "libguile/variable.h"
  30. #include "libguile/fluids.h"
  31. #include "libguile/deprecation.h"
  32. #include "libguile/modules.h"
  33. int scm_module_system_booted_p = 0;
  34. scm_t_bits scm_module_tag;
  35. /* The current module, a fluid. */
  36. static SCM the_module;
  37. /* Most of the module system is implemented in Scheme. These bindings from
  38. boot-9 are needed to provide the Scheme interface. */
  39. static SCM the_root_module_var;
  40. static SCM module_make_local_var_x_var;
  41. static SCM define_module_star_var;
  42. static SCM process_use_modules_var;
  43. static SCM resolve_module_var;
  44. static SCM module_public_interface_var;
  45. static SCM module_export_x_var;
  46. static SCM default_duplicate_binding_procedures_var;
  47. /* The #:ensure keyword. */
  48. static SCM k_ensure;
  49. static SCM unbound_variable (const char *func, SCM sym)
  50. {
  51. scm_error (scm_from_latin1_symbol ("unbound-variable"), func,
  52. "Unbound variable: ~S", scm_list_1 (sym), SCM_BOOL_F);
  53. }
  54. SCM
  55. scm_the_root_module (void)
  56. {
  57. if (scm_module_system_booted_p)
  58. return SCM_VARIABLE_REF (the_root_module_var);
  59. else
  60. return SCM_BOOL_F;
  61. }
  62. SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
  63. (),
  64. "Return the current module.")
  65. #define FUNC_NAME s_scm_current_module
  66. {
  67. SCM curr = scm_fluid_ref (the_module);
  68. return scm_is_true (curr) ? curr : scm_the_root_module ();
  69. }
  70. #undef FUNC_NAME
  71. static void scm_post_boot_init_modules (void);
  72. SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
  73. (SCM module),
  74. "Set the current module to @var{module} and return\n"
  75. "the previous current module.")
  76. #define FUNC_NAME s_scm_set_current_module
  77. {
  78. SCM old;
  79. if (!scm_module_system_booted_p)
  80. scm_post_boot_init_modules ();
  81. SCM_VALIDATE_MODULE (SCM_ARG1, module);
  82. old = scm_current_module ();
  83. scm_fluid_set_x (the_module, module);
  84. return old;
  85. }
  86. #undef FUNC_NAME
  87. SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
  88. (),
  89. "Return a specifier for the environment that contains\n"
  90. "implementation--defined bindings, typically a superset of those\n"
  91. "listed in the report. The intent is that this procedure will\n"
  92. "return the environment in which the implementation would\n"
  93. "evaluate expressions dynamically typed by the user.")
  94. #define FUNC_NAME s_scm_interaction_environment
  95. {
  96. return scm_current_module ();
  97. }
  98. #undef FUNC_NAME
  99. SCM
  100. scm_c_call_with_current_module (SCM module,
  101. SCM (*func)(void *), void *data)
  102. {
  103. return scm_c_with_fluid (the_module, module, func, data);
  104. }
  105. void
  106. scm_dynwind_current_module (SCM module)
  107. {
  108. scm_dynwind_fluid (the_module, module);
  109. }
  110. /*
  111. convert "A B C" to scheme list (A B C)
  112. */
  113. static SCM
  114. convert_module_name (const char *name)
  115. {
  116. SCM list = SCM_EOL;
  117. SCM *tail = &list;
  118. const char *ptr;
  119. while (*name)
  120. {
  121. while (*name == ' ')
  122. name++;
  123. ptr = name;
  124. while (*ptr && *ptr != ' ')
  125. ptr++;
  126. if (ptr > name)
  127. {
  128. SCM sym = scm_from_locale_symboln (name, ptr-name);
  129. *tail = scm_cons (sym, SCM_EOL);
  130. tail = SCM_CDRLOC (*tail);
  131. }
  132. name = ptr;
  133. }
  134. return list;
  135. }
  136. SCM
  137. scm_c_resolve_module (const char *name)
  138. {
  139. return scm_resolve_module (convert_module_name (name));
  140. }
  141. SCM
  142. scm_resolve_module (SCM name)
  143. {
  144. return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
  145. }
  146. SCM
  147. scm_c_define_module (const char *name,
  148. void (*init)(void *), void *data)
  149. {
  150. SCM module = scm_call_1 (SCM_VARIABLE_REF (define_module_star_var),
  151. convert_module_name (name));
  152. if (init)
  153. scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
  154. return module;
  155. }
  156. void
  157. scm_c_use_module (const char *name)
  158. {
  159. scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
  160. scm_list_1 (scm_list_1 (convert_module_name (name))));
  161. }
  162. SCM
  163. scm_module_export (SCM module, SCM namelist)
  164. {
  165. return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
  166. module, namelist);
  167. }
  168. /*
  169. @code{scm_c_export}(@var{name-list})
  170. @code{scm_c_export} exports the named bindings from the current
  171. module, making them visible to users of the module. This function
  172. takes a list of string arguments, terminated by NULL, e.g.
  173. @example
  174. scm_c_export ("add-double-record", "bamboozle-money", NULL);
  175. @end example
  176. */
  177. void
  178. scm_c_export (const char *name, ...)
  179. {
  180. if (name)
  181. {
  182. va_list ap;
  183. SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
  184. SCM *tail = SCM_CDRLOC (names);
  185. va_start (ap, name);
  186. while (1)
  187. {
  188. const char *n = va_arg (ap, const char *);
  189. if (n == NULL)
  190. break;
  191. *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
  192. tail = SCM_CDRLOC (*tail);
  193. }
  194. va_end (ap);
  195. scm_module_export (scm_current_module (), names);
  196. }
  197. }
  198. /* Environments */
  199. SCM_SYMBOL (sym_module, "module");
  200. SCM
  201. scm_lookup_closure_module (SCM proc)
  202. {
  203. if (scm_is_false (proc))
  204. return scm_the_root_module ();
  205. else if (SCM_EVAL_CLOSURE_P (proc))
  206. return SCM_PACK (SCM_SMOB_DATA (proc));
  207. else
  208. {
  209. SCM mod;
  210. /* FIXME: The `module' property is no longer set on eval closures, as it
  211. introduced a circular reference that precludes garbage collection of
  212. modules with the current weak hash table semantics (see
  213. http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
  214. http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
  215. for details). Since it doesn't appear to be used (only in this
  216. function, which has 1 caller), we no longer extend
  217. `set-module-eval-closure!' to set the `module' property. */
  218. abort ();
  219. mod = scm_procedure_property (proc, sym_module);
  220. if (scm_is_false (mod))
  221. mod = scm_the_root_module ();
  222. return mod;
  223. }
  224. }
  225. /*
  226. * C level implementation of the standard eval closure
  227. *
  228. * This increases loading speed substantially. The code may be
  229. * replaced by something based on environments.[ch], in a future
  230. * release.
  231. */
  232. /* Return the list of default duplicate binding handlers (procedures). */
  233. static inline SCM
  234. default_duplicate_binding_handlers (void)
  235. {
  236. SCM get_handlers;
  237. get_handlers = SCM_VARIABLE_REF (default_duplicate_binding_procedures_var);
  238. return (scm_call_0 (get_handlers));
  239. }
  240. /* Resolve the import of SYM in MODULE, where SYM is currently provided by
  241. both IFACE1 as VAR1 and IFACE2 as VAR2. Return the variable chosen by the
  242. duplicate binding handlers or `#f'. */
  243. static inline SCM
  244. resolve_duplicate_binding (SCM module, SCM sym,
  245. SCM iface1, SCM var1,
  246. SCM iface2, SCM var2)
  247. {
  248. SCM result = SCM_BOOL_F;
  249. if (!scm_is_eq (var1, var2))
  250. {
  251. SCM val1, val2;
  252. SCM handlers, h, handler_args;
  253. val1 = SCM_VARIABLE_REF (var1);
  254. val2 = SCM_VARIABLE_REF (var2);
  255. val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1;
  256. val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2;
  257. handlers = SCM_MODULE_DUPLICATE_HANDLERS (module);
  258. if (scm_is_false (handlers))
  259. handlers = default_duplicate_binding_handlers ();
  260. handler_args = scm_list_n (module, sym,
  261. iface1, val1, iface2, val2,
  262. var1, val1,
  263. SCM_UNDEFINED);
  264. for (h = handlers;
  265. scm_is_pair (h) && scm_is_false (result);
  266. h = SCM_CDR (h))
  267. {
  268. result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL);
  269. }
  270. }
  271. else
  272. result = var1;
  273. return result;
  274. }
  275. /* No lock is needed for access to this variable, as there are no
  276. threads before modules are booted. */
  277. SCM scm_pre_modules_obarray;
  278. /* Lookup SYM as an imported variable of MODULE. */
  279. static inline SCM
  280. module_imported_variable (SCM module, SCM sym)
  281. {
  282. #define SCM_BOUND_THING_P scm_is_true
  283. register SCM var, imports;
  284. /* Search cached imported bindings. */
  285. imports = SCM_MODULE_IMPORT_OBARRAY (module);
  286. var = scm_hashq_ref (imports, sym, SCM_UNDEFINED);
  287. if (SCM_BOUND_THING_P (var))
  288. return var;
  289. {
  290. /* Search the use list for yet uncached imported bindings, possibly
  291. resolving duplicates as needed and caching the result in the import
  292. obarray. */
  293. SCM uses;
  294. SCM found_var = SCM_BOOL_F, found_iface = SCM_BOOL_F;
  295. for (uses = SCM_MODULE_USES (module);
  296. scm_is_pair (uses);
  297. uses = SCM_CDR (uses))
  298. {
  299. SCM iface;
  300. iface = SCM_CAR (uses);
  301. var = scm_module_variable (iface, sym);
  302. if (SCM_BOUND_THING_P (var))
  303. {
  304. if (SCM_BOUND_THING_P (found_var))
  305. {
  306. /* SYM is a duplicate binding (imported more than once) so we
  307. need to resolve it. */
  308. found_var = resolve_duplicate_binding (module, sym,
  309. found_iface, found_var,
  310. iface, var);
  311. if (scm_is_eq (found_var, var))
  312. found_iface = iface;
  313. }
  314. else
  315. /* Keep track of the variable we found and check for other
  316. occurences of SYM in the use list. */
  317. found_var = var, found_iface = iface;
  318. }
  319. }
  320. if (SCM_BOUND_THING_P (found_var))
  321. {
  322. /* Save the lookup result for future reference. */
  323. (void) scm_hashq_set_x (imports, sym, found_var);
  324. return found_var;
  325. }
  326. }
  327. return SCM_BOOL_F;
  328. #undef SCM_BOUND_THING_P
  329. }
  330. SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
  331. (SCM module, SCM sym),
  332. "Return the variable bound to @var{sym} in @var{module}. Return "
  333. "@code{#f} is @var{sym} is not bound locally in @var{module}.")
  334. #define FUNC_NAME s_scm_module_local_variable
  335. {
  336. #define SCM_BOUND_THING_P(b) \
  337. (scm_is_true (b))
  338. register SCM b;
  339. if (scm_module_system_booted_p)
  340. SCM_VALIDATE_MODULE (1, module);
  341. SCM_VALIDATE_SYMBOL (2, sym);
  342. if (scm_is_false (module))
  343. return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
  344. /* 1. Check module obarray */
  345. b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
  346. if (SCM_BOUND_THING_P (b))
  347. return b;
  348. /* At this point we should just be able to return #f, but there is the
  349. possibility that a custom binder establishes a mapping for this
  350. variable.
  351. However a custom binder should be called only if there is no
  352. imported binding with the name SYM. So here instead of the order:
  353. 2. Search imported bindings. In order to be consistent with
  354. `module-variable', the binder gets called only when no
  355. imported binding matches SYM.
  356. 3. Query the custom binder.
  357. we first check if there is a binder at all, and if not, just return
  358. #f directly.
  359. */
  360. {
  361. SCM binder = SCM_MODULE_BINDER (module);
  362. if (scm_is_true (binder))
  363. {
  364. /* 2. */
  365. b = module_imported_variable (module, sym);
  366. if (SCM_BOUND_THING_P (b))
  367. return SCM_BOOL_F;
  368. /* 3. */
  369. b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
  370. if (SCM_BOUND_THING_P (b))
  371. return b;
  372. }
  373. }
  374. return SCM_BOOL_F;
  375. #undef SCM_BOUND_THING_P
  376. }
  377. #undef FUNC_NAME
  378. SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0,
  379. (SCM module, SCM sym),
  380. "Return the variable bound to @var{sym} in @var{module}. This "
  381. "may be both a local variable or an imported variable. Return "
  382. "@code{#f} is @var{sym} is not bound in @var{module}.")
  383. #define FUNC_NAME s_scm_module_variable
  384. {
  385. #define SCM_BOUND_THING_P(b) \
  386. (scm_is_true (b))
  387. register SCM var;
  388. if (scm_module_system_booted_p)
  389. SCM_VALIDATE_MODULE (1, module);
  390. SCM_VALIDATE_SYMBOL (2, sym);
  391. if (scm_is_false (module))
  392. return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
  393. /* 1. Check module obarray */
  394. var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
  395. if (SCM_BOUND_THING_P (var))
  396. return var;
  397. /* 2. Search among the imported variables. */
  398. var = module_imported_variable (module, sym);
  399. if (SCM_BOUND_THING_P (var))
  400. return var;
  401. {
  402. /* 3. Query the custom binder. */
  403. SCM binder;
  404. binder = SCM_MODULE_BINDER (module);
  405. if (scm_is_true (binder))
  406. {
  407. var = scm_call_3 (binder, module, sym, SCM_BOOL_F);
  408. if (SCM_BOUND_THING_P (var))
  409. return var;
  410. }
  411. }
  412. return SCM_BOOL_F;
  413. #undef SCM_BOUND_THING_P
  414. }
  415. #undef FUNC_NAME
  416. scm_t_bits scm_tc16_eval_closure;
  417. #define SCM_F_EVAL_CLOSURE_INTERFACE (1<<0)
  418. #define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
  419. (SCM_SMOB_FLAGS (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
  420. /* NOTE: This function may be called by a smob application
  421. or from another C function directly. */
  422. SCM
  423. scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
  424. {
  425. SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
  426. if (scm_is_true (definep))
  427. {
  428. if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
  429. return SCM_BOOL_F;
  430. return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
  431. module, sym);
  432. }
  433. else
  434. return scm_module_variable (module, sym);
  435. }
  436. SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
  437. (SCM module),
  438. "Return an eval closure for the module @var{module}.")
  439. #define FUNC_NAME s_scm_standard_eval_closure
  440. {
  441. SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
  442. }
  443. #undef FUNC_NAME
  444. SCM_DEFINE (scm_standard_interface_eval_closure,
  445. "standard-interface-eval-closure", 1, 0, 0,
  446. (SCM module),
  447. "Return a interface eval closure for the module @var{module}. "
  448. "Such a closure does not allow new bindings to be added.")
  449. #define FUNC_NAME s_scm_standard_interface_eval_closure
  450. {
  451. SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | (SCM_F_EVAL_CLOSURE_INTERFACE<<16),
  452. SCM_UNPACK (module));
  453. }
  454. #undef FUNC_NAME
  455. SCM_DEFINE (scm_eval_closure_module,
  456. "eval-closure-module", 1, 0, 0,
  457. (SCM eval_closure),
  458. "Return the module associated with this eval closure.")
  459. /* the idea is that eval closures are really not the way to do things, they're
  460. superfluous given our module system. this function lets mmacros migrate away
  461. from eval closures. */
  462. #define FUNC_NAME s_scm_eval_closure_module
  463. {
  464. SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
  465. "eval-closure");
  466. return SCM_SMOB_OBJECT (eval_closure);
  467. }
  468. #undef FUNC_NAME
  469. SCM
  470. scm_module_lookup_closure (SCM module)
  471. {
  472. if (scm_is_false (module))
  473. return SCM_BOOL_F;
  474. else
  475. return SCM_MODULE_EVAL_CLOSURE (module);
  476. }
  477. SCM
  478. scm_current_module_lookup_closure ()
  479. {
  480. if (scm_module_system_booted_p)
  481. return scm_module_lookup_closure (scm_current_module ());
  482. else
  483. return SCM_BOOL_F;
  484. }
  485. SCM_SYMBOL (sym_macroexpand, "macroexpand");
  486. SCM_DEFINE (scm_module_transformer, "module-transformer", 1, 0, 0,
  487. (SCM module),
  488. "Returns the syntax expander for the given module.")
  489. #define FUNC_NAME s_scm_module_transformer
  490. {
  491. if (SCM_UNLIKELY (scm_is_false (module)))
  492. {
  493. SCM v = scm_hashq_ref (scm_pre_modules_obarray,
  494. sym_macroexpand,
  495. SCM_BOOL_F);
  496. if (scm_is_false (v))
  497. SCM_MISC_ERROR ("no module, and `macroexpand' unbound", SCM_EOL);
  498. return SCM_VARIABLE_REF (v);
  499. }
  500. else
  501. {
  502. SCM_VALIDATE_MODULE (SCM_ARG1, module);
  503. return SCM_MODULE_TRANSFORMER (module);
  504. }
  505. }
  506. #undef FUNC_NAME
  507. SCM
  508. scm_current_module_transformer ()
  509. {
  510. return scm_module_transformer (scm_current_module ());
  511. }
  512. SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
  513. (SCM module, SCM sym),
  514. "Return the module or interface from which @var{sym} is imported "
  515. "in @var{module}. If @var{sym} is not imported (i.e., it is not "
  516. "defined in @var{module} or it is a module-local binding instead "
  517. "of an imported one), then @code{#f} is returned.")
  518. #define FUNC_NAME s_scm_module_import_interface
  519. {
  520. SCM var, result = SCM_BOOL_F;
  521. SCM_VALIDATE_MODULE (1, module);
  522. SCM_VALIDATE_SYMBOL (2, sym);
  523. var = scm_module_variable (module, sym);
  524. if (scm_is_true (var))
  525. {
  526. /* Look for the module that provides VAR. */
  527. SCM local_var;
  528. local_var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym,
  529. SCM_UNDEFINED);
  530. if (scm_is_eq (local_var, var))
  531. result = module;
  532. else
  533. {
  534. /* Look for VAR among the used modules. */
  535. SCM uses, imported_var;
  536. for (uses = SCM_MODULE_USES (module);
  537. scm_is_pair (uses) && scm_is_false (result);
  538. uses = SCM_CDR (uses))
  539. {
  540. imported_var = scm_module_variable (SCM_CAR (uses), sym);
  541. if (scm_is_eq (imported_var, var))
  542. result = SCM_CAR (uses);
  543. }
  544. }
  545. }
  546. return result;
  547. }
  548. #undef FUNC_NAME
  549. SCM
  550. scm_module_public_interface (SCM module)
  551. {
  552. return scm_call_1 (SCM_VARIABLE_REF (module_public_interface_var), module);
  553. }
  554. /* scm_sym2var
  555. *
  556. * looks up the variable bound to SYM according to PROC. PROC should be
  557. * a `eval closure' of some module.
  558. *
  559. * When no binding exists, and DEFINEP is true, create a new binding
  560. * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
  561. * false and no binding exists.
  562. *
  563. * When PROC is `#f', it is ignored and the binding is searched for in
  564. * the scm_pre_modules_obarray (a `eq' hash table).
  565. */
  566. SCM
  567. scm_sym2var (SCM sym, SCM proc, SCM definep)
  568. #define FUNC_NAME "scm_sym2var"
  569. {
  570. SCM var;
  571. if (SCM_NIMP (proc))
  572. {
  573. if (SCM_EVAL_CLOSURE_P (proc))
  574. {
  575. /* Bypass evaluator in the standard case. */
  576. var = scm_eval_closure_lookup (proc, sym, definep);
  577. }
  578. else
  579. var = scm_call_2 (proc, sym, definep);
  580. }
  581. else
  582. {
  583. SCM handle;
  584. if (scm_is_false (definep))
  585. var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
  586. else
  587. {
  588. handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
  589. sym, SCM_BOOL_F);
  590. var = SCM_CDR (handle);
  591. if (scm_is_false (var))
  592. {
  593. var = scm_make_variable (SCM_UNDEFINED);
  594. SCM_SETCDR (handle, var);
  595. }
  596. }
  597. }
  598. if (scm_is_true (var) && !SCM_VARIABLEP (var))
  599. SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
  600. return var;
  601. }
  602. #undef FUNC_NAME
  603. SCM
  604. scm_c_module_lookup (SCM module, const char *name)
  605. {
  606. return scm_module_lookup (module, scm_from_locale_symbol (name));
  607. }
  608. SCM
  609. scm_module_lookup (SCM module, SCM sym)
  610. #define FUNC_NAME "module-lookup"
  611. {
  612. SCM var;
  613. SCM_VALIDATE_MODULE (1, module);
  614. var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
  615. if (scm_is_false (var))
  616. unbound_variable (FUNC_NAME, sym);
  617. return var;
  618. }
  619. #undef FUNC_NAME
  620. SCM
  621. scm_c_lookup (const char *name)
  622. {
  623. return scm_lookup (scm_from_locale_symbol (name));
  624. }
  625. SCM
  626. scm_lookup (SCM sym)
  627. {
  628. SCM var =
  629. scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
  630. if (scm_is_false (var))
  631. unbound_variable (NULL, sym);
  632. return var;
  633. }
  634. SCM
  635. scm_public_variable (SCM module_name, SCM name)
  636. {
  637. SCM mod, iface;
  638. mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
  639. k_ensure, SCM_BOOL_F);
  640. if (scm_is_false (mod))
  641. scm_misc_error ("public-lookup", "Module named ~s does not exist",
  642. scm_list_1 (module_name));
  643. iface = scm_module_public_interface (mod);
  644. if (scm_is_false (iface))
  645. scm_misc_error ("public-lookup", "Module ~s has no public interface",
  646. scm_list_1 (mod));
  647. return scm_module_variable (iface, name);
  648. }
  649. SCM
  650. scm_private_variable (SCM module_name, SCM name)
  651. {
  652. SCM mod;
  653. mod = scm_call_3 (scm_variable_ref (resolve_module_var), module_name,
  654. k_ensure, SCM_BOOL_F);
  655. if (scm_is_false (mod))
  656. scm_misc_error ("private-lookup", "Module named ~s does not exist",
  657. scm_list_1 (module_name));
  658. return scm_module_variable (mod, name);
  659. }
  660. SCM
  661. scm_c_public_variable (const char *module_name, const char *name)
  662. {
  663. return scm_public_variable (convert_module_name (module_name),
  664. scm_from_locale_symbol (name));
  665. }
  666. SCM
  667. scm_c_private_variable (const char *module_name, const char *name)
  668. {
  669. return scm_private_variable (convert_module_name (module_name),
  670. scm_from_locale_symbol (name));
  671. }
  672. SCM
  673. scm_public_lookup (SCM module_name, SCM name)
  674. {
  675. SCM var;
  676. var = scm_public_variable (module_name, name);
  677. if (scm_is_false (var))
  678. scm_misc_error ("public-lookup", "No variable bound to ~s in module ~s",
  679. scm_list_2 (name, module_name));
  680. return var;
  681. }
  682. SCM
  683. scm_private_lookup (SCM module_name, SCM name)
  684. {
  685. SCM var;
  686. var = scm_private_variable (module_name, name);
  687. if (scm_is_false (var))
  688. scm_misc_error ("private-lookup", "No variable bound to ~s in module ~s",
  689. scm_list_2 (name, module_name));
  690. return var;
  691. }
  692. SCM
  693. scm_c_public_lookup (const char *module_name, const char *name)
  694. {
  695. return scm_public_lookup (convert_module_name (module_name),
  696. scm_from_locale_symbol (name));
  697. }
  698. SCM
  699. scm_c_private_lookup (const char *module_name, const char *name)
  700. {
  701. return scm_private_lookup (convert_module_name (module_name),
  702. scm_from_locale_symbol (name));
  703. }
  704. SCM
  705. scm_public_ref (SCM module_name, SCM name)
  706. {
  707. return scm_variable_ref (scm_public_lookup (module_name, name));
  708. }
  709. SCM
  710. scm_private_ref (SCM module_name, SCM name)
  711. {
  712. return scm_variable_ref (scm_private_lookup (module_name, name));
  713. }
  714. SCM
  715. scm_c_public_ref (const char *module_name, const char *name)
  716. {
  717. return scm_public_ref (convert_module_name (module_name),
  718. scm_from_locale_symbol (name));
  719. }
  720. SCM
  721. scm_c_private_ref (const char *module_name, const char *name)
  722. {
  723. return scm_private_ref (convert_module_name (module_name),
  724. scm_from_locale_symbol (name));
  725. }
  726. SCM
  727. scm_c_module_define (SCM module, const char *name, SCM value)
  728. {
  729. return scm_module_define (module, scm_from_locale_symbol (name), value);
  730. }
  731. SCM
  732. scm_module_define (SCM module, SCM sym, SCM value)
  733. #define FUNC_NAME "module-define"
  734. {
  735. SCM var;
  736. SCM_VALIDATE_MODULE (1, module);
  737. var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
  738. SCM_VARIABLE_SET (var, value);
  739. return var;
  740. }
  741. #undef FUNC_NAME
  742. SCM
  743. scm_c_define (const char *name, SCM value)
  744. {
  745. return scm_define (scm_from_locale_symbol (name), value);
  746. }
  747. SCM_DEFINE (scm_define, "define!", 2, 0, 0,
  748. (SCM sym, SCM value),
  749. "Define @var{sym} to be @var{value} in the current module."
  750. "Returns the variable itself. Note that this is a procedure, "
  751. "not a macro.")
  752. #define FUNC_NAME s_scm_define
  753. {
  754. SCM var;
  755. SCM_VALIDATE_SYMBOL (SCM_ARG1, sym);
  756. var = scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
  757. SCM_VARIABLE_SET (var, value);
  758. return var;
  759. }
  760. #undef FUNC_NAME
  761. SCM_DEFINE (scm_module_reverse_lookup, "module-reverse-lookup", 2, 0, 0,
  762. (SCM module, SCM variable),
  763. "Return the symbol under which @var{variable} is bound in "
  764. "@var{module} or @var{#f} if @var{variable} is not visible "
  765. "from @var{module}. If @var{module} is @code{#f}, then the "
  766. "pre-module obarray is used.")
  767. #define FUNC_NAME s_scm_module_reverse_lookup
  768. {
  769. SCM obarray;
  770. long i, n;
  771. if (scm_is_false (module))
  772. obarray = scm_pre_modules_obarray;
  773. else
  774. {
  775. SCM_VALIDATE_MODULE (1, module);
  776. obarray = SCM_MODULE_OBARRAY (module);
  777. }
  778. SCM_VALIDATE_VARIABLE (SCM_ARG2, variable);
  779. if (!SCM_HASHTABLE_P (obarray))
  780. return SCM_BOOL_F;
  781. /* XXX - We do not use scm_hash_fold here to avoid searching the
  782. whole obarray. We should have a scm_hash_find procedure. */
  783. n = SCM_HASHTABLE_N_BUCKETS (obarray);
  784. for (i = 0; i < n; ++i)
  785. {
  786. SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
  787. while (!scm_is_null (ls))
  788. {
  789. handle = SCM_CAR (ls);
  790. if (SCM_UNPACK (SCM_CAR (handle)) == 0)
  791. {
  792. /* FIXME: We hit a weak pair whose car has become unreachable.
  793. We should remove the pair in question or something. */
  794. }
  795. else
  796. {
  797. if (scm_is_eq (SCM_CDR (handle), variable))
  798. return SCM_CAR (handle);
  799. }
  800. ls = SCM_CDR (ls);
  801. }
  802. }
  803. if (!scm_is_false (module))
  804. {
  805. /* Try the `uses' list. */
  806. SCM uses = SCM_MODULE_USES (module);
  807. while (scm_is_pair (uses))
  808. {
  809. SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
  810. if (scm_is_true (sym))
  811. return sym;
  812. uses = SCM_CDR (uses);
  813. }
  814. }
  815. return SCM_BOOL_F;
  816. }
  817. #undef FUNC_NAME
  818. SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
  819. (),
  820. "Return the obarray that is used for all new bindings before "
  821. "the module system is booted. The first call to "
  822. "@code{set-current-module} will boot the module system.")
  823. #define FUNC_NAME s_scm_get_pre_modules_obarray
  824. {
  825. return scm_pre_modules_obarray;
  826. }
  827. #undef FUNC_NAME
  828. SCM_SYMBOL (scm_sym_system_module, "system-module");
  829. void
  830. scm_modules_prehistory ()
  831. {
  832. scm_pre_modules_obarray = scm_c_make_hash_table (1533);
  833. }
  834. void
  835. scm_init_modules ()
  836. {
  837. #include "libguile/modules.x"
  838. module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
  839. SCM_UNDEFINED);
  840. scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
  841. scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
  842. the_module = scm_make_fluid ();
  843. }
  844. static void
  845. scm_post_boot_init_modules ()
  846. {
  847. SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
  848. scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
  849. resolve_module_var = scm_c_lookup ("resolve-module");
  850. define_module_star_var = scm_c_lookup ("define-module*");
  851. process_use_modules_var = scm_c_lookup ("process-use-modules");
  852. module_export_x_var = scm_c_lookup ("module-export!");
  853. the_root_module_var = scm_c_lookup ("the-root-module");
  854. default_duplicate_binding_procedures_var =
  855. scm_c_lookup ("default-duplicate-binding-procedures");
  856. module_public_interface_var = scm_c_lookup ("module-public-interface");
  857. k_ensure = scm_from_locale_keyword ("ensure");
  858. scm_module_system_booted_p = 1;
  859. }
  860. /*
  861. Local Variables:
  862. c-file-style: "gnu"
  863. End:
  864. */