static SCM scm_gnumeric_funcall (SCM funcname, SCM arglist) { int i, num_args; GnmValue **argvals; GnmValue *retval; SCM retsmob; GnmCellRef cell_ref = { 0, 0, 0, 0 }; SCM_ASSERT (SCM_NIMP (funcname) && SCM_STRINGP (funcname), funcname, SCM_ARG1, "gnumeric-funcall"); SCM_ASSERT (SCM_NFALSEP (scm_list_p (arglist)), arglist, SCM_ARG2, "gnumeric-funcall"); num_args = scm_ilength (arglist); argvals = g_new (GnmValue *, num_args); for (i = 0; i < num_args; ++i) { argvals[i] = scm_to_value (SCM_CAR (arglist)); arglist = SCM_CDR (arglist); } retval = function_call_with_values (eval_pos, SCM_CHARS (funcname), num_args,argvals); retsmob = value_to_scm (retval, cell_ref); value_release (retval); return retsmob; }
/* * FIXME: If we clean up at exit, removing the registered functions, we get * rid of the 'Leaking string [Guile] with ref_count=1' warnings. The way we * do this for other plugins, including Python, we deactivate the * plugin. However, it is not possible to finalize Guile. */ static SCM scm_register_function (SCM scm_name, SCM scm_args, SCM scm_help, SCM scm_category, SCM scm_function) { GnmFunc *fndef; GnmFuncGroup *cat; GnmFuncDescriptor desc; char *help; SCM_ASSERT (SCM_NIMP (scm_name) && SCM_STRINGP (scm_name), scm_name, SCM_ARG1, "scm_register_function"); SCM_ASSERT (SCM_NIMP (scm_args) && SCM_STRINGP (scm_args), scm_args, SCM_ARG2, "scm_register_function"); SCM_ASSERT (SCM_NIMP (scm_help) && SCM_STRINGP (scm_help), scm_help, SCM_ARG3, "scm_register_function"); SCM_ASSERT (SCM_NIMP (scm_category) && SCM_STRINGP (scm_category), scm_category, SCM_ARG4, "scm_register_function"); SCM_ASSERT (scm_procedure_p (scm_function), scm_function, SCM_ARG5, "scm_register_function"); scm_permanent_object (scm_function); desc.name = g_strdup (SCM_CHARS (scm_name)); desc.arg_spec = g_strdup (SCM_CHARS (scm_args)); desc.arg_names = NULL; help = g_strdup (SCM_CHARS (scm_help)); desc.help = &help; desc.fn_args = func_marshal_func; desc.fn_nodes = NULL; desc.linker = NULL; desc.unlinker = NULL; desc.flags = 0; desc.ref_notify = NULL; desc.impl_status = GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC; desc.test_status = GNM_FUNC_TEST_STATUS_UNKNOWN; cat = gnm_func_group_fetch (SCM_CHARS (scm_category), NULL); fndef = gnm_func_add (cat, &desc, NULL); gnm_func_set_user_data (fndef, GINT_TO_POINTER (scm_function)); return SCM_UNSPECIFIED; }
/* FIXME: needs comment: */ void scm_scmval_print(LONGEST svalue, struct ui_file *stream, int format, int deref_ref, int recurse, enum val_prettyprint pretty) { taloop: switch (7 & (int)svalue) { case 2: case 6: print_longest(stream, (format ? format : 'd'), 1, (svalue >> 2)); break; case 4: if (SCM_ICHRP(svalue)) { svalue = SCM_ICHR(svalue); scm_printchar((int)svalue, stream); break; } else if (SCM_IFLAGP(svalue) && ((size_t)SCM_ISYMNUM(svalue) < (sizeof(scm_isymnames) / sizeof(char *)))) { fputs_filtered(SCM_ISYMCHARS(svalue), stream); break; } else if (SCM_ILOCP(svalue)) { fprintf_filtered(stream, "#@%ld%c%ld", (long)SCM_IFRAME(svalue), (SCM_ICDRP(svalue) ? '-' : '+'), (long)SCM_IDIST(svalue)); break; } else goto idef; break; case 1: /* gloc */ svalue = SCM_CAR (svalue - 1); goto taloop; default: idef: scm_ipruk ("immediate", svalue, stream); break; case 0: switch (SCM_TYP7 (svalue)) { case scm_tcs_cons_gloc: if (SCM_CDR (SCM_CAR (svalue) - 1L) == 0) { #if 0 SCM name; #endif /* 0 */ fputs_filtered ("#<latte ", stream); #if 1 fputs_filtered ("???", stream); #else name = ((SCM n *) (STRUCT_TYPE (exp)))[struct_i_name]; scm_lfwrite (CHARS (name), (sizet) sizeof (char), (sizet) LENGTH (name), port); #endif /* 1 */ fprintf_filtered (stream, " #X%s>", paddr_nz (svalue)); break; } /* -Wimplicit-fallthrough vs. -Wdeclaration-after-statement: */ goto imcar_noncase_label; imcar_noncase_label: case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: fputs_filtered ("(", stream); scm_scmlist_print (svalue, stream, format, deref_ref, recurse + 1, pretty); fputs_filtered (")", stream); break; case scm_tcs_closures: fputs_filtered ("#<CLOSURE ", stream); scm_scmlist_print (SCM_CODE (svalue), stream, format, deref_ref, recurse + 1, pretty); fputs_filtered (">", stream); break; case scm_tc7_string: { size_t len = SCM_LENGTH(svalue); CORE_ADDR addr = (CORE_ADDR)SCM_CDR(svalue); size_t i; size_t done = 0UL; size_t buf_size; gdb_byte buffer[64]; int truncate = (print_max && (len > print_max)); if (truncate) len = print_max; fputs_filtered ("\"", stream); for (; done < len; done += buf_size) { buf_size = min((len - done), 64); read_memory((addr + done), buffer, (int)buf_size); for (i = 0; i < buf_size; ++i) switch (buffer[i]) { case '\"': case '\\': fputs_filtered("\\", stream); goto the_default_label; the_default_label: default: fprintf_filtered(stream, "%c", buffer[i]); } } fputs_filtered((truncate ? "...\"" : "\""), stream); break; } break; case scm_tcs_symbols: { const size_t len = min(SCM_LENGTH(svalue), MAX_ALLOCA_SIZE); char *str = (char *)alloca(min(len, MAX_ALLOCA_SIZE)); read_memory(SCM_CDR(svalue), (gdb_byte *)str, (int)(len + 1)); /* Should handle weird characters, FIXME: do it. */ str[len] = '\0'; fputs_filtered(str, stream); break; } case scm_tc7_vector: { long len = SCM_LENGTH(svalue); int i; LONGEST elements = SCM_CDR(svalue); fputs_filtered ("#(", stream); for (i = 0; i < len; ++i) { if (i > 0) fputs_filtered (" ", stream); scm_scmval_print (scm_get_field (elements, i), stream, format, deref_ref, recurse + 1, pretty); } fputs_filtered (")", stream); } break; #if 0 case tc7_lvector: { SCM result; SCM hook; hook = scm_get_lvector_hook (exp, LV_PRINT_FN); if (hook == BOOL_F) { scm_puts ("#<locked-vector ", port); scm_intprint (CDR (exp), 16, port); scm_puts (">", port); } else { result = scm_apply (hook, scm_listify (exp, port, (writing ? BOOL_T : BOOL_F), SCM_UNDEFINED), EOL); if (result == BOOL_F) goto punk; } break; } break; case tc7_bvect: case tc7_ivect: case tc7_uvect: case tc7_fvect: case tc7_dvect: case tc7_cvect: scm_raprin1 (exp, port, writing); break; #endif /* 0 */ case scm_tcs_subrs: { int index = (int)(SCM_CAR(svalue) >> 8); #if 1 char str[20]; snprintf(str, sizeof(str), "#%d", index); #else char *str = (index ? SCM_CHARS(scm_heap_org + index) : ""); # define SCM_CHARS(x) ((char *)(SCM_CDR(x))) char *str = CHARS(SNAME(exp)); #endif /* 1 */ fprintf_filtered(stream, "#<primitive-procedure %s>", str); } break; #if 0 #ifdef CCLO case tc7_cclo: scm_puts ("#<compiled-closure ", port); scm_iprin1 (CCLO_SUBR (exp), port, writing); scm_putc ('>', port); break; #endif case tc7_contin: fprintf_filtered (stream, "#<continuation %d @ #X%lx >", LENGTH (svalue), (long) CHARS (svalue)); break; case tc7_port: i = PTOBNUM (exp); if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing)) break; goto punk; case tc7_smob: i = SMOBNUM (exp); if (i < scm_numsmob && scm_smobs[i].print && (scm_smobs[i].print) (exp, port, writing)) break; goto punk; #endif default: #if 0 punk: #endif scm_ipruk ("type", svalue, stream); } break; } }