1 /* -----------------------------------------------------------------------------
2 * This file is part of SWIG, which is licensed as a whole under version 3
3 * (or any later version) of the GNU General Public License. Some additional
4 * terms also apply to certain portions of SWIG. The full details of the SWIG
5 * license and copyrights can be found in the LICENSE and COPYRIGHT files
6 * included with the SWIG source code as distributed by the SWIG developers
7 * and at http://www.swig.org/legal.html.
8 *
9 * chicken.cxx
10 *
11 * CHICKEN language module for SWIG.
12 * ----------------------------------------------------------------------------- */
13
14 #include "swigmod.h"
15
16 #include <ctype.h>
17
18 static const char *usage = "\
19 \
20 CHICKEN Options (available with -chicken)\n\
21 -closprefix <prefix> - Prepend <prefix> to all clos identifiers\n\
22 -noclosuses - Do not (declare (uses ...)) in scheme file\n\
23 -nocollection - Do not register pointers with chicken garbage\n\
24 collector and export destructors\n\
25 -nounit - Do not (declare (unit ...)) in scheme file\n\
26 -proxy - Export TinyCLOS class definitions\n\
27 -unhideprimitive - Unhide the primitive: symbols\n\
28 -useclassprefix - Prepend the class name to all clos identifiers\n\
29 \n";
30
31 static char *module = 0;
32 static const char *chicken_path = "chicken";
33 static int num_methods = 0;
34
35 static File *f_begin = 0;
36 static File *f_runtime = 0;
37 static File *f_header = 0;
38 static File *f_wrappers = 0;
39 static File *f_init = 0;
40 static String *chickentext = 0;
41 static String *closprefix = 0;
42 static String *swigtype_ptr = 0;
43
44
45 static String *f_sym_size = 0;
46
47 /* some options */
48 static int declare_unit = 1;
49 static int no_collection = 0;
50 static int clos_uses = 1;
51
52 /* C++ Support + Clos Classes */
53 static int clos = 0;
54 static String *c_class_name = 0;
55 static String *class_name = 0;
56 static String *short_class_name = 0;
57
58 static int in_class = 0;
59 static int have_constructor = 0;
60 static bool exporting_destructor = false;
61 static bool exporting_constructor = false;
62 static String *constructor_name = 0;
63 static String *member_name = 0;
64
65 /* sections of the .scm code */
66 static String *scm_const_defs = 0;
67 static String *clos_class_defines = 0;
68 static String *clos_methods = 0;
69
70 /* Some clos options */
71 static int useclassprefix = 0;
72 static String *clossymnameprefix = 0;
73 static int hide_primitive = 1;
74 static Hash *primitive_names = 0;
75
76 /* Used for overloading constructors */
77 static int has_constructor_args = 0;
78 static List *constructor_arg_types = 0;
79 static String *constructor_dispatch = 0;
80
81 static Hash *overload_parameter_lists = 0;
82
83 class CHICKEN:public Language {
84 public:
85
86 virtual void main(int argc, char *argv[]);
87 virtual int top(Node *n);
88 virtual int functionWrapper(Node *n);
89 virtual int variableWrapper(Node *n);
90 virtual int constantWrapper(Node *n);
91 virtual int classHandler(Node *n);
92 virtual int memberfunctionHandler(Node *n);
93 virtual int membervariableHandler(Node *n);
94 virtual int constructorHandler(Node *n);
95 virtual int destructorHandler(Node *n);
96 virtual int validIdentifier(String *s);
97 virtual int staticmembervariableHandler(Node *n);
98 virtual int staticmemberfunctionHandler(Node *n);
99 virtual int importDirective(Node *n);
100
101 protected:
102 void addMethod(String *scheme_name, String *function);
103 /* Return true iff T is a pointer type */
104 int isPointer(SwigType *t);
105 void dispatchFunction(Node *n);
106
107 String *chickenNameMapping(String *, const_String_or_char_ptr );
108 String *chickenPrimitiveName(String *);
109
110 String *runtimeCode();
111 String *defaultExternalRuntimeFilename();
112 String *buildClosFunctionCall(List *types, const_String_or_char_ptr closname, const_String_or_char_ptr funcname);
113 };
114
115 /* -----------------------------------------------------------------------
116 * swig_chicken() - Instantiate module
117 * ----------------------------------------------------------------------- */
118
new_swig_chicken()119 static Language *new_swig_chicken() {
120 return new CHICKEN();
121 }
122
123 extern "C" {
swig_chicken(void)124 Language *swig_chicken(void) {
125 return new_swig_chicken();
126 }
127 }
128
main(int argc,char * argv[])129 void CHICKEN::main(int argc, char *argv[]) {
130 int i;
131
132 SWIG_library_directory(chicken_path);
133
134 // Look for certain command line options
135 for (i = 1; i < argc; i++) {
136 if (argv[i]) {
137 if (strcmp(argv[i], "-help") == 0) {
138 fputs(usage, stdout);
139 SWIG_exit(0);
140 } else if (strcmp(argv[i], "-proxy") == 0) {
141 clos = 1;
142 Swig_mark_arg(i);
143 } else if (strcmp(argv[i], "-closprefix") == 0) {
144 if (argv[i + 1]) {
145 clossymnameprefix = NewString(argv[i + 1]);
146 Swig_mark_arg(i);
147 Swig_mark_arg(i + 1);
148 i++;
149 } else {
150 Swig_arg_error();
151 }
152 } else if (strcmp(argv[i], "-useclassprefix") == 0) {
153 useclassprefix = 1;
154 Swig_mark_arg(i);
155 } else if (strcmp(argv[i], "-unhideprimitive") == 0) {
156 hide_primitive = 0;
157 Swig_mark_arg(i);
158 } else if (strcmp(argv[i], "-nounit") == 0) {
159 declare_unit = 0;
160 Swig_mark_arg(i);
161 } else if (strcmp(argv[i], "-noclosuses") == 0) {
162 clos_uses = 0;
163 Swig_mark_arg(i);
164 } else if (strcmp(argv[i], "-nocollection") == 0) {
165 no_collection = 1;
166 Swig_mark_arg(i);
167 }
168 }
169 }
170
171 if (!clos)
172 hide_primitive = 0;
173
174 // Add a symbol for this module
175 Preprocessor_define("SWIGCHICKEN 1", 0);
176
177 // Set name of typemaps
178
179 SWIG_typemap_lang("chicken");
180
181 // Read in default typemaps */
182 SWIG_config_file("chicken.swg");
183 allow_overloading();
184 }
185
top(Node * n)186 int CHICKEN::top(Node *n) {
187 String *chicken_filename = NewString("");
188 File *f_scm;
189 String *scmmodule;
190
191 /* Initialize all of the output files */
192 String *outfile = Getattr(n, "outfile");
193
194 f_begin = NewFile(outfile, "w", SWIG_output_files());
195 if (!f_begin) {
196 FileErrorDisplay(outfile);
197 SWIG_exit(EXIT_FAILURE);
198 }
199 f_runtime = NewString("");
200 f_init = NewString("");
201 f_header = NewString("");
202 f_wrappers = NewString("");
203 chickentext = NewString("");
204 closprefix = NewString("");
205 f_sym_size = NewString("");
206 primitive_names = NewHash();
207 overload_parameter_lists = NewHash();
208
209 /* Register file targets with the SWIG file handler */
210 Swig_register_filebyname("header", f_header);
211 Swig_register_filebyname("wrapper", f_wrappers);
212 Swig_register_filebyname("begin", f_begin);
213 Swig_register_filebyname("runtime", f_runtime);
214 Swig_register_filebyname("init", f_init);
215
216 Swig_register_filebyname("chicken", chickentext);
217 Swig_register_filebyname("closprefix", closprefix);
218
219 clos_class_defines = NewString("");
220 clos_methods = NewString("");
221 scm_const_defs = NewString("");
222
223 Swig_banner(f_begin);
224
225 Printf(f_runtime, "\n\n#ifndef SWIGCHICKEN\n#define SWIGCHICKEN\n#endif\n\n");
226
227 if (no_collection)
228 Printf(f_runtime, "#define SWIG_CHICKEN_NO_COLLECTION 1\n");
229
230 Printf(f_runtime, "\n");
231
232 /* Set module name */
233 module = Swig_copy_string(Char(Getattr(n, "name")));
234 scmmodule = NewString(module);
235 Replaceall(scmmodule, "_", "-");
236
237 Printf(f_header, "#define SWIG_init swig_%s_init\n", module);
238 Printf(f_header, "#define SWIG_name \"%s\"\n", scmmodule);
239
240 Printf(f_wrappers, "#ifdef __cplusplus\n");
241 Printf(f_wrappers, "extern \"C\" {\n");
242 Printf(f_wrappers, "#endif\n\n");
243
244 Language::top(n);
245
246 SwigType_emit_type_table(f_runtime, f_wrappers);
247
248 Printf(f_wrappers, "#ifdef __cplusplus\n");
249 Printf(f_wrappers, "}\n");
250 Printf(f_wrappers, "#endif\n");
251
252 Printf(f_init, "C_kontinue (continuation, ret);\n");
253 Printf(f_init, "}\n\n");
254
255 Printf(f_init, "#ifdef __cplusplus\n");
256 Printf(f_init, "}\n");
257 Printf(f_init, "#endif\n");
258
259 Printf(chicken_filename, "%s%s.scm", SWIG_output_directory(), module);
260 if ((f_scm = NewFile(chicken_filename, "w", SWIG_output_files())) == 0) {
261 FileErrorDisplay(chicken_filename);
262 SWIG_exit(EXIT_FAILURE);
263 }
264
265 Swig_banner_target_lang(f_scm, ";;");
266 Printf(f_scm, "\n");
267
268 if (declare_unit)
269 Printv(f_scm, "(declare (unit ", scmmodule, "))\n\n", NIL);
270 Printv(f_scm, "(declare \n",
271 tab4, "(hide swig-init swig-init-return)\n",
272 tab4, "(foreign-declare \"C_extern void swig_", module, "_init(C_word,C_word,C_word) C_noret;\"))\n", NIL);
273 Printv(f_scm, "(define swig-init (##core#primitive \"swig_", module, "_init\"))\n", NIL);
274 Printv(f_scm, "(define swig-init-return (swig-init))\n\n", NIL);
275
276 if (clos) {
277 //Printf (f_scm, "(declare (uses tinyclos))\n");
278 //New chicken versions have tinyclos as an egg
279 Printf(f_scm, "(require-extension tinyclos)\n");
280 Replaceall(closprefix, "$module", scmmodule);
281 Printf(f_scm, "%s\n", closprefix);
282 Printf(f_scm, "%s\n", clos_class_defines);
283 Printf(f_scm, "%s\n", clos_methods);
284 } else {
285 Printf(f_scm, "%s\n", scm_const_defs);
286 }
287
288 Printf(f_scm, "%s\n", chickentext);
289
290 Delete(f_scm);
291
292 char buftmp[20];
293 sprintf(buftmp, "%d", num_methods);
294 Replaceall(f_init, "$nummethods", buftmp);
295 Replaceall(f_init, "$symsize", f_sym_size);
296
297 if (hide_primitive)
298 Replaceall(f_init, "$veclength", buftmp);
299 else
300 Replaceall(f_init, "$veclength", "0");
301
302 Delete(chicken_filename);
303 Delete(chickentext);
304 Delete(closprefix);
305 Delete(overload_parameter_lists);
306
307 Delete(clos_class_defines);
308 Delete(clos_methods);
309 Delete(scm_const_defs);
310
311 /* Close all of the files */
312 Delete(primitive_names);
313 Delete(scmmodule);
314 Dump(f_runtime, f_begin);
315 Dump(f_header, f_begin);
316 Dump(f_wrappers, f_begin);
317 Wrapper_pretty_print(f_init, f_begin);
318 Delete(f_header);
319 Delete(f_wrappers);
320 Delete(f_sym_size);
321 Delete(f_init);
322 Delete(f_runtime);
323 Delete(f_begin);
324 return SWIG_OK;
325 }
326
functionWrapper(Node * n)327 int CHICKEN::functionWrapper(Node *n) {
328
329 String *name = Getattr(n, "name");
330 String *iname = Getattr(n, "sym:name");
331 SwigType *d = Getattr(n, "type");
332 ParmList *l = Getattr(n, "parms");
333
334 Parm *p;
335 int i;
336 String *wname;
337 Wrapper *f;
338 String *mangle = NewString("");
339 String *get_pointers;
340 String *cleanup;
341 String *argout;
342 String *tm;
343 String *overname = 0;
344 String *declfunc = 0;
345 String *scmname;
346 bool any_specialized_arg = false;
347 List *function_arg_types = NewList();
348
349 int num_required;
350 int num_arguments;
351 int have_argout;
352
353 Printf(mangle, "\"%s\"", SwigType_manglestr(d));
354
355 if (Getattr(n, "sym:overloaded")) {
356 overname = Getattr(n, "sym:overname");
357 } else {
358 if (!addSymbol(iname, n))
359 return SWIG_ERROR;
360 }
361
362 f = NewWrapper();
363 wname = NewString("");
364 get_pointers = NewString("");
365 cleanup = NewString("");
366 argout = NewString("");
367 declfunc = NewString("");
368 scmname = NewString(iname);
369 Replaceall(scmname, "_", "-");
370
371 /* Local vars */
372 Wrapper_add_local(f, "resultobj", "C_word resultobj");
373
374 /* Write code to extract function parameters. */
375 emit_parameter_variables(l, f);
376
377 /* Attach the standard typemaps */
378 emit_attach_parmmaps(l, f);
379 Setattr(n, "wrap:parms", l);
380
381 /* Get number of required and total arguments */
382 num_arguments = emit_num_arguments(l);
383 num_required = emit_num_required(l);
384
385 Append(wname, Swig_name_wrapper(iname));
386 if (overname) {
387 Append(wname, overname);
388 }
389 // Check for interrupts
390 Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
391
392 Printv(f->def, "static ", "void ", wname, " (C_word argc, C_word closure, C_word continuation", NIL);
393 Printv(declfunc, "void ", wname, "(C_word,C_word,C_word", NIL);
394
395 /* Generate code for argument marshalling */
396 for (i = 0, p = l; i < num_arguments; i++) {
397
398 while (checkAttribute(p, "tmap:in:numinputs", "0")) {
399 p = Getattr(p, "tmap:in:next");
400 }
401
402 SwigType *pt = Getattr(p, "type");
403 String *ln = Getattr(p, "lname");
404
405 Printf(f->def, ", C_word scm%d", i + 1);
406 Printf(declfunc, ",C_word");
407
408 /* Look for an input typemap */
409 if ((tm = Getattr(p, "tmap:in"))) {
410 String *parse = Getattr(p, "tmap:in:parse");
411 if (!parse) {
412 String *source = NewStringf("scm%d", i + 1);
413 Replaceall(tm, "$source", source);
414 Replaceall(tm, "$target", ln);
415 Replaceall(tm, "$input", source);
416 Setattr(p, "emit:input", source); /* Save the location of
417 the object */
418
419 if (Getattr(p, "wrap:disown") || (Getattr(p, "tmap:in:disown"))) {
420 Replaceall(tm, "$disown", "SWIG_POINTER_DISOWN");
421 } else {
422 Replaceall(tm, "$disown", "0");
423 }
424
425 if (i >= num_required)
426 Printf(get_pointers, "if (argc-2>%i && (%s)) {\n", i, source);
427 Printv(get_pointers, tm, "\n", NIL);
428 if (i >= num_required)
429 Printv(get_pointers, "}\n", NIL);
430
431 if (clos) {
432 if (i < num_required) {
433 if (strcmp("void", Char(pt)) != 0) {
434 Node *class_node = 0;
435 String *clos_code = Getattr(p, "tmap:in:closcode");
436 class_node = classLookup(pt);
437 if (clos_code && class_node) {
438 String *class_name = NewStringf("<%s>", Getattr(class_node, "sym:name"));
439 Replaceall(class_name, "_", "-");
440 Append(function_arg_types, class_name);
441 Append(function_arg_types, Copy(clos_code));
442 any_specialized_arg = true;
443 Delete(class_name);
444 } else {
445 Append(function_arg_types, "<top>");
446 Append(function_arg_types, "$input");
447 }
448 }
449 }
450 }
451 Delete(source);
452 }
453
454 p = Getattr(p, "tmap:in:next");
455 continue;
456 } else {
457 Swig_warning(WARN_TYPEMAP_IN_UNDEF, input_file, line_number, "Unable to use type %s as a function argument.\n", SwigType_str(pt, 0));
458 break;
459 }
460 }
461
462 /* finish argument marshalling */
463
464 Printf(f->def, ") {");
465 Printf(declfunc, ")");
466
467 if (num_required != num_arguments) {
468 Append(function_arg_types, "^^##optional$$");
469 }
470
471 /* First check the number of arguments is correct */
472 if (num_arguments != num_required)
473 Printf(f->code, "if (argc-2<%i || argc-2>%i) C_bad_argc(argc,%i);\n", num_required, num_arguments, num_required + 2);
474 else
475 Printf(f->code, "if (argc!=%i) C_bad_argc(argc,%i);\n", num_arguments + 2, num_arguments + 2);
476
477 /* Now piece together the first part of the wrapper function */
478 Printv(f->code, get_pointers, NIL);
479
480 /* Insert constraint checking code */
481 for (p = l; p;) {
482 if ((tm = Getattr(p, "tmap:check"))) {
483 Replaceall(tm, "$target", Getattr(p, "lname"));
484 Printv(f->code, tm, "\n", NIL);
485 p = Getattr(p, "tmap:check:next");
486 } else {
487 p = nextSibling(p);
488 }
489 }
490
491 /* Insert cleanup code */
492 for (p = l; p;) {
493 if ((tm = Getattr(p, "tmap:freearg"))) {
494 Replaceall(tm, "$source", Getattr(p, "lname"));
495 Printv(cleanup, tm, "\n", NIL);
496 p = Getattr(p, "tmap:freearg:next");
497 } else {
498 p = nextSibling(p);
499 }
500 }
501
502 /* Insert argument output code */
503 have_argout = 0;
504 for (p = l; p;) {
505 if ((tm = Getattr(p, "tmap:argout"))) {
506
507 if (!have_argout) {
508 have_argout = 1;
509 // Print initial argument output code
510 Printf(argout, "SWIG_Chicken_SetupArgout\n");
511 }
512
513 Replaceall(tm, "$source", Getattr(p, "lname"));
514 Replaceall(tm, "$target", "resultobj");
515 Replaceall(tm, "$arg", Getattr(p, "emit:input"));
516 Replaceall(tm, "$input", Getattr(p, "emit:input"));
517 Printf(argout, "%s", tm);
518 p = Getattr(p, "tmap:argout:next");
519 } else {
520 p = nextSibling(p);
521 }
522 }
523
524 Setattr(n, "wrap:name", wname);
525
526 /* Emit the function call */
527 String *actioncode = emit_action(n);
528
529 /* Return the function value */
530 if ((tm = Swig_typemap_lookup_out("out", n, Swig_cresult_name(), f, actioncode))) {
531 Replaceall(tm, "$source", Swig_cresult_name());
532 Replaceall(tm, "$target", "resultobj");
533 Replaceall(tm, "$result", "resultobj");
534 if (GetFlag(n, "feature:new")) {
535 Replaceall(tm, "$owner", "1");
536 } else {
537 Replaceall(tm, "$owner", "0");
538 }
539
540 Printf(f->code, "%s", tm);
541
542 if (have_argout)
543 Printf(f->code, "\nSWIG_APPEND_VALUE(resultobj);\n");
544
545 } else {
546 Swig_warning(WARN_TYPEMAP_OUT_UNDEF, input_file, line_number, "Unable to use return type %s in function %s.\n", SwigType_str(d, 0), name);
547 }
548 emit_return_variable(n, d, f);
549
550 /* Insert the argument output code */
551 Printv(f->code, argout, NIL);
552
553 /* Output cleanup code */
554 Printv(f->code, cleanup, NIL);
555
556 /* Look to see if there is any newfree cleanup code */
557 if (GetFlag(n, "feature:new")) {
558 if ((tm = Swig_typemap_lookup("newfree", n, Swig_cresult_name(), 0))) {
559 Replaceall(tm, "$source", Swig_cresult_name());
560 Printf(f->code, "%s\n", tm);
561 }
562 }
563
564 /* See if there is any return cleanup code */
565 if ((tm = Swig_typemap_lookup("ret", n, Swig_cresult_name(), 0))) {
566 Replaceall(tm, "$source", Swig_cresult_name());
567 Printf(f->code, "%s\n", tm);
568 }
569
570
571 if (have_argout) {
572 Printf(f->code, "C_kontinue(continuation,C_SCHEME_END_OF_LIST);\n");
573 } else {
574 if (exporting_constructor && clos && hide_primitive) {
575 /* Don't return a proxy, the wrapped CLOS class is the proxy */
576 Printf(f->code, "C_kontinue(continuation,resultobj);\n");
577 } else {
578 // make the continuation the proxy creation function, if one exists
579 Printv(f->code, "{\n",
580 "C_word func;\n",
581 "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
582 "if (C_swig_is_closurep(func))\n",
583 " ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
584 "else\n", " C_kontinue(continuation, resultobj);\n", "}\n", NIL);
585 }
586 }
587
588 /* Error handling code */
589 #ifdef USE_FAIL
590 Printf(f->code, "fail:\n");
591 Printv(f->code, cleanup, NIL);
592 Printf(f->code, "swig_panic (\"failure in " "'$symname' SWIG function wrapper\");\n");
593 #endif
594 Printf(f->code, "}\n");
595
596 /* Substitute the cleanup code */
597 Replaceall(f->code, "$cleanup", cleanup);
598
599 /* Substitute the function name */
600 Replaceall(f->code, "$symname", iname);
601 Replaceall(f->code, "$result", "resultobj");
602
603 /* Dump the function out */
604 Printv(f_wrappers, "static ", declfunc, " C_noret;\n", NIL);
605 Wrapper_print(f, f_wrappers);
606
607 /* Now register the function with the interpreter. */
608 if (!Getattr(n, "sym:overloaded")) {
609 if (exporting_destructor && !no_collection) {
610 Printf(f_init, "((swig_chicken_clientdata *)(SWIGTYPE%s->clientdata))->destroy = (swig_chicken_destructor) %s;\n", swigtype_ptr, wname);
611 } else {
612 addMethod(scmname, wname);
613 }
614
615 /* Only export if we are not in a class, or if in a class memberfunction */
616 if (!in_class || member_name) {
617 String *method_def;
618 String *clos_name;
619 if (in_class)
620 clos_name = NewString(member_name);
621 else
622 clos_name = chickenNameMapping(scmname, "");
623
624 if (!any_specialized_arg) {
625 method_def = NewString("");
626 Printv(method_def, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")", NIL);
627 } else {
628 method_def = buildClosFunctionCall(function_arg_types, clos_name, chickenPrimitiveName(scmname));
629 }
630 Printv(clos_methods, method_def, "\n", NIL);
631 Delete(clos_name);
632 Delete(method_def);
633 }
634
635 if (have_constructor && !has_constructor_args && any_specialized_arg) {
636 has_constructor_args = 1;
637 constructor_arg_types = Copy(function_arg_types);
638 }
639 } else {
640 /* add function_arg_types to overload hash */
641 List *flist = Getattr(overload_parameter_lists, scmname);
642 if (!flist) {
643 flist = NewList();
644 Setattr(overload_parameter_lists, scmname, flist);
645 }
646
647 Append(flist, Copy(function_arg_types));
648
649 if (!Getattr(n, "sym:nextSibling")) {
650 dispatchFunction(n);
651 }
652 }
653
654
655 Delete(wname);
656 Delete(get_pointers);
657 Delete(cleanup);
658 Delete(declfunc);
659 Delete(mangle);
660 Delete(function_arg_types);
661 DelWrapper(f);
662 return SWIG_OK;
663 }
664
variableWrapper(Node * n)665 int CHICKEN::variableWrapper(Node *n) {
666 char *name = GetChar(n, "name");
667 char *iname = GetChar(n, "sym:name");
668 SwigType *t = Getattr(n, "type");
669 ParmList *l = Getattr(n, "parms");
670
671 String *wname = NewString("");
672 String *mangle = NewString("");
673 String *tm;
674 String *tm2 = NewString("");
675 String *argnum = NewString("0");
676 String *arg = NewString("argv[0]");
677 Wrapper *f;
678 String *overname = 0;
679 String *scmname;
680
681 scmname = NewString(iname);
682 Replaceall(scmname, "_", "-");
683
684 Printf(mangle, "\"%s\"", SwigType_manglestr(t));
685
686 if (Getattr(n, "sym:overloaded")) {
687 overname = Getattr(n, "sym:overname");
688 } else {
689 if (!addSymbol(iname, n))
690 return SWIG_ERROR;
691 }
692
693 f = NewWrapper();
694
695 /* Attach the standard typemaps */
696 emit_attach_parmmaps(l, f);
697 Setattr(n, "wrap:parms", l);
698
699 // evaluation function names
700 Append(wname, Swig_name_wrapper(iname));
701 if (overname) {
702 Append(wname, overname);
703 }
704 Setattr(n, "wrap:name", wname);
705
706 // Check for interrupts
707 Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
708
709 if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
710
711 Printv(f->def, "static ", "void ", wname, "(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
712 Printv(f->def, "static " "void ", wname, "(C_word argc, C_word closure, " "C_word continuation, C_word value) {\n", NIL);
713
714 Wrapper_add_local(f, "resultobj", "C_word resultobj");
715
716 Printf(f->code, "if (argc!=2 && argc!=3) C_bad_argc(argc,2);\n");
717
718 /* Check for a setting of the variable value */
719 if (!GetFlag(n, "feature:immutable")) {
720 Printf(f->code, "if (argc > 2) {\n");
721 if ((tm = Swig_typemap_lookup("varin", n, name, 0))) {
722 Replaceall(tm, "$source", "value");
723 Replaceall(tm, "$target", name);
724 Replaceall(tm, "$input", "value");
725 /* Printv(f->code, tm, "\n",NIL); */
726 emit_action_code(n, f->code, tm);
727 } else {
728 Swig_warning(WARN_TYPEMAP_VARIN_UNDEF, input_file, line_number, "Unable to set variable of type %s.\n", SwigType_str(t, 0));
729 }
730 Printf(f->code, "}\n");
731 }
732
733 String *varname;
734 if (SwigType_istemplate((char *) name)) {
735 varname = SwigType_namestr((char *) name);
736 } else {
737 varname = name;
738 }
739
740 // Now return the value of the variable - regardless
741 // of evaluating or setting.
742 if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
743 Replaceall(tm, "$source", varname);
744 Replaceall(tm, "$varname", varname);
745 Replaceall(tm, "$target", "resultobj");
746 Replaceall(tm, "$result", "resultobj");
747 /* Printf(f->code, "%s\n", tm); */
748 emit_action_code(n, f->code, tm);
749 } else {
750 Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
751 }
752
753 Printv(f->code, "{\n",
754 "C_word func;\n",
755 "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
756 "if (C_swig_is_closurep(func))\n",
757 " ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
758 "else\n", " C_kontinue(continuation, resultobj);\n", "}\n", NIL);
759
760 /* Error handling code */
761 #ifdef USE_FAIL
762 Printf(f->code, "fail:\n");
763 Printf(f->code, "swig_panic (\"failure in " "'%s' SWIG wrapper\");\n", proc_name);
764 #endif
765 Printf(f->code, "}\n");
766
767 Wrapper_print(f, f_wrappers);
768
769 /* Now register the variable with the interpreter. */
770 addMethod(scmname, wname);
771
772 if (!in_class || member_name) {
773 String *clos_name;
774 if (in_class)
775 clos_name = NewString(member_name);
776 else
777 clos_name = chickenNameMapping(scmname, "");
778
779 Node *class_node = classLookup(t);
780 String *clos_code = Getattr(n, "tmap:varin:closcode");
781 if (class_node && clos_code && !GetFlag(n, "feature:immutable")) {
782 Replaceall(clos_code, "$input", "(car lst)");
783 Printv(clos_methods, "(define (", clos_name, " . lst) (if (null? lst) (", chickenPrimitiveName(scmname), ") (",
784 chickenPrimitiveName(scmname), " ", clos_code, ")))\n", NIL);
785 } else {
786 /* Simply re-export the procedure */
787 if (GetFlag(n, "feature:immutable") && GetFlag(n, "feature:constasvar")) {
788 Printv(clos_methods, "(define ", clos_name, " (", chickenPrimitiveName(scmname), "))\n", NIL);
789 Printv(scm_const_defs, "(set! ", scmname, " (", scmname, "))\n", NIL);
790 } else {
791 Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
792 }
793 }
794 Delete(clos_name);
795 }
796 } else {
797 Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
798 }
799
800 Delete(wname);
801 Delete(argnum);
802 Delete(arg);
803 Delete(tm2);
804 Delete(mangle);
805 DelWrapper(f);
806 return SWIG_OK;
807 }
808
809 /* ------------------------------------------------------------
810 * constantWrapper()
811 * ------------------------------------------------------------ */
812
constantWrapper(Node * n)813 int CHICKEN::constantWrapper(Node *n) {
814
815 char *name = GetChar(n, "name");
816 char *iname = GetChar(n, "sym:name");
817 SwigType *t = Getattr(n, "type");
818 ParmList *l = Getattr(n, "parms");
819 String *value = Getattr(n, "value");
820
821 String *proc_name = NewString("");
822 String *wname = NewString("");
823 String *mangle = NewString("");
824 String *tm;
825 String *tm2 = NewString("");
826 String *source = NewString("");
827 String *argnum = NewString("0");
828 String *arg = NewString("argv[0]");
829 Wrapper *f;
830 String *overname = 0;
831 String *scmname;
832 String *rvalue;
833 SwigType *nctype;
834
835 scmname = NewString(iname);
836 Replaceall(scmname, "_", "-");
837
838 Printf(source, "swig_const_%s", iname);
839 Replaceall(source, "::", "__");
840
841 Printf(mangle, "\"%s\"", SwigType_manglestr(t));
842
843 if (Getattr(n, "sym:overloaded")) {
844 overname = Getattr(n, "sym:overname");
845 } else {
846 if (!addSymbol(iname, n))
847 return SWIG_ERROR;
848 }
849
850 Append(wname, Swig_name_wrapper(iname));
851 if (overname) {
852 Append(wname, overname);
853 }
854
855 nctype = NewString(t);
856 if (SwigType_isconst(nctype)) {
857 Delete(SwigType_pop(nctype));
858 }
859
860 bool is_enum_item = (Cmp(nodeType(n), "enumitem") == 0);
861 if (SwigType_type(nctype) == T_STRING) {
862 rvalue = NewStringf("\"%s\"", value);
863 } else if (SwigType_type(nctype) == T_CHAR && !is_enum_item) {
864 rvalue = NewStringf("\'%s\'", value);
865 } else {
866 rvalue = NewString(value);
867 }
868
869 /* Special hook for member pointer */
870 if (SwigType_type(t) == T_MPOINTER) {
871 Printf(f_header, "static %s = %s;\n", SwigType_str(t, source), rvalue);
872 } else {
873 if ((tm = Swig_typemap_lookup("constcode", n, name, 0))) {
874 Replaceall(tm, "$source", rvalue);
875 Replaceall(tm, "$target", source);
876 Replaceall(tm, "$result", source);
877 Replaceall(tm, "$value", rvalue);
878 Printf(f_header, "%s\n", tm);
879 } else {
880 Swig_warning(WARN_TYPEMAP_CONST_UNDEF, input_file, line_number, "Unsupported constant value.\n");
881 return SWIG_NOWRAP;
882 }
883 }
884
885 f = NewWrapper();
886
887 /* Attach the standard typemaps */
888 emit_attach_parmmaps(l, f);
889 Setattr(n, "wrap:parms", l);
890
891 // evaluation function names
892
893 // Check for interrupts
894 Printv(f->code, "C_trace(\"", scmname, "\");\n", NIL);
895
896 if (1 || (SwigType_type(t) != T_USER) || (isPointer(t))) {
897
898 Setattr(n, "wrap:name", wname);
899 Printv(f->def, "static ", "void ", wname, "(C_word, C_word, C_word) C_noret;\n", NIL);
900
901 Printv(f->def, "static ", "void ", wname, "(C_word argc, C_word closure, " "C_word continuation) {\n", NIL);
902
903 Wrapper_add_local(f, "resultobj", "C_word resultobj");
904
905 Printf(f->code, "if (argc!=2) C_bad_argc(argc,2);\n");
906
907 // Return the value of the variable
908 if ((tm = Swig_typemap_lookup("varout", n, name, 0))) {
909
910 Replaceall(tm, "$source", source);
911 Replaceall(tm, "$varname", source);
912 Replaceall(tm, "$target", "resultobj");
913 Replaceall(tm, "$result", "resultobj");
914 /* Printf(f->code, "%s\n", tm); */
915 emit_action_code(n, f->code, tm);
916 } else {
917 Swig_warning(WARN_TYPEMAP_VAROUT_UNDEF, input_file, line_number, "Unable to read variable of type %s\n", SwigType_str(t, 0));
918 }
919
920 Printv(f->code, "{\n",
921 "C_word func;\n",
922 "SWIG_Chicken_FindCreateProxy(func, resultobj)\n",
923 "if (C_swig_is_closurep(func))\n",
924 " ((C_proc4)(void *)C_block_item(func, 0))(4,func,continuation,resultobj,C_SCHEME_FALSE);\n",
925 "else\n", " C_kontinue(continuation, resultobj);\n", "}\n", NIL);
926
927 /* Error handling code */
928 #ifdef USE_FAIL
929 Printf(f->code, "fail:\n");
930 Printf(f->code, "swig_panic (\"failure in " "'%s' SWIG wrapper\");\n", proc_name);
931 #endif
932 Printf(f->code, "}\n");
933
934 Wrapper_print(f, f_wrappers);
935
936 /* Now register the variable with the interpreter. */
937 addMethod(scmname, wname);
938
939 if (!in_class || member_name) {
940 String *clos_name;
941 if (in_class)
942 clos_name = NewString(member_name);
943 else
944 clos_name = chickenNameMapping(scmname, "");
945 if (GetFlag(n, "feature:constasvar")) {
946 Printv(clos_methods, "(define ", clos_name, " (", chickenPrimitiveName(scmname), "))\n", NIL);
947 Printv(scm_const_defs, "(set! ", scmname, " (", scmname, "))\n", NIL);
948 } else {
949 Printv(clos_methods, "(define ", clos_name, " ", chickenPrimitiveName(scmname), ")\n", NIL);
950 }
951 Delete(clos_name);
952 }
953
954 } else {
955 Swig_warning(WARN_TYPEMAP_VAR_UNDEF, input_file, line_number, "Unsupported variable type %s (ignored).\n", SwigType_str(t, 0));
956 }
957
958 Delete(wname);
959 Delete(nctype);
960 Delete(proc_name);
961 Delete(argnum);
962 Delete(arg);
963 Delete(tm2);
964 Delete(mangle);
965 Delete(source);
966 Delete(rvalue);
967 DelWrapper(f);
968 return SWIG_OK;
969 }
970
classHandler(Node * n)971 int CHICKEN::classHandler(Node *n) {
972 /* Create new strings for building up a wrapper function */
973 have_constructor = 0;
974 constructor_dispatch = 0;
975 constructor_name = 0;
976
977 c_class_name = NewString(Getattr(n, "sym:name"));
978 class_name = NewString("");
979 short_class_name = NewString("");
980 Printv(class_name, "<", c_class_name, ">", NIL);
981 Printv(short_class_name, c_class_name, NIL);
982 Replaceall(class_name, "_", "-");
983 Replaceall(short_class_name, "_", "-");
984
985 if (!addSymbol(class_name, n))
986 return SWIG_ERROR;
987
988 /* Handle inheritance */
989 String *base_class = NewString("");
990 List *baselist = Getattr(n, "bases");
991 if (baselist && Len(baselist)) {
992 Iterator base = First(baselist);
993 while (base.item) {
994 if (!Getattr(base.item, "feature:ignore"))
995 Printv(base_class, "<", Getattr(base.item, "sym:name"), "> ", NIL);
996 base = Next(base);
997 }
998 }
999
1000 Replaceall(base_class, "_", "-");
1001
1002 String *scmmod = NewString(module);
1003 Replaceall(scmmod, "_", "-");
1004
1005 Printv(clos_class_defines, "(define ", class_name, "\n", " (make <swig-metaclass-", scmmod, "> 'name \"", short_class_name, "\"\n", NIL);
1006 Delete(scmmod);
1007
1008 if (Len(base_class)) {
1009 Printv(clos_class_defines, " 'direct-supers (list ", base_class, ")\n", NIL);
1010 } else {
1011 Printv(clos_class_defines, " 'direct-supers (list <object>)\n", NIL);
1012 }
1013
1014 Printf(clos_class_defines, " 'direct-slots (list 'swig-this\n");
1015
1016 String *mangled_classname = Swig_name_mangle(Getattr(n, "sym:name"));
1017
1018 SwigType *ct = NewStringf("p.%s", Getattr(n, "name"));
1019 swigtype_ptr = SwigType_manglestr(ct);
1020
1021 Printf(f_runtime, "static swig_chicken_clientdata _swig_chicken_clientdata%s = { 0 };\n", mangled_classname);
1022 Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, ", (void *) &_swig_chicken_clientdata", mangled_classname, ");\n", NIL);
1023 SwigType_remember(ct);
1024
1025 /* Emit all of the members */
1026
1027 in_class = 1;
1028 Language::classHandler(n);
1029 in_class = 0;
1030
1031 Printf(clos_class_defines, ")))\n\n");
1032
1033 if (have_constructor) {
1034 Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", " (swig-initialize obj initargs ", NIL);
1035 if (constructor_arg_types) {
1036 String *initfunc_name = NewStringf("%s@@SWIG@initmethod", class_name);
1037 String *func_call = buildClosFunctionCall(constructor_arg_types, initfunc_name, chickenPrimitiveName(constructor_name));
1038 Printf(clos_methods, "%s)\n)\n", initfunc_name);
1039 Printf(clos_methods, "(declare (hide %s))\n", initfunc_name);
1040 Printf(clos_methods, "%s\n", func_call);
1041 Delete(func_call);
1042 Delete(initfunc_name);
1043 Delete(constructor_arg_types);
1044 constructor_arg_types = 0;
1045 } else if (constructor_dispatch) {
1046 Printf(clos_methods, "%s)\n)\n", constructor_dispatch);
1047 Delete(constructor_dispatch);
1048 constructor_dispatch = 0;
1049 } else {
1050 Printf(clos_methods, "%s)\n)\n", chickenPrimitiveName(constructor_name));
1051 }
1052 Delete(constructor_name);
1053 constructor_name = 0;
1054 } else {
1055 Printv(clos_methods, "(define-method (initialize (obj ", class_name, ") initargs)\n", " (swig-initialize obj initargs (lambda x #f)))\n", NIL);
1056 }
1057
1058 /* export class initialization function */
1059 if (clos) {
1060 String *funcname = NewString(mangled_classname);
1061 Printf(funcname, "_swig_chicken_setclosclass");
1062 String *closfuncname = NewString(funcname);
1063 Replaceall(closfuncname, "_", "-");
1064
1065 Printv(f_wrappers, "static void ", funcname, "(C_word,C_word,C_word,C_word) C_noret;\n",
1066 "static void ", funcname, "(C_word argc, C_word closure, C_word continuation, C_word cl) {\n",
1067 " C_trace(\"", funcname, "\");\n",
1068 " if (argc!=3) C_bad_argc(argc,3);\n",
1069 " swig_chicken_clientdata *cdata = (swig_chicken_clientdata *) SWIGTYPE", swigtype_ptr, "->clientdata;\n",
1070 " cdata->gc_proxy_create = CHICKEN_new_gc_root();\n",
1071 " CHICKEN_gc_root_set(cdata->gc_proxy_create, cl);\n", " C_kontinue(continuation, C_SCHEME_UNDEFINED);\n", "}\n", NIL);
1072 addMethod(closfuncname, funcname);
1073
1074 Printv(clos_methods, "(", chickenPrimitiveName(closfuncname), " (lambda (x lst) (if lst ",
1075 "(cons (make ", class_name, " 'swig-this x) lst) ", "(make ", class_name, " 'swig-this x))))\n\n", NIL);
1076 Delete(closfuncname);
1077 Delete(funcname);
1078 }
1079
1080 Delete(mangled_classname);
1081 Delete(swigtype_ptr);
1082 swigtype_ptr = 0;
1083
1084 Delete(class_name);
1085 Delete(short_class_name);
1086 Delete(c_class_name);
1087 class_name = 0;
1088 short_class_name = 0;
1089 c_class_name = 0;
1090
1091 return SWIG_OK;
1092 }
1093
memberfunctionHandler(Node * n)1094 int CHICKEN::memberfunctionHandler(Node *n) {
1095 String *iname = Getattr(n, "sym:name");
1096 String *proc = NewString(iname);
1097 Replaceall(proc, "_", "-");
1098
1099 member_name = chickenNameMapping(proc, short_class_name);
1100 Language::memberfunctionHandler(n);
1101 Delete(member_name);
1102 member_name = NULL;
1103 Delete(proc);
1104
1105 return SWIG_OK;
1106 }
1107
staticmemberfunctionHandler(Node * n)1108 int CHICKEN::staticmemberfunctionHandler(Node *n) {
1109 String *iname = Getattr(n, "sym:name");
1110 String *proc = NewString(iname);
1111 Replaceall(proc, "_", "-");
1112
1113 member_name = NewStringf("%s-%s", short_class_name, proc);
1114 Language::staticmemberfunctionHandler(n);
1115 Delete(member_name);
1116 member_name = NULL;
1117 Delete(proc);
1118
1119 return SWIG_OK;
1120 }
1121
membervariableHandler(Node * n)1122 int CHICKEN::membervariableHandler(Node *n) {
1123 String *iname = Getattr(n, "sym:name");
1124 //String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type")));
1125
1126 Language::membervariableHandler(n);
1127
1128 String *proc = NewString(iname);
1129 Replaceall(proc, "_", "-");
1130
1131 //Node *class_node = Swig_symbol_clookup(pb, Getattr(n, "sym:symtab"));
1132 Node *class_node = classLookup(Getattr(n, "type"));
1133
1134 //String *getfunc = NewStringf("%s-%s-get", short_class_name, proc);
1135 //String *setfunc = NewStringf("%s-%s-set", short_class_name, proc);
1136 String *getfunc = Swig_name_get(NSPACE_TODO, Swig_name_member(NSPACE_TODO, c_class_name, iname));
1137 Replaceall(getfunc, "_", "-");
1138 String *setfunc = Swig_name_set(NSPACE_TODO, Swig_name_member(NSPACE_TODO, c_class_name, iname));
1139 Replaceall(setfunc, "_", "-");
1140
1141 Printv(clos_class_defines, " (list '", proc, " ':swig-virtual ':swig-get ", chickenPrimitiveName(getfunc), NIL);
1142
1143 if (!GetFlag(n, "feature:immutable")) {
1144 if (class_node) {
1145 Printv(clos_class_defines, " ':swig-set (lambda (x y) (", chickenPrimitiveName(setfunc), " x (slot-ref y 'swig-this))))\n", NIL);
1146 } else {
1147 Printv(clos_class_defines, " ':swig-set ", chickenPrimitiveName(setfunc), ")\n", NIL);
1148 }
1149 } else {
1150 Printf(clos_class_defines, ")\n");
1151 }
1152
1153 Delete(proc);
1154 Delete(setfunc);
1155 Delete(getfunc);
1156 return SWIG_OK;
1157 }
1158
staticmembervariableHandler(Node * n)1159 int CHICKEN::staticmembervariableHandler(Node *n) {
1160 String *iname = Getattr(n, "sym:name");
1161 String *proc = NewString(iname);
1162 Replaceall(proc, "_", "-");
1163
1164 member_name = NewStringf("%s-%s", short_class_name, proc);
1165 Language::staticmembervariableHandler(n);
1166 Delete(member_name);
1167 member_name = NULL;
1168 Delete(proc);
1169
1170 return SWIG_OK;
1171 }
1172
constructorHandler(Node * n)1173 int CHICKEN::constructorHandler(Node *n) {
1174 have_constructor = 1;
1175 has_constructor_args = 0;
1176
1177
1178 exporting_constructor = true;
1179 Language::constructorHandler(n);
1180 exporting_constructor = false;
1181
1182 has_constructor_args = 1;
1183
1184 String *iname = Getattr(n, "sym:name");
1185 constructor_name = Swig_name_construct(NSPACE_TODO, iname);
1186 Replaceall(constructor_name, "_", "-");
1187 return SWIG_OK;
1188 }
1189
destructorHandler(Node * n)1190 int CHICKEN::destructorHandler(Node *n) {
1191
1192 if (no_collection)
1193 member_name = NewStringf("delete-%s", short_class_name);
1194
1195 exporting_destructor = true;
1196 Language::destructorHandler(n);
1197 exporting_destructor = false;
1198
1199 if (no_collection) {
1200 Delete(member_name);
1201 member_name = NULL;
1202 }
1203
1204 return SWIG_OK;
1205 }
1206
importDirective(Node * n)1207 int CHICKEN::importDirective(Node *n) {
1208 String *modname = Getattr(n, "module");
1209 if (modname && clos_uses) {
1210
1211 // Find the module node for this imported module. It should be the
1212 // first child but search just in case.
1213 Node *mod = firstChild(n);
1214 while (mod && Strcmp(nodeType(mod), "module") != 0)
1215 mod = nextSibling(mod);
1216
1217 if (mod) {
1218 String *name = Getattr(mod, "name");
1219 if (name) {
1220 Printf(closprefix, "(declare (uses %s))\n", name);
1221 }
1222 }
1223 }
1224
1225 return Language::importDirective(n);
1226 }
1227
buildClosFunctionCall(List * types,const_String_or_char_ptr closname,const_String_or_char_ptr funcname)1228 String *CHICKEN::buildClosFunctionCall(List *types, const_String_or_char_ptr closname, const_String_or_char_ptr funcname) {
1229 String *method_signature = NewString("");
1230 String *func_args = NewString("");
1231 String *func_call = NewString("");
1232
1233 Iterator arg_type;
1234 int arg_count = 0;
1235 int optional_arguments = 0;
1236
1237 for (arg_type = First(types); arg_type.item; arg_type = Next(arg_type)) {
1238 if (Strcmp(arg_type.item, "^^##optional$$") == 0) {
1239 optional_arguments = 1;
1240 } else {
1241 Printf(method_signature, " (arg%i %s)", arg_count, arg_type.item);
1242 arg_type = Next(arg_type);
1243 if (!arg_type.item)
1244 break;
1245
1246 String *arg = NewStringf("arg%i", arg_count);
1247 String *access_arg = Copy(arg_type.item);
1248
1249 Replaceall(access_arg, "$input", arg);
1250 Printf(func_args, " %s", access_arg);
1251
1252 Delete(arg);
1253 Delete(access_arg);
1254 }
1255 arg_count++;
1256 }
1257
1258 if (optional_arguments) {
1259 Printf(func_call, "(define-method (%s %s . args) (apply %s %s args))", closname, method_signature, funcname, func_args);
1260 } else {
1261 Printf(func_call, "(define-method (%s %s) (%s %s))", closname, method_signature, funcname, func_args);
1262 }
1263
1264 Delete(method_signature);
1265 Delete(func_args);
1266
1267 return func_call;
1268 }
1269
1270 extern "C" {
1271
1272 /* compares based on non-primitive names */
compareTypeListsHelper(const DOH * a,const DOH * b,int opt_equal)1273 static int compareTypeListsHelper(const DOH *a, const DOH *b, int opt_equal) {
1274 List *la = (List *) a;
1275 List *lb = (List *) b;
1276
1277 Iterator ia = First(la);
1278 Iterator ib = First(lb);
1279
1280 while (ia.item && ib.item) {
1281 int ret = Strcmp(ia.item, ib.item);
1282 if (ret)
1283 return ret;
1284 ia = Next(Next(ia));
1285 ib = Next(Next(ib));
1286 } if (opt_equal && ia.item && Strcmp(ia.item, "^^##optional$$") == 0)
1287 return 0;
1288 if (ia.item)
1289 return -1;
1290 if (opt_equal && ib.item && Strcmp(ib.item, "^^##optional$$") == 0)
1291 return 0;
1292 if (ib.item)
1293 return 1;
1294
1295 return 0;
1296 }
1297
compareTypeLists(const DOH * a,const DOH * b)1298 static int compareTypeLists(const DOH *a, const DOH *b) {
1299 return compareTypeListsHelper(a, b, 0);
1300 }
1301 }
1302
dispatchFunction(Node * n)1303 void CHICKEN::dispatchFunction(Node *n) {
1304 /* Last node in overloaded chain */
1305
1306 int maxargs;
1307 String *tmp = NewString("");
1308 String *dispatch = Swig_overload_dispatch(n, "%s (2+$numargs,closure," "continuation$commaargs);", &maxargs);
1309
1310 /* Generate a dispatch wrapper for all overloaded functions */
1311
1312 Wrapper *f = NewWrapper();
1313 String *iname = Getattr(n, "sym:name");
1314 String *wname = NewString("");
1315 String *scmname = NewString(iname);
1316 Replaceall(scmname, "_", "-");
1317
1318 Append(wname, Swig_name_wrapper(iname));
1319
1320 Printv(f->def, "static void real_", wname, "(C_word, C_word, C_word, C_word) C_noret;\n", NIL);
1321
1322 Printv(f->def, "static void real_", wname, "(C_word oldargc, C_word closure, C_word continuation, C_word args) {", NIL);
1323
1324 Wrapper_add_local(f, "argc", "int argc");
1325 Printf(tmp, "C_word argv[%d]", maxargs + 1);
1326 Wrapper_add_local(f, "argv", tmp);
1327 Wrapper_add_local(f, "ii", "int ii");
1328 Wrapper_add_local(f, "t", "C_word t = args");
1329 Printf(f->code, "if (!C_swig_is_list (args)) {\n");
1330 Printf(f->code, " swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE, " "\"Argument #1 must be a list of overloaded arguments\");\n");
1331 Printf(f->code, "}\n");
1332 Printf(f->code, "argc = C_unfix (C_i_length (args));\n");
1333 Printf(f->code, "for (ii = 0; (ii < argc) && (ii < %d); ii++, t = C_block_item (t, 1)) {\n", maxargs);
1334 Printf(f->code, "argv[ii] = C_block_item (t, 0);\n");
1335 Printf(f->code, "}\n");
1336
1337 Printv(f->code, dispatch, "\n", NIL);
1338 Printf(f->code, "swig_barf (SWIG_BARF1_BAD_ARGUMENT_TYPE," "\"No matching function for overloaded '%s'\");\n", iname);
1339 Printv(f->code, "}\n", NIL);
1340 Wrapper_print(f, f_wrappers);
1341 addMethod(scmname, wname);
1342
1343 DelWrapper(f);
1344 f = NewWrapper();
1345
1346 /* varargs */
1347 Printv(f->def, "void ", wname, "(C_word, C_word, C_word, ...) C_noret;\n", NIL);
1348 Printv(f->def, "void ", wname, "(C_word c, C_word t0, C_word t1, ...) {", NIL);
1349 Printv(f->code,
1350 "C_word t2;\n",
1351 "va_list v;\n",
1352 "C_word *a, c2 = c;\n",
1353 "C_save_rest (t1, c2, 2);\n", "a = C_alloc((c-2)*3);\n", "t2 = C_restore_rest (a, C_rest_count (0));\n", "real_", wname, " (3, t0, t1, t2);\n", NIL);
1354 Printv(f->code, "}\n", NIL);
1355 Wrapper_print(f, f_wrappers);
1356
1357 /* Now deal with overloaded function when exporting clos */
1358 if (clos) {
1359 List *flist = Getattr(overload_parameter_lists, scmname);
1360 if (flist) {
1361 Delattr(overload_parameter_lists, scmname);
1362
1363 SortList(flist, compareTypeLists);
1364
1365 String *clos_name;
1366 if (have_constructor && !has_constructor_args) {
1367 has_constructor_args = 1;
1368 constructor_dispatch = NewStringf("%s@SWIG@new@dispatch", short_class_name);
1369 clos_name = Copy(constructor_dispatch);
1370 Printf(clos_methods, "(declare (hide %s))\n", clos_name);
1371 } else if (in_class)
1372 clos_name = NewString(member_name);
1373 else
1374 clos_name = chickenNameMapping(scmname, "");
1375
1376 Iterator f;
1377 List *prev = 0;
1378 int all_primitive = 1;
1379
1380 /* first check for duplicates and an empty call */
1381 String *newlist = NewList();
1382 for (f = First(flist); f.item; f = Next(f)) {
1383 /* check if cur is a duplicate of prev */
1384 if (prev && compareTypeListsHelper(f.item, prev, 1) == 0) {
1385 Delete(f.item);
1386 } else {
1387 Append(newlist, f.item);
1388 prev = f.item;
1389 Iterator j;
1390 for (j = First(f.item); j.item; j = Next(j)) {
1391 if (Strcmp(j.item, "^^##optional$$") != 0 && Strcmp(j.item, "<top>") != 0)
1392 all_primitive = 0;
1393 }
1394 }
1395 }
1396 Delete(flist);
1397 flist = newlist;
1398
1399 if (all_primitive) {
1400 Printf(clos_methods, "(define %s %s)\n", clos_name, chickenPrimitiveName(scmname));
1401 } else {
1402 for (f = First(flist); f.item; f = Next(f)) {
1403 /* now export clos code for argument */
1404 String *func_call = buildClosFunctionCall(f.item, clos_name, chickenPrimitiveName(scmname));
1405 Printf(clos_methods, "%s\n", func_call);
1406 Delete(f.item);
1407 Delete(func_call);
1408 }
1409 }
1410
1411 Delete(clos_name);
1412 Delete(flist);
1413 }
1414 }
1415
1416 DelWrapper(f);
1417 Delete(dispatch);
1418 Delete(tmp);
1419 Delete(wname);
1420 }
1421
isPointer(SwigType * t)1422 int CHICKEN::isPointer(SwigType *t) {
1423 return SwigType_ispointer(SwigType_typedef_resolve_all(t));
1424 }
1425
addMethod(String * scheme_name,String * function)1426 void CHICKEN::addMethod(String *scheme_name, String *function) {
1427 String *sym = NewString("");
1428 if (clos) {
1429 Append(sym, "primitive:");
1430 }
1431 Append(sym, scheme_name);
1432
1433 /* add symbol to Chicken internal symbol table */
1434 if (hide_primitive) {
1435 Printv(f_init, "{\n",
1436 " C_word *p0 = a;\n", " *(a++)=C_CLOSURE_TYPE|1;\n", " *(a++)=(C_word)", function, ";\n", " C_mutate(return_vec++, (C_word)p0);\n", "}\n", NIL);
1437 } else {
1438 Printf(f_sym_size, "+C_SIZEOF_INTERNED_SYMBOL(%d)", Len(sym));
1439 Printf(f_init, "sym = C_intern (&a, %d, \"%s\");\n", Len(sym), sym);
1440 Printv(f_init, "C_mutate ((C_word*)sym+1, (*a=C_CLOSURE_TYPE|1, a[1]=(C_word)", function, ", tmp=(C_word)a, a+=2, tmp));\n", NIL);
1441 }
1442
1443 if (hide_primitive) {
1444 Setattr(primitive_names, scheme_name, NewStringf("(vector-ref swig-init-return %i)", num_methods));
1445 } else {
1446 Setattr(primitive_names, scheme_name, Copy(sym));
1447 }
1448
1449 num_methods++;
1450
1451 Delete(sym);
1452 }
1453
chickenPrimitiveName(String * name)1454 String *CHICKEN::chickenPrimitiveName(String *name) {
1455 String *value = Getattr(primitive_names, name);
1456 if (value)
1457 return value;
1458 else {
1459 Swig_error(input_file, line_number, "Internal Error: attempting to reference non-existent primitive name %s\n", name);
1460 return NewString("#f");
1461 }
1462 }
1463
validIdentifier(String * s)1464 int CHICKEN::validIdentifier(String *s) {
1465 char *c = Char(s);
1466 /* Check whether we have an R5RS identifier. */
1467 /* <identifier> --> <initial> <subsequent>* | <peculiar identifier> */
1468 /* <initial> --> <letter> | <special initial> */
1469 if (!(isalpha(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1470 || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1471 || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1472 || (*c == '^') || (*c == '_') || (*c == '~'))) {
1473 /* <peculiar identifier> --> + | - | ... */
1474 if ((strcmp(c, "+") == 0)
1475 || strcmp(c, "-") == 0 || strcmp(c, "...") == 0)
1476 return 1;
1477 else
1478 return 0;
1479 }
1480 /* <subsequent> --> <initial> | <digit> | <special subsequent> */
1481 while (*c) {
1482 if (!(isalnum(*c) || (*c == '!') || (*c == '$') || (*c == '%')
1483 || (*c == '&') || (*c == '*') || (*c == '/') || (*c == ':')
1484 || (*c == '<') || (*c == '=') || (*c == '>') || (*c == '?')
1485 || (*c == '^') || (*c == '_') || (*c == '~') || (*c == '+')
1486 || (*c == '-') || (*c == '.') || (*c == '@')))
1487 return 0;
1488 c++;
1489 }
1490 return 1;
1491 }
1492
1493 /* ------------------------------------------------------------
1494 * closNameMapping()
1495 * Maps the identifier from C++ to the CLOS based on command
1496 * line parameters and such.
1497 * If class_name = "" that means the mapping is for a function or
1498 * variable not attached to any class.
1499 * ------------------------------------------------------------ */
chickenNameMapping(String * name,const_String_or_char_ptr class_name)1500 String *CHICKEN::chickenNameMapping(String *name, const_String_or_char_ptr class_name) {
1501 String *n = NewString("");
1502
1503 if (Strcmp(class_name, "") == 0) {
1504 // not part of a class, so no class name to prefix
1505 if (clossymnameprefix) {
1506 Printf(n, "%s%s", clossymnameprefix, name);
1507 } else {
1508 Printf(n, "%s", name);
1509 }
1510 } else {
1511 if (useclassprefix) {
1512 Printf(n, "%s-%s", class_name, name);
1513 } else {
1514 if (clossymnameprefix) {
1515 Printf(n, "%s%s", clossymnameprefix, name);
1516 } else {
1517 Printf(n, "%s", name);
1518 }
1519 }
1520 }
1521 return n;
1522 }
1523
runtimeCode()1524 String *CHICKEN::runtimeCode() {
1525 String *s = Swig_include_sys("chickenrun.swg");
1526 if (!s) {
1527 Printf(stderr, "*** Unable to open 'chickenrun.swg'\n");
1528 s = NewString("");
1529 }
1530 return s;
1531 }
1532
defaultExternalRuntimeFilename()1533 String *CHICKEN::defaultExternalRuntimeFilename() {
1534 return NewString("swigchickenrun.h");
1535 }
1536