X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Flily-guile.cc;h=ccc87807f05852445f8e1e1b933ecffcf0ac0587;hb=a0c43e4df998137c94996e799d96d72d087d1708;hp=09447caa1911de018b465b03dfb74a4a31d20b55;hpb=4975901229a1b074f6c93d812e15d653aa8e2952;p=lilypond.git diff --git a/lily/lily-guile.cc b/lily/lily-guile.cc index 09447caa19..ccc87807f0 100644 --- a/lily/lily-guile.cc +++ b/lily/lily-guile.cc @@ -1,450 +1,675 @@ /* - lily-guile.cc -- implement assorted guile functions + lily-guile.cc -- implement assorted SCM interface functions source file of the GNU LilyPond music typesetter - (c) 1998--2000 Jan Nieuwenhuizen - - Han-Wen Nienhuys + (c) 1998--2008 Jan Nieuwenhuizen + Han-Wen Nienhuys */ +#include "lily-guile.hh" + +#include +#include +#include /* strdup, strchr */ +#include -#include -#include -#include // isinf +using namespace std; +#include "dimensions.hh" +#include "direction.hh" +#include "file-path.hh" +#include "international.hh" #include "libc-extension.hh" -#include "lily-guile.hh" #include "main.hh" -#include "simple-file-storage.hh" -#include "file-path.hh" -#include "debug.hh" -#include "direction.hh" +#include "misc.hh" #include "offset.hh" -#include "interval.hh" +#include "pitch.hh" +#include "string-convert.hh" +#include "source-file.hh" +#include "version.hh" +#include "warn.hh" -SCM -ly_str02scm (char const*c) -{ - // this all really sucks, guile should take char const* arguments! - return gh_str02scm ((char*)c); -} /* - Pass string to scm parser, evaluate one expression. - Return result value and #chars read. - - Thanks to Gary Houston - - Need guile-1.3.4 (>1.3 anyway) for ftell on str ports -- jcn -*/ -SCM -ly_parse_scm (char const* s, int* n) + symbols/strings. + */ +string +ly_scm_write_string (SCM s) { - SCM str = gh_str02scm ((char*)s); - SCM port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_RDNG, - "ly_eval_scm_0str"); - SCM from = scm_ftell (port); - - SCM form; - SCM answer = SCM_UNSPECIFIED; - - /* Read expression from port */ - if (!SCM_EOF_OBJECT_P (form = scm_read (port))) - answer = scm_eval_3 (form, 1, SCM_EOL); // guh? - - /* - After parsing - - (begin (foo 1 2)) - - all seems fine, but after parsing - - (foo 1 2) + SCM port = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + "ly_write2string"); + // SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL); + SCM write = scm_primitive_eval (ly_symbol2scm ("write")); - read_buf has been advanced to read_pos - 1, - so that scm_ftell returns 1, instead of #parsed chars - */ - - /* - urg: reset read_buf for scm_ftell - shouldn't scm_read () do this for us? - */ - scm_fill_input (port); - SCM to = scm_ftell (port); - *n = gh_scm2int (to) - gh_scm2int (from); - - /* Don't close the port here; if we re-enter this function via a - continuation, then the next time we enter it, we'll get an error. - It's a string port anyway, so there's no advantage to closing it - early. - - scm_close_port (port); - */ - - return answer; + // scm_apply (write, port, SCM_EOL); + scm_call_2 (write, s, port); + return ly_scm2string (scm_strport_to_string (port)); } SCM ly_quote_scm (SCM s) { - return gh_list (ly_symbol2scm ("quote"), s, SCM_UNDEFINED); + return scm_list_n (ly_symbol2scm ("quote"), s, SCM_UNDEFINED); } - -SCM -ly_symbol2scm(const char *s) -{ - return gh_symbol2scm ((char *)s); -} - - -String +string ly_symbol2string (SCM s) { - assert (gh_symbol_p (s)); - return String((Byte*)SCM_CHARS (s), (int) SCM_LENGTH(s)); + /* + Ugh. this is not very efficient. + */ + SCM str = scm_symbol_to_string (s); + return ly_scm2string (str); } - -String -gulp_file_to_string (String fn) +string +gulp_file_to_string (string fn, bool must_exist, int size) { - String s = global_path.find (fn); + string s = global_path.find (fn); if (s == "") { - String e = _f ("can't find file: `%s'", fn); - e += " "; - e += _f ("(load path: `%s')", global_path.str ()); - error (e); + if (must_exist) + { + string e = _f ("cannot find file: `%s'", fn); + e += " "; + e += _f ("(load path: `%s')", global_path.to_string ()); + error (e); + /* unreachable */ + } + return s; } - else if (verbose_global_b) - progress_indication ("[" + s ); + if (be_verbose_global) + progress_indication ("[" + s); - Simple_file_storage f(s); - String result (f.ch_C()); - if (verbose_global_b) + vector chars = gulp_file (s, size); + string result (&chars[0], chars.size ()); + + if (be_verbose_global) progress_indication ("]"); - return result; -} -SCM -ly_gulp_file (SCM fn) -{ - return ly_str02scm (gulp_file_to_string (ly_scm2string (fn)).ch_C()); + return result; } +extern "C" { + // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing? + void + ly_display_scm (SCM s) + { + scm_display (s, scm_current_output_port ()); + scm_newline (scm_current_output_port ()); + } +}; -/** - Read a file, and shove it down GUILE. GUILE also has file read - functions, but you can't fiddle with the path of those. +/* + STRINGS */ -void -read_lily_scm_file (String fn) -{ - gh_eval_str ((char *) gulp_file_to_string (fn).ch_C()); +string +ly_scm2string (SCM str) +{ + assert (scm_is_string (str)); + string result; + size_t len = scm_c_string_length (str); + if (len) { + result.resize(len); + scm_to_locale_stringbuf(str, &result.at(0), len); + } + return result; } -extern "C" { - // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing? -void -ly_display_scm (SCM s) +SCM +ly_string2scm (string const &str) { - gh_display (s); - gh_newline (); + return scm_from_locale_stringn (str.c_str (), + str.length ()); } -}; -String -ly_scm2string (SCM s) -{ - assert (gh_string_p (s)); - int len; - char * p = gh_scm2newstr (s , &len); - - String r (p); - free (p); - return r; +char * +ly_scm2newstr (SCM str, size_t *lenp) +{ + char* p = scm_to_locale_stringn(str, lenp); + return p; } -SCM -index_cell (SCM s, Direction d) +/* + PAIRS +*/ +SCM +index_get_cell (SCM s, Direction d) { assert (d); - return (d == LEFT) ? gh_car (s) : gh_cdr (s); + return (d == LEFT) ? scm_car (s) : scm_cdr (s); } SCM index_set_cell (SCM s, Direction d, SCM v) { if (d == LEFT) - gh_set_car_x (s, v); + scm_set_car_x (s, v); else if (d == RIGHT) - gh_set_cdr_x (s, v); + scm_set_cdr_x (s, v); return s; } - -SCM -ly_warning (SCM str) + +bool +is_number_pair (SCM p) { - assert (gh_string_p (str)); - warning ("lily-guile: " + ly_scm2string (str)); - return SCM_BOOL_T; + return scm_is_pair (p) + && scm_is_number (scm_car (p)) && scm_is_number (scm_cdr (p)); } -SCM -ly_isdir_p (SCM s) + +unsigned int +ly_scm_hash (SCM s) { - if (gh_number_p (s)) + return scm_ihashv (s, ~1u); +} + +bool +is_axis (SCM s) +{ + if (scm_is_number (s)) { - int i = gh_scm2int (s); - return (i>= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F; + int i = scm_to_int (s); + return i == 0 || i == 1; } - return SCM_BOOL_F; + return false; } - - -typedef void (*Void_fptr)(); -Array *scm_init_funcs_; - -void add_scm_init_func (void (*f)()) +bool +to_boolean (SCM s) { - if (!scm_init_funcs_) - scm_init_funcs_ = new Array; - - scm_init_funcs_->push (f); + return scm_is_bool (s) && ly_scm2bool (s); } -extern void init_cxx_function_smobs(); -void -init_lily_guile () +/* + DIRECTIONS + */ +Direction +to_dir (SCM s) { - init_cxx_function_smobs(); - for (int i=scm_init_funcs_->size() ; i--;) - (scm_init_funcs_->elem (i)) (); + return scm_is_integer (s) ? (Direction) scm_to_int (s) : CENTER; } -unsigned int ly_scm_hash (SCM s) +Direction +robust_scm2dir (SCM d, Direction def) { - return scm_ihashv (s, ~1u); + if (is_direction (d)) + def = to_dir (d); + return def; } - - bool -isdir_b (SCM s) +is_direction (SCM s) { - if (gh_number_p (s)) + if (scm_is_number (s)) { - int i = gh_scm2int (s); - return i>= -1 && i <= 1; + int i = scm_to_int (s); + return i >= -1 && i <= 1; } return false; } -Direction -to_dir (SCM s) +/* + INTERVALS + */ +Interval +ly_scm2interval (SCM p) { - return (Direction) gh_scm2int (s); + return Interval (scm_to_double (scm_car (p)), scm_to_double (scm_cdr (p))); } -Interval -ly_scm2interval (SCM p) +Drul_array +ly_scm2realdrul (SCM p) { - return Interval (gh_scm2double (gh_car (p)), - gh_scm2double (gh_cdr (p))); + return Drul_array (scm_to_double (scm_car (p)), + scm_to_double (scm_cdr (p))); } SCM -ly_interval2scm (Interval i) +ly_interval2scm (Drul_array i) { - return gh_cons (gh_double2scm (i[LEFT]), - gh_double2scm (i[RIGHT])); + return scm_cons (scm_from_double (i[LEFT]), scm_from_double (i[RIGHT])); } -bool -to_boolean (SCM s) +Interval +robust_scm2interval (SCM k, Drul_array v) { - return gh_boolean_p (s) && gh_scm2bool (s); + Interval i; + i[LEFT] = v[LEFT]; + i[RIGHT] = v[RIGHT]; + if (is_number_pair (k)) + i = ly_scm2interval (k); + return i; } -/* - Appendable list L: the cdr contains the list, the car the last cons - in the list. - */ -SCM -appendable_list () +Drul_array +robust_scm2drul (SCM k, Drul_array v) { - SCM s = gh_cons (SCM_EOL, SCM_EOL); - gh_set_car_x (s, s); - - return s; + if (is_number_pair (k)) + v = ly_scm2interval (k); + return v; } -void -appendable_list_append (SCM l, SCM elt) +Drul_array +robust_scm2booldrul (SCM k, Drul_array def) { - SCM newcons = gh_cons (elt, SCM_EOL); - - gh_set_cdr_x (gh_car (l), newcons); - gh_set_car_x (l, newcons); + if (scm_is_pair (k)) + { + def[LEFT] = to_boolean (scm_car (k)); + def[RIGHT] = to_boolean (scm_cdr (k)); + } + return def; } - +/* + OFFSET +*/ SCM ly_offset2scm (Offset o) { - return gh_cons (gh_double2scm (o[X_AXIS]), gh_double2scm(o[Y_AXIS])); + return scm_cons (scm_from_double (o[X_AXIS]), scm_from_double (o[Y_AXIS])); } Offset ly_scm2offset (SCM s) { - return Offset (gh_scm2double (gh_car (s)), - gh_scm2double (gh_cdr (s))); + return Offset (scm_to_double (scm_car (s)), + scm_to_double (scm_cdr (s))); } +Offset +robust_scm2offset (SCM k, Offset o) +{ + if (is_number_pair (k)) + o = ly_scm2offset (k); + return o; +} SCM -ly_type (SCM exp) +ly_offsets2scm (vector os) { - char const * cp = "unknown"; - if (gh_number_p (exp)) + SCM l = SCM_EOL; + SCM *tail = &l; + for (vsize i = 0; i < os.size (); i++) { - cp = "number"; + *tail = scm_cons (ly_offset2scm (os[i]), SCM_EOL); + tail = SCM_CDRLOC (*tail); } - else if (gh_string_p (exp)) - { - cp = "string"; - } - else if (gh_procedure_p (exp)) - { - cp = "procedure"; - } - else if (gh_boolean_p (exp)) - { - cp = "boolean"; - } - else if (gh_pair_p (exp)) + return l; +} + +vector +ly_scm2offsets (SCM s) +{ + vector os; + for (; scm_is_pair (s); s = scm_cdr (s)) + os.push_back (ly_scm2offset (scm_car (s))); + return os; +} + + + + +/* + ALIST +*/ + +bool +alist_equal_p (SCM a, SCM b) +{ + for (SCM s = a; + scm_is_pair (s); s = scm_cdr (s)) { - cp = "list"; + SCM key = scm_caar (s); + SCM val = scm_cdar (s); + SCM l = scm_assoc (key, b); + + if (l == SCM_BOOL_F + || !ly_is_equal (scm_cdr (l), val)) + + return false; } + return true; +} - return ly_str02scm (cp); +SCM +ly_alist_vals (SCM alist) +{ + SCM x = SCM_EOL; + for (SCM p = alist; scm_is_pair (p); p = scm_cdr (p)) + x = scm_cons (scm_cdar (p), x); + return x; } /* - convert without too many decimals, and leave a space at the end. + LISTS */ - - + +/* Return I-th element, or last elt L. If I < 0, then we take the first + element. + + PRE: length (L) > 0 */ SCM -ly_number2string (SCM s) +robust_list_ref (int i, SCM l) { - assert (gh_number_p (s)); + while (i-- > 0 && scm_is_pair (scm_cdr (l))) + l = scm_cdr (l); + return scm_car (l); +} - char str[400]; // ugh. - if (scm_integer_p (s) == SCM_BOOL_F) +SCM +ly_deep_copy (SCM src) +{ + if (scm_is_pair (src)) + return scm_cons (ly_deep_copy (scm_car (src)), ly_deep_copy (scm_cdr (src))); + else if (scm_is_vector (src)) { - Real r (gh_scm2double (s)); - - if (isinf (r) || isnan (r)) + int len = scm_c_vector_length (src); + SCM nv = scm_c_make_vector (len, SCM_UNDEFINED); + for (int i = 0;i < len; i++) { - programming_error ("Infinity or NaN encountered while converting Real number; setting to zero."); - r = 0.0; + SCM si = scm_from_int (i); + scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si))); } + } + return src; +} + +string +print_scm_val (SCM val) +{ + string realval = ly_scm_write_string (val); + if (realval.length () > 200) + realval = realval.substr (0, 100) + + "\n :\n :\n" + + realval.substr (realval.length () - 100); + return realval; +} + +bool +type_check_assignment (SCM sym, SCM val, SCM type_symbol) +{ + bool ok = true; - sprintf (str, "%8.4f ", r); + /* + Always succeeds. + + + TODO: should remove #f from allowed vals? + */ + if (val == SCM_EOL || val == SCM_BOOL_F) + return ok; + + if (!scm_is_symbol (sym)) +#if 0 + return false; +#else + /* + This is used for autoBeamSettings. + + TODO: deprecate the use of \override and \revert for + autoBeamSettings? + + or use a symbol autoBeamSettingS? + */ + return true; +#endif + + SCM type = scm_object_property (sym, type_symbol); + + if (type != SCM_EOL && !ly_is_procedure (type)) + { + warning (_f ("cannot find property type-check for `%s' (%s).", + ly_symbol2string (sym).c_str (), + ly_symbol2string (type_symbol).c_str ()) + + " " + _ ("perhaps a typing error?")); + + /* Be strict when being anal :) */ + if (do_internal_type_checking_global) + scm_throw (ly_symbol2scm ("ly-file-failed"), scm_list_3 (ly_symbol2scm ("typecheck"), + sym, val)); + + warning (_ ("doing assignment anyway")); } else { - sprintf (str, "%d ", gh_scm2int (s)); + if (val != SCM_EOL + && ly_is_procedure (type) + && scm_call_1 (type, val) == SCM_BOOL_F) + { + ok = false; + SCM typefunc = ly_lily_module_constant ("type-name"); + SCM type_name = scm_call_1 (typefunc, type); + + warning (_f ("type check for `%s' failed; value `%s' must be of type `%s'", + ly_symbol2string (sym).c_str (), + print_scm_val (val), + ly_scm2string (type_name).c_str ())); + progress_indication ("\n"); + } } + return ok; +} + +/* some SCM abbrevs - return gh_str02scm (str); +zijn deze nou handig? +zijn ze er al in scheme, maar heten ze anders? */ + +/* Remove doubles from (sorted) list */ +SCM +ly_unique (SCM list) +{ + SCM unique = SCM_EOL; + for (SCM i = list; scm_is_pair (i); i = scm_cdr (i)) + { + if (!scm_is_pair (scm_cdr (i)) + || !ly_is_equal (scm_car (i), scm_cadr (i))) + unique = scm_cons (scm_car (i), unique); + } + return scm_reverse_x (unique, SCM_EOL); +} + + +/* Split list at member s, removing s. + Return (BEFORE . AFTER) */ +SCM +ly_split_list (SCM s, SCM list) +{ + SCM before = SCM_EOL; + SCM after = list; + for (; scm_is_pair (after);) + { + SCM i = scm_car (after); + after = scm_cdr (after); + if (ly_is_equal (i, s)) + break; + before = scm_cons (i, before); + } + return scm_cons (scm_reverse_x (before, SCM_EOL), after); +} + +void +taint (SCM *) +{ + /* + nop. + */ } /* - Undef this to see if GUILE GC is causing too many swaps. - */ + display stuff without using stack +*/ +SCM +display_list (SCM s) +{ + SCM p = scm_current_output_port (); + + scm_puts ("(", p); + for (; scm_is_pair (s); s = scm_cdr (s)) + { + scm_display (scm_car (s), p); + scm_puts (" ", p); + } + scm_puts (")", p); + return SCM_UNSPECIFIED; +} -// #define TEST_GC +Slice +int_list_to_slice (SCM l) +{ + Slice s; + s.set_empty (); + for (; scm_is_pair (l); l = scm_cdr (l)) + if (scm_is_number (scm_car (l))) + s.add_point (scm_to_int (scm_car (l))); + return s; +} + +Real +robust_scm2double (SCM k, double x) +{ + if (scm_is_number (k)) + x = scm_to_double (k); + return x; +} -#ifdef TEST_GC -#include -static void * -greet_sweep (void *dummy1, void *dummy2, void *dummy3) +string +robust_scm2string (SCM k, string s) { - fprintf(stderr, "entering sweep\n"); + if (scm_is_string (k)) + s = ly_scm2string (k); + return s; } -static void * -wave_sweep_goodbye (void *dummy1, void *dummy2, void *dummy3) +int +robust_scm2int (SCM k, int o) { - fprintf(stderr, "leaving sweep\n"); + if (scm_integer_p (k) == SCM_BOOL_T) + o = scm_to_int (k); + return o; } -#endif -#include "version.hh" SCM -ly_version () +ly_rational2scm (Rational r) { - char const* vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")" ; + return scm_divide (scm_from_int64 (r.numerator ()), + scm_from_int64 (r.denominator ())); +} - - return gh_eval_str ((char*)vs); + +Rational +ly_scm2rational (SCM r) +{ + return Rational (scm_to_int64 (scm_numerator (r)), + scm_to_int64 (scm_denominator (r))); } -static void -init_functions () +Rational +robust_scm2rational (SCM n, Rational rat) { - scm_make_gsubr ("ly-warn", 1, 0, 0, (Scheme_function_unknown)ly_warning); - scm_make_gsubr ("ly-version", 0, 0, 0, (Scheme_function_unknown)ly_warning); - scm_make_gsubr ("ly-gulp-file", 1,0, 0, (Scheme_function_unknown)ly_gulp_file); - scm_make_gsubr ("dir?", 1,0, 0, (Scheme_function_unknown)ly_isdir_p); + if (ly_is_fraction (n)) + return ly_scm2rational (n); + else + return rat; +} - scm_make_gsubr ("ly-number->string", 1, 0,0, (Scheme_function_unknown) ly_number2string); +SCM +alist_to_hashq (SCM alist) +{ + int i = scm_ilength (alist); + if (i < 0) + return scm_c_make_hash_table (0); + SCM tab = scm_c_make_hash_table (i); + for (SCM s = alist; scm_is_pair (s); s = scm_cdr (s)) + { + SCM pt = scm_cdar (s); + scm_hashq_set_x (tab, scm_caar (s), pt); + } + return tab; +} -#ifdef TEST_GC - scm_c_hook_add (&scm_before_mark_c_hook, greet_sweep, 0, 0); - scm_c_hook_add (&scm_before_sweep_c_hook, wave_sweep_goodbye, 0, 0); -#endif +SCM +ly_hash2alist (SCM tab) +{ + SCM func = ly_lily_module_constant ("hash-table->alist"); + return scm_call_1 (func, tab); } -ADD_SCM_INIT_FUNC(funcs, init_functions); -SCM -ly_deep_copy (SCM l) +/* + C++ interfacing. + */ + +string +mangle_cxx_identifier (string cxx_id) { - if (gh_pair_p (l)) + if (cxx_id.substr (0, 3) == "ly_") + cxx_id = cxx_id.replace (0, 3, "ly:"); + else { - return gh_cons (ly_deep_copy (gh_car (l)), ly_deep_copy (gh_cdr (l))); + cxx_id = String_convert::to_lower (cxx_id); + cxx_id = "ly:" + cxx_id; } - else - return l; + if (cxx_id.substr (cxx_id.length () - 2) == "_p") + cxx_id = cxx_id.replace (cxx_id.length () - 2, 2, "?"); + else if (cxx_id.substr (cxx_id.length () - 2) == "_x") + cxx_id = cxx_id.replace (cxx_id.length () - 2, 2, "!"); + + replace_all (&cxx_id, "_less?", ""); + replace_all (&cxx_id, "__", "::"); + replace_all (&cxx_id, '_', '-'); + + + return cxx_id; } +SCM +ly_string_array_to_scm (vector a) +{ + SCM s = SCM_EOL; + for (vsize i = a.size (); i ; i--) + s = scm_cons (ly_symbol2scm (a[i - 1].c_str ()), s); + return s; +} +/* SYMBOLS is a whitespace separated list. */ SCM -ly_assoc_chain (SCM key, SCM achain) +parse_symbol_list (char const *symbols) { - if (gh_pair_p (achain)) - { - SCM handle = scm_assoc (key, gh_car (achain)); - if (gh_pair_p (handle)) - return handle; - else - return ly_assoc_chain (key, gh_cdr (achain)); - } - else - return SCM_BOOL_F; + while (isspace (*symbols)) + *symbols++; + string s = symbols; + replace_all (&s, '\n', ' '); + replace_all (&s, '\t', ' '); + replace_all (&s, " ", " "); + return ly_string_array_to_scm (string_split (s, ' ')); } + +/* GDB debugging. */ +struct ly_t_double_cell +{ + SCM a; + SCM b; + SCM c; + SCM d; +}; + +/* inserts at front, removing duplicates */ +SCM ly_assoc_prepend_x (SCM alist, SCM key, SCM val) +{ + return scm_acons (key, val, scm_assoc_remove_x (alist, key)); +} +