]> git.donarmstrong.com Git - lilypond.git/blob - lily/lily-guile.cc
* scm/lily.scm (tex-output-expression): new function, eval within
[lilypond.git] / lily / lily-guile.cc
1 /*
2   lily-guile.cc -- implement assorted guile functions
3
4   source file of the GNU LilyPond music typesetter
5
6   (c) 1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
7
8   Han-Wen Nienhuys <hanwen@cs.uu.nl>
9 */
10
11
12 #include <stdio.h>
13 #include <stdlib.h>
14 #include <math.h>   /* isinf */
15 #include <string.h> /* strdup, strchr */
16 #include <ctype.h>
17
18 #include "lily-proto.hh"
19
20 /* macosx fix:
21
22
23  source-file.hh includes cmath which undefines isinf and isnan
24 */
25 inline int my_isinf (Real r) { return isinf (r); }
26 inline int my_isnan (Real r) { return isnan (r); }
27
28
29
30 #include "libc-extension.hh"
31 #include "lily-guile.hh"
32 #include "main.hh"
33 #include "file-path.hh"
34 #include "warn.hh"
35 #include "direction.hh"
36 #include "offset.hh"
37 #include "interval.hh"
38 #include "pitch.hh"
39 #include "dimensions.hh"
40 #include "source-file.hh"
41
42 // #define TEST_GC
43
44 SCM
45 ly_last (SCM list)
46 {
47   return ly_car (scm_last_pair (list));
48 }
49
50
51 SCM
52 ly_write2scm (SCM s)
53 {
54   SCM port = scm_mkstrport (SCM_INUM0, 
55                             scm_make_string (SCM_INUM0, SCM_UNDEFINED),
56                             SCM_OPN | SCM_WRTNG,
57                             "ly_write2string");
58   //  SCM write = scm_eval_3 (ly_symbol2scm ("write"), s, SCM_EOL);
59   SCM write = scm_primitive_eval (ly_symbol2scm ("write"));
60   
61   // scm_apply (write, port, SCM_EOL);
62   gh_call2 (write, s, port);
63   return scm_strport_to_string (port);
64 }
65
66
67 SCM
68 ly_quote_scm (SCM s)
69 {
70   return scm_list_n (ly_symbol2scm ("quote"), s, SCM_UNDEFINED);
71 }
72
73 String
74 ly_symbol2string (SCM s)
75 {
76   assert (gh_symbol_p (s));
77   return String ((Byte*)SCM_STRING_CHARS (s), (int) SCM_STRING_LENGTH (s));
78 }
79
80 String
81 gulp_file_to_string (String fn)
82 {
83   String s = global_path.find (fn);
84   if (s == "")
85     {
86       String e = _f ("can't find file: `%s'", fn);
87       e += " ";
88       e += _f ("(load path: `%s')", global_path.to_string ());
89       error (e);
90     }
91   else if (verbose_global_b)
92     progress_indication ("[" + s);
93
94   int n;
95   char * str = gulp_file (s, &n);
96   String result (str);
97   delete[] str;
98   
99   if (verbose_global_b)
100     progress_indication ("]");
101
102   return result;
103 }
104
105 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
106            1, 0, 0, (SCM name),
107           "Read the file @var{name}, and return its contents in a string.  "
108            "The file is looked up using the search path.")
109 {
110   return scm_makfrom0str (gulp_file_to_string (ly_scm2string (name)).to_str0 ());
111 }
112
113
114 extern "C" {
115   // maybe gdb 5.0 becomes quicker if it doesn't do fancy C++ typing?
116 void
117 ly_display_scm (SCM s)
118 {
119   gh_display (s);
120   gh_newline ();
121 }
122 };
123
124 String
125 ly_scm2string (SCM s)
126 {
127   assert (gh_string_p (s));
128
129   char *p = SCM_STRING_CHARS (s);
130   String r (p);
131   return r;
132 }
133
134 SCM
135 index_get_cell (SCM s, Direction d)
136 {
137   
138   assert (d);
139   return (d == LEFT) ? ly_car (s) : ly_cdr (s);
140 }
141
142 SCM
143 index_set_cell (SCM s, Direction d, SCM v)
144 {
145   if (d == LEFT)
146     gh_set_car_x (s, v);
147   else if (d == RIGHT)
148     gh_set_cdr_x (s, v);
149   return s;
150 }
151   
152 LY_DEFINE (ly_warning,"ly:warn", 1, 0, 0,
153   (SCM str),"Scheme callable function to issue the warning @code{msg}.")
154 {
155   SCM_ASSERT_TYPE (gh_string_p (str), str, SCM_ARG1, __FUNCTION__, "string");
156   warning ("lily-guile: " + ly_scm2string (str));
157   return SCM_BOOL_T;
158 }
159
160 LY_DEFINE (ly_dir_p,  "ly:dir?", 1,0, 0,  (SCM s),
161           "type predicate. A direction is @code{-1}, @code{0} or "
162            "@code{1}, where @code{-1} represents "
163           "left or down and @code{1} represents right or up.")
164 {
165   if (gh_number_p (s))
166     {
167       int i = gh_scm2int (s);
168       return (i>= -1 && i <= 1)  ? SCM_BOOL_T : SCM_BOOL_F; 
169     }
170   return SCM_BOOL_F;
171 }
172
173 bool
174 is_number_pair (SCM p)
175 {
176   return gh_pair_p (p) && gh_number_p (ly_car (p)) && gh_number_p (ly_cdr (p));
177 }
178
179 typedef void (*Void_fptr) ();
180 Array<Void_fptr> *scm_init_funcs_;
181
182 void add_scm_init_func (void (*f) ())
183 {
184   if (!scm_init_funcs_)
185     scm_init_funcs_ = new Array<Void_fptr>;
186
187   scm_init_funcs_->push (f);
188 }
189
190
191 void
192 ly_init_ly_module (void *)
193 {
194   for (int i=scm_init_funcs_->size () ; i--;)
195     (scm_init_funcs_->elem (i)) ();
196
197   if (verbose_global_b)
198     progress_indication ("\n");
199   
200   scm_primitive_load_path (scm_makfrom0str ("lily.scm"));
201 }
202
203
204 SCM global_lily_module;
205
206 void
207 ly_init_guile ()
208 {
209   global_lily_module = scm_c_define_module ("lily", ly_init_ly_module, 0);
210   scm_c_use_module ("lily");
211 }
212
213 unsigned int ly_scm_hash (SCM s)
214 {
215   return scm_ihashv (s, ~1u);
216 }
217
218
219
220 bool
221 is_direction (SCM s)
222 {
223   if (gh_number_p (s))
224     {
225       int i = gh_scm2int (s);
226       return i>= -1 && i <= 1; 
227     }
228   return false;
229 }
230
231
232 bool
233 is_axis (SCM s)
234 {
235   if (gh_number_p (s))
236     {
237       int i = gh_scm2int (s);
238       return i== 0 || i == 1;
239     }
240   return false;
241 }
242
243
244 Direction
245 to_dir (SCM s)
246 {
247   return SCM_INUMP (s) ?  (Direction) gh_scm2int (s) : CENTER;
248 }
249
250 Interval
251 ly_scm2interval (SCM p)
252 {
253   return  Interval (gh_scm2double (ly_car (p)),
254                     gh_scm2double (ly_cdr (p)));
255 }
256
257 Drul_array<Real>
258 ly_scm2realdrul (SCM p)
259 {
260   return  Drul_array<Real> (gh_scm2double (ly_car (p)),
261                             gh_scm2double (ly_cdr (p)));
262 }
263
264 SCM
265 ly_interval2scm (Drul_array<Real> i)
266 {
267   return gh_cons (gh_double2scm (i[LEFT]),
268                   gh_double2scm (i[RIGHT]));
269 }
270
271
272
273
274 bool
275 to_boolean (SCM s)
276 {
277   return gh_boolean_p (s) && gh_scm2bool (s);
278 }
279
280 /*
281   Appendable list L: the cdr contains the list, the car the last cons
282   in the list.
283  */
284 SCM
285 appendable_list ()
286 {
287   SCM s = gh_cons (SCM_EOL, SCM_EOL);
288   gh_set_car_x (s, s);
289   
290   return s;
291 }
292
293 void
294 appendable_list_append (SCM l, SCM elt)
295 {
296   SCM newcons = gh_cons (elt, SCM_EOL);
297   
298   gh_set_cdr_x (ly_car (l), newcons);      
299   gh_set_car_x (l, newcons);
300 }
301
302
303 SCM
304 ly_offset2scm (Offset o)
305 {
306   return gh_cons (gh_double2scm (o[X_AXIS]), gh_double2scm (o[Y_AXIS]));
307 }
308
309 Offset
310 ly_scm2offset (SCM s)
311 {
312   return Offset (gh_scm2double (ly_car (s)),
313                  gh_scm2double (ly_cdr (s)));
314 }
315
316    
317 LY_DEFINE (ly_number2string,  "ly:number->string", 1, 0,0,
318           (SCM s),
319           " converts @var{num} to a string without generating many decimals. It "
320 "leaves a space at the end.")
321 {
322   SCM_ASSERT_TYPE (gh_number_p (s), s, SCM_ARG1, __FUNCTION__, "number");
323
324   char str[400];                        // ugh.
325
326   if (scm_exact_p (s) == SCM_BOOL_F)
327     {
328       Real r (gh_scm2double (s));
329
330       if (my_isinf (r) || my_isnan (r))
331         {
332           programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
333           r = 0.0;
334         }
335
336       sprintf (str, "%8.4f ", r);
337     }
338   else
339     {
340       sprintf (str, "%d ", gh_scm2int (s));
341     }
342
343   return scm_makfrom0str (str);
344 }
345
346 /*
347   Undef this to see if GUILE GC is causing too many swaps.
348  */
349
350 //#define TEST_GC
351
352 #ifdef TEST_GC
353 #include <libguile/gc.h>
354
355 static void *
356 greet_sweep (void *dummy1, void *dummy2, void *dummy3)
357 {
358    fprintf (stderr, "entering sweep\n");
359 }
360
361 static void *
362 wave_sweep_goodbye (void *dummy1, void *dummy2, void *dummy3)
363 {
364    fprintf (stderr, "leaving sweep\n");
365 }
366 #endif
367
368
369 #include "version.hh"
370 LY_DEFINE (ly_version,  "ly:version", 0, 0, 0, (),
371           "Return the current lilypond version as a list, e.g. @code{(1 3 127 uu1)}. ")
372 {
373   char const* vs =  "\'(" MAJOR_VERSION " " MINOR_VERSION " "  PATCH_LEVEL " " MY_PATCH_LEVEL ")" ;
374   
375   return gh_eval_str ((char*)vs);
376 }
377
378 LY_DEFINE (ly_unit,  "ly:unit", 0, 0, 0, (),
379           "Return the unit used for lengths as a string.")
380 {
381   return scm_makfrom0str (INTERNAL_UNIT);
382 }
383
384
385
386 LY_DEFINE (ly_dimension_p,  "ly:dimension?", 1, 0, 0, (SCM d),
387           "Return @var{d} is a number. Used to distinguish length "
388           "variables from normal numbers.")
389 {
390   return scm_number_p (d);
391 }
392
393 static void
394 init_functions ()
395 {
396 #ifdef TEST_GC 
397   scm_c_hook_add (&scm_before_mark_c_hook, greet_sweep, 0, 0);
398   scm_c_hook_add (&scm_before_sweep_c_hook, wave_sweep_goodbye, 0, 0);
399 #endif
400 }
401
402 ADD_SCM_INIT_FUNC (funcs, init_functions);
403
404 SCM
405 ly_deep_copy (SCM src)
406 {
407   if (gh_pair_p (src))
408     {
409       return gh_cons (ly_deep_copy (ly_car (src)), ly_deep_copy (ly_cdr (src)));
410     }
411   else if (gh_vector_p (src))
412     {
413       int  l = SCM_VECTOR_LENGTH (src);
414       SCM nv = scm_c_make_vector (l, SCM_UNDEFINED);
415       for (int i  =0 ; i< l ; i++)
416         {
417           SCM si = gh_int2scm (i);
418           scm_vector_set_x (nv, si, ly_deep_copy (scm_vector_ref (src, si))); 
419         }
420     }
421   else
422     return src;
423
424   return src;
425 }
426
427
428
429
430 SCM
431 ly_assoc_chain (SCM key, SCM achain)
432 {
433   if (gh_pair_p (achain))
434     {
435       SCM handle = scm_assoc (key, ly_car (achain));
436       if (gh_pair_p (handle))
437         return handle;
438       else
439         return ly_assoc_chain (key, ly_cdr (achain));
440     }
441   else
442     return SCM_BOOL_F;
443 }
444
445 /* looks the key up in the cdrs of the alist-keys
446    - ignoring the car and ignoring non-pair keys.
447    Returns first match found, i.e.
448
449    alist = ((1 . 10)
450                    ((1 . 2) . 11)
451                    ((2 . 1) . 12)
452                    ((3 . 0) . 13)
453                    ((4 . 1) . 14) )
454
455 I would like (ly_assoc_cdr 1) to return 12 - because it's the first
456 element with the cdr of the key = 1.  In other words (alloc_cdr key)
457 corresponds to call
458
459 (alloc (anything . key))
460
461
462
463 */
464 SCM
465 ly_assoc_cdr (SCM key, SCM alist)
466 {
467   if (gh_pair_p (alist)) {
468     SCM trykey = ly_caar (alist);
469     if (gh_pair_p (trykey) && to_boolean (scm_equal_p (key,ly_cdr (trykey))))
470       return ly_car (alist);
471     else
472       return ly_assoc_cdr (key, ly_cdr (alist));
473   }
474   else
475     return SCM_BOOL_F;
476 }
477
478 /*
479   LIST has the form "sym1 sym2 sym3\nsym4\nsym5"
480
481   i.e. \n and ' ' can be used interchangeably as separators.
482  */
483 SCM
484 parse_symbol_list (const char * list)
485 {
486   char * s = strdup (list);
487   char *orig = s;
488   SCM create_list = SCM_EOL;
489
490   char * e = s + strlen (s) - 1;
491   while (e >= s && isspace (*e))
492     *e -- = 0;
493
494   for (char * p = s; *p; p++)
495     {
496       if (*p == '\n')
497         *p = ' ' ;
498     }
499   
500   if (!s[0] )
501     s = 0;
502
503
504   
505   while (s)
506     {
507       char *next = strchr (s, ' ');
508       if (next)
509         *next++ = 0;
510
511       create_list = gh_cons (ly_symbol2scm (s), create_list);
512       s = next;
513     }
514
515   free (orig);
516   return create_list;
517 }
518
519
520 SCM
521 ly_truncate_list (int k, SCM l )
522 {
523   if (k == 0)
524     {
525       l = SCM_EOL;
526     }
527   else
528     {
529       SCM s = l;
530       k--;
531       for (; gh_pair_p (s) && k--; s = ly_cdr (s))
532         ;
533
534       if (gh_pair_p (s))
535         {
536           gh_set_cdr_x (s, SCM_EOL);
537         }
538     }
539   return l;
540 }
541
542
543 String
544 print_scm_val (SCM val)
545 {
546   String realval = ly_scm2string (ly_write2scm (val));
547   if (realval.length () > 200)
548     realval = realval.left_string (100) + "\n :\n :\n" + realval.right_string (100);
549   
550   return realval;        
551 }
552
553 bool
554 type_check_assignment (SCM sym, SCM val,  SCM type_symbol) 
555 {
556   bool ok = true;
557
558   /*
559     Always succeeds.
560
561
562     TODO: should remove #f from allowed vals?
563    */
564   if (val == SCM_EOL || val == SCM_BOOL_F)
565     return ok;
566
567   if (!gh_symbol_p (sym))
568 #if 0
569     return false;
570 #else
571   /*
572     This is used for autoBeamSettings.
573
574     TODO: deprecate the use of \override and \revert for
575     autoBeamSettings?
576
577     or use a symbol autoBeamSettingS?  
578    */
579   return true; 
580 #endif
581   
582   SCM type = scm_object_property (sym, type_symbol);
583
584   if (type != SCM_EOL && !gh_procedure_p (type))
585       {
586         warning (_f ("Can't find property type-check for `%s' (%s).",
587                      ly_symbol2string (sym).to_str0 (),
588                      ly_symbol2string (type_symbol).to_str0 ())
589                  + "  " + _ ("Perhaps you made a typing error?"));
590
591         /* Be strict when being anal :) */
592         if (internal_type_checking_global_b)
593           abort ();
594         
595         warning (_ ("Doing assignment anyway."));
596       }
597   else
598     {
599       if (val != SCM_EOL
600           && gh_procedure_p (type)
601           && gh_call1 (type, val) == SCM_BOOL_F)
602         {
603           SCM errport = scm_current_error_port ();
604           ok = false;
605           SCM typefunc = scm_primitive_eval (ly_symbol2scm ("type-name"));
606           SCM type_name = gh_call1 (typefunc, type);
607
608          
609           scm_puts (_f ("Type check for `%s' failed; value `%s' must be of type `%s'",
610                         ly_symbol2string (sym).to_str0 (),
611                         print_scm_val (val),
612                         ly_scm2string (type_name).to_str0 ()).to_str0 (),
613                     errport);
614           scm_puts ("\n", errport);                   
615         }
616     }
617   return ok;
618 }
619
620
621 /* some SCM abbrevs
622
623    zijn deze nou handig?
624    zijn ze er al in scheme, maar heten ze anders? */
625
626
627 /* Remove doubles from (sorted) list */
628 SCM
629 ly_unique (SCM list)
630 {
631   SCM unique = SCM_EOL;
632   for (SCM i = list; gh_pair_p (i); i = ly_cdr (i))
633     {
634       if (!gh_pair_p (ly_cdr (i))
635           || !gh_equal_p (ly_car (i), ly_cadr (i)))
636         unique = gh_cons (ly_car (i), unique);
637     }
638   return scm_reverse_x (unique, SCM_EOL);
639 }
640
641 /* tail add */
642 SCM
643 ly_snoc (SCM s, SCM list)
644 {
645   return gh_append2 (list, scm_list_n (s, SCM_UNDEFINED));
646 }
647
648
649 /* Split list at member s, removing s.
650    Return (BEFORE . AFTER) */
651 SCM
652 ly_split_list (SCM s, SCM list)
653 {
654   SCM before = SCM_EOL;
655   SCM after = list;
656   for (; gh_pair_p (after);)
657     {
658       SCM i = ly_car (after);
659       after = ly_cdr (after);
660       if (gh_equal_p (i, s))
661         break;
662       before = gh_cons (i, before);
663     }
664   return gh_cons ( scm_reverse_x (before, SCM_EOL),  after);
665   
666 }
667
668
669 void
670 taint (SCM *)
671 {
672   /*
673     nop.
674    */
675 }
676
677 /*
678   display stuff without using stack
679  */
680 SCM
681 display_list (SCM s)
682 {
683   SCM p = scm_current_output_port ();
684
685   scm_puts ("(", p);
686   for (; gh_pair_p (s); s =gh_cdr (s))
687     {
688       scm_display (gh_car (s), p);
689       scm_puts (" ", p);      
690     }
691   scm_puts (")", p);
692   return SCM_UNSPECIFIED;
693 }
694
695 Slice
696 int_list_to_slice (SCM l)
697 {
698   Slice s;
699   s.set_empty ();
700   for (; gh_pair_p (l); l = gh_cdr (l))
701     {
702       if (gh_number_p (gh_car (l)))
703         s.add_point (gh_scm2int (gh_car (l))); 
704     }
705
706   return s;
707 }
708
709
710 /*
711   Return I-th element, or last elt L. If I < 0, then we take the first
712   element.
713
714   PRE: length (L) > 0
715  */
716 SCM
717 robust_list_ref (int i, SCM l)
718 {
719   while (i-- > 0 && gh_pair_p (gh_cdr (l)))
720     l = gh_cdr (l);
721
722   return gh_car (l);
723 }
724
725
726
727 Real
728 robust_scm2double (SCM k, double x)
729 {
730   if (gh_number_p (k))
731     x = gh_scm2double (k);
732   return x;
733 }
734
735 Interval
736 robust_scm2interval (SCM k, Drul_array<Real> v)
737 {
738   Interval i;
739   i[LEFT]= v[LEFT];
740   i[RIGHT]= v[RIGHT];
741   if (is_number_pair (k))
742     i = ly_scm2interval (k);
743   return i;
744 }
745
746 Drul_array<Real>
747 robust_scm2drul (SCM k, Drul_array<Real> v)
748 {
749   if (is_number_pair (k))
750     v = ly_scm2interval (k);
751   return v;
752 }
753
754 Offset
755 robust_scm2offset (SCM k, Offset o)
756 {
757   if (is_number_pair (k))
758     o = ly_scm2offset (k);
759
760   return o;
761 }
762
763
764 int
765 robust_scm2int (SCM k, int o)
766 {
767   if (scm_integer_p (k) == SCM_BOOL_T)
768     o = gh_scm2int (k);
769
770   return o;
771 }
772
773
774 SCM
775 alist_to_hashq (SCM alist)
776 {
777   int i = scm_ilength (alist);
778   if (i < 0)
779     return scm_make_vector (gh_int2scm (0), SCM_EOL);
780           
781   SCM tab = scm_make_vector (gh_int2scm (i), SCM_EOL);
782   for (SCM s = alist; gh_pair_p (s); s = ly_cdr (s))
783     {
784       SCM pt = ly_cdar (s);
785       scm_hashq_set_x (tab, ly_caar (s), pt);
786     }
787   return tab; 
788 }
789
790 #if 1
791 /*
792   Debugging mem leaks:
793  */
794 LY_DEFINE (ly_protects, "ly:protects", 0, 0, 0, (),
795           "Return hash of protected objects.")
796 {
797   return scm_protects;
798 }
799 #endif