libguile/load.c

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