SCM scm_oldfmt (SCM s) { #ifdef HAVE_SCM_SIMPLE_FORMAT return s; #else int n; SCM_ASSERT (SCM_NIMP (s) && SCM_STRINGP (s), s, 1, s_oldfmt); n = SCM_LENGTH (s); return scm_return_first (scm_mem2string (scm_c_oldfmt (SCM_ROCHARS (s), n), n), s); #endif }
/********************************************************************\ * gnc_trans_scm_get_num_splits * * get the number of scheme splits in a scheme transaction. * * * * Args: trans_scm - the scheme transaction * * Returns: number of scheme splits in the transaction * \********************************************************************/ int gnc_trans_scm_get_num_splits(SCM trans_scm) { SCM result; initialize_scm_functions(); if (!gnc_is_trans_scm(trans_scm)) return 0; result = scm_call_1(getters.trans_scm_split_scms, trans_scm); if (!scm_is_list(result)) return 0; return SCM_LENGTH(result); }
/* 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; } }