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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  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, 2, 0, scm_primitive_load);
  72 SCM
  73 scm_primitive_load (filename, case_insensitive_p, sharp)
  74      SCM filename;
  75      SCM case_insensitive_p;
  76      SCM sharp;
  77 {
  78   SCM hook = *scm_loc_load_hook;
  79   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
  80               SCM_ARG1, s_primitive_load);
  81   SCM_ASSERT (hook == SCM_BOOL_F
  82               || (scm_procedure_p (hook) == SCM_BOOL_T),
  83               hook, "value of %load-hook is neither a procedure nor #f",
  84               s_primitive_load);
  85
  86   if (hook != SCM_BOOL_F)
  87     scm_apply (hook, scm_listify (filename, SCM_UNDEFINED), SCM_EOL);
  88
  89   {
  90     SCM form, port;
  91     port = scm_open_file (filename,
  92                           scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
  93     while (1)
  94       {
  95         form = scm_read (port, case_insensitive_p, sharp);
  96         if (SCM_EOF_VAL == form)
  97           break;
  98         scm_eval_x (form);
  99       }
 100     scm_close_port (port);
 101   }
 102   return SCM_UNSPECIFIED;
 103 }
 104
 105 \f
 106 /* Builtin path to scheme library files. */
 107 #ifdef SCM_PKGDATA_DIR
 108 SCM_PROC (s_sys_package_data_dir, "%package-data-dir", 0, 0, 0, scm_sys_package_data_dir);
 109 SCM
 110 scm_sys_package_data_dir ()
 111 {
 112   return scm_makfrom0str (SCM_PKGDATA_DIR);
 113 }
 114 #endif /* SCM_PKGDATA_DIR */
 115
 116 \f
 117 /* Initializing the load path, and searching it.  */
 118
 119 /* List of names of directories we search for files to load.  */
 120 static SCM *scm_loc_load_path;
 121
 122 /* List of extensions we try adding to the filenames.  */
 123 static SCM *scm_loc_load_extensions;
 124
 125 /* Initialize the global variable %load-path, given the value of the
 126    SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
 127    SCHEME_LOAD_PATH environment variable.  */
 128 void
 129 scm_init_load_path ()
 130 {
 131   SCM path = SCM_EOL;
 132
 133 #ifdef SCM_LIBRARY_DIR
 134   path = scm_cons2 (scm_makfrom0str (SCM_SITE_DIR),
 135                     scm_makfrom0str (SCM_LIBRARY_DIR),
 136                     path);
 137 #endif /* SCM_LIBRARY_DIR */
 138
 139   {
 140     char *path_string = getenv ("SCHEME_LOAD_PATH");
 141
 142     if (path_string && path_string[0] != '\0')
 143       {
 144         char *scan, *elt_end;
 145
 146         /* Scan backwards from the end of the string, to help
 147            construct the list in the right order.  */
 148         scan = elt_end = path_string + strlen (path_string);
 149         do {
 150           /* Scan back to the beginning of the current element.  */
 151           do scan--;
 152           while (scan >= path_string && *scan != ':');
 153           path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
 154                            path);
 155           elt_end = scan;
 156         } while (scan >= path_string);
 157       }
 158   }
 159
 160   *scm_loc_load_path = path;
 161 }
 162
 163
 164 /* Search %load-path for a directory containing a file named FILENAME.
 165    The file must be readable, and not a directory.
 166    If we find one, return its full filename; otherwise, return #f.
 167    If FILENAME is absolute, return it unchanged.  */
 168 SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
 169 SCM
 170 scm_sys_search_load_path (filename)
 171      SCM filename;
 172 {
 173   SCM path = *scm_loc_load_path;
 174   SCM exts = *scm_loc_load_extensions;
 175   char *buf;
 176   int filename_len;
 177   int max_path_len;
 178   int max_ext_len;
 179
 180   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 181               SCM_ARG1, s_sys_search_load_path);
 182   SCM_ASSERT (scm_ilength (path) >= 0, path, "load path is not a proper list",
 183               s_sys_search_load_path);
 184   SCM_ASSERT (scm_ilength (exts) >= 0, exts,
 185               "load extension list is not a proper list",
 186               s_sys_search_load_path);
 187   filename_len = SCM_ROLENGTH (filename);
 188
 189   /* If FILENAME is absolute, return it unchanged.  */
 190   if (filename_len >= 1
 191       && SCM_ROCHARS (filename)[0] == '/')
 192     return filename;
 193
 194   /* Find the length of the longest element of path.  */
 195   {
 196     SCM walk;
 197
 198     max_path_len = 0;
 199     for (walk = path; SCM_NIMP (walk); walk = SCM_CDR (walk))
 200       {
 201         SCM elt = SCM_CAR (walk);
 202         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 203                     "load path is not a list of strings",
 204                     s_sys_search_load_path);
 205         if (SCM_LENGTH (elt) > max_path_len)
 206           max_path_len = SCM_LENGTH (elt);
 207       }
 208   }
 209
 210   /* Find the length of the longest element of the load extensions
 211      list.  */
 212   {
 213     SCM walk;
 214
 215     max_ext_len = 0;
 216     for (walk = exts; SCM_NIMP (walk); walk = SCM_CDR (walk))
 217       {
 218         SCM elt = SCM_CAR (walk);
 219         SCM_ASSERT (SCM_NIMP (elt) && SCM_ROSTRINGP (elt), elt,
 220                     "load extension list is not a list of strings",
 221                     s_sys_search_load_path);
 222         if (SCM_LENGTH (elt) > max_ext_len)
 223           max_ext_len = SCM_LENGTH (elt);
 224       }
 225   }
 226
 227   SCM_DEFER_INTS;
 228
 229   buf = scm_must_malloc (max_path_len + 1 + filename_len + max_ext_len + 1,
 230                          s_sys_search_load_path);
 231
 232   /* Try every path element.  At this point, we know it's a proper
 233      list of strings.  */
 234   for (; SCM_NIMP (path); path = SCM_CDR (path))
 235     {
 236       SCM path_elt = SCM_CAR (path);
 237
 238       /* Try every extension.  At this point, we know it's a proper
 239          list of strings.  */
 240       for (exts = *scm_loc_load_extensions;
 241            SCM_NIMP (exts);
 242            exts = SCM_CDR (exts))
 243         {
 244           SCM ext_elt = SCM_CAR (exts);
 245           int i;
 246
 247           /* Concatenate the path name, the filename, and the extension. */
 248           i = SCM_ROLENGTH (path_elt);
 249           memcpy (buf, SCM_ROCHARS (path_elt), i);
 250           if (i >= 1 && buf[i - 1] != '/')
 251             buf[i++] = '/';
 252           memcpy (buf + i, SCM_ROCHARS (filename), filename_len);
 253           i += filename_len;
 254           memcpy (buf + i, SCM_ROCHARS (ext_elt), SCM_LENGTH (ext_elt));
 255           i += SCM_LENGTH (ext_elt);
 256           buf[i] = '\0';
 257
 258           {
 259             struct stat mode;
 260
 261             if (stat (buf, &mode) >= 0
 262                 && ! (mode.st_mode & S_IFDIR)
 263                 && access (buf, R_OK) == 0)
 264               {
 265                 SCM result = scm_makfromstr (buf, i, 0);
 266                 scm_must_free (buf);
 267                 SCM_ALLOW_INTS;
 268                 return result;
 269               }
 270           }
 271         }
 272     }
 273
 274   scm_must_free (buf);
 275   SCM_ALLOW_INTS;
 276   return SCM_BOOL_F;
 277 }
 278
 279
 280 SCM_PROC(s_primitive_load_path, "primitive-load-path", 1, 2, 0, scm_primitive_load_path);
 281 SCM
 282 scm_primitive_load_path (filename, case_insensitive_p, sharp)
 283      SCM filename;
 284      SCM case_insensitive_p;
 285      SCM sharp;
 286 {
 287   SCM full_filename;
 288
 289   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 290               SCM_ARG1, s_primitive_load_path);
 291
 292   full_filename = scm_sys_search_load_path (filename);
 293
 294   if (SCM_FALSEP (full_filename))
 295     {
 296       int absolute = (SCM_LENGTH (filename) >= 1
 297                       && SCM_ROCHARS (filename)[0] == '/');
 298       scm_misc_error (s_primitive_load_path,
 299                       (absolute
 300                        ? "Unable to load file %S"
 301                        : "Unable to find file %S in load path"),
 302                       scm_listify (filename, SCM_UNDEFINED));
 303     }
 304
 305   return scm_primitive_load (full_filename, case_insensitive_p, sharp);
 306 }
 307
 308 /* The following function seems trivial - and indeed it is.  Its
 309  * existence is motivated by its ability to evaluate expressions
 310  * without copying them first (as is done in "eval").
 311  */
 312
 313 SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
 314
 315 SCM_PROC (s_read_and_eval_x, "read-and-eval!", 0, 3, 0, scm_read_and_eval_x);
 316
 317 SCM
 318 scm_read_and_eval_x (port, case_insensitive_p, sharp)
 319      SCM port;
 320      SCM case_insensitive_p;
 321      SCM sharp;
 322 {
 323   SCM form = scm_read (port, case_insensitive_p, sharp);
 324   if (form == SCM_EOF_VAL)
 325     scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
 326   return scm_eval_x (form);
 327 }
 328
 329 \f
 330
 331 void
 332 scm_init_load ()
 333 {
 334   scm_loc_load_path = SCM_CDRLOC(scm_sysintern("%load-path", SCM_EOL));
 335   scm_loc_load_extensions
 336     = SCM_CDRLOC(scm_sysintern("%load-extensions",
 337                                scm_listify (scm_makfrom0str (""),
 338                                             scm_makfrom0str (".scm"),
 339                                             SCM_UNDEFINED)));
 340   scm_loc_load_hook = SCM_CDRLOC(scm_sysintern("%load-hook", SCM_BOOL_F));
 341
 342 #include "load.x"
 343 }