X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=lily%2Flily-guile.cc;h=04bb47cdd3c47dcd3bc60d402a22595521afa094;hb=d4e71555e7e093a4da32d92378f8f475fa0d6aaa;hp=31b9f497bebddd350cc4dafc3d5fb2a774da1fed;hpb=8f58f4428d70961938e9151097886d861b3faeb3;p=lilypond.git diff --git a/lily/lily-guile.cc b/lily/lily-guile.cc index 31b9f497be..04bb47cdd3 100644 --- a/lily/lily-guile.cc +++ b/lily/lily-guile.cc @@ -3,293 +3,473 @@ source file of the GNU LilyPond music typesetter - (c) 1998--1999 Jan Nieuwenhuizen + (c) 1998--2001 Jan Nieuwenhuizen Han-Wen Nienhuys */ + #include +#include +#include // isinf + #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 "offset.hh" +#include "interval.hh" +SCM +ly_last (SCM list) +{ + return gh_car (scm_last_pair (list)); +} -/* - scm_m_quote doesn't use any env, but needs one for a good signature in GUILE. +SCM +ly_str02scm (char const*c) +{ + // this all really sucks, guile should take char const* arguments! + return gh_str02scm ((char*)c); +} - Why there is no gh_quote () in GUILE beats me. -*/ SCM -ly_quote_scm (SCM s) +ly_write2scm (SCM s) { - return scm_cons2 (scm_i_quote, s, SCM_EOL); + 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_eval2 (ly_symbol2scm ("write"), SCM_EOL); + + // scm_apply (write, port, SCM_EOL); + gh_call2 (write, s, port); + return scm_strport_to_string (port); } + /* - See: libguile/symbols.c + Pass string to scm parser, evaluate one expression. + Return result value and #chars read. - SCM - scm_string_to_symbol(s) - + Thanks to Gary Houston + + Need guile-1.3.4 (>1.3 anyway) for ftell on str ports -- jcn */ SCM -ly_symbol (String name) +ly_parse_scm (char const* s, int* n) { - return gh_car (scm_intern (name.ch_C(), name.length_i())); + SCM str = ly_str02scm (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) + + 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; } -String -symbol_to_string (SCM s) +SCM +ly_quote_scm (SCM s) { - return String((Byte*)SCM_CHARS (s), (int) SCM_LENGTH(s)); + return gh_list (ly_symbol2scm ("quote"), s, SCM_UNDEFINED); } + SCM -ly_set_scm (String name, SCM val) +ly_symbol2scm (const char *s) { - return scm_sysintern (name.ch_C(), val); - + return gh_symbol2scm ((char *)s); } -/** - Read a file, and shove it down GUILE. GUILE also has file read - functions, but you can't fiddle with the path of those. - - */ -void -read_lily_scm_file (String fn) + +String +ly_symbol2string (SCM s) +{ + assert (gh_symbol_p (s)); + return String ((Byte*)SCM_CHARS (s), (int) SCM_LENGTH (s)); +} + + +String +gulp_file_to_string (String fn) { String s = global_path.find (fn); if (s == "") { - String e = _f ("Can not find file `%s\'", fn); + String e = _f ("can't find file: `%s'", fn); e += " "; - e += _f ("(Load path is `%s\'", global_path.str ()); + e += _f ("(load path: `%s')", global_path.str ()); error (e); } - else - *mlog << '[' << s; + else if (verbose_global_b) + progress_indication ("[" + s); - Simple_file_storage f(s); - - gh_eval_str ((char *) f.ch_C()); - *mlog << ']' << flush; + Simple_file_storage f (s); + String result (f.ch_C ()); + if (verbose_global_b) + progress_indication ("]"); + return result; +} + +SCM +ly_gulp_file (SCM fn) +{ + return ly_str02scm (gulp_file_to_string (ly_scm2string (fn)).ch_C ()); } +/** + Read a file, and shove it down GUILE. GUILE also has file read + functions, but you can't fiddle with the path of those. + */ +void +read_lily_scm_file (String fn) +{ + gh_eval_str ((char *) gulp_file_to_string (fn).ch_C ()); +} + +extern "C" { + // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing? void ly_display_scm (SCM s) { gh_display (s); gh_newline (); } +}; String ly_scm2string (SCM s) { + assert (gh_string_p (s)); int len; char * p = gh_scm2newstr (s , &len); String r (p); - delete p; + + free (p); return r; } -/* - Layout of nodes: +SCM +index_cell (SCM s, Direction d) +{ + assert (d); + return (d == LEFT) ? gh_car (s) : gh_cdr (s); +} - (key . (left_child . right_child)) +SCM +index_set_cell (SCM s, Direction d, SCM v) +{ + if (d == LEFT) + gh_set_car_x (s, v); + else if (d == RIGHT) + gh_set_cdr_x (s, v); + return s; +} + +SCM +ly_warning (SCM str) +{ + assert (gh_string_p (str)); + warning ("lily-guile: " + ly_scm2string (str)); + return SCM_BOOL_T; +} - SCM_EOL is the nil-pointer (should use SCM_NIMP() ?) - */ +SCM +ly_isdir_p (SCM s) +{ + if (gh_number_p (s)) + { + int i = gh_scm2int (s); + return (i>= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F; + } + return SCM_BOOL_F; +} -#define left_child(s) SCM_CADR((s)) -#define right_child(s) SCM_CDDR((s)) -#define key(s) SCM_CAR((s)) -/* - Garble pointers, to prevent unbalanced tree due to ordered inserts. - */ -unsigned int -munge (SCM s) +typedef void (*Void_fptr) (); +Array *scm_init_funcs_; + +void add_scm_init_func (void (*f) ()) { - const int SHIFT = 18; - return (unsigned int)(s << (32-SHIFT) | s >> SHIFT ); + if (!scm_init_funcs_) + scm_init_funcs_ = new Array; + + scm_init_funcs_->push (f); } +extern void init_cxx_function_smobs (); -SCM -ly_new_bintree_node (SCM val) +void +init_lily_guile () { - return gh_cons (val, gh_cons (SCM_EOL, SCM_EOL)); + init_cxx_function_smobs (); + for (int i=scm_init_funcs_->size () ; i--;) + (scm_init_funcs_->elem (i)) (); } +unsigned int ly_scm_hash (SCM s) +{ + return scm_ihashv (s, ~1u); +} -/* - add VAL to TREE. TREE must be non-nil - */ -void -ly_addto_bintree (SCM *tree, SCM val) + + +bool +isdir_b (SCM s) { - while(*tree != SCM_EOL) + if (gh_number_p (s)) { - if (munge (val) <= munge (key (*tree))) - tree = &left_child (*tree); - else - tree = &right_child (*tree); + int i = gh_scm2int (s); + return i>= -1 && i <= 1; } + return false; +} + +Direction +to_dir (SCM s) +{ + return (Direction) gh_scm2int (s); +} - *tree = ly_new_bintree_node (val); +Interval +ly_scm2interval (SCM p) +{ + return Interval (gh_scm2double (gh_car (p)), + gh_scm2double (gh_cdr (p))); +} + +SCM +ly_interval2scm (Interval i) +{ + return gh_cons (gh_double2scm (i[LEFT]), + gh_double2scm (i[RIGHT])); } + + +bool +to_boolean (SCM s) +{ + return gh_boolean_p (s) && gh_scm2bool (s); +} + /* - find the address of a node in the tree represented by *NODE with key VAL + Appendable list L: the cdr contains the list, the car the last cons + in the list. */ -SCM * -ly_find_in_bintree (SCM *node, SCM val) +SCM +appendable_list () { - while (*node != SCM_EOL) - { - if (munge (val) < munge (key(*node) )) - node = &left_child(*node); - else if (munge (val) > munge (key (*node))) - node = &right_child (*node); - else - return node; - } - return node; + SCM s = gh_cons (SCM_EOL, SCM_EOL); + gh_set_car_x (s, s); + + return s; } void -ly_remove_from_bintree (SCM *node) +appendable_list_append (SCM l, SCM elt) { - SCM r = right_child (*node); - SCM l = left_child (*node); + SCM newcons = gh_cons (elt, SCM_EOL); - if (r == SCM_EOL) + gh_set_cdr_x (gh_car (l), newcons); + gh_set_car_x (l, newcons); +} + + +SCM +ly_offset2scm (Offset o) +{ + return gh_cons (gh_double2scm (o[X_AXIS]), gh_double2scm (o[Y_AXIS])); +} + +Offset +ly_scm2offset (SCM s) +{ + return Offset (gh_scm2double (gh_car (s)), + gh_scm2double (gh_cdr (s))); +} + +SCM +ly_type (SCM exp) +{ + char const * cp = "unknown"; + if (gh_number_p (exp)) { - *node = l; + cp = "number"; } - else if (l == SCM_EOL) + else if (gh_string_p (exp)) { - *node = r; + cp = "string"; } - else + else if (gh_procedure_p (exp)) + { + cp = "procedure"; + } + else if (gh_boolean_p (exp)) + { + cp = "boolean"; + } + else if (gh_pair_p (exp)) + { + cp = "list"; + } + + return ly_str02scm (cp); +} + +/* + convert without too many decimals, and leave a space at the end. + */ + + +SCM +ly_number2string (SCM s) +{ + assert (gh_number_p (s)); + + char str[400]; // ugh. + + if (scm_integer_p (s) == SCM_BOOL_F) { - /*deleting from binary trees. See Knuth's TAOCP. - */ - SCM *t = node; - SCM *left_t = &left_child (*t); - - /* - INV: LEFT_T is the left child of T - */ - while (*left_t != SCM_EOL) + Real r (gh_scm2double (s)); + + if (isinf (r) || isnan (r)) { - t = left_t; - left_t = &left_child (*t); + programming_error ("Infinity or NaN encountered while converting Real number; setting to zero."); + r = 0.0; } - /* - POST: T is the leftmost right child of NODE which has no left child, - - leftchild (LASTT) == T - */ - key(*node) = key(*t); - *left_t = right_child (*t); + sprintf (str, "%8.4f ", r); + } + else + { + sprintf (str, "%d ", gh_scm2int (s)); } + + return ly_str02scm (str); } +/* + Undef this to see if GUILE GC is causing too many swaps. + */ + +// #define TEST_GC -static SCM protect_tree_root; +#ifdef TEST_GC +#include -SCM -ly_protect_scm (SCM s) +static void * +greet_sweep (void *dummy1, void *dummy2, void *dummy3) { - ly_addto_bintree (&protect_tree_root, s); - return s; + fprintf (stderr, "entering sweep\n"); } +static void * +wave_sweep_goodbye (void *dummy1, void *dummy2, void *dummy3) +{ + fprintf (stderr, "leaving sweep\n"); +} +#endif + + +#include "version.hh" SCM -ly_unprotect_scm (SCM s) +ly_version () { - SCM *to_remove = ly_find_in_bintree (&protect_tree_root, s); + char const* vs = "\' (" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")" ; - /* - this shouldn't happen, according to me. But it does. - */ - if (*to_remove != SCM_EOL) - ly_remove_from_bintree (to_remove); - return s; + + return gh_eval_str ((char*)vs); } -void -ly_init_protection () +static void +init_functions () { - protect_tree_root = scm_protect_object (ly_new_bintree_node(SCM_EOL)); - key (protect_tree_root) = protect_tree_root; -} + 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_version); + 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); + scm_make_gsubr ("ly-number->string", 1, 0,0, (Scheme_function_unknown) ly_number2string); -int -ly_count_elements (SCM tree) -{ - if (tree == SCM_EOL) - return 0; - else - return 1 + ly_count_elements (left_child (tree)) + ly_count_elements (right_child( tree)); + +#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 } -int -ly_tree_depth (SCM tree) +ADD_SCM_INIT_FUNC (funcs, init_functions); + +SCM +ly_deep_copy (SCM l) { - if (tree == SCM_EOL) - return 0; + if (gh_pair_p (l)) + { + return gh_cons (ly_deep_copy (gh_car (l)), ly_deep_copy (gh_cdr (l))); + } else - return 1 + (ly_tree_depth (left_child (tree)) >? ly_tree_depth (right_child(tree))); + return l; } -void -ly_print_bintree (SCM node) -{ -#ifndef NPRINT - if (node == SCM_EOL) - return; - DOUT << "{val = " << key(node) << " \nleft = "; - ly_print_bintree (left_child (node)); - DOUT << "\n right ="; - ly_print_bintree (right_child (node)); - DOUT << "}"; -#endif -} -struct Imbalance { int imbalance; int total; }; -Imbalance -ly_calc_imbalance (SCM node) +SCM +ly_assoc_chain (SCM key, SCM achain) { - Imbalance t; - if (node == SCM_EOL) + if (gh_pair_p (achain)) { - t.imbalance = 0; - t.total = 0; - return t; + SCM handle = scm_assoc (key, gh_car (achain)); + if (gh_pair_p (handle)) + return handle; + else + return ly_assoc_chain (key, gh_cdr (achain)); } - - Imbalance l = ly_calc_imbalance (left_child (node)); - Imbalance r = ly_calc_imbalance (right_child (node)); - - t.total = l.total + r.total + 1; - int dif = l.total - r.total; - if (dif < 0) - dif = -dif; - t.imbalance = l.imbalance + r.imbalance + dif; - return t; + else + return SCM_BOOL_F; }