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