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
  51 #include "load.h"
  52
  53 #include <sys/types.h>
  54 #include <sys/stat.h>
  55
  56 #ifdef HAVE_UNISTD_H
  57 #include <unistd.h>
  58 #endif /* HAVE_UNISTD_H */
  59
  60 #ifndef R_OK
  61 #define R_OK 4
  62 #endif
  63
  64 \f
  65 /* Loading a file, given an absolute filename.  */
  66
  67 /* Hook to run when we load a file, perhaps to announce the fact somewhere.
  68    Applied to the full name of the file.  */
  69 static SCM *scm_loc_load_hook;
  70
  71 SCM_PROC(s_primitive_load, "primitive-load", 1, 0, 0, scm_primitive_load);
  72 SCM
  73 scm_primitive_load (filename)
  74      SCM filename;
  75 {
  76   SCM hook = *scm_loc_load_hook;
  77   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
  78               SCM_ARG1, s_primitive_load);
  79   SCM_ASSERT (hook == SCM_BOOL_F
  80               || (scm_procedure_p (hook) == SCM_BOOL_T),
  81               hook, "value of %load-hook is neither a procedure nor #f",
  82               s_primitive_load);
  83
  84   if (hook != SCM_BOOL_F)
  85     scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
  86
  87   {
  88     SCM form, port;
  89     port = scm_open_file (filename,
  90                           scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
  91     while (1)
  92       {
  93         form = scm_read (port);
  94         if (SCM_EOF_VAL == form)
  95           break;
  96         scm_eval_x (form);
  97       }
  98     scm_close_port (port);
  99   }
 100   return SCM_UNSPECIFIED;
 101 }
 102
 103 \f
 104 /* Builtin path to scheme library files. */
 105 #ifdef SCM_PKGDATA_DIR
 106 SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
 107 SCM
 108 scm_sys_package_data_dir ()
 109 {
 110   return scm_makfrom0str (SCM_PKGDATA_DIR);
 111 }
 112 #endif /* SCM_PKGDATA_DIR */
 113
 114 \f
 115 /* Initializing the load path, and searching it.  */
 116
 117 /* List of names of directories we search for files to load.  */
 118 static SCM *scm_loc_load_path;
 119
 120 /* List of extensions we try adding to the filenames.  */
 121 static SCM *scm_loc_load_extensions;
 122
 123 /* Initialize the global variable %load-path, given the value of the
 124    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
 125    SCHEME_LOAD_PATH environment variable.  */
 126 void
 127 scm_init_load_path ()
 128 {
 129   SCM path = SCM_EOL;
 130
 131 #ifdef SCM_LIBRARY_DIR
 132   path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR),
 133                     scm_makfrom0str (SCM_LIBRARY_DIR),
 134                     path);
 135 #endif /* SCM_LIBRARY_DIR */
 136
 137   {
 138     char *path_string = getenv ("SCHEME_LOAD_PATH");
 139
 140     if (path_string && path_string[0] != '\0')
 141       {
 142         char *scan, *elt_end;
 143
 144         /* Scan backwards from the end of the string, to help
 145            construct the list in the right order.  */
 146         scan = elt_end = path_string + strlen (path_string);
 147         do {
 148           /* Scan back to the beginning of the current element.  */
 149           do scan--;
 150           while (scan >= path_string && *scan != ':');
 151           path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
 152                            path);
 153           elt_end = scan;
 154         } while (scan >= path_string);
 155       }
 156   }
 157
 158   *scm_loc_load_path = path;
 159 }
 160
 161
 162 /* Search %load-path for a directory containing a file named FILENAME.
 163    The file must be readable, and not a directory.
 164    If we find one, return its full filename; otherwise, return #f.
 165    If FILENAME is absolute, return it unchanged.  */
 166 SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
 167 SCM
 168 scm_sys_search_load_path (filename)
 169      SCM filename;
 170 {
 171   SCM path = *scm_loc_load_path;
 172   SCM exts = *scm_loc_load_extensions;
 173   char *buf;
 174   int filename_len;
 175   int max_path_len;
 176   int max_ext_len;
 177
 178   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 179               SCM_ARG1, s_sys_search_load_path);
 180   SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
 181               s_sys_search_load_path);
 182   SCM_ASSERT (scm_ilength (exts) >= 0, exts,
 183               "load extension list is not a proper list",
 184               s_sys_search_load_path);
 185   filename_len = SCM_ROLENGTH (filename);
 186
 187   /* If FILENAME is absolute, return it unchanged.  */
 188   if (filename_len >= 1
 189       && SCM_ROCHARS (filename)[0] == '/')
 190     return filename;
 191
 192   /* Find the length of the longest element of path.  */
 193   {
 194     SCM walk;
 195
 196     max_path_len = 0;
 197     for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk))
 198       {
 199         SCM elt = SCM_CAR (walk);
 200         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 201                     "load path is not a list of strings",
 202                     s_sys_search_load_path);
 203         if (SCM_LENGTH (elt) > max_path_len)
 204           max_path_len = SCM_LENGTH (elt);
 205       }
 206   }
 207
 208   /* Find the length of the longest element of the load extensions
 209      list.  */
 210   {
 211     SCM walk;
 212
 213     max_ext_len = 0;
 214     for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk))
 215       {
 216         SCM elt = SCM_CAR (walk);
 217         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 218                     "load extension list is not a list of strings",
 219                     s_sys_search_load_path);
 220         if (SCM_LENGTH (elt) > max_ext_len)
 221           max_ext_len = SCM_LENGTH (elt);
 222       }
 223   }
 224
 225   SCM_DEFER_INTS;
 226
 227   buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1,
 228                          s_sys_search_load_path);
 229
 230   /* Try every path element.  At this point, we know it's a proper
 231      list of strings.  */
 232   for (; SCM_NIMP (path); path = SCM_CDR (path))
 233     {
 234       SCM path_elt = SCM_CAR (path);
 235
 236       /* Try every extension.  At this point, we know it's a proper
 237          list of strings.  */
 238       for (exts = *scm_loc_load_extensions;
 239            SCM_NIMP (exts);
 240            exts = SCM_CDR (exts))
 241         {
 242           SCM ext_elt = SCM_CAR (exts);
 243           int i;
 244
 245           /* Concatenate the path name, the filename, and the extension. */
 246           i = SCM_ROLENGTH (path_elt);
 247           memcpy (buf, SCM_ROCHARS (path_elt), i);
 248           if (i >= 1 && buf[i - 1] != '/')
 249             buf[i++] = '/';
 250           memcpy (buf + i, SCM_ROCHARS (filename), filename_len);
 251           i += filename_len;
 252           memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt));
 253           i += SCM_LENGTH (ext_elt);
 254           buf[i] = '\0';
 255
 256           {
 257             struct stat mode;
 258
 259             if (stat (buf, &mode) >= 0
 260                 && ! (mode.st_mode & S_IFDIR)
 261                 && access (buf, R_OK) == 0)
 262               {
 263                 SCM result = scm_makfromstr (buf, i, 0);
 264                 scm_must_free (buf);
 265                 SCM_ALLOW_INTS;
 266                 return result;
 267               }
 268           }
 269         }
 270     }
 271
 272   scm_must_free (buf);
 273   SCM_ALLOW_INTS;
 274   return SCM_BOOL_F;
 275 }
 276
 277
 278 SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 0, 0, scm_primitive_load_path);
 279 SCM
 280 scm_primitive_load_path (filename)
 281      SCM filename;
 282 {
 283   SCM full_filename;
 284
 285   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 286               SCM_ARG1, s_primitive_load_path);
 287
 288   full_filename = scm_sys_search_load_path (filename);
 289
 290   if (SCM_FALSEP (full_filename))
 291     {
 292       int absolute = (SCM_LENGTH (filename) >= 1
 293                       && SCM_ROCHARS (filename)[0] == '/');
 294       scm_misc_error (s_primitive_load_path,
 295                       (absolute
 296                        ? "Unable to load file %S"
 297                        : "Unable to find file %S in load path"),
 298                       scm_listify (filename, SCM_UNDEFINED));
 299     }
 300
 301   return scm_primitive_load (full_filename);
 302 }
 303
 304 /* The following function seems trivial - and indeed it is.  Its
 305  * existence is motivated by its ability to evaluate expressions
 306  * without copying them first (as is done in "eval").
 307  */
 308
 309 SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
 310
 311 SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 1, 0, scm_read_and_eval_x);
 312
 313 SCM
 314 scm_read_and_eval_x (port)
 315      SCM port;
 316 {
 317   SCM form = scm_read (port);
 318   if (form == SCM_EOF_VAL)
 319     scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
 320   return scm_eval_x (form);
 321 }
 322
 323 \f
 324
 325 void
 326 scm_init_load ()
 327 {
 328   scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL));
 329   scm_loc_load_extensions
 330     = SCM_CDRLOC(scm_sysintern("%load-extensions",
 331                                scm_listify (scm_makfrom0str (""),
 332                                             scm_makfrom0str (".scm"),
 333                                             SCM_UNDEFINED)));
 334   scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F));
 335
 336 #include "load.x"
 337 }