libguile/load.c

   1 /*      Copyright (C) 1995,1996 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 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45 #include "libpath.h"
  46 #include "fports.h"
  47 #include "read.h"
  48 #include "eval.h"
  49 #include "throw.h"
  50 #include "alist.h"
  51 #include "dynwind.h"
  52
  53 #include "load.h"
  54
  55 #include <sys/types.h>
  56 #include <sys/stat.h>
  57
  58 #ifdef HAVE_UNISTD_H
  59 #include <unistd.h>
  60 #endif /* HAVE_UNISTD_H */
  61
  62 #ifndef R_OK
  63 #define R_OK 4
  64 #endif
  65
  66 \f
  67 /* Loading a file, given an absolute filename.  */
  68
  69 /* Hook to run when we load a file, perhaps to announce the fact somewhere.
  70    Applied to the full name of the file.  */
  71 static SCM *scm_loc_load_hook;
  72
  73 static void
  74 swap_port (void *data)
  75 {
  76   SCM *save_port = data, tmp = scm_cur_loadp;
  77   scm_cur_loadp = *save_port;
  78   *save_port = tmp;
  79 }
  80
  81 static SCM
  82 load (void *data)
  83 {
  84   SCM port = (SCM) data, form;
  85   while (1)
  86     {
  87       form = scm_read (port);
  88       if (SCM_EOF_OBJECT_P (form))
  89         break;
  90       scm_eval_x (form);
  91     }
  92   return SCM_UNSPECIFIED;
  93 }
  94
  95 SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load);
  96 SCM
  97 scm_primitive_load (filename)
  98      SCM filename;
  99 {
 100   SCM hook = *scm_loc_load_hook;
 101   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 102               SCM_ARG1, s_primitive_load);
 103   SCM_ASSERT (hook == SCM_BOOL_F
 104               || (scm_procedure_p (hook) == SCM_BOOL_T),
 105               hook, "value of %load-hook is neither a procedure nor #f",
 106               s_primitive_load);
 107
 108   if (hook != SCM_BOOL_F)
 109     scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
 110
 111   {
 112     SCM port, save_port;
 113     port = scm_open_file (filename,
 114                           scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
 115     save_port = port;
 116     scm_internal_dynamic_wind (swap_port,
 117                                load,
 118                                swap_port,
 119                                (void *) port,
 120                                &save_port);
 121     scm_close_port (port);
 122   }
 123   return SCM_UNSPECIFIED;
 124 }
 125
 126 \f
 127 /* Builtin path to scheme library files. */
 128 #ifdef SCM_PKGDATA_DIR
 129 SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
 130 SCM
 131 scm_sys_package_data_dir ()
 132 {
 133   return scm_makfrom0str (SCM_PKGDATA_DIR);
 134 }
 135 #endif /* SCM_PKGDATA_DIR */
 136
 137 \f
 138 /* Initializing the load path, and searching it.  */
 139
 140 /* List of names of directories we search for files to load.  */
 141 static SCM *scm_loc_load_path;
 142
 143 /* List of extensions we try adding to the filenames.  */
 144 static SCM *scm_loc_load_extensions;
 145
 146
 147 /* Parse the null-terminated string PATH as if it were a standard path
 148    environment variable (i.e. a colon-separated list of strings), and
 149    prepend the elements to TAIL.  */
 150 SCM
 151 scm_internal_parse_path (char *path, SCM tail)
 152 {
 153   if (path && path[0] != '\0')
 154     {
 155       char *scan, *elt_end;
 156
 157       /* Scan backwards from the end of the string, to help
 158          construct the list in the right order.  */
 159       scan = elt_end = path + strlen (path);
 160       do {
 161         /* Scan back to the beginning of the current element.  */
 162         do scan--;
 163         while (scan >= path && *scan != ':');
 164         tail = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
 165                          tail);
 166         elt_end = scan;
 167       } while (scan >= path);
 168     }
 169
 170   return tail;
 171 }
 172
 173
 174 SCM_PROC (s_parse_path, "parse-path", 1, 1, 0, scm_parse_path);
 175
 176 SCM
 177 scm_parse_path (SCM path, SCM tail)
 178 {
 179   SCM_ASSERT (SCM_FALSEP (path) || (SCM_NIMP (path) && SCM_ROSTRINGP (path)),
 180               path,
 181               SCM_ARG1,
 182               s_parse_path);
 183   if (SCM_UNBNDP (tail))
 184     tail = SCM_EOL;
 185   return (SCM_FALSEP (path)
 186           ? tail
 187           : scm_internal_parse_path (SCM_ROCHARS (path), tail));
 188 }
 189
 190
 191 /* Initialize the global variable %load-path, given the value of the
 192    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
 193    GUILE_LOAD_PATH environment variable.  */
 194 void
 195 scm_init_load_path ()
 196 {
 197   SCM path = SCM_EOL;
 198
 199 #ifdef SCM_LIBRARY_DIR
 200   path = scm_listify (scm_makfrom0str (SCM_SITE_DIR),
 201                       scm_makfrom0str (SCM_LIBRARY_DIR),
 202                       scm_makfrom0str (SCM_PKGDATA_DIR),
 203                       SCM_UNDEFINED);
 204 #endif /* SCM_LIBRARY_DIR */
 205
 206   /* For compatibility, we still check this, but give a warning.  */
 207   {
 208     char *p = getenv ("SCHEME_LOAD_PATH");
 209     if (p && p[0] != '\0')
 210       {
 211         fprintf (stderr, "guile: warning: SCHEME_LOAD_PATH variable will be"
 212                  " removed by Guile 1.4;\n"
 213                  "                use GUILE_LOAD_PATH instead\n");
 214         path = scm_internal_parse_path (p, path);
 215       }
 216   }
 217
 218   path = scm_internal_parse_path (getenv ("GUILE_LOAD_PATH"), path);
 219
 220   *scm_loc_load_path = path;
 221 }
 222
 223 SCM scm_listofnullstr;
 224
 225 /* Search PATH for a directory containing a file named FILENAME.
 226    The file must be readable, and not a directory.
 227    If we find one, return its full filename; otherwise, return #f.
 228    If FILENAME is absolute, return it unchanged.  */
 229 SCM_PROC(s_search_path, "search-path", 2, 1, 0, scm_search_path);
 230 SCM
 231 scm_search_path (path, filename, extensions)
 232      SCM path;
 233      SCM filename;
 234      SCM extensions;
 235 {
 236   char *buf;
 237   int filename_len;
 238   size_t max_path_len;
 239   size_t max_ext_len;
 240
 241   SCM_ASSERT (scm_ilength (path) >= 0, path, SCM_ARG1, s_search_path);
 242   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 243               SCM_ARG2, s_search_path);
 244   if (SCM_UNBNDP (extensions))
 245     extensions = scm_listofnullstr;
 246   else
 247     SCM_ASSERT (scm_ilength (extensions) >= 0, extensions,
 248                 SCM_ARG3, s_search_path);
 249   filename_len = SCM_ROLENGTH (filename);
 250
 251   /* If FILENAME is absolute, return it unchanged.  */
 252   if (filename_len >= 1
 253       && SCM_ROCHARS (filename)[0] == '/')
 254     return filename;
 255
 256   /* Find the length of the longest element of path.  */
 257   {
 258     SCM walk;
 259
 260     max_path_len = 0;
 261     for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk))
 262       {
 263         SCM elt = SCM_CAR (walk);
 264         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 265                     "path is not a list of strings",
 266                     s_search_path);
 267         if (SCM_LENGTH (elt) > max_path_len)
 268           max_path_len = SCM_LENGTH (elt);
 269       }
 270   }
 271
 272   /* Find the length of the longest element of the load extensions
 273      list.  */
 274   {
 275     SCM walk;
 276
 277     max_ext_len = 0;
 278     for (walk = extensions; SCM_NIMP (walk); walk = SCM_CDR (walk))
 279       {
 280         SCM elt = SCM_CAR (walk);
 281         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 282                     "extension list is not a list of strings",
 283                     s_search_path);
 284         if (SCM_LENGTH (elt) > max_ext_len)
 285           max_ext_len = SCM_LENGTH (elt);
 286       }
 287   }
 288
 289   SCM_DEFER_INTS;
 290
 291   buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1,
 292                          s_search_path);
 293
 294   /* Try every path element.  At this point, we know it's a proper
 295      list of strings.  */
 296   for (; SCM_NIMP (path); path = SCM_CDR (path))
 297     {
 298       SCM path_elt = SCM_CAR (path), exts;
 299
 300       /* Try every extension.  At this point, we know it's a proper
 301          list of strings.  */
 302       for (exts = extensions; SCM_NIMP (exts); exts = SCM_CDR (exts))
 303         {
 304           SCM ext_elt = SCM_CAR (exts);
 305           int i;
 306
 307           /* Concatenate the path name, the filename, and the extension. */
 308           i = SCM_ROLENGTH (path_elt);
 309           memcpy (buf, SCM_ROCHARS (path_elt), i);
 310           if (i >= 1 && buf[i - 1] != '/')
 311             buf[i++] = '/';
 312           memcpy (buf + i, SCM_ROCHARS (filename), filename_len);
 313           i += filename_len;
 314           memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt));
 315           i += SCM_LENGTH (ext_elt);
 316           buf[i] = '\0';
 317
 318           {
 319             struct stat mode;
 320
 321             if (stat (buf, &mode) >= 0
 322                 && ! (mode.st_mode & S_IFDIR)
 323                 && access (buf, R_OK) == 0)
 324               {
 325                 SCM result = scm_makfromstr (buf, i, 0);
 326                 scm_must_free (buf);
 327                 SCM_ALLOW_INTS;
 328                 return result;
 329               }
 330           }
 331         }
 332     }
 333
 334   scm_must_free (buf);
 335   SCM_ALLOW_INTS;
 336   return SCM_BOOL_F;
 337 }
 338
 339
 340 /* Search %load-path for a directory containing a file named FILENAME.
 341    The file must be readable, and not a directory.
 342    If we find one, return its full filename; otherwise, return #f.
 343    If FILENAME is absolute, return it unchanged.  */
 344 SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
 345 SCM
 346 scm_sys_search_load_path (filename)
 347      SCM filename;
 348 {
 349   SCM path = *scm_loc_load_path;
 350   SCM exts = *scm_loc_load_extensions;
 351   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 352               SCM_ARG1, s_sys_search_load_path);
 353   SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
 354               s_sys_search_load_path);
 355   SCM_ASSERT (scm_ilength (exts) >= 0, exts,
 356               "load extension list is not a proper list",
 357               s_sys_search_load_path);
 358   return scm_search_path (path,
 359                           filename,
 360                           exts);
 361 }
 362
 363
 364 SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path);
 365 SCM
 366 scm_primitive_load_path (filename)
 367      SCM filename;
 368 {
 369   SCM full_filename;
 370
 371   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 372               SCM_ARG1, s_primitive_load_path);
 373
 374   full_filename = scm_sys_search_load_path (filename);
 375
 376   if (SCM_FALSEP (full_filename))
 377     {
 378       int absolute = (SCM_LENGTH (filename) >= 1
 379                       && SCM_ROCHARS (filename)[0] == '/');
 380       scm_misc_error (s_primitive_load_path,
 381                       (absolute
 382                        ? "Unable to load file %S"
 383                        : "Unable to find file %S in load path"),
 384                       scm_listify (filename, SCM_UNDEFINED));
 385     }
 386
 387   return scm_primitive_load (full_filename);
 388 }
 389
 390 /* The following function seems trivial - and indeed it is.  Its
 391  * existence is motivated by its ability to evaluate expressions
 392  * without copying them first (as is done in "eval").
 393  */
 394
 395 SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
 396
 397 SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x);
 398
 399 SCM
 400 scm_read_and_eval_x (port)
 401      SCM port;
 402 {
 403   SCM form = scm_read (port);
 404   if (SCM_EOF_OBJECT_P (form))
 405     scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
 406   return scm_eval_x (form);
 407 }
 408
 409 \f
 410 /* Information about the build environment.  */
 411
 412 /* Initialize the scheme variable %guile-build-info, based on data
 413    provided by the Makefile, via libpath.h.  */
 414 static void
 415 init_build_info ()
 416 {
 417   static struct { char *name; char *value; } info[] = SCM_BUILD_INFO;
 418   SCM *loc = SCM_CDRLOC (scm_sysintern ("%guile-build-info", SCM_EOL));
 419   unsigned int i;
 420
 421   for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
 422     *loc = scm_acons (SCM_CAR (scm_intern0 (info[i].name)),
 423                       scm_makfrom0str (info[i].value),
 424                       *loc);
 425 }
 426
 427
 428 \f
 429 void
 430 scm_init_load ()
 431 {
 432   scm_listofnullstr = scm_permanent_object (SCM_LIST1 (scm_nullstr));
 433   scm_loc_load_path = SCM_CDRLOC (scm_sysintern ("%load-path", SCM_EOL));
 434   scm_loc_load_extensions
 435     = SCM_CDRLOC (scm_sysintern ("%load-extensions",
 436                                  scm_listify (scm_makfrom0str (""),
 437                                               scm_makfrom0str (".scm"),
 438                                               SCM_UNDEFINED)));
 439   scm_loc_load_hook = SCM_CDRLOC (scm_sysintern ("%load-hook", SCM_BOOL_F));
 440
 441   init_build_info ();
 442
 443 #include "load.x"
 444 }