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 SCM_PROC(s_sys_try_load, "primitive-load", 1, 2, 0, scm_sys_try_load);
  67 SCM
  68 scm_sys_try_load (filename, case_insensitive_p, sharp)
  69      SCM filename;
  70      SCM case_insensitive_p;
  71      SCM sharp;
  72 {
  73   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
  74               SCM_ARG1, s_sys_try_load);
  75   {
  76     SCM form, port;
  77     port = scm_open_file (filename,
  78                           scm_makfromstr ("r", (scm_sizet) sizeof (char), 0));
  79     while (1)
  80       {
  81         form = scm_read (port, case_insensitive_p, sharp);
  82         if (SCM_EOF_VAL == form)
  83           break;
  84         scm_eval_x (form);
  85       }
  86     scm_close_port (port);
  87   }
  88   return SCM_UNSPECIFIED;
  89 }
  90
  91 \f
  92 /* Initializing the load path, and searching it.  */
  93
  94 static SCM *scm_loc_load_path;
  95
  96 /* Initialize the global variable %load-path, given the value of the
  97    LIBRARY_PATH preprocessor symbol and the SCHEME_LOAD_PATH
  98    environment variable.  */
  99 void
 100 scm_init_load_path ()
 101 {
 102   SCM path = SCM_EOL;
 103
 104 #ifdef LIBRARY_PATH
 105   path = scm_cons (scm_makfrom0str (LIBRARY_PATH), path);
 106 #endif /* LIBRARY_PATH */
 107
 108   {
 109     char *path_string = getenv ("SCHEME_LOAD_PATH");
 110
 111     if (path_string && path_string[0] != '\0')
 112       {
 113         char *scan, *elt_end;
 114
 115         /* Scan backwards from the end of the string, to help
 116            construct the list in the right order.  */
 117         scan = elt_end = path_string + strlen (path_string);
 118         do {
 119           /* Scan back to the beginning of the current element.  */
 120           do scan--;
 121           while (scan >= path_string && *scan != ':');
 122           path = scm_cons (scm_makfromstr (scan + 1, elt_end - (scan + 1), 0),
 123                            path);
 124           elt_end = scan;
 125         } while (scan >= path_string);
 126       }
 127   }
 128
 129   *scm_loc_load_path = path;
 130 }
 131
 132
 133 /* Search %load-path for a directory containing a file named FILENAME.
 134    The file must be readable, and not a directory.
 135    If we find one, return its full filename; otherwise, return #f.  */
 136 SCM_PROC(s_sys_search_load_path, "%search-load-path", 1, 0, 0, scm_sys_search_load_path);
 137 SCM
 138 scm_sys_search_load_path (filename)
 139      SCM filename;
 140 {
 141   SCM path = *scm_loc_load_path;
 142   char *buf;
 143   int buf_size;
 144   int filename_len;
 145
 146   SCM_ASSERT (SCM_NIMP (filename) && SCM_ROSTRINGP (filename), filename,
 147               SCM_ARG1, s_sys_search_load_path);
 148   filename_len = SCM_ROLENGTH (filename);
 149
 150   SCM_DEFER_INTS;
 151
 152   buf_size = 80;
 153   buf = scm_must_malloc (buf_size, s_sys_search_load_path);
 154
 155   while (SCM_NIMP (path) && SCM_CONSP (path))
 156     {
 157       SCM elt = SCM_CAR (path);
 158       if (SCM_NIMP (elt) && SCM_ROSTRINGP (elt))
 159         {
 160           int len = SCM_ROLENGTH (elt) + 1 + filename_len;
 161
 162           if (len + 1 > buf_size)
 163             {
 164               int old_size = buf_size;
 165               buf_size = len + 50;
 166               buf = scm_must_realloc (buf, old_size, buf_size,
 167                                       s_sys_search_load_path);
 168             }
 169
 170           memcpy (buf, SCM_ROCHARS (elt), SCM_ROLENGTH (elt));
 171           buf[SCM_ROLENGTH (elt)] = '/';
 172           memcpy (buf + SCM_ROLENGTH (elt) + 1,
 173                   SCM_ROCHARS (filename), filename_len);
 174           buf[len] = '\0';
 175
 176           {
 177             struct stat mode;
 178
 179             if (stat (buf, &mode) >= 0
 180                 && ! (mode.st_mode & S_IFDIR)
 181                 && access (buf, R_OK) == 0)
 182               {
 183                 SCM result = scm_makfromstr (buf, len, 0);
 184                 scm_must_free (buf);
 185                 SCM_ALLOW_INTS;
 186                 return result;
 187               }
 188           }
 189         }
 190
 191       path = SCM_CDR (path);
 192     }
 193
 194   scm_must_free (buf);
 195   SCM_ALLOW_INTS;
 196   return SCM_BOOL_F;
 197 }
 198
 199
 200 SCM_PROC(s_sys_try_load_path, "%try-load-path", 1, 2, 0,scm_sys_try_load_path);
 201 SCM
 202 scm_sys_try_load_path (filename, case_insensitive_p, sharp)
 203      SCM filename;
 204      SCM case_insensitive_p;
 205      SCM sharp;
 206 {
 207   SCM full_filename = scm_sys_search_load_path (filename);
 208   if (SCM_FALSEP (full_filename))
 209     {
 210       scm_error (scm_misc_error_key,
 211                  s_sys_try_load_path,
 212                  "Unable to find file %S in %S",
 213                  scm_listify (filename, *scm_loc_load_path, SCM_UNDEFINED),
 214                  SCM_BOOL_F);
 215     }
 216   return scm_sys_try_load (full_filename, case_insensitive_p, sharp);
 217 }
 218
 219 \f
 220
 221 void
 222 scm_init_load ()
 223 {
 224   scm_loc_load_path = &SCM_CDR(scm_sysintern("%load-path", SCM_EOL));
 225
 226 #include "load.x"
 227 }