libguile/load.c

   1 /*      Copyright (C) 1995,1996,1998,1999, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include <string.h>
  49
  50 #include "libguile/_scm.h"
  51 #include "libguile/libpath.h"
  52 #include "libguile/fports.h"
  53 #include "libguile/read.h"
  54 #include "libguile/eval.h"
  55 #include "libguile/throw.h"
  56 #include "libguile/alist.h"
  57 #include "libguile/dynwind.h"
  58 #include "libguile/root.h"
  59 #include "libguile/strings.h"
  60 #include "libguile/modules.h"
  61
  62 #include "libguile/validate.h"
  63 #include "libguile/load.h"
  64
  65 #include <sys/types.h>
  66 #include <sys/stat.h>
  67
  68 #ifdef HAVE_UNISTD_H
  69 #include <unistd.h>
  70 #endif /* HAVE_UNISTD_H */
  71
  72 #ifndef R_OK
  73 #define R_OK 4
  74 #endif
  75
  76 \f
  77 /* Loading a file, given an absolute filename.  */
  78
  79 /* Hook to run when we load a file, perhaps to announce the fact somewhere.
  80    Applied to the full name of the file.  */
  81 static SCM *scm_loc_load_hook;
  82
  83 static void
  84 swap_port (void *data)
  85 {
  86   SCM *save_port = data, tmp = scm_cur_loadp;
  87   scm_cur_loadp = *save_port;
  88   *save_port = tmp;
  89 }
  90
  91 static SCM
  92 load (void *data)
  93 {
  94   SCM port = SCM_PACK (data);
  95   while (1)
  96     {
  97       SCM form = scm_read (port);
  98       if (SCM_EOF_OBJECT_P (form))
  99         break;
 100       /* Ugh!  We need to re-check the environment for every form.
 101        * We should change this in the new module system.
 102        */
 103       scm_i_eval_x (form,
 104                     scm_module_system_booted_p
 105                     ? (scm_top_level_env
 106                        (SCM_MODULE_EVAL_CLOSURE (scm_selected_module ())))
 107                     : SCM_EOL);
 108     }
 109   return SCM_UNSPECIFIED;
 110 }
 111
 112 SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
 113            (SCM filename),
 114             "Load @var{file} and evaluate its contents in the top-level environment.\n"
 115             "The load paths are not searched; @var{file} must either be a full\n"
 116             "pathname or be a pathname relative to the current directory.  If the\n"
 117             "variable @code{%load-hook} is defined, it should be bound to a procedure\n"
 118             "that will be called before any code is loaded.  See documentation for\n"
 119             "@code{%load-hook} later in this section.")
 120 #define FUNC_NAME s_scm_primitive_load
 121 {
 122   SCM hook = *scm_loc_load_hook;
 123   SCM_VALIDATE_STRING (1, filename);
 124   SCM_ASSERT (SCM_FALSEP (hook) || (SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T)),
 125               hook, "value of %load-hook is neither a procedure nor #f",
 126               FUNC_NAME);
 127
 128   if (! SCM_FALSEP (hook))
 129     scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
 130
 131   { /* scope */
 132     SCM port, save_port;
 133     port = scm_open_file (filename,
 134                           scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
 135     save_port = port;
 136     scm_internal_dynamic_wind (swap_port,
 137                                load,
 138                                swap_port,
 139                                (void *) SCM_UNPACK (port),
 140                                &save_port);
 141     scm_close_port (port);
 142   }
 143   return SCM_UNSPECIFIED;
 144 }
 145 #undef FUNC_NAME
 146
 147 \f
 148 /* Builtin path to scheme library files. */
 149 #ifdef SCM_PKGDATA_DIR
 150 SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0,
 151             (),
 152             "Return the name of the directory where Scheme packages, modules and\n"
 153             "libraries are kept.  On most Unix systems, this will be\n"
 154             "@samp{/usr/local/share/guile}.")
 155 #define FUNC_NAME s_scm_sys_package_data_dir
 156 {
 157   return scm_makfrom0str (SCM_PKGDATA_DIR);
 158 }
 159 #undef FUNC_NAME
 160 #endif /* SCM_PKGDATA_DIR */
 161
 162 #ifdef SCM_LIBRARY_DIR
 163 SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0,
 164             (),
 165             "Return the directory where the Guile Scheme library files are installed.\n"
 166             "E.g., may return \"/usr/share/guile/1.3.5\".")
 167 #define FUNC_NAME s_scm_sys_library_dir
 168 {
 169   return scm_makfrom0str(SCM_LIBRARY_DIR);
 170 }
 171 #undef FUNC_NAME
 172 #endif /* SCM_LIBRARY_DIR */
 173
 174 #ifdef SCM_SITE_DIR
 175 SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
 176             (),
 177             "Return the directory where the Guile site files are installed.\n"
 178             "E.g., may return \"/usr/share/guile/site\".")
 179 #define FUNC_NAME s_scm_sys_site_dir
 180 {
 181   return scm_makfrom0str(SCM_SITE_DIR);
 182 }
 183 #undef FUNC_NAME
 184 #endif /* SCM_SITE_DIR */
 185
 186
 187
 188 \f
 189 /* Initializing the load path, and searching it.  */
 190
 191 /* List of names of directories we search for files to load.  */
 192 static SCM *scm_loc_load_path;
 193
 194 /* List of extensions we try adding to the filenames.  */
 195 static SCM *scm_loc_load_extensions;
 196
 197
 198 /* Parse the null-terminated string PATH as if it were a standard path
 199    environment variable (i.e. a colon-separated list of strings), and
 200    prepend the elements to TAIL.  */
 201 SCM
 202 scm_internal_parse_path (char *path, SCM tail)
 203 {
 204   if (path && path[0] != '\0')
 205     {
 206       char *scan, *elt_end;
 207
 208       /* Scan backwards from the end of the string, to help
 209          construct the list in the right order.  */
 210       scan = elt_end = path + strlen (path);
 211       do {
 212         /* Scan back to the beginning of the current element.  */
 213         do scan--;
 214         while (scan >= path && *scan != ':');
 215         tail = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
 216                          tail);
 217         elt_end = scan;
 218       } while (scan >= path);
 219     }
 220
 221   return tail;
 222 }
 223
 224
 225 SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
 226             (SCM path, SCM tail),
 227             "")
 228 #define FUNC_NAME s_scm_parse_path
 229 {
 230   SCM_ASSERT (SCM_FALSEP (path) || (SCM_STRINGP (path)),
 231               path,
 232               SCM_ARG1, FUNC_NAME);
 233   if (SCM_UNBNDP (tail))
 234     tail = SCM_EOL;
 235   return (SCM_FALSEP (path)
 236           ? tail
 237           : scm_internal_parse_path (SCM_STRING_CHARS (path), tail));
 238 }
 239 #undef FUNC_NAME
 240
 241
 242 /* Initialize the global variable %load-path, given the value of the
 243    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
 244    GUILE_LOAD_PATH environment variable.  */
 245 void
 246 scm_init_load_path ()
 247 {
 248   SCM path = SCM_EOL;
 249
 250 #ifdef SCM_LIBRARY_DIR
 251   path = scm_listify (scm_makfrom0str (SCM_SITE_DIR),
 252                       scm_makfrom0str (SCM_LIBRARY_DIR),
 253                       scm_makfrom0str (SCM_PKGDATA_DIR),
 254                       SCM_UNDEFINED);
 255 #endif /* SCM_LIBRARY_DIR */
 256
 257   path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path);
 258
 259   *scm_loc_load_path = path;
 260 }
 261
 262 SCM scm_listofnullstr;
 263
 264 /* Search PATH for a directory containing a file named FILENAME.
 265    The file must be readable, and not a directory.
 266    If we find one, return its full filename; otherwise, return #f.
 267    If FILENAME is absolute, return it unchanged.
 268    If given, EXTENSIONS is a list of strings; for each directory
 269    in PATH, we search for FILENAME concatenated with each EXTENSION.  */
 270 SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
 271            (SCM path, SCM filename, SCM extensions),
 272             "")
 273 #define FUNC_NAME s_scm_search_path
 274 {
 275   char *filename_chars;
 276   int filename_len;
 277   size_t max_path_len;          /* maximum length of any PATH element */
 278   size_t max_ext_len;           /* maximum length of any EXTENSIONS element */
 279
 280   SCM_VALIDATE_LIST (1,path);
 281   SCM_VALIDATE_STRING (2, filename);
 282   if (SCM_UNBNDP (extensions))
 283     extensions = SCM_EOL;
 284   else
 285     SCM_VALIDATE_LIST (3,extensions);
 286
 287   filename_chars = SCM_STRING_CHARS (filename);
 288   filename_len = SCM_STRING_LENGTH (filename);
 289
 290   /* If FILENAME is absolute, return it unchanged.  */
 291   if (filename_len >= 1 && filename_chars[0] == '/')
 292     return filename;
 293
 294   /* Find the length of the longest element of path.  */
 295   {
 296     SCM walk;
 297
 298     max_path_len = 0;
 299     for (walk = path; !SCM_NULLP (walk); walk = SCM_CDR (walk))
 300       {
 301         SCM elt = SCM_CAR (walk);
 302         SCM_ASSERT (SCM_STRINGP (elt), elt,
 303                     "path is not a list of strings",
 304                     FUNC_NAME);
 305         if (SCM_STRING_LENGTH (elt) > max_path_len)
 306           max_path_len = SCM_STRING_LENGTH (elt);
 307       }
 308   }
 309
 310   /* If FILENAME has an extension, don't try to add EXTENSIONS to it.  */
 311   {
 312     char *endp;
 313
 314     for (endp = filename_chars + filename_len - 1;
 315          endp >= filename_chars;
 316          endp--)
 317       {
 318         if (*endp == '.')
 319           {
 320             /* This filename already has an extension, so cancel the
 321                list of extensions.  */
 322             extensions = SCM_EOL;
 323             break;
 324           }
 325         else if (*endp == '/')
 326           /* This filename has no extension, so keep the current list
 327              of extensions.  */
 328           break;
 329       }
 330   }
 331
 332   /* Find the length of the longest element of the load extensions
 333      list.  */
 334   { /* scope */
 335     SCM walk;
 336
 337     max_ext_len = 0;
 338     for (walk = extensions; !SCM_NULLP (walk); walk = SCM_CDR (walk))
 339       {
 340         SCM elt = SCM_CAR (walk);
 341         SCM_ASSERT (SCM_STRINGP (elt), elt,
 342                     "extension list is not a list of strings",
 343                     FUNC_NAME);
 344         if (SCM_STRING_LENGTH (elt) > max_ext_len)
 345           max_ext_len = SCM_STRING_LENGTH (elt);
 346       }
 347   }
 348
 349   SCM_DEFER_INTS;
 350
 351   { /* scope */
 352     SCM result = SCM_BOOL_F;
 353     int buf_size = max_path_len + 1 + filename_len + max_ext_len + 1;
 354     char *buf = SCM_MUST_MALLOC (buf_size);
 355
 356     /* This simplifies the loop below a bit.  */
 357     if (SCM_NULLP (extensions))
 358       extensions = scm_listofnullstr;
 359
 360     /* Try every path element.  At this point, we know the path is a
 361        proper list of strings.  */
 362     for (; !SCM_NULLP (path); path = SCM_CDR (path))
 363       {
 364         int len;
 365         SCM dir = SCM_CAR (path);
 366         SCM exts;
 367
 368         /* Concatenate the path name and the filename. */
 369         len = SCM_STRING_LENGTH (dir);
 370         memcpy (buf, SCM_STRING_CHARS (dir), len);
 371         if (len >= 1 && buf[len - 1] != '/')
 372           buf[len++] = '/';
 373         memcpy (buf + len, filename_chars, filename_len);
 374         len += filename_len;
 375
 376         /* Try every extension.  At this point, we know the extension
 377            list is a proper, nonempty list of strings.  */
 378         for (exts = extensions; !SCM_NULLP (exts); exts = SCM_CDR (exts))
 379           {
 380             SCM ext = SCM_CAR (exts);
 381             int ext_len = SCM_STRING_LENGTH (ext);
 382             struct stat mode;
 383
 384             /* Concatenate the extension. */
 385             memcpy (buf + len, SCM_STRING_CHARS (ext), ext_len);
 386             buf[len + ext_len] = '\0';
 387
 388             /* If the file exists at all, we should return it.  If the
 389                file is inaccessible, then that's an error.  */
 390             if (stat (buf, &mode) == 0
 391                 && ! (mode.st_mode & S_IFDIR))
 392               {
 393                 result = scm_makfromstr (buf, len + ext_len, 0);
 394                 goto end;
 395               }
 396           }
 397       }
 398
 399   end:
 400     scm_must_free (buf);
 401     scm_done_malloc (- buf_size);
 402     SCM_ALLOW_INTS;
 403     return result;
 404   }
 405 }
 406 #undef FUNC_NAME
 407
 408
 409 /* Search %load-path for a directory containing a file named FILENAME.
 410    The file must be readable, and not a directory.
 411    If we find one, return its full filename; otherwise, return #f.
 412    If FILENAME is absolute, return it unchanged.  */
 413 SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
 414            (SCM filename),
 415             "Search @var{%load-path} for @var{file}, which must be readable by the\n"
 416             "current user.  If @var{file} is found in the list of paths to search or\n"
 417             "is an absolute pathname, return its full pathname.  Otherwise, return\n"
 418             "@code{#f}.  Filenames may have any of the optional extensions in the\n"
 419             "@code{%load-extensions} list; @code{%search-load-path} will try each\n"
 420             "extension automatically.")
 421 #define FUNC_NAME s_scm_sys_search_load_path
 422 {
 423   SCM path = *scm_loc_load_path;
 424   SCM exts = *scm_loc_load_extensions;
 425   SCM_VALIDATE_STRING (1, filename);
 426
 427   SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
 428               FUNC_NAME);
 429   SCM_ASSERT (scm_ilength (exts) >= 0, exts,
 430               "load extension list is not a proper list",
 431               FUNC_NAME);
 432   return scm_search_path (path, filename, exts);
 433 }
 434 #undef FUNC_NAME
 435
 436
 437 SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
 438            (SCM filename),
 439             "Search @var{%load-path} for @var{file} and load it into the top-level\n"
 440             "environment.  If @var{file} is a relative pathname and is not found in\n"
 441             "the list of search paths, an error is signalled.")
 442 #define FUNC_NAME s_scm_primitive_load_path
 443 {
 444   SCM full_filename;
 445
 446   SCM_VALIDATE_STRING (1, filename);
 447
 448   full_filename = scm_sys_search_load_path (filename);
 449
 450   if (SCM_FALSEP (full_filename))
 451     {
 452       int absolute = (SCM_STRING_LENGTH (filename) >= 1
 453                       && SCM_STRING_CHARS (filename)[0] == '/');
 454       SCM_MISC_ERROR ((absolute
 455                        ? "Unable to load file ~S"
 456                        : "Unable to find file ~S in load path"),
 457                       scm_listify (filename, SCM_UNDEFINED));
 458     }
 459
 460   return scm_primitive_load (full_filename);
 461 }
 462 #undef FUNC_NAME
 463
 464 #if SCM_DEBUG_DEPRECATED == 0
 465
 466 /* Eval now copies source properties, so this function is no longer required.
 467  */
 468
 469 SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
 470
 471 SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
 472             (SCM port),
 473             "Read a form from @var{port} (standard input by default), and evaluate it\n"
 474             "(memoizing it in the process) in the top-level environment.  If no data\n"
 475             "is left to be read from @var{port}, an @code{end-of-file} error is\n"
 476             "signalled.")
 477 #define FUNC_NAME s_scm_read_and_eval_x
 478 {
 479   SCM form = scm_read (port);
 480   if (SCM_EOF_OBJECT_P (form))
 481     scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
 482   return scm_eval_x (form, scm_selected_module ());
 483 }
 484 #undef FUNC_NAME
 485
 486 #endif
 487
 488 \f
 489 /* Information about the build environment.  */
 490
 491 /* Initialize the scheme variable %guile-build-info, based on data
 492    provided by the Makefile, via libpath.h.  */
 493 static void
 494 init_build_info ()
 495 {
 496   static struct { char *name; char *value; } info[] = SCM_BUILD_INFO;
 497   SCM *loc = SCM_CDRLOC (scm_sysintern ("%guile-build-info", SCM_EOL));
 498   unsigned int i;
 499
 500   for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
 501     *loc = scm_acons (scm_str2symbol (info[i].name),
 502                       scm_makfrom0str (info[i].value),
 503                       *loc);
 504 }
 505
 506
 507 \f
 508 void
 509 scm_init_load ()
 510 {
 511   scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr));
 512   scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL));
 513   scm_loc_load_extensions
 514     = SCM_CDRLOC (scm_sysintern ("%load-extensions",
 515                                  scm_listify (scm_makfrom0str (".scm"),
 516                                               scm_makfrom0str (""),
 517                                               SCM_UNDEFINED)));
 518   scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F));
 519
 520   init_build_info ();
 521
 522 #ifndef SCM_MAGIC_SNARFER
 523 #include "libguile/load.x"
 524 #endif
 525 }
 526
 527 /*
 528   Local Variables:
 529   c-file-style: "gnu"
 530   End:
 531 */