← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/prosfs.c

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/microcode/prosfs.c
 
1
/* -*-C-*-
 
2
 
 
3
$Id: prosfs.c,v 1.16 2001/05/09 03:15:11 cph Exp $
 
4
 
 
5
Copyright (c) 1987-2001 Massachusetts Institute of Technology
 
6
 
 
7
This program is free software; you can redistribute it and/or modify
 
8
it under the terms of the GNU General Public License as published by
 
9
the Free Software Foundation; either version 2 of the License, or (at
 
10
your option) any later version.
 
11
 
 
12
This program is distributed in the hope that it will be useful, but
 
13
WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
General Public License for more details.
 
16
 
 
17
You should have received a copy of the GNU General Public License
 
18
along with this program; if not, write to the Free Software
 
19
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
20
USA.
 
21
*/
 
22
 
 
23
/* Primitives to perform file-system operations. */
 
24
 
 
25
#include "scheme.h"
 
26
#include "prims.h"
 
27
#include "osfile.h"
 
28
#include "osfs.h"
 
29
#include "osio.h"
 
30
 
 
31
extern int EXFUN (OS_channel_copy,
 
32
                  (off_t source_length,
 
33
                   Tchannel source_channel,
 
34
                   Tchannel destination_channel));
 
35
extern void EXFUN (OS_file_copy, (CONST char *, CONST char *));
 
36
 
 
37
#define STRING_RESULT(expression)                                       \
 
38
{                                                                       \
 
39
  CONST char * result = (expression);                                   \
 
40
  PRIMITIVE_RETURN                                                      \
 
41
    ((result == 0)                                                      \
 
42
     ? SHARP_F                                                          \
 
43
     : (char_pointer_to_string ((unsigned char *) result)));            \
 
44
}
 
45
 
 
46
DEFINE_PRIMITIVE ("FILE-EXISTS?", Prim_file_exists_p, 1, 1,
 
47
  "Return #T iff FILENAME refers to an existing file.\n\
 
48
Return #F if the file doesn't exist.\n\
 
49
Return zero if it's a symbolic link that points to a nonexisting file.\n\
 
50
Signal an error if the file's existence is indeterminate.")
 
51
{
 
52
  PRIMITIVE_HEADER (1);
 
53
  {
 
54
    enum file_existence result = (OS_file_existence_test (STRING_ARG (1)));
 
55
    PRIMITIVE_RETURN
 
56
      ((result == file_doesnt_exist)
 
57
       ? SHARP_F
 
58
       : (result == file_does_exist)
 
59
       ? SHARP_T
 
60
       : FIXNUM_ZERO);
 
61
  }
 
62
}
 
63
 
 
64
DEFINE_PRIMITIVE ("FILE-EXISTS-DIRECT?", Prim_file_exists_direct_p, 1, 1,
 
65
  "Return #T iff FILENAME refers to an existing file.\n\
 
66
Return #F if the file doesn't exist.\n\
 
67
Return zero if it's a symbolic link.\n\
 
68
Signal an error if the file's existence is indeterminate.")
 
69
{
 
70
  PRIMITIVE_HEADER (1);
 
71
  {
 
72
    enum file_existence result
 
73
      = (OS_file_existence_test_direct (STRING_ARG (1)));
 
74
    PRIMITIVE_RETURN
 
75
      ((result == file_doesnt_exist)
 
76
       ? SHARP_F
 
77
       : (result == file_does_exist)
 
78
       ? SHARP_T
 
79
       : FIXNUM_ZERO);
 
80
  }
 
81
}
 
82
 
 
83
DEFINE_PRIMITIVE ("FILE-TYPE-DIRECT", Prim_file_type_direct, 1, 1,
 
84
  "Return type of FILE, as an exact non-negative integer.\n\
 
85
Don't indirect through symbolic links.")
 
86
{
 
87
  PRIMITIVE_HEADER (1);
 
88
  {
 
89
    enum file_type t = (OS_file_type_direct (STRING_ARG (1)));
 
90
    PRIMITIVE_RETURN
 
91
      ((t == file_type_nonexistent)
 
92
       ? SHARP_F
 
93
       : (ulong_to_integer ((unsigned long) t)));
 
94
  }
 
95
}
 
96
 
 
97
DEFINE_PRIMITIVE ("FILE-TYPE-INDIRECT", Prim_file_type_indirect, 1, 1,
 
98
  "Return type of FILE, as an exact non-negative integer.\n\
 
99
Indirect through symbolic links.")
 
100
{
 
101
  PRIMITIVE_HEADER (1);
 
102
  {
 
103
    enum file_type t = (OS_file_type_indirect (STRING_ARG (1)));
 
104
    PRIMITIVE_RETURN
 
105
      ((t == file_type_nonexistent)
 
106
       ? SHARP_F
 
107
       : (ulong_to_integer ((unsigned long) t)));
 
108
  }
 
109
}
 
110
 
 
111
DEFINE_PRIMITIVE ("FILE-ACCESS", Prim_file_access, 2, 2,
 
112
  "Return #T iff FILENAME exists and is accessible according to MODE.\n\
 
113
MODE is an integer between 0 and 7 inclusive, bitwise encoded:\n\
 
114
  4 ==> file is readable;\n\
 
115
  2 ==> file is writable;\n\
 
116
  1 ==> file is executable.")
 
117
{
 
118
  PRIMITIVE_HEADER (2);
 
119
  PRIMITIVE_RETURN
 
120
    (BOOLEAN_TO_OBJECT
 
121
     (OS_file_access ((STRING_ARG (1)), (arg_index_integer (2, 8)))));
 
122
}
 
123
 
 
124
DEFINE_PRIMITIVE ("FILE-DIRECTORY?", Prim_file_directory_p, 1, 1,
 
125
  "Return #T iff FILENAME refers to an existing directory.\n\
 
126
Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
 
127
 or that it isn't a directory.")
 
128
{
 
129
  PRIMITIVE_HEADER (1);
 
130
  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_file_directory_p (STRING_ARG (1))));
 
131
}
 
132
 
 
133
DEFINE_PRIMITIVE ("FILE-SOFT-LINK?", Prim_file_soft_link_p, 1, 1,
 
134
  "Iff FILENAME refers to an existing soft link, return the link contents.\n\
 
135
Otherwise #F is returned, meaning either that FILENAME doesn't exist\n\
 
136
 or that it isn't a soft link.")
 
137
{
 
138
  PRIMITIVE_HEADER (1);
 
139
  STRING_RESULT (OS_file_soft_link_p (STRING_ARG (1)));
 
140
}
 
141
 
 
142
DEFINE_PRIMITIVE ("FILE-REMOVE", Prim_file_remove, 1, 1,
 
143
  "Delete file FILENAME.\n\
 
144
If FILENAME is a soft link, the link is deleted.")
 
145
{
 
146
  PRIMITIVE_HEADER (1);
 
147
  OS_file_remove (STRING_ARG (1));
 
148
  PRIMITIVE_RETURN (UNSPECIFIC);
 
149
}
 
150
 
 
151
DEFINE_PRIMITIVE ("FILE-REMOVE-LINK", Prim_file_remove_link, 1, 1,
 
152
  "If file FILENAME is a link to another file (hard or soft), remove it.")
 
153
{
 
154
  PRIMITIVE_HEADER (1);
 
155
  OS_file_remove_link (STRING_ARG (1));
 
156
  PRIMITIVE_RETURN (UNSPECIFIC);
 
157
}
 
158
 
 
159
DEFINE_PRIMITIVE ("FILE-RENAME", Prim_file_rename, 2, 2,
 
160
  "Rename file FROM-NAME to TO-NAME.")
 
161
{
 
162
  PRIMITIVE_HEADER (2);
 
163
  OS_file_rename ((STRING_ARG (1)), (STRING_ARG (2)));
 
164
  PRIMITIVE_RETURN (UNSPECIFIC);
 
165
}
 
166
 
 
167
DEFINE_PRIMITIVE ("FILE-LINK-HARD", Prim_file_link_hard, 2, 2,
 
168
  "Create a hard link from file FROM-NAME to file TO-NAME.\n\
 
169
TO-NAME becomes another name for the file FROM-NAME.")
 
170
{
 
171
  PRIMITIVE_HEADER (2);
 
172
  OS_file_link_hard ((STRING_ARG (1)), (STRING_ARG (2)));
 
173
  PRIMITIVE_RETURN (UNSPECIFIC);
 
174
}
 
175
 
 
176
DEFINE_PRIMITIVE ("FILE-LINK-SOFT", Prim_file_link_soft, 2, 2,
 
177
  "Create a soft link from file FROM-NAME to file TO-NAME.\n\
 
178
TO-NAME becomes a soft link containing the string FROM-NAME.")
 
179
{
 
180
  PRIMITIVE_HEADER (2);
 
181
  OS_file_link_soft ((STRING_ARG (1)), (STRING_ARG (2)));
 
182
  PRIMITIVE_RETURN (UNSPECIFIC);
 
183
}
 
184
 
 
185
DEFINE_PRIMITIVE ("LINK-FILE", Prim_link_file, 3, 3,
 
186
  "This is an obsolete primitive.  Use `file-link-hard' or `file-link-soft'.\n\
 
187
Create a new name for file FROM-NAME, called TO-NAME.\n\
 
188
If third arg HARD? is #F, a soft link is created;\n\
 
189
 otherwise a hard link is created.")
 
190
{
 
191
  PRIMITIVE_HEADER (3);
 
192
  {
 
193
    CONST char * from_name = (STRING_ARG (1));
 
194
    CONST char * to_name = (STRING_ARG (2));
 
195
    if ((ARG_REF (3)) != SHARP_F)
 
196
      OS_file_link_hard (from_name, to_name);
 
197
    else
 
198
      OS_file_link_soft (from_name, to_name);
 
199
  }
 
200
  PRIMITIVE_RETURN (UNSPECIFIC);
 
201
}
 
202
 
 
203
#ifndef FILE_COPY_BUFFER_LENGTH
 
204
#define FILE_COPY_BUFFER_LENGTH 8192
 
205
#endif
 
206
 
 
207
int
 
208
DEFUN (OS_channel_copy, (source_length, source_channel, destination_channel),
 
209
       off_t source_length AND
 
210
       Tchannel source_channel AND
 
211
       Tchannel destination_channel)
 
212
{
 
213
  char buffer [FILE_COPY_BUFFER_LENGTH];
 
214
  off_t transfer_length =
 
215
    ((source_length > (sizeof (buffer))) ? (sizeof (buffer)) : source_length);
 
216
 
 
217
  while (source_length > 0)
 
218
  {
 
219
    long nread =
 
220
      (OS_channel_read (source_channel, buffer, transfer_length));
 
221
    if (nread <= 0)
 
222
    {
 
223
      return (-1);
 
224
    }
 
225
    if ((OS_channel_write (destination_channel, buffer, nread)) <
 
226
        nread)
 
227
    {
 
228
      return (-1);
 
229
    }
 
230
    source_length -= nread;
 
231
    if (source_length < (sizeof (buffer)))
 
232
      transfer_length = source_length;
 
233
  }
 
234
  return (0);
 
235
}  
 
236
 
 
237
DEFINE_PRIMITIVE ("FILE-COPY", Prim_file_copy, 2, 2,
 
238
  "Make a new copy of the file FROM-NAME, called TO-NAME.")
 
239
{
 
240
  PRIMITIVE_HEADER (2);
 
241
  OS_file_copy ((STRING_ARG (1)), (STRING_ARG (2)));
 
242
  PRIMITIVE_RETURN (UNSPECIFIC);
 
243
}
 
244
 
 
245
DEFINE_PRIMITIVE ("DIRECTORY-MAKE", Prim_directory_make, 1, 1,
 
246
  "Create a new directory, called NAME.")
 
247
{
 
248
  PRIMITIVE_HEADER (1);
 
249
  OS_directory_make (STRING_ARG (1));
 
250
  PRIMITIVE_RETURN (UNSPECIFIC);
 
251
}
 
252
 
 
253
DEFINE_PRIMITIVE ("DIRECTORY-DELETE", Prim_directory_delete, 1, 1,
 
254
  "Delete directory called NAME.")
 
255
{
 
256
  PRIMITIVE_HEADER (1);
 
257
  OS_directory_delete (STRING_ARG (1));
 
258
  PRIMITIVE_RETURN (UNSPECIFIC);
 
259
}
 
260
 
 
261
DEFINE_PRIMITIVE ("FILE-TOUCH", Prim_file_touch, 1, 1,
 
262
  "Given a file name, change the times of the file to the current time.\n\
 
263
If the file does not exist, create it.\n\
 
264
Both the access time and modification time are changed.\n\
 
265
Return #F if the file existed and its time was modified.\n\
 
266
Otherwise the file did not exist and it was created.")
 
267
{
 
268
  PRIMITIVE_HEADER (1);
 
269
  PRIMITIVE_RETURN
 
270
    (BOOLEAN_TO_OBJECT (OS_file_touch ((CONST char *) (STRING_ARG (1)))));
 
271
}
 
272
 
 
273
DEFINE_PRIMITIVE ("NEW-DIRECTORY-OPEN", Prim_new_directory_open, 1, 1,
 
274
  "Open the directory NAME for reading, returning a directory number.")
 
275
{
 
276
  PRIMITIVE_HEADER (1);
 
277
  PRIMITIVE_RETURN (long_to_integer (OS_directory_open (STRING_ARG (1))));
 
278
}
 
279
 
 
280
static unsigned int
 
281
DEFUN (arg_directory_index, (argument), unsigned int argument)
 
282
{
 
283
  long index = (arg_integer (argument));
 
284
  if (! (OS_directory_valid_p (index)))
 
285
    error_bad_range_arg (argument);
 
286
  return (index);
 
287
}
 
288
 
 
289
DEFINE_PRIMITIVE ("NEW-DIRECTORY-CLOSE", Prim_new_directory_close, 1, 1,
 
290
  "Close DIRECTORY.")
 
291
{
 
292
  PRIMITIVE_HEADER (1);
 
293
  OS_directory_close (arg_directory_index (1));
 
294
  PRIMITIVE_RETURN (UNSPECIFIC);
 
295
}
 
296
 
 
297
DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ", Prim_new_directory_read, 1, 1,
 
298
  "Read and return a filename from DIRECTORY, or #F if no more files.")
 
299
{
 
300
  PRIMITIVE_HEADER (1);
 
301
  STRING_RESULT (OS_directory_read (arg_directory_index (1)));
 
302
}
 
303
 
 
304
DEFINE_PRIMITIVE ("NEW-DIRECTORY-READ-MATCHING", Prim_new_directory_read_match, 2, 2,
 
305
  "Read and return a filename from DIRECTORY.\n\
 
306
The filename must begin with the STRING.\n\
 
307
Return #F if there are no more matching files in the directory.")
 
308
{
 
309
  PRIMITIVE_HEADER (2);
 
310
  STRING_RESULT
 
311
    (OS_directory_read_matching ((arg_directory_index (1)), (STRING_ARG (2))));
 
312
}