45 |
|
|
46 |
#include "libguile/_scm.h" |
#include "libguile/_scm.h" |
47 |
#include "libguile/deprecated.h" |
#include "libguile/deprecated.h" |
48 |
|
#include "libguile/deprecation.h" |
49 |
#include "libguile/snarf.h" |
#include "libguile/snarf.h" |
50 |
#include "libguile/validate.h" |
#include "libguile/validate.h" |
51 |
#include "libguile/strings.h" |
#include "libguile/strings.h" |
52 |
#include "libguile/strop.h" |
#include "libguile/strop.h" |
53 |
|
|
54 |
|
#include <stdio.h> |
55 |
|
#include <string.h> |
56 |
|
|
57 |
#if (SCM_ENABLE_DEPRECATED == 1) |
#if (SCM_ENABLE_DEPRECATED == 1) |
58 |
|
|
59 |
SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); |
SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x); |
60 |
|
|
61 |
SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); |
SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x); |
62 |
|
|
63 |
|
SCM |
64 |
|
scm_wta (SCM arg, const char *pos, const char *s_subr) |
65 |
|
{ |
66 |
|
if (!s_subr || !*s_subr) |
67 |
|
s_subr = NULL; |
68 |
|
if ((~0x1fL) & (long) pos) |
69 |
|
{ |
70 |
|
/* error string supplied. */ |
71 |
|
scm_misc_error (s_subr, pos, scm_list_1 (arg)); |
72 |
|
} |
73 |
|
else |
74 |
|
{ |
75 |
|
/* numerical error code. */ |
76 |
|
scm_t_bits error = (scm_t_bits) pos; |
77 |
|
|
78 |
|
switch (error) |
79 |
|
{ |
80 |
|
case SCM_ARGn: |
81 |
|
scm_wrong_type_arg (s_subr, 0, arg); |
82 |
|
case SCM_ARG1: |
83 |
|
scm_wrong_type_arg (s_subr, 1, arg); |
84 |
|
case SCM_ARG2: |
85 |
|
scm_wrong_type_arg (s_subr, 2, arg); |
86 |
|
case SCM_ARG3: |
87 |
|
scm_wrong_type_arg (s_subr, 3, arg); |
88 |
|
case SCM_ARG4: |
89 |
|
scm_wrong_type_arg (s_subr, 4, arg); |
90 |
|
case SCM_ARG5: |
91 |
|
scm_wrong_type_arg (s_subr, 5, arg); |
92 |
|
case SCM_ARG6: |
93 |
|
scm_wrong_type_arg (s_subr, 6, arg); |
94 |
|
case SCM_ARG7: |
95 |
|
scm_wrong_type_arg (s_subr, 7, arg); |
96 |
|
case SCM_WNA: |
97 |
|
scm_wrong_num_args (arg); |
98 |
|
case SCM_OUTOFRANGE: |
99 |
|
scm_out_of_range (s_subr, arg); |
100 |
|
case SCM_NALLOC: |
101 |
|
scm_memory_error (s_subr); |
102 |
|
default: |
103 |
|
/* this shouldn't happen. */ |
104 |
|
scm_misc_error (s_subr, "Unknown error", SCM_EOL); |
105 |
|
} |
106 |
|
} |
107 |
|
return SCM_UNSPECIFIED; |
108 |
|
} |
109 |
|
|
110 |
|
/* Module registry |
111 |
|
*/ |
112 |
|
|
113 |
|
/* We can't use SCM objects here. One should be able to call |
114 |
|
SCM_REGISTER_MODULE from a C++ constructor for a static |
115 |
|
object. This happens before main and thus before libguile is |
116 |
|
initialized. */ |
117 |
|
|
118 |
|
struct moddata { |
119 |
|
struct moddata *link; |
120 |
|
char *module_name; |
121 |
|
void *init_func; |
122 |
|
}; |
123 |
|
|
124 |
|
static struct moddata *registered_mods = NULL; |
125 |
|
|
126 |
|
void |
127 |
|
scm_register_module_xxx (char *module_name, void *init_func) |
128 |
|
{ |
129 |
|
struct moddata *md; |
130 |
|
|
131 |
|
scm_c_issue_deprecation_warning |
132 |
|
("`scm_register_module_xxx' is deprecated. Use extensions instead."); |
133 |
|
|
134 |
|
/* XXX - should we (and can we) DEFER_INTS here? */ |
135 |
|
|
136 |
|
for (md = registered_mods; md; md = md->link) |
137 |
|
if (!strcmp (md->module_name, module_name)) |
138 |
|
{ |
139 |
|
md->init_func = init_func; |
140 |
|
return; |
141 |
|
} |
142 |
|
|
143 |
|
md = (struct moddata *) malloc (sizeof (struct moddata)); |
144 |
|
if (md == NULL) |
145 |
|
{ |
146 |
|
fprintf (stderr, |
147 |
|
"guile: can't register module (%s): not enough memory", |
148 |
|
module_name); |
149 |
|
return; |
150 |
|
} |
151 |
|
|
152 |
|
md->module_name = module_name; |
153 |
|
md->init_func = init_func; |
154 |
|
md->link = registered_mods; |
155 |
|
registered_mods = md; |
156 |
|
} |
157 |
|
|
158 |
|
SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0, |
159 |
|
(), |
160 |
|
"Return a list of the object code modules that have been imported into\n" |
161 |
|
"the current Guile process. Each element of the list is a pair whose\n" |
162 |
|
"car is the name of the module, and whose cdr is the function handle\n" |
163 |
|
"for that module's initializer function. The name is the string that\n" |
164 |
|
"has been passed to scm_register_module_xxx.") |
165 |
|
#define FUNC_NAME s_scm_registered_modules |
166 |
|
{ |
167 |
|
SCM res; |
168 |
|
struct moddata *md; |
169 |
|
|
170 |
|
res = SCM_EOL; |
171 |
|
for (md = registered_mods; md; md = md->link) |
172 |
|
res = scm_cons (scm_cons (scm_makfrom0str (md->module_name), |
173 |
|
scm_ulong2num ((unsigned long) md->init_func)), |
174 |
|
res); |
175 |
|
return res; |
176 |
|
} |
177 |
|
#undef FUNC_NAME |
178 |
|
|
179 |
|
SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0, |
180 |
|
(), |
181 |
|
"Destroy the list of modules registered with the current Guile process.\n" |
182 |
|
"The return value is unspecified. @strong{Warning:} this function does\n" |
183 |
|
"not actually unlink or deallocate these modules, but only destroys the\n" |
184 |
|
"records of which modules have been loaded. It should therefore be used\n" |
185 |
|
"only by module bookkeeping operations.") |
186 |
|
#define FUNC_NAME s_scm_clear_registered_modules |
187 |
|
{ |
188 |
|
struct moddata *md1, *md2; |
189 |
|
|
190 |
|
SCM_DEFER_INTS; |
191 |
|
|
192 |
|
for (md1 = registered_mods; md1; md1 = md2) |
193 |
|
{ |
194 |
|
md2 = md1->link; |
195 |
|
free (md1); |
196 |
|
} |
197 |
|
registered_mods = NULL; |
198 |
|
|
199 |
|
SCM_ALLOW_INTS; |
200 |
|
return SCM_UNSPECIFIED; |
201 |
|
} |
202 |
|
#undef FUNC_NAME |
203 |
|
|
204 |
|
|
205 |
void |
void |
206 |
scm_i_init_deprecated () |
scm_i_init_deprecated () |
207 |
{ |
{ |