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--2000 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
  16 #include "libc-extension.hh"
  17 #include "lily-guile.hh"
  18 #include "main.hh"
  19 #include "simple-file-storage.hh"
  20 #include "file-path.hh"
  21 #include "debug.hh"
  22 #include "direction.hh"
  23 #include "offset.hh"
  24 #include "interval.hh"
  25
  26 SCM
  27 ly_str02scm (char const*c)
  28 {
  29   // this all really sucks, guile should take char const* arguments!
  30   return gh_str02scm ((char*)c);
  31 }
  32
  33
  34 #if 0
  35 /*
  36   this all really sucks, LilyPond should not communicate with GUILE using strings.
  37  */
  38 SCM
  39 ly_eval_str (String s);
  40 #endif
  41
  42
  43 /*
  44   Pass string to scm parser, evaluate one expression.
  45   Return result value and #chars read.
  46
  47   Thanks to Gary Houston <ghouston@freewire.co.uk>
  48
  49   Need guile-1.3.4 (>1.3 anyway) for ftell on str ports -- jcn
  50 */
  51 SCM
  52 ly_parse_scm (char const* s, int* n)
  53 {
  54   SCM str = gh_str02scm ((char*)s);
  55   SCM port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_RDNG,
  56                             "scm_eval_0str");
  57   SCM from = scm_ftell (port);
  58
  59   SCM form;
  60   SCM answer = SCM_UNSPECIFIED;
  61
  62   /* Read expression from port */
  63   if (!SCM_EOF_OBJECT_P (form = scm_read (port)))
  64     answer = scm_eval_x (form);
  65
  66   /*
  67    After parsing
  68
  69        (begin (foo 1 2))
  70
  71    all seems fine, but after parsing
  72
  73        (foo 1 2)
  74
  75    read_buf has been advanced to read_pos - 1,
  76    so that scm_ftell returns 1, instead of #parsed chars
  77    */
  78
  79   /*
  80     urg: reset read_buf for scm_ftell
  81     shouldn't scm_read () do this for us?
  82   */
  83   scm_fill_input (port);
  84   SCM to = scm_ftell (port);
  85   *n = gh_scm2int (to) - gh_scm2int (from);
  86
  87   /* Don't close the port here; if we re-enter this function via a
  88      continuation, then the next time we enter it, we'll get an error.
  89      It's a string port anyway, so there's no advantage to closing it
  90      early.
  91
  92      scm_close_port (port);
  93   */
  94
  95   return answer;
  96 }
  97
  98 SCM
  99 ly_quote_scm (SCM s)
 100 {
 101   return gh_list (ly_symbol2scm ("quote"), s, SCM_UNDEFINED);
 102 }
 103
 104
 105 SCM
 106 ly_symbol2scm(const char *s)
 107 {
 108   return gh_symbol2scm ((char *)s);
 109 }
 110
 111 String
 112 ly_symbol2string (SCM s)
 113 {
 114   assert (gh_symbol_p (s));
 115   return String((Byte*)SCM_CHARS (s), (int) SCM_LENGTH(s));
 116 }
 117
 118
 119 /**
 120    Read a file, and shove it down GUILE.  GUILE also has file read
 121    functions, but you can't fiddle with the path of those.
 122  */
 123 void
 124 read_lily_scm_file (String fn)
 125 {
 126   String s = global_path.find (fn);
 127   if (s == "")
 128     {
 129       String e = _f ("can't find file: `%s'", fn);
 130       e += " ";
 131       e += _f ("(load path: `%s')", global_path.str ());
 132       error (e);
 133     }
 134   else
 135     progress_indication ("[" + s);
 136
 137
 138   Simple_file_storage f(s);
 139
 140   gh_eval_str ((char *) f.ch_C());
 141   progress_indication ("]");
 142 }
 143
 144
 145 SCM
 146 ly_gulp_file (SCM name)
 147 {
 148   String fn (ly_scm2string (name));
 149  String s = global_path.find (fn);
 150   if (s == "")
 151     {
 152       String e = _f ("can't find file: `%s'", fn);
 153       e += " ";
 154       e += _f ("(load path: `%s')", global_path.str ());
 155       error (e);
 156     }
 157   else
 158     progress_indication ("[" + s );
 159
 160
 161   Simple_file_storage f(s);
 162   SCM result = ly_str02scm (f.ch_C());
 163   progress_indication ("]");
 164   return result;
 165 }
 166
 167 void
 168 ly_display_scm (SCM s)
 169 {
 170   gh_display (s);
 171   gh_newline ();
 172 }
 173
 174 String
 175 ly_scm2string (SCM s)
 176 {
 177   assert (gh_string_p (s));
 178   int len;
 179   char * p = gh_scm2newstr (s , &len);
 180
 181   String r (p);
 182
 183   free (p);
 184   return r;
 185 }
 186
 187 SCM
 188 index_cell (SCM s, Direction d)
 189 {
 190   assert (d);
 191   return (d == LEFT) ? gh_car  (s) : gh_cdr (s);
 192 }
 193
 194 SCM
 195 index_set_cell (SCM s, Direction d, SCM v)
 196 {
 197   if (d == LEFT)
 198     gh_set_car_x (s, v);
 199   else if (d == RIGHT)
 200     gh_set_cdr_x (s, v);
 201   return s;
 202 }
 203
 204 SCM
 205 ly_warning (SCM str)
 206 {
 207   assert (gh_string_p (str));
 208   warning ("lily-guile: " + ly_scm2string (str));
 209   return SCM_BOOL_T;
 210 }
 211
 212 SCM
 213 ly_isdir_p (SCM s)
 214 {
 215   if (gh_number_p (s))
 216     {
 217       int i = gh_scm2int (s);
 218       return (i>= -1 && i <= 1)  ? SCM_BOOL_T : SCM_BOOL_F;
 219     }
 220   return SCM_BOOL_F;
 221 }
 222
 223
 224
 225 typedef void (*Void_fptr)();
 226 Array<Void_fptr> *scm_init_funcs_;
 227
 228 void add_scm_init_func (void (*f)())
 229 {
 230   if (!scm_init_funcs_)
 231     scm_init_funcs_ = new Array<Void_fptr>;
 232
 233   scm_init_funcs_->push (f);
 234 }
 235
 236 void
 237 init_lily_guile ()
 238 {
 239   for (int i=scm_init_funcs_->size() ; i--;)
 240     (scm_init_funcs_->elem (i)) ();
 241 }
 242
 243 unsigned int ly_scm_hash (SCM s)
 244 {
 245   return scm_ihashv (s, ~1u);
 246 }
 247
 248
 249
 250 bool
 251 isdir_b (SCM s)
 252 {
 253   if (gh_number_p (s))
 254     {
 255       int i = gh_scm2int (s);
 256       return i>= -1 && i <= 1;
 257     }
 258   return false;
 259 }
 260
 261 Direction
 262 to_dir (SCM s)
 263 {
 264   return (Direction) gh_scm2int (s);
 265 }
 266
 267 Interval
 268 ly_scm2interval (SCM p)
 269 {
 270   return  Interval (gh_scm2double (gh_car (p)),
 271                     gh_scm2double (gh_cdr (p)));
 272 }
 273
 274 SCM
 275 ly_interval2scm (Interval i)
 276 {
 277   return gh_cons (gh_double2scm (i[LEFT]),
 278                   gh_double2scm (i[RIGHT]));
 279 }
 280
 281
 282 bool
 283 to_boolean (SCM s)
 284 {
 285   return gh_boolean_p (s) && gh_scm2bool (s);
 286 }
 287
 288 /*
 289   Appendable list L: the cdr contains the list, the car the last cons
 290   in the list.
 291  */
 292 SCM
 293 appendable_list ()
 294 {
 295   SCM s = gh_cons (SCM_EOL, SCM_EOL);
 296   gh_set_car_x (s, s);
 297
 298   return s;
 299 }
 300
 301 void
 302 appendable_list_append (SCM l, SCM elt)
 303 {
 304   SCM newcons = gh_cons (elt, SCM_EOL);
 305
 306   gh_set_cdr_x (gh_car (l), newcons);
 307   gh_set_car_x (l, newcons);
 308 }
 309
 310
 311 SCM
 312 ly_offset2scm (Offset o)
 313 {
 314   return gh_cons (gh_double2scm (o[X_AXIS]), gh_double2scm(o[Y_AXIS]));
 315 }
 316
 317 Offset
 318 ly_scm2offset (SCM s)
 319 {
 320   return Offset (gh_scm2double (gh_car (s)),
 321                  gh_scm2double (gh_cdr (s)));
 322 }
 323
 324 SCM
 325 ly_type (SCM exp)
 326 {
 327   char const  * cp = "unknown";
 328   if (gh_number_p (exp))
 329     {
 330       cp = "number";
 331     }
 332   else if (gh_string_p (exp))
 333     {
 334       cp = "string";
 335     }
 336   else if (gh_procedure_p (exp))
 337     {
 338       cp = "procedure";
 339     }
 340   else if (gh_boolean_p (exp))
 341     {
 342       cp = "boolean";
 343     }
 344   else if (gh_pair_p (exp))
 345     {
 346       cp = "list";
 347     }
 348
 349   return ly_str02scm (cp);
 350 }
 351
 352 /*
 353   convert without too many decimals, and leave  a space at the end.
 354  */
 355
 356
 357 SCM
 358 ly_number2string (SCM s)
 359 {
 360   assert (gh_number_p (s));
 361
 362   char str[100];                        // ugh.
 363
 364   if (scm_integer_p (s))
 365     {
 366       Real r (gh_scm2double (s));
 367
 368       if (isinf (r) || isnan (r))
 369         {
 370           programming_error ("Infinity or NaN encountered while converting Real number; setting to zero.");
 371           r = 0.0;
 372         }
 373
 374       sprintf (str, "%8.4f ", r);
 375     }
 376   else
 377     {
 378       sprintf (str, "%d ", gh_scm2int (s));
 379     }
 380
 381   return gh_str02scm (str);
 382 }
 383
 384 // #define TEST_GC
 385
 386 #ifdef TEST_GC
 387 #include <libguile/gc.h>
 388
 389 static void *
 390 greet_sweep (void *dummy1, void *dummy2, void *dummy3)
 391 {
 392    fprintf(stderr, "entering sweep\n");
 393 }
 394
 395 static void *
 396 wave_sweep_goodbye (void *dummy1, void *dummy2, void *dummy3)
 397 {
 398    fprintf(stderr, "leaving sweep\n");
 399 }
 400 #endif
 401
 402 static void
 403 init_functions ()
 404 {
 405   scm_make_gsubr ("ly-warn", 1, 0, 0, (SCM(*)(...))ly_warning);
 406   scm_make_gsubr ("ly-gulp-file", 1,0, 0, (SCM(*)(...))ly_gulp_file);
 407   scm_make_gsubr ("dir?", 1,0, 0, (SCM(*)(...))ly_isdir_p);
 408   scm_make_gsubr ("ly-number->string", 1, 0,0, (SCM(*)(...)) ly_number2string);
 409
 410
 411 #ifdef TEST_GC
 412   scm_c_hook_add (&scm_before_mark_c_hook, greet_sweep, 0, 0);
 413   scm_c_hook_add (&scm_before_sweep_c_hook, wave_sweep_goodbye, 0, 0);
 414 #endif
 415
 416 }
 417
 418 ADD_SCM_INIT_FUNC(funcs, init_functions);