From c7340a0bf3548210334ee9a63aed30cbe10408a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Matthias=20K=C3=B6ppe?= Date: Sun, 2 Nov 2003 23:15:59 +0000 Subject: [PATCH] Merge new set of GOOPS changes by John Lenz. GOOPS objects are now manipulated directly by the C code. Some fixes to typemap-GOOPS interaction. Remove the file argument to -scmstub and -goops. The Scheme files are now always called MODULE.scm or MODULE-primitive.scm, where MODULE is the module name and "primitive" can be changed by the -primsuffix option. The Scheme files are now placed in the directory given by the -outdir option, or the current directory. (Patch by John Lenz, slightly modified.) git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk/SWIG@5255 626c5289-ae23-0410-ae9c-e8d60b6d4f22 --- Source/Modules/guile.cxx | 264 ++++++++++++++++++++------------------- 1 file changed, 137 insertions(+), 127 deletions(-) diff --git a/Source/Modules/guile.cxx b/Source/Modules/guile.cxx index 4b928b6ab..9f3f046e9 100644 --- a/Source/Modules/guile.cxx +++ b/Source/Modules/guile.cxx @@ -56,11 +56,11 @@ Guile Options (available with -guile)\n\ `ltdlmod' for Guile's old dynamic module\n\ convention (Guile <= 1.4), or `hobbit' for hobbit\n\ modules.\n\ - -scmstub - Output Scheme with module declaration and\n\ + -scmstub - Output Scheme file with module declaration and\n\ exports; only with `passive' and `simple' linkage\n\ -gh - Use the gh_ Guile API. (Guile <= 1.8, default) \n\ -scm - Use the scm Guile API. (Guile >= 1.6) \n\ - -goops - Export GOOPS class definitions to \n\ + -shadow - Export GOOPS class definitions\n\ -emitslotaccessors - Emit accessor methods for all GOOPS slots\n\ -primsuffix - Name appended to primitive module when exporting\n\ GOOPS classes. (default = \"primitive\")\n\ @@ -86,10 +86,10 @@ static enum { GUILE_LSTYLE_HOBBIT // use (hobbit4d link) } linkage = GUILE_LSTYLE_SIMPLE; -static File *procdoc = 0; -static File *scmstub = 0; +static File *procdoc = 0; +static bool scmstub = false; static String *scmtext; -static File *goopsfile = 0; +static bool goops = false; static String *goopstext; static String *goopscode; static String *goopsexport; @@ -236,24 +236,12 @@ public: Swig_mark_arg (i); } else if (strcmp (argv[i], "-scmstub") == 0) { - if (argv[i + 1]) { - scmstub = NewFile(argv[i + 1], (char *) "w"); - Swig_mark_arg (i); - Swig_mark_arg (i + 1); - i++; - } else { - Swig_arg_error(); - } + scmstub = true; + Swig_mark_arg(i); } - else if (strcmp (argv[i], "-goops") == 0) { - if (argv[i + 1]) { - goopsfile = NewFile(argv[i + 1], (char *) "w"); - Swig_mark_arg (i); - Swig_mark_arg (i + 1); - i++; - } else { - Swig_arg_error(); - } + else if (strcmp (argv[i], "-shadow") == 0) { + goops = true; + Swig_mark_arg(i); } else if (strcmp(argv[i], "-gh") == 0) { use_scm_interface = 0; @@ -300,15 +288,15 @@ public: primsuffix = NewString("primitive"); //goops support can only be enabled if passive or module linkage is used - if (goopsfile) { + if (goops) { if (linkage != GUILE_LSTYLE_PASSIVE && linkage != GUILE_LSTYLE_MODULE) { Printf(stderr, "guile: GOOPS support requires passive or module linkage\n"); exit(1); } } - if (goopsfile) { - // -goops implies -emit-setters + if (goops) { + // -shadow implies -emit-setters emit_setters = 1; } @@ -435,14 +423,6 @@ public: Delete(procdoc); procdoc = NULL; } - if (scmstub) { - Delete(scmstub); - scmstub = NULL; - } - if (goopsfile) { - Delete(goopsfile); - goopsfile = NULL; - } Delete(goopscode); Delete(goopsexport); Delete(goopstext); @@ -468,7 +448,7 @@ public: } Printv(module_func,module_name,NIL); - if (goopsfile) + if (goops) Replaceall(module_func,"-", "_"); switch (linkage) { @@ -518,7 +498,7 @@ public: Printf (f_init, "SCM\n%s (void)\n{\n", module_func); { String *mod = NewString(module_name); - if (goopsfile) + if (goops) Printv(mod,"-",primsuffix,NIL); Replaceall(mod,"/", " "); Printf(f_init, " SCM module = scm_c_define_module(\"%s\",\n", mod); @@ -549,32 +529,55 @@ public: if (scmstub) { /* Emit Scheme stub if requested */ - String *mod = NewString(module_name); - if (goopsfile) - Printv(mod,"-",primsuffix,NIL); + String *primitive_name = NewString(module_name); + if (goops) + Printv(primitive_name,"-",primsuffix,NIL); + + String *mod = NewString(primitive_name); Replaceall(mod, "/", " "); - Printf (scmstub, ";;; -*- buffer-read-only: t -*- vi: set ro: */\n"); - Printf (scmstub, ";;; Automatically generated by SWIG; do not edit.\n\n"); + + String *fname = NewStringf("%s%s.scm", + SWIG_output_directory(), + primitive_name); + Delete(primitive_name); + File *scmstubfile = NewFile(fname, (char *) "w"); + if (!scmstubfile) { + Printf(stderr,"*** Can't open '%s' for writing\n", fname); + SWIG_exit(EXIT_FAILURE); + } + Delete(fname); + + Printf (scmstubfile, ";;; -*- buffer-read-only: t -*- vi: set ro: */\n"); + Printf (scmstubfile, ";;; Automatically generated by SWIG; do not edit.\n\n"); if (linkage == GUILE_LSTYLE_SIMPLE - || linkage == GUILE_LSTYLE_PASSIVE) - Printf (scmstub, "(define-module (%s))\n\n", mod); + || linkage == GUILE_LSTYLE_PASSIVE) + Printf (scmstubfile, "(define-module (%s))\n\n", mod); Delete(mod); - Printf (scmstub, "%s", scmtext); + Printf (scmstubfile, "%s", scmtext); if ((linkage == GUILE_LSTYLE_SIMPLE - || linkage == GUILE_LSTYLE_PASSIVE) - && Len(exported_symbols) > 0) { - String *ex = NewString(exported_symbols); - Replaceall(ex, ", ", "\n "); - Replaceall(ex, "\"", ""); - Chop(ex); - Printf(scmstub, "\n(export %s)\n", ex); - Delete(ex); + || linkage == GUILE_LSTYLE_PASSIVE) + && Len(exported_symbols) > 0) { + String *ex = NewString(exported_symbols); + Replaceall(ex, ", ", "\n "); + Replaceall(ex, "\"", ""); + Chop(ex); + Printf(scmstubfile, "\n(export %s)\n", ex); + Delete(ex); } } - if (goopsfile) { + if (goops) { String *mod = NewString(module_name); Replaceall(mod, "/", " "); + + String *fname = NewStringf("%s%s.scm", SWIG_output_directory(), + module_name); + File *goopsfile = NewFile(fname, (char *)"w"); + if (!goopsfile) { + Printf(stderr,"*** Can't open '%s' for writing\n", fname); + SWIG_exit(EXIT_FAILURE); + } + Delete(fname); Printf (goopsfile, ";;; -*- buffer-read-only: t -*- vi: set ro: */\n"); Printf (goopsfile, ";;; Automatically generated by SWIG; do not edit.\n\n"); Printf (goopsfile, "(define-module (%s))\n", mod); @@ -594,6 +597,7 @@ public: Delete(ex); } Delete(mod); + Delete(goopsfile); } Delete(module_func); @@ -966,14 +970,14 @@ public: if (use_scm_interface) { /* GOOPS support uses the MEMBER-set and MEMBER-get functions, so ignore only_setters in this case. */ - if (only_setters && !goopsfile) + if (only_setters && !goops) Printf(f_init, "scm_c_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs-numreq, wname); else Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs-numreq, wname); } else { - if (only_setters && !goopsfile) + if (only_setters && !goops) Printf(f_init, "scm_make_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs-numreq, wname); else @@ -1014,7 +1018,10 @@ public: /* Register the function */ if (use_scm_interface) { if (exporting_destructor) { - Printf(f_init, "SWIG_TypeClientData(SWIGTYPE%s, (void *) %s);\n", swigtype_ptr, wname); + Printf(f_init, + "((swig_guile_clientdata *)(SWIGTYPE%s->clientdata))->destroy = (guile_destructor) %s;\n", + swigtype_ptr, wname); + //Printf(f_init, "SWIG_TypeClientData(SWIGTYPE%s, (void *) %s);\n", swigtype_ptr, wname); } else { Printf(f_init, "scm_c_define_gsubr(\"%s\", %d, %d, 0, (swig_guile_proc) %s);\n", proc_name, numreq, numargs-numreq, wname); @@ -1068,18 +1075,10 @@ public: String *wrapargs = NewString(""); buildGoopsArguments(Getattr(n, "parms"), args, wrapargs); - String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type"))); String *goops_name = goopsNameMapping(proc_name, (char *)""); - if (Getattr(known_classes, pb)) { - Printv(goopscode, "(define-method (", goops_name, args, ")\n", NIL); - Printv(goopscode, " (make <", pb, "> #:init-smob (", primRenamer ? "primitive:" : "", NIL); - Printv(goopscode, proc_name, wrapargs, ")))\n", NIL); - } else { - Printv(goopscode, "(define-method (", goops_name, args, ")\n", NIL); - Printv(goopscode, primRenamer ? " (primitive:" : " (", proc_name, wrapargs, "))\n", NIL); - } + Printv(goopscode, "(define-method (", goops_name, args, ")\n", NIL); + Printv(goopscode, primRenamer ? " (primitive:" : " (", proc_name, wrapargs, "))\n", NIL); Printf(goopsexport, "%s ", goops_name); - Delete(pb); Delete(goops_name); Delete(wrapargs); Delete(args); @@ -1237,23 +1236,8 @@ public: if (primRenamer) Printv(primitive_name, "primitive:", NIL); Printv(primitive_name, proc_name, NIL); - if (Getattr(known_classes, class_name)) { - /* Create a procedure or p-w-s that handles the GOOPS object */ - if (!Getattr(n, "feature:immutable")) { - Printv(goopscode, "(define ", goops_name, " (make-procedure-with-setter\n", - "\t(lambda () (make <", class_name, "> #:init-smob (", primitive_name, ")))\n", - "\t(lambda (new-value) (", primitive_name, " (slot-ref new-value 'smob))))\n", - NIL); - } - else { - Printv(goopscode, "(define (", goops_name, ")\n", - " (make <", class_name, "> #:init-smob (", primitive_name, ")))"); - } - Printf(goopscode, "\n"); - } else { - /* Simply re-export the procedure */ - Printv(goopscode, "(define ", goops_name, " ", primitive_name, ")\n", NIL); - } + /* Simply re-export the procedure */ + Printv(goopscode, "(define ", goops_name, " ", primitive_name, ")\n", NIL); Printf(goopsexport, "%s ", goops_name); Delete(primitive_name); Delete(class_name); @@ -1456,9 +1440,20 @@ public: } else { Printv(goopscode,"()\n", NIL); } - SwigType *t = NewStringf("p.%s", Getattr(n, "name")); - swigtype_ptr = SwigType_manglestr(t); - Delete(t); + SwigType *ct = NewStringf("p.%s", Getattr(n, "name")); + swigtype_ptr = SwigType_manglestr(ct); + + String *mangled_classname = Swig_name_mangle(Getattr(n, "sym:name")); + /* Export clientdata structure */ + if (use_scm_interface) { + Printf(f_runtime, "static swig_guile_clientdata _swig_guile_clientdata%s = { NULL, SCM_EOL };\n", + mangled_classname); + + Printv(f_init, "SWIG_TypeClientData(SWIGTYPE", swigtype_ptr, + ", (void *) &_swig_guile_clientdata", mangled_classname, ");\n", NIL); + SwigType_remember(ct); + } + Delete(ct); /* Emit all of the members */ goops_class_methods = NewString(""); @@ -1472,10 +1467,40 @@ public: if (have_constructor) Printv(goopscode," #:new-function ", primRenamer ? "primitive:" : "", "new-", short_class_name, "\n", NIL); + Printf(goopscode,")\n%s\n", goops_class_methods); Delete(goops_class_methods); goops_class_methods = 0; + + /* export class initialization function */ + if (goops) { + /* export the wrapper function */ + String *funcName = NewString(mangled_classname); + Printf(funcName, "_swig_guile_setgoopsclass"); + String *guileFuncName = NewString(funcName); + Replaceall(guileFuncName, "_", "-"); + + Printv(f_wrappers, "static SCM ", funcName, "(SCM cl) \n", NIL); + Printf(f_wrappers, "#define FUNC_NAME %s\n{\n", guileFuncName); + Printv(f_wrappers, " ((swig_guile_clientdata *)(SWIGTYPE", swigtype_ptr, + "->clientdata))->goops_class = cl;\n", NIL); + Printf(f_wrappers, " return SCM_UNSPECIFIED;\n"); + Printf(f_wrappers, "}\n#undef FUNC_NAME\n\n"); + + Printf(f_init, "scm_c_define_gsubr(\"%s\", 1, 0, 0, (swig_guile_proc) %s);\n", + guileFuncName, funcName); + Printf(exported_symbols, "\"%s\", ", guileFuncName); + + /* export the call to the wrapper function */ + Printf(goopscode, "(%s%s %s)\n\n", primRenamer ? "primitive:" : "", guileFuncName, class_name); + + Delete(guileFuncName); + Delete(funcName); + } + + Delete(mangled_classname); + Delete(swigtype_ptr); swigtype_ptr = 0; @@ -1495,34 +1520,42 @@ public: void buildGoopsArguments(ParmList *l, String *args, String *wrapargs) { Parm *p; Node *search; - int i; + int argnum = 0; /* input arguments */ - for (i=0, p=l; p; i++) { - while (checkAttribute(p,"tmap:in:numinputs","0")) { - if (Getattr(p, "tmap:in:next")) { - p = Getattr(p,"tmap:in:next"); - } else { - break; - } + for (p=l; p; p = nextSibling(p)) { + while (p && checkAttribute(p,"tmap:in:numinputs","0")) { + p = Getattr(p,"tmap:in:next"); } + if (!p) break; + SwigType *pt = Getattr(p,"type"); String *pn = Getattr(p,"name"); SwigType *pb = SwigType_typedef_resolve_all(SwigType_base(pt)); - + String *argname; + argnum++; + if (pn) + argname = pn; + else { + /* Anonymous arg */ + argname = NewStringf("arg%d", argnum); + } + if (strcmp("void", Char(pt)) != 0) { /* do input conversion */ if ((search = Getattr(known_classes, pb))) { - Printv(wrapargs, " (slot-ref ", pn, " 'smob)", NIL); - Printv(args, " (", pn, " <", pb, ">)", NIL); + Printv(wrapargs, " (slot-ref ", argname, " 'swig-smob)", NIL); + Printv(args, " (", argname, " <", pb, ">)", NIL); } else { - Printv(wrapargs, " ", pn, NIL); - Printv(args, " ", pn, NIL); + Printv(wrapargs, " ", argname, NIL); + Printv(args, " ", argname, NIL); } } + if (!pn) { + Delete(argname); + } - p = nextSibling(p); } Replaceall(args, "_", "-"); @@ -1534,7 +1567,6 @@ public: * ------------------------------------------------------------ */ int memberfunctionHandler(Node *n) { String *iname = Getattr(n,"sym:name"); - SwigType *d = Getattr(n,"type"); String *args; String *wrapargs; @@ -1547,21 +1579,12 @@ public: String *proc = NewString(iname); Replaceall(proc,"_", "-"); - String *pb = SwigType_typedef_resolve_all(SwigType_base(d)); String *goops_name = goopsNameMapping(proc, short_class_name); - if (Getattr(known_classes, pb)) { - Printv(goops_class_methods, - "(define-method (", goops_name, " (swig_smob ", class_name, ")", args, ")\n", - " (make <", pb, "> #:init-smob (", primRenamer ? "primitive:" : "", short_class_name, "-", proc, - " (slot-ref swig_smob 'smob)", wrapargs, ")))\n", NIL); - } else { - Printv(goops_class_methods, + Printv(goops_class_methods, "(define-method (", goops_name, " (swig_smob ", class_name, ")", args, ")\n", primRenamer ? " (primitive:" : " (", short_class_name, "-", proc, - " (slot-ref swig_smob 'smob)", wrapargs, "))\n", NIL); - } + " (slot-ref swig_smob 'swig-smob)", wrapargs, "))\n", NIL); Printf(goopsexport, "%s ", goops_name); - Delete(pb); Delete(goops_name); Delete(wrapargs); @@ -1576,8 +1599,6 @@ public: int membervariableHandler(Node *n) { String *iname = Getattr(n,"sym:name"); - String *search; - String *pb = SwigType_typedef_resolve_all(SwigType_base(Getattr(n, "type"))); if (emit_setters) { struct_member = 1; @@ -1591,29 +1612,18 @@ public: struct_member = 0; } - bool class_found = false; - if ((search = Getattr(known_classes, pb))) { - class_found = true; - } - String *proc = NewString(iname); Replaceall(proc,"_", "-"); String *goops_name = goopsNameMapping(proc, short_class_name); - Printv(goopscode, " (", goops_name, " #:allocation", NIL); - if (class_found) { - Printv(goopscode, " #:swig-virtual-class", NIL); - } else { - Printv(goopscode, " #:swig-virtual", NIL); - } + Printv(goopscode, " (", goops_name, " #:allocation #:virtual", NIL); Printv(goopscode, " #:slot-ref ", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-get", NIL); if (!Getattr(n,"feature:immutable")) { Printv(goopscode, " #:slot-set! ", primRenamer ? "primitive:" : "", short_class_name, "-", proc, "-set", NIL); - } - if (class_found) { - Printv(goopscode, " #:class <", pb, ">", NIL); + } else { + Printf(goopscode, " #:slot-set! (lambda (obj value) (error \"Immutable slot\"))"); } if (emit_slot_accessors) { if (Getattr(n, "feature:immutable")) {