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