libguile/load.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001 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
  43 \f
  44
  45 #if HAVE_CONFIG_H
  46 #  include <config.h>
  47 #endif
  48
  49 #include <string.h>
  50
  51 #include "libguile/_scm.h"
  52 #include "libguile/libpath.h"
  53 #include "libguile/fports.h"
  54 #include "libguile/read.h"
  55 #include "libguile/eval.h"
  56 #include "libguile/throw.h"
  57 #include "libguile/alist.h"
  58 #include "libguile/dynwind.h"
  59 #include "libguile/root.h"
  60 #include "libguile/strings.h"
  61 #include "libguile/modules.h"
  62 #include "libguile/lang.h"
  63
  64 #include "libguile/validate.h"
  65 #include "libguile/load.h"
  66
  67 #include <sys/types.h>
  68 #include <sys/stat.h>
  69
  70 #ifdef HAVE_UNISTD_H
  71 #include <unistd.h>
  72 #endif /* HAVE_UNISTD_H */
  73
  74 #ifndef R_OK
  75 #define R_OK 4
  76 #endif
  77
  78 \f
  79 /* Loading a file, given an absolute filename.  */
  80
  81 /* Hook to run when we load a file, perhaps to announce the fact somewhere.
  82    Applied to the full name of the file.  */
  83 static SCM *scm_loc_load_hook;
  84
  85 static void
  86 swap_port (void *data)
  87 {
  88   SCM *save_port = data, tmp = scm_cur_loadp;
  89   scm_cur_loadp = *save_port;
  90   *save_port = tmp;
  91 }
  92
  93 static SCM
  94 load (void *data)
  95 {
  96   SCM port = SCM_PACK (data);
  97   while (1)
  98     {
  99       SCM form = scm_read (port);
 100       if (SCM_EOF_OBJECT_P (form))
 101         break;
 102       scm_primitive_eval_x (form);
 103     }
 104   return SCM_UNSPECIFIED;
 105 }
 106
 107 SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
 108            (SCM filename),
 109             "Load the file named @var{filename} and evaluate its contents in\n"
 110             "the top-level environment. The load paths are not searched;\n"
 111             "@var{filename} must either be a full pathname or be a pathname\n"
 112             "relative to the current directory.  If the  variable\n"
 113             "@code{%load-hook} is defined, it should be bound to a procedure\n"
 114             "that will be called before any code is loaded.  See the\n"
 115             "documentation for @code{%load-hook} later in this section.")
 116 #define FUNC_NAME s_scm_primitive_load
 117 {
 118   SCM hook = *scm_loc_load_hook;
 119   SCM_VALIDATE_STRING (1, filename);
 120   if (!SCM_FALSEP (hook) && !SCM_EQ_P (scm_procedure_p (hook), SCM_BOOL_T))
 121     SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
 122                     SCM_EOL);
 123
 124   if (! SCM_FALSEP (hook))
 125     scm_call_1 (hook, filename);
 126
 127   { /* scope */
 128     SCM port, save_port;
 129     port = scm_open_file (filename, scm_mem2string ("r", sizeof (char)));
 130     save_port = port;
 131     scm_internal_dynamic_wind (swap_port,
 132                                load,
 133                                swap_port,
 134                                (void *) SCM_UNPACK (port),
 135                                &save_port);
 136     scm_close_port (port);
 137   }
 138   return SCM_UNSPECIFIED;
 139 }
 140 #undef FUNC_NAME
 141
 142 SCM
 143 scm_c_primitive_load (const char *filename)
 144 {
 145   return scm_primitive_load (scm_makfrom0str (filename));
 146 }
 147
 148 \f
 149 /* Builtin path to scheme library files. */
 150 #ifdef SCM_PKGDATA_DIR
 151 SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0,
 152             (),
 153             "Return the name of the directory where Scheme packages, modules and\n"
 154             "libraries are kept.  On most Unix systems, this will be\n"
 155             "@samp{/usr/local/share/guile}.")
 156 #define FUNC_NAME s_scm_sys_package_data_dir
 157 {
 158   return scm_makfrom0str (SCM_PKGDATA_DIR);
 159 }
 160 #undef FUNC_NAME
 161 #endif /* SCM_PKGDATA_DIR */
 162
 163 #ifdef SCM_LIBRARY_DIR
 164 SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0,
 165             (),
 166             "Return the directory where the Guile Scheme library files are installed.\n"
 167             "E.g., may return \"/usr/share/guile/1.3.5\".")
 168 #define FUNC_NAME s_scm_sys_library_dir
 169 {
 170   return scm_makfrom0str(SCM_LIBRARY_DIR);
 171 }
 172 #undef FUNC_NAME
 173 #endif /* SCM_LIBRARY_DIR */
 174
 175 #ifdef SCM_SITE_DIR
 176 SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
 177             (),
 178             "Return the directory where the Guile site files are installed.\n"
 179             "E.g., may return \"/usr/share/guile/site\".")
 180 #define FUNC_NAME s_scm_sys_site_dir
 181 {
 182   return scm_makfrom0str(SCM_SITE_DIR);
 183 }
 184 #undef FUNC_NAME
 185 #endif /* SCM_SITE_DIR */
 186
 187
 188
 189 \f
 190 /* Initializing the load path, and searching it.  */
 191
 192 /* List of names of directories we search for files to load.  */
 193 static SCM *scm_loc_load_path;
 194
 195 /* List of extensions we try adding to the filenames.  */
 196 static SCM *scm_loc_load_extensions;
 197
 198
 199 /* Parse the null-terminated string PATH as if it were a standard path
 200    environment variable (i.e. a colon-separated list of strings), and
 201    prepend the elements to TAIL.  */
 202 SCM
 203 scm_internal_parse_path (char *path, SCM tail)
 204 {
 205   if (path && path[0] != '\0')
 206     {
 207       char *scan, *elt_end;
 208
 209       /* Scan backwards from the end of the string, to help
 210          construct the list in the right order.  */
 211       scan = elt_end = path + strlen (path);
 212       do {
 213         /* Scan back to the beginning of the current element.  */
 214         do scan--;
 215         while (scan >= path && *scan != ':');
 216         tail = scm_cons (scm_mem2string (scan + 1, elt_end - (scan + 1)),
 217                          tail);
 218         elt_end = scan;
 219       } while (scan >= path);
 220     }
 221
 222   return tail;
 223 }
 224
 225
 226 SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
 227             (SCM path, SCM tail),
 228             "Parse @var{path}, which is expected to be a colon-separated\n"
 229             "string, into a list and return the resulting list with\n"
 230             "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n"
 231             "is returned.")
 232 #define FUNC_NAME s_scm_parse_path
 233 {
 234   SCM_ASSERT (SCM_FALSEP (path) || (SCM_STRINGP (path)),
 235               path,
 236               SCM_ARG1, FUNC_NAME);
 237   if (SCM_UNBNDP (tail))
 238     tail = SCM_EOL;
 239   return (SCM_FALSEP (path)
 240           ? tail
 241           : scm_internal_parse_path (SCM_STRING_CHARS (path), tail));
 242 }
 243 #undef FUNC_NAME
 244
 245
 246 /* Initialize the global variable %load-path, given the value of the
 247    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
 248    GUILE_LOAD_PATH environment variable.  */
 249 void
 250 scm_init_load_path ()
 251 {
 252   SCM path = SCM_EOL;
 253
 254 #ifdef SCM_LIBRARY_DIR
 255   path = scm_list_3 (scm_makfrom0str (SCM_SITE_DIR),
 256                      scm_makfrom0str (SCM_LIBRARY_DIR),
 257                      scm_makfrom0str (SCM_PKGDATA_DIR));
 258 #endif /* SCM_LIBRARY_DIR */
 259
 260   path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path);
 261
 262   *scm_loc_load_path = path;
 263 }
 264
 265 SCM scm_listofnullstr;
 266
 267 /* Search PATH for a directory containing a file named FILENAME.
 268    The file must be readable, and not a directory.
 269    If we find one, return its full filename; otherwise, return #f.
 270    If FILENAME is absolute, return it unchanged.
 271    If given, EXTENSIONS is a list of strings; for each directory
 272    in PATH, we search for FILENAME concatenated with each EXTENSION.  */
 273 SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
 274            (SCM path, SCM filename, SCM extensions),
 275             "Search @var{path} for a directory containing a file named\n"
 276             "@var{filename}. The file must be readable, and not a directory.\n"
 277             "If we find one, return its full filename; otherwise, return\n"
 278             "@code{#f}.  If @var{filename} is absolute, return it unchanged.\n"
 279             "If given, @var{extensions} is a list of strings; for each\n"
 280             "directory in @var{path}, we search for @var{filename}\n"
 281             "concatenated with each @var{extension}.")
 282 #define FUNC_NAME s_scm_search_path
 283 {
 284   char *filename_chars;
 285   int filename_len;
 286   size_t max_path_len;          /* maximum length of any PATH element */
 287   size_t max_ext_len;           /* maximum length of any EXTENSIONS element */
 288
 289   SCM_VALIDATE_LIST (1, path);
 290   SCM_VALIDATE_STRING (2, filename);
 291   if (SCM_UNBNDP (extensions))
 292     extensions = SCM_EOL;
 293   else
 294     SCM_VALIDATE_LIST (3, extensions);
 295
 296   filename_chars = SCM_STRING_CHARS (filename);
 297   filename_len = SCM_STRING_LENGTH (filename);
 298
 299   /* If FILENAME is absolute, return it unchanged.  */
 300   if (filename_len >= 1 && filename_chars[0] == '/')
 301     return filename;
 302
 303   /* Find the length of the longest element of path.  */
 304   {
 305     SCM walk;
 306
 307     max_path_len = 0;
 308     for (walk = path; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk))
 309       {
 310         SCM elt = SCM_CAR (walk);
 311         SCM_ASSERT_TYPE (SCM_STRINGP (elt), path, 1, FUNC_NAME,
 312                          "list of strings");
 313         if (SCM_STRING_LENGTH (elt) > max_path_len)
 314           max_path_len = SCM_STRING_LENGTH (elt);
 315       }
 316   }
 317
 318   /* If FILENAME has an extension, don't try to add EXTENSIONS to it.  */
 319   {
 320     char *endp;
 321
 322     for (endp = filename_chars + filename_len - 1;
 323          endp >= filename_chars;
 324          endp--)
 325       {
 326         if (*endp == '.')
 327           {
 328             /* This filename already has an extension, so cancel the
 329                list of extensions.  */
 330             extensions = SCM_EOL;
 331             break;
 332           }
 333         else if (*endp == '/')
 334           /* This filename has no extension, so keep the current list
 335              of extensions.  */
 336           break;
 337       }
 338   }
 339
 340   /* Find the length of the longest element of the load extensions
 341      list.  */
 342   { /* scope */
 343     SCM walk;
 344
 345     max_ext_len = 0;
 346     for (walk = extensions; !SCM_NULL_OR_NIL_P (walk); walk = SCM_CDR (walk))
 347       {
 348         SCM elt = SCM_CAR (walk);
 349         SCM_ASSERT_TYPE (SCM_STRINGP (elt), elt, 3, FUNC_NAME,
 350                          "list of strings");
 351         if (SCM_STRING_LENGTH (elt) > max_ext_len)
 352           max_ext_len = SCM_STRING_LENGTH (elt);
 353       }
 354   }
 355
 356   SCM_DEFER_INTS;
 357
 358   { /* scope */
 359     SCM result = SCM_BOOL_F;
 360     size_t buf_size = max_path_len + 1 + filename_len + max_ext_len + 1;
 361     char *buf = scm_malloc (buf_size);
 362
 363     /* This simplifies the loop below a bit.  */
 364     if (SCM_NULL_OR_NIL_P (extensions))
 365       extensions = scm_listofnullstr;
 366
 367     /* Try every path element.  At this point, we know the path is a
 368        proper list of strings.  */
 369     for (; !SCM_NULL_OR_NIL_P (path); path = SCM_CDR (path))
 370       {
 371         size_t len;
 372         SCM dir = SCM_CAR (path);
 373         SCM exts;
 374
 375         /* Concatenate the path name and the filename. */
 376         len = SCM_STRING_LENGTH (dir);
 377         memcpy (buf, SCM_STRING_CHARS (dir), len);
 378         if (len >= 1 && buf[len - 1] != '/')
 379           buf[len++] = '/';
 380         memcpy (buf + len, filename_chars, filename_len);
 381         len += filename_len;
 382
 383         /* Try every extension.  At this point, we know the extension
 384            list is a proper, nonempty list of strings.  */
 385         for (exts = extensions; !SCM_NULL_OR_NIL_P (exts); exts = SCM_CDR (exts))
 386           {
 387             SCM ext = SCM_CAR (exts);
 388             size_t ext_len = SCM_STRING_LENGTH (ext);
 389             struct stat mode;
 390
 391             /* Concatenate the extension. */
 392             memcpy (buf + len, SCM_STRING_CHARS (ext), ext_len);
 393             buf[len + ext_len] = '\0';
 394
 395             /* If the file exists at all, we should return it.  If the
 396                file is inaccessible, then that's an error.  */
 397             if (stat (buf, &mode) == 0
 398                 && ! (mode.st_mode & S_IFDIR))
 399               {
 400                 result = scm_mem2string (buf, len + ext_len);
 401                 goto end;
 402               }
 403           }
 404       }
 405
 406   end:
 407     free (buf);
 408     SCM_ALLOW_INTS;
 409     return result;
 410   }
 411 }
 412 #undef FUNC_NAME
 413
 414
 415 /* Search %load-path for a directory containing a file named FILENAME.
 416    The file must be readable, and not a directory.
 417    If we find one, return its full filename; otherwise, return #f.
 418    If FILENAME is absolute, return it unchanged.  */
 419 SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
 420             (SCM filename),
 421             "Search @var{%load-path} for the file named @var{filename},\n"
 422             "which must be readable by the current user.  If @var{filename}\n"
 423             "is found in the list of paths to search or is an absolute\n"
 424             "pathname, return its full pathname.  Otherwise, return\n"
 425             "@code{#f}.  Filenames may have any of the optional extensions\n"
 426             "in the @code{%load-extensions} list; @code{%search-load-path}\n"
 427             "will try each extension automatically.")
 428 #define FUNC_NAME s_scm_sys_search_load_path
 429 {
 430   SCM path = *scm_loc_load_path;
 431   SCM exts = *scm_loc_load_extensions;
 432   SCM_VALIDATE_STRING (1, filename);
 433
 434   if (scm_ilength (path) < 0)
 435     SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
 436   if (scm_ilength (exts) < 0)
 437     SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
 438   return scm_search_path (path, filename, exts);
 439 }
 440 #undef FUNC_NAME
 441
 442
 443 SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
 444             (SCM filename),
 445             "Search @var{%load-path} for the file named @var{filename} and\n"
 446             "load it into the top-level environment.  If @var{filename} is a\n"
 447             "relative pathname and is not found in the list of search paths,\n"
 448             "an error is signalled.")
 449 #define FUNC_NAME s_scm_primitive_load_path
 450 {
 451   SCM full_filename;
 452
 453   SCM_VALIDATE_STRING (1, filename);
 454
 455   full_filename = scm_sys_search_load_path (filename);
 456
 457   if (SCM_FALSEP (full_filename))
 458     {
 459       int absolute = (SCM_STRING_LENGTH (filename) >= 1
 460                       && SCM_STRING_CHARS (filename)[0] == '/');
 461       SCM_MISC_ERROR ((absolute
 462                        ? "Unable to load file ~S"
 463                        : "Unable to find file ~S in load path"),
 464                       scm_list_1 (filename));
 465     }
 466
 467   return scm_primitive_load (full_filename);
 468 }
 469 #undef FUNC_NAME
 470
 471 SCM
 472 scm_c_primitive_load_path (const char *filename)
 473 {
 474   return scm_primitive_load_path (scm_makfrom0str (filename));
 475 }
 476
 477 \f
 478 /* Information about the build environment.  */
 479
 480 /* Initialize the scheme variable %guile-build-info, based on data
 481    provided by the Makefile, via libpath.h.  */
 482 static void
 483 init_build_info ()
 484 {
 485   static struct { char *name; char *value; } info[] = SCM_BUILD_INFO;
 486   SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL));
 487   unsigned long i;
 488
 489   for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
 490     *loc = scm_acons (scm_str2symbol (info[i].name),
 491                       scm_makfrom0str (info[i].value),
 492                       *loc);
 493 }
 494
 495
 496 \f
 497 void
 498 scm_init_load ()
 499 {
 500   scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr));
 501   scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL));
 502   scm_loc_load_extensions
 503     = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
 504                                     scm_list_2 (scm_makfrom0str (".scm"),
 505                                                 scm_nullstr)));
 506   scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
 507
 508   init_build_info ();
 509
 510 #include "libguile/load.x"
 511 }
 512
 513 /*
 514   Local Variables:
 515   c-file-style: "gnu"
 516   End:
 517 */