2 lily-guile.cc -- implement assorted guile functions
4 source file of the GNU LilyPond music typesetter
6 (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
7 Han-Wen Nienhuys <hanwen@cs.uu.nl>
13 #include <math.h> /* isinf */
14 #include <string.h> /* strdup, strchr */
17 #include "lily-proto.hh"
21 source-file.hh includes cmath which undefines isinf and isnan
23 FIXME: #ifdef MACOS_X?
25 inline int my_isinf (Real r
) { return isinf (r
); }
26 inline int my_isnan (Real r
) { return isnan (r
); }
29 #include "libc-extension.hh"
30 #include "lily-guile.hh"
32 #include "file-path.hh"
34 #include "direction.hh"
36 #include "interval.hh"
38 #include "dimensions.hh"
39 #include "source-file.hh"
46 return ly_car (scm_last_pair (list
));
53 SCM port
= scm_mkstrport (SCM_INUM0
,
54 scm_make_string (SCM_INUM0
, SCM_UNDEFINED
),
57 // SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
58 SCM write
= scm_primitive_eval (ly_symbol2scm ("write"));
60 // scm_apply (write, port, SCM_EOL);
61 scm_call_2 (write
, s
, port
);
62 return scm_strport_to_string (port
);
69 return scm_list_n (ly_symbol2scm ("quote"), s
, SCM_UNDEFINED
);
73 ly_symbol2string (SCM s
)
75 assert (ly_c_symbol_p (s
));
76 return String ((Byte
*)SCM_STRING_CHARS (s
), (int) SCM_STRING_LENGTH (s
));
80 gulp_file_to_string (String fn
)
82 String s
= global_path
.find (fn
);
85 String e
= _f ("can't find file: `%s'", fn
);
87 e
+= _f ("(load path: `%s')", global_path
.to_string ());
90 else if (verbose_global_b
)
91 progress_indication ("[" + s
);
94 char * str
= gulp_file (s
, &n
);
99 progress_indication ("]");
104 LY_DEFINE (ly_gulp_file
, "ly:gulp-file",
106 "Read the file @var{name}, and return its contents in a string. "
107 "The file is looked up using the search path.")
109 SCM_ASSERT_TYPE (ly_c_string_p (name
), name
, SCM_ARG1
, __FUNCTION__
, "string");
110 return scm_makfrom0str (gulp_file_to_string (ly_scm2string (name
)).to_str0 ());
115 // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
117 ly_display_scm (SCM s
)
119 scm_display (s
, scm_current_output_port ());
120 scm_newline (scm_current_output_port ());
125 ly_scm2string (SCM s
)
127 assert (ly_c_string_p (s
));
129 char *p
= SCM_STRING_CHARS (s
);
135 ly_scm2newstr (SCM str
, size_t *lenp
)
137 SCM_ASSERT_TYPE (ly_c_string_p (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
139 size_t len
= SCM_STRING_LENGTH (str
);
140 if (char *new_str
= (char *) malloc ((len
+ 1) * sizeof (char)))
142 memcpy (new_str
, SCM_STRING_CHARS (str
), len
);
154 index_get_cell (SCM s
, Direction d
)
158 return (d
== LEFT
) ? ly_car (s
) : ly_cdr (s
);
162 index_set_cell (SCM s
, Direction d
, SCM v
)
165 scm_set_car_x (s
, v
);
167 scm_set_cdr_x (s
, v
);
171 LY_DEFINE (ly_warn
, "ly:warn",
173 "Scheme callable function to issue the warning @code{msg}.")
175 SCM_ASSERT_TYPE (ly_c_string_p (str
), str
, SCM_ARG1
, __FUNCTION__
, "string");
176 progress_indication ("\n");
177 warning ("lily-guile: " + ly_scm2string (str
));
181 LY_DEFINE (ly_dir_p
, "ly:dir?",
183 "type predicate. A direction is @code{-1}, @code{0} or "
184 "@code{1}, where @code{-1} represents "
185 "left or down and @code{1} represents right or up.")
187 if (ly_c_number_p (s
))
189 int i
= ly_scm2int (s
);
190 return (i
>= -1 && i
<= 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
196 is_number_pair (SCM p
)
198 return ly_c_pair_p (p
)
199 && ly_c_number_p (ly_car (p
)) && ly_c_number_p (ly_cdr (p
));
202 typedef void (*Void_fptr
) ();
203 Array
<Void_fptr
> *scm_init_funcs_
;
205 void add_scm_init_func (void (*f
) ())
207 if (!scm_init_funcs_
)
208 scm_init_funcs_
= new Array
<Void_fptr
>;
210 scm_init_funcs_
->push (f
);
214 ly_init_ly_module (void *)
216 for (int i
=scm_init_funcs_
->size () ; i
--;)
217 (scm_init_funcs_
->elem (i
)) ();
219 if (verbose_global_b
)
220 progress_indication ("\n");
222 scm_primitive_load_path (scm_makfrom0str ("lily.scm"));
225 SCM global_lily_module
;
230 global_lily_module
= scm_c_define_module ("lily", ly_init_ly_module
, 0);
231 scm_c_use_module ("lily");
237 return scm_ihashv (s
, ~1u);
243 if (ly_c_number_p (s
))
245 int i
= ly_scm2int (s
);
246 return i
>= -1 && i
<= 1;
254 if (ly_c_number_p (s
))
256 int i
= ly_scm2int (s
);
257 return i
== 0 || i
== 1;
265 return SCM_INUMP (s
) ? (Direction
) ly_scm2int (s
) : CENTER
;
269 ly_scm2interval (SCM p
)
271 return Interval (ly_scm2double (ly_car (p
)), ly_scm2double (ly_cdr (p
)));
275 ly_scm2realdrul (SCM p
)
277 return Drul_array
<Real
> (ly_scm2double (ly_car (p
)),
278 ly_scm2double (ly_cdr (p
)));
282 ly_interval2scm (Drul_array
<Real
> i
)
284 return scm_cons (scm_make_real (i
[LEFT
]), scm_make_real (i
[RIGHT
]));
290 return ly_c_boolean_p (s
) && ly_scm2bool (s
);
293 /* Appendable list L: the cdr contains the list, the car the last cons
298 SCM s
= scm_cons (SCM_EOL
, SCM_EOL
);
299 scm_set_car_x (s
, s
);
305 appendable_list_append (SCM l
, SCM elt
)
307 SCM newcons
= scm_cons (elt
, SCM_EOL
);
309 scm_set_cdr_x (ly_car (l
), newcons
);
310 scm_set_car_x (l
, newcons
);
314 ly_offset2scm (Offset o
)
316 return scm_cons (scm_make_real (o
[X_AXIS
]), scm_make_real (o
[Y_AXIS
]));
320 ly_scm2offset (SCM s
)
322 return Offset (ly_scm2double (ly_car (s
)),
323 ly_scm2double (ly_cdr (s
)));
326 LY_DEFINE (ly_number2string
, "ly:number->string",
328 "Convert @var{num} to a string without generating many decimals.")
330 SCM_ASSERT_TYPE (ly_c_number_p (s
), s
, SCM_ARG1
, __FUNCTION__
, "number");
332 char str
[400]; // ugh.
334 if (scm_exact_p (s
) == SCM_BOOL_F
)
336 Real
r (ly_scm2double (s
));
338 if (my_isinf (r
) || my_isnan (r
))
340 programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
344 sprintf (str
, "%08.4f", r
);
347 sprintf (str
, "%d", ly_scm2int (s
));
349 return scm_makfrom0str (str
);
354 LY_DEFINE (ly_version
, "ly:version", 0, 0, 0, (),
355 "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
357 char const* vs
= "\'(" MAJOR_VERSION
" " MINOR_VERSION
" " PATCH_LEVEL
" " MY_PATCH_LEVEL
")" ;
359 return scm_c_eval_string ((char*)vs
);
362 LY_DEFINE (ly_unit
, "ly:unit", 0, 0, 0, (),
363 "Return the unit used for lengths as a string.")
365 return scm_makfrom0str (INTERNAL_UNIT
);
370 LY_DEFINE (ly_dimension_p
, "ly:dimension?", 1, 0, 0, (SCM d
),
371 "Return @var{d} is a number. Used to distinguish length "
372 "variables from normal numbers.")
374 return scm_number_p (d
);
378 ly_deep_copy (SCM src
)
380 if (ly_c_pair_p (src
))
381 return scm_cons (ly_deep_copy (ly_car (src
)), ly_deep_copy (ly_cdr (src
)));
382 else if (ly_c_vector_p (src
))
384 int len
= SCM_VECTOR_LENGTH (src
);
385 SCM nv
= scm_c_make_vector (len
, SCM_UNDEFINED
);
386 for (int i
=0 ; i
< len
; i
++)
388 SCM si
= scm_int2num (i
);
389 scm_vector_set_x (nv
, si
, ly_deep_copy (scm_vector_ref (src
, si
)));
399 ly_assoc_chain (SCM key
, SCM achain
)
401 if (ly_c_pair_p (achain
))
403 SCM handle
= scm_assoc (key
, ly_car (achain
));
404 if (ly_c_pair_p (handle
))
407 return ly_assoc_chain (key
, ly_cdr (achain
));
413 /* looks the key up in the cdrs of the alist-keys
414 - ignoring the car and ignoring non-pair keys.
415 Returns first match found, i.e.
423 I would like (ly_assoc_cdr 1) to return 12 - because it's the first
424 element with the cdr of the key = 1. In other words (alloc_cdr key)
427 (alloc (anything . key))
433 ly_assoc_cdr (SCM key
, SCM alist
)
435 if (ly_c_pair_p (alist
))
437 SCM trykey
= ly_caar (alist
);
438 if (ly_c_pair_p (trykey
) && to_boolean (scm_equal_p (key
, ly_cdr (trykey
))))
439 return ly_car (alist
);
441 return ly_assoc_cdr (key
, ly_cdr (alist
));
446 /* LST has the form "sym1 sym2 sym3\nsym4\nsym5"
447 i.e. \n and ' ' can be used interchangeably as separators. */
449 parse_symbol_list (char const *lst
)
451 char *s
= strdup (lst
);
453 SCM create_list
= SCM_EOL
;
455 char * e
= s
+ strlen (s
) - 1;
456 while (e
>= s
&& isspace (*e
))
459 for (char * p
= s
; *p
; p
++)
468 char *next
= strchr (s
, ' ');
472 create_list
= scm_cons (ly_symbol2scm (s
), create_list
);
481 ly_truncate_list (int k
, SCM lst
)
489 for (; ly_c_pair_p (s
) && k
--; s
= ly_cdr (s
))
493 scm_set_cdr_x (s
, SCM_EOL
);
499 print_scm_val (SCM val
)
501 String realval
= ly_scm2string (ly_write2scm (val
));
502 if (realval
.length () > 200)
503 realval
= realval
.left_string (100)
505 + realval
.right_string (100);
510 type_check_assignment (SCM sym
, SCM val
, SCM type_symbol
)
518 TODO: should remove #f from allowed vals?
520 if (val
== SCM_EOL
|| val
== SCM_BOOL_F
)
523 if (!ly_c_symbol_p (sym
))
528 This is used for autoBeamSettings.
530 TODO: deprecate the use of \override and \revert for
533 or use a symbol autoBeamSettingS?
538 SCM type
= scm_object_property (sym
, type_symbol
);
540 if (type
!= SCM_EOL
&& !ly_c_procedure_p (type
))
542 warning (_f ("Can't find property type-check for `%s' (%s).",
543 ly_symbol2string (sym
).to_str0 (),
544 ly_symbol2string (type_symbol
).to_str0 ())
545 + " " + _ ("Perhaps you made a typing error?"));
547 /* Be strict when being anal :) */
548 if (internal_type_checking_global_b
)
551 warning (_ ("Doing assignment anyway."));
556 && ly_c_procedure_p (type
)
557 && scm_call_1 (type
, val
) == SCM_BOOL_F
)
559 SCM errport
= scm_current_error_port ();
561 SCM typefunc
= ly_scheme_function ("type-name");
562 SCM type_name
= scm_call_1 (typefunc
, type
);
565 scm_puts (_f ("Type check for `%s' failed; value `%s' must be of type `%s'",
566 ly_symbol2string (sym
).to_str0 (),
568 ly_scm2string (type_name
).to_str0 ()).to_str0 (),
570 scm_puts ("\n", errport
);
579 zijn deze nou handig?
580 zijn ze er al in scheme, maar heten ze anders? */
583 /* Remove doubles from (sorted) list */
587 SCM unique
= SCM_EOL
;
588 for (SCM i
= list
; ly_c_pair_p (i
); i
= ly_cdr (i
))
590 if (!ly_c_pair_p (ly_cdr (i
))
591 || !ly_c_equal_p (ly_car (i
), ly_cadr (i
)))
592 unique
= scm_cons (ly_car (i
), unique
);
594 return scm_reverse_x (unique
, SCM_EOL
);
599 scm_default_compare (void const *a
, void const *b
)
605 return pa
< pb
? -1 : 1;
608 /* Modify LST in place: qsort it. */
610 ly_list_qsort_uniq_x (SCM lst
)
612 int len
= scm_ilength (lst
);
613 SCM
*arr
= new SCM
[len
];
615 for (SCM s
= lst
; SCM_NNULLP (s
); s
= SCM_CDR (s
))
616 arr
[k
++] = SCM_CAR (s
);
619 qsort (arr
, len
, sizeof (SCM
), &scm_default_compare
);
622 for (int i
= 0; i
< len
; i
++)
623 if (!i
|| arr
[i
] != arr
[i
- 1])
625 SCM_SETCAR (*tail
, arr
[i
]);
626 tail
= SCM_CDRLOC (*tail
);
638 ly_snoc (SCM s
, SCM list
)
640 return ly_append2 (list
, scm_list_n (s
, SCM_UNDEFINED
));
643 /* Split list at member s, removing s.
644 Return (BEFORE . AFTER) */
646 ly_split_list (SCM s
, SCM list
)
648 SCM before
= SCM_EOL
;
650 for (; ly_c_pair_p (after
);)
652 SCM i
= ly_car (after
);
653 after
= ly_cdr (after
);
654 if (ly_c_equal_p (i
, s
))
656 before
= scm_cons (i
, before
);
658 return scm_cons ( scm_reverse_x (before
, SCM_EOL
), after
);
672 display stuff without using stack
677 SCM p
= scm_current_output_port ();
680 for (; ly_c_pair_p (s
); s
=ly_cdr (s
))
682 scm_display (ly_car (s
), p
);
686 return SCM_UNSPECIFIED
;
690 int_list_to_slice (SCM l
)
694 for (; ly_c_pair_p (l
); l
= ly_cdr (l
))
695 if (ly_c_number_p (ly_car (l
)))
696 s
.add_point (ly_scm2int (ly_car (l
)));
700 /* Return I-th element, or last elt L. If I < 0, then we take the first
703 PRE: length (L) > 0 */
705 robust_list_ref (int i
, SCM l
)
707 while (i
-- > 0 && ly_c_pair_p (ly_cdr (l
)))
713 robust_scm2double (SCM k
, double x
)
715 if (ly_c_number_p (k
))
716 x
= ly_scm2double (k
);
721 robust_scm2interval (SCM k
, Drul_array
<Real
> v
)
726 if (is_number_pair (k
))
727 i
= ly_scm2interval (k
);
732 robust_scm2drul (SCM k
, Drul_array
<Real
> v
)
734 if (is_number_pair (k
))
735 v
= ly_scm2interval (k
);
740 robust_scm2offset (SCM k
, Offset o
)
742 if (is_number_pair (k
))
743 o
= ly_scm2offset (k
);
748 robust_scm2int (SCM k
, int o
)
750 if (scm_integer_p (k
) == SCM_BOOL_T
)
756 alist_to_hashq (SCM alist
)
758 int i
= scm_ilength (alist
);
760 return scm_make_vector (scm_int2num (0), SCM_EOL
);
762 SCM tab
= scm_make_vector (scm_int2num (i
), SCM_EOL
);
763 for (SCM s
= alist
; ly_c_pair_p (s
); s
= ly_cdr (s
))
765 SCM pt
= ly_cdar (s
);
766 scm_hashq_set_x (tab
, ly_caar (s
), pt
);
775 LY_DEFINE (ly_protects
, "ly:protects",
777 "Return hash of protected objects.")
784 #if HAVE_PANGO_FC_FONT_MAP_ADD_DECODER_FIND_FUNC
786 #include "pangofc-afm-decoder.hh"
788 LY_DEFINE (ly_pango_add_afm_decoder
, "ly:pango-add-afm-decoder",
789 1, 0, 0, (SCM font_family
),
790 "Add pango afm decoder for FONT-FAMILY.")
792 SCM_ASSERT_TYPE (ly_c_string_p (font_family
), font_family
, SCM_ARG1
, __FUNCTION__
, "font_family");
793 pango_fc_afm_add_decoder (ly_scm2newstr (font_family
, 0));
794 return SCM_UNSPECIFIED
;