« back to all changes in this revision
Viewing changes to .pc/2.6.10pre-test-3/o/file.d
- browse files at revision 57
- compare with another revision
- download diff
- download tarball
- view history from revision 57
- Committer: Package Import Robot
- Author(s): Camm Maguire
- Date: 2013-11-13 18:39:19 UTC
- mfrom: (13.1.102 sid)
- Revision ID: package-import@ubuntu.com-20131113183919-cs74swffevkpkp1l
Tags: 2.6.10-1
New upstream release
- files removed:
- .pc/2.6.10pre-test
- .pc/2.6.10pre-test-10
- .pc/2.6.10pre-test-10/cmpnew
- .pc/2.6.10pre-test-10/o
- .pc/2.6.10pre-test-11
- .pc/2.6.10pre-test-11/o
- .pc/2.6.10pre-test-13
- .pc/2.6.10pre-test-13/h
- .pc/2.6.10pre-test-13/o
- .pc/2.6.10pre-test-14
- .pc/2.6.10pre-test-14/o
- .pc/2.6.10pre-test-15
- .pc/2.6.10pre-test-15/h
- .pc/2.6.10pre-test-15/lsp
- .pc/2.6.10pre-test-15/o
- .pc/2.6.10pre-test-16
- .pc/2.6.10pre-test-16/o
- .pc/2.6.10pre-test-17
- .pc/2.6.10pre-test-17/cmpnew
- .pc/2.6.10pre-test-17/o
- .pc/2.6.10pre-test-3
- .pc/2.6.10pre-test-3/h
- .pc/2.6.10pre-test-3/o
- .pc/2.6.10pre-test-4
- .pc/2.6.10pre-test-4/o
- .pc/2.6.10pre-test-5
- .pc/2.6.10pre-test-5/h
- .pc/2.6.10pre-test-5/o
- .pc/2.6.10pre-test-6
- .pc/2.6.10pre-test-6/cmpnew
- .pc/2.6.10pre-test-6/h
- .pc/2.6.10pre-test-6/lsp
- .pc/2.6.10pre-test-6/o
- .pc/2.6.10pre-test-6/unixport
- .pc/2.6.10pre-test-7
- .pc/2.6.10pre-test-7/h
- .pc/2.6.10pre-test-7/o
- .pc/2.6.10pre-test-8
- .pc/2.6.10pre-test-8/h
- .pc/2.6.10pre-test-9
- .pc/2.6.10pre-test-9/o
- .pc/2.6.10pre-test/cmpnew
- .pc/2.6.10pre-test/h
- .pc/2.6.10pre-test/lsp
- .pc/2.6.10pre-test/man
- .pc/2.6.10pre-test/man/man1
- .pc/2.6.10pre-test/o
- .pc/environment-allocation-unrandomize.h
- .pc/environment-allocation-unrandomize.h/h
- .pc/fast-fixnums
- .pc/fast-fixnums/cmpnew
- .pc/fast-fixnums/h
- .pc/fast-fixnums/lsp
- .pc/fast-fixnums/o
- .pc/gcl_2.6.10pre-test-2
- .pc/gcl_2.6.10pre-test-2/h
- .pc/gcl_2.6.10pre-test-2/o
- .pc/s390-mingw-cleanup
- .pc/s390-mingw-cleanup/h
- .pc/s390-mingw-cleanup/o
- files modified:
- .pc/applied-patches
added
removed
.pc/2.6.10pre-test-3/o/file.d
1
/*
2
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
3
4
This file is part of GNU Common Lisp, herein referred to as GCL
5
6
GCL is free software; you can redistribute it and/or modify it under
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
8
the Free Software Foundation; either version 2, or (at your option)
9
any later version.
10
11
GCL is distributed in the hope that it will be useful, but WITHOUT
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
14
License for more details.
15
16
You should have received a copy of the GNU Library General Public License
17
along with GCL; see the file COPYING. If not, write to the Free Software
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19
*/
20
21
/*
22
file.d
23
IMPLEMENTATION-DEPENDENT
24
25
The specification of printf may be dependent on the C library,
26
especially for read-write access, append access, etc.
27
The file also contains the code to reclaim the I/O buffer
28
by accessing the FILE structure of C.
29
It also contains read_fasl_data.
30
*/
31
32
#include <string.h>
33
#include <stdlib.h>
34
#include <unistd.h>
35
#include <sys/types.h>
36
#include <sys/stat.h>
37
38
#define IN_FILE
39
#include "include.h"
40
41
#ifdef HAVE_READLINE
42
#include <readline/readline.h>
43
#define kclgetc(FP) rl_getc_em(FP)
44
#define kclungetc(C, FP) rl_ungetc_em(C, FP)
45
#define kclputc(C, FP) rl_putc_em(C, FP)
46
#else
47
#define kclgetc(FP) getc(FP)
48
#define kclungetc(C, FP) ungetc(C, FP)
49
#define kclputc(C, FP) putc(C, FP)
50
#endif /* HAVE_READLINE */
51
52
#define xkclfeof(c,FP) feof(FP)
53
54
#ifdef HAVE_AOUT
55
#undef ATT
56
#undef BSD
57
#ifndef HAVE_ELF
58
#ifndef HAVE_FILEHDR
59
#define BSD
60
#endif
61
#endif
62
#include HAVE_AOUT
63
#endif
64
65
#ifdef ATT
66
#include <filehdr.h>
67
#include <syms.h>
68
#define HAVE_FILEHDR
69
#endif
70
71
#ifdef E15
72
#include <a.out.h>
73
#define exec bhdr
74
#define a_text tsize
75
#define a_data dsize
76
#define a_bss bsize
77
#define a_syms ssize
78
#define a_trsize rtsize
79
#define a_drsize rdsize
80
#endif
81
82
#if defined(HAVE_ELF_H)
83
#include <elf.h>
84
#elif defined(HAVE_ELF_ABI_H)
85
#include <elf_abi.h>
86
#endif
87
88
#ifndef __MINGW32__
89
# include <sys/socket.h>
90
# include <netinet/in.h>
91
# include <arpa/inet.h>
92
#else
93
# include <windows.h>
94
# include <winsock2.h>
95
#endif
96
#include <errno.h>
97
98
extern void tcpCloseSocket (int fd);
99
100
object terminal_io;
101
102
object Vverbose;
103
object LSP_string;
104
105
106
object sSAignore_eof_on_terminal_ioA;
107
108
static bool
109
feof1(fp)
110
FILE *fp;
111
{
112
113
#ifdef HAVE_READLINE
114
if (readline_on && fp==rl_instream && rl_line_buffer && *rl_line_buffer==EOF)
115
return TRUE;
116
#endif
117
if (!feof(fp))
118
return(FALSE);
119
if (fp == terminal_io->sm.sm_object0->sm.sm_fp) {
120
if (symbol_value(sSAignore_eof_on_terminal_ioA) == Cnil)
121
return(TRUE);
122
#ifdef UNIX
123
fp = freopen("/dev/tty", "r", fp);
124
#endif
125
#ifdef AOSVS
126
127
#endif
128
if (fp == NULL)
129
error("can't reopen the console");
130
return(FALSE);
131
}
132
return(TRUE);
133
}
134
135
#undef feof
136
#define feof feof1
137
138
void
139
end_of_stream(strm)
140
object strm;
141
{
142
FEerror("Unexpected end of ~S.", 1, strm);
143
}
144
145
/*
146
Input_stream_p(strm) answers
147
if stream strm is an input stream or not.
148
It does not check if it really is possible to read
149
from the stream,
150
but only checks the mode of the stream (sm_mode).
151
*/
152
static bool
153
input_stream_p(strm)
154
object strm;
155
{
156
BEGIN:
157
switch (strm->sm.sm_mode) {
158
case smm_input:
159
return(TRUE);
160
161
case smm_output:
162
return(FALSE);
163
164
case smm_io:
165
case smm_socket:
166
return(TRUE);
167
168
case smm_probe:
169
return(FALSE);
170
171
case smm_synonym:
172
strm = symbol_value(strm->sm.sm_object0);
173
if (type_of(strm) != t_stream)
174
FEwrong_type_argument(sLstream, strm);
175
goto BEGIN;
176
177
case smm_broadcast:
178
return(FALSE);
179
180
case smm_concatenated:
181
return(TRUE);
182
183
case smm_two_way:
184
return(TRUE);
185
186
case smm_echo:
187
return(TRUE);
188
189
case smm_string_input:
190
return(TRUE);
191
192
case smm_string_output:
193
return(FALSE);
194
195
default:
196
error("illegal stream mode");
197
return(FALSE);
198
}
199
}
200
201
/*
202
Output_stream_p(strm) answers
203
if stream strm is an output stream.
204
It does not check if it really is possible to write
205
to the stream,
206
but only checks the mode of the stream (sm_mode).
207
*/
208
static bool
209
output_stream_p(strm)
210
object strm;
211
{
212
BEGIN:
213
switch (strm->sm.sm_mode) {
214
case smm_input:
215
return(FALSE);
216
217
case smm_output:
218
return(TRUE);
219
220
case smm_io:
221
case smm_socket:
222
return(TRUE);
223
224
case smm_probe:
225
return(FALSE);
226
227
case smm_synonym:
228
strm = symbol_value(strm->sm.sm_object0);
229
if (type_of(strm) != t_stream)
230
FEwrong_type_argument(sLstream, strm);
231
goto BEGIN;
232
233
case smm_broadcast:
234
return(TRUE);
235
236
case smm_concatenated:
237
return(FALSE);
238
239
case smm_two_way:
240
return(TRUE);
241
242
case smm_echo:
243
return(TRUE);
244
245
case smm_string_input:
246
return(FALSE);
247
248
case smm_string_output:
249
return(TRUE);
250
251
default:
252
error("illegal stream mode");
253
return(FALSE);
254
}
255
}
256
257
static object
258
stream_element_type(strm)
259
object strm;
260
{
261
object x;
262
263
BEGIN:
264
switch (strm->sm.sm_mode) {
265
case smm_input:
266
case smm_output:
267
case smm_io:
268
case smm_probe:
269
return(strm->sm.sm_object0);
270
271
case smm_socket:
272
return (sLstring_char);
273
274
case smm_synonym:
275
strm = symbol_value(strm->sm.sm_object0);
276
if (type_of(strm) != t_stream)
277
FEwrong_type_argument(sLstream, strm);
278
goto BEGIN;
279
280
case smm_broadcast:
281
x = strm->sm.sm_object0;
282
if (endp(x))
283
return(Ct);
284
return(stream_element_type(x->c.c_car));
285
286
case smm_concatenated:
287
x = strm->sm.sm_object0;
288
if (endp(x))
289
return(Ct);
290
return(stream_element_type(x->c.c_car));
291
292
case smm_two_way:
293
return(stream_element_type(STREAM_INPUT_STREAM(strm)));
294
295
case smm_echo:
296
return(stream_element_type(STREAM_INPUT_STREAM(strm)));
297
298
case smm_string_input:
299
return(sLstring_char);
300
301
case smm_string_output:
302
return(sLstring_char);
303
304
default:
305
error("illegal stream mode");
306
return(FALSE);
307
}
308
}
309
310
#ifndef NO_SETBUF
311
void
312
setup_stream_buffer(object x) {
313
char *buf=alloc_contblock(BUFSIZ);
314
x->sm.sm_buffer = buf;
315
setbuf(x->sm.sm_fp, buf);
316
}
317
318
static void
319
deallocate_stream_buffer(strm)
320
object strm;
321
{
322
323
/* SGC contblock pages: Its possible this is on an old page CM 20030827 */
324
if (strm->sm.sm_buffer)
325
{
326
#ifdef SGC
327
insert_maybe_sgc_contblock(strm->sm.sm_buffer, BUFSIZ);
328
#else
329
insert_contblock(strm->sm.sm_buffer, BUFSIZ);
330
#endif
331
strm->sm.sm_buffer = 0;}
332
else
333
printf("no buffer? %p \n",strm->sm.sm_fp);
334
335
#ifndef FCLOSE_SETBUF_OK
336
strm->sm.sm_fp->_base = NULL;
337
#endif
338
}
339
/* end ifndef NO_SETBUF */
340
#endif
341
342
DEFVAR("*ALLOW-GZIPPED-FILE*",sSAallow_gzipped_fileA,SI,sLnil,"");
343
344
static void
345
too_long_file_name(object);
346
static void
347
cannot_open(object);
348
static void
349
cannot_create(object);
350
/*
351
Open_stream(fn, smm, if_exists, if_does_not_exist)
352
opens file fn with mode smm.
353
Fn is a namestring.
354
*/
355
object
356
open_stream(fn, smm, if_exists, if_does_not_exist)
357
object fn;
358
enum smmode smm;
359
object if_exists, if_does_not_exist;
360
{
361
object x;
362
FILE *fp=NULL;
363
char fname[BUFSIZ];
364
int i;
365
object unzipped = 0;
366
vs_mark;
367
368
/*
369
if (type_of(fn) != t_string)
370
FEwrong_type_argument(sLstring, fn);
371
*/
372
if (fn->st.st_fillp > BUFSIZ - 1)
373
too_long_file_name(fn);
374
for (i = 0; i < fn->st.st_fillp; i++)
375
fname[i] = fn->st.st_self[i];
376
377
fname[i] = '\0';
378
if (smm == smm_input || smm == smm_probe) {
379
if(fname[0]=='|')
380
fp = popen(fname+1,"r");
381
else
382
fp = fopen_not_dir(fname, "r");
383
384
AGAIN:
385
if (fp == NULL) {
386
if (sSAallow_gzipped_fileA->s.s_dbind != sLnil)
387
{
388
struct string st;
389
char buf[256];
390
if (snprintf(buf,sizeof(buf),"%s.gz",fname)<=0)
391
FEerror("Cannot write .gz filename",0);
392
st.st_self=buf;
393
st.st_dim=st.st_fillp=strlen(buf);
394
set_type_of(&st,t_string);
395
if (file_exists((object)&st)) {
396
FILE *pp;
397
int n;
398
if (!(fp=tmpfile()))
399
FEerror("Cannot create temporary file",0);
400
if (snprintf(buf,sizeof(buf),"zcat %s.gz",fname)<=0)
401
FEerror("Cannot write zcat pipe name",0);
402
if (!(pp=popen(buf,"r")))
403
FEerror("Cannot open zcat pipe",0);
404
while((n=fread(buf,1,sizeof(buf),pp)))
405
if (!fwrite(buf,1,n,fp))
406
FEerror("Cannot write pipe output to temporary file",0);
407
if (pclose(pp)<0)
408
FEerror("Cannot close zcat pipe",0);
409
if (fseek(fp,0,SEEK_SET))
410
FEerror("Cannot rewind temporary file\n",0);
411
goto AGAIN;
412
}
413
}
414
415
/* fp = fopen_not_dir(buf,"r"); */
416
/* if (fp) */
417
/* { */
418
/* #ifdef NO_MKSTEMP */
419
/* char *tmp; */
420
/* #else */
421
/* char tmp[200]; */
422
/* #endif */
423
/* char command [500]; */
424
/* fclose(fp); */
425
/* #ifdef NO_MKSTEMP */
426
/* tmp = tmpnam(0); */
427
/* #else */
428
/* snprintf(tmp,sizeof(tmp),"uzipXXXXXX"); */
429
/* mkstemp(tmp); */ /* fixme: catch errors */
430
/* #endif */
431
/* unzipped = make_simple_string(tmp); */
432
/* sprintf(command,"gzip -dc %s > %s",buf,tmp); */
433
/* fp = 0; */
434
/* if (0 == system(command)) */
435
/* { */
436
/* fp = fopen_not_dir(tmp,"r"); */
437
/* if (fp) */
438
/* goto AGAIN; */
439
/* /\* should not get here *\/ */
440
/* else { unlink(tmp);}} */
441
/* }} */
442
if (if_does_not_exist == sKerror)
443
cannot_open(fn);
444
else if (if_does_not_exist == sKcreate) {
445
fp = fopen_not_dir(fname, "w");
446
if (fp == NULL)
447
cannot_create(fn);
448
fclose(fp);
449
fp = fopen_not_dir(fname, "r");
450
if (fp == NULL)
451
cannot_open(fn);
452
} else if (if_does_not_exist == Cnil)
453
return(Cnil);
454
else
455
FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
456
1, if_does_not_exist);
457
}
458
} else if (smm == smm_output || smm == smm_io) {
459
if (if_exists == sKnew_version && if_does_not_exist == sKcreate)
460
goto CREATE;
461
fp = fopen_not_dir(fname, "r");
462
if (fp != NULL) {
463
fclose(fp);
464
if (if_exists == sKerror)
465
FEerror("The file ~A already exists.", 1, fn);
466
else if (if_exists == sKrename) {
467
if (smm == smm_output)
468
fp = backup_fopen(fname, "w");
469
else
470
fp = backup_fopen(fname, "w+");
471
if (fp == NULL)
472
cannot_create(fn);
473
} else if (if_exists == sKrename_and_delete ||
474
if_exists == sKnew_version ||
475
if_exists == sKsupersede) {
476
if (smm == smm_output)
477
fp = fopen_not_dir(fname, "w");
478
else
479
fp = fopen_not_dir(fname, "w+");
480
if (fp == NULL)
481
cannot_create(fn);
482
} else if (if_exists == sKoverwrite) {
483
fp = fopen_not_dir(fname, "r+");
484
if (fp == NULL)
485
cannot_open(fn);
486
} else if (if_exists == sKappend) {
487
if (smm == smm_output)
488
fp = fopen_not_dir(fname, "a");
489
else
490
fp = fopen_not_dir(fname, "a+");
491
if (fp == NULL)
492
FEerror("Cannot append to the file ~A.",1,fn);
493
} else if (if_exists == Cnil)
494
return(Cnil);
495
else
496
FEerror("~S is an illegal IF-EXISTS option.",
497
1, if_exists);
498
} else {
499
if (if_does_not_exist == sKerror)
500
FEerror("The file ~A does not exist.", 1, fn);
501
else if (if_does_not_exist == sKcreate) {
502
CREATE:
503
if (smm == smm_output)
504
{
505
if(fname[0]=='|')
506
fp = popen(fname+1,"w");
507
else
508
fp = fopen_not_dir(fname, "w");
509
}
510
else
511
fp = fopen_not_dir(fname, "w+");
512
if (fp == NULL)
513
cannot_create(fn);
514
} else if (if_does_not_exist == Cnil)
515
return(Cnil);
516
else
517
FEerror("~S is an illegal IF-DOES-NOT-EXIST option.",
518
1, if_does_not_exist);
519
}
520
} else
521
error("illegal stream mode");
522
x = alloc_object(t_stream);
523
x->sm.sm_mode = (short)smm;
524
x->sm.sm_fp = fp;
525
526
x->sm.sm_buffer = 0;
527
x->sm.sm_object0 = (unzipped ? make_cons(sSAallow_gzipped_fileA,unzipped) : sLstring_char);
528
x->sm.sm_object1 = fn;
529
x->sm.sm_int0 = x->sm.sm_int1 = 0;
530
vs_push(x);
531
setup_stream_buffer(x);
532
vs_reset;
533
return(x);
534
}
535
536
static void
537
gclFlushSocket(object);
538
/*
539
Close_stream(strm) closes stream strm.
540
The abort_flag is not used now.
541
*/
542
void
543
close_stream(strm)
544
object strm;
545
/*bool abort_flag; */ /* Not used now! */
546
{
547
object x;
548
549
BEGIN:
550
switch (strm->sm.sm_mode) {
551
case smm_output:
552
if (strm->sm.sm_fp == stdout)
553
FEerror("Cannot close the standard output.", 0);
554
if (strm->sm.sm_fp == NULL) break;
555
fflush(strm->sm.sm_fp);
556
deallocate_stream_buffer(strm);
557
fclose(strm->sm.sm_fp);
558
strm->sm.sm_fp = NULL;
559
break;
560
561
562
case smm_socket:
563
if (SOCKET_STREAM_FD(strm) < 2) {
564
fprintf(stderr,"tried Clsing %d ! as scoket \n",SOCKET_STREAM_FD(strm));
565
fflush(stderr);
566
}
567
else {
568
#ifdef HAVE_NSOCKET
569
if (GET_STREAM_FLAG(strm,gcl_sm_output))
570
{
571
gclFlushSocket(strm);
572
/* there are two for one fd so close only one */
573
tcpCloseSocket(SOCKET_STREAM_FD(strm));
574
}
575
#endif
576
SOCKET_STREAM_FD(strm)=-1;
577
}
578
579
case smm_input:
580
if (strm->sm.sm_fp == stdin)
581
FEerror("Cannot close the standard input.", 0);
582
583
case smm_io:
584
case smm_probe:
585
if (strm->sm.sm_fp == NULL) break;
586
deallocate_stream_buffer(strm);
587
if (strm->sm.sm_object1 &&
588
type_of(strm->sm.sm_object1)==t_string &&
589
strm->sm.sm_object1->st.st_self[0] =='|')
590
pclose(strm->sm.sm_fp);
591
else
592
fclose(strm->sm.sm_fp);
593
strm->sm.sm_fp = NULL;
594
if (type_of(strm->sm.sm_object0 ) == t_cons &&
595
Mcar(strm->sm.sm_object0 ) == sSAallow_gzipped_fileA)
596
fLdelete_file(Mcdr(strm->sm.sm_object0));
597
break;
598
599
case smm_synonym:
600
strm = symbol_value(strm->sm.sm_object0);
601
if (type_of(strm) != t_stream)
602
FEwrong_type_argument(sLstream, strm);
603
goto BEGIN;
604
605
case smm_broadcast:
606
for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
607
close_stream(x->c.c_car);
608
break;
609
610
case smm_concatenated:
611
for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
612
close_stream(x->c.c_car);
613
break;
614
615
case smm_two_way:
616
case smm_echo:
617
close_stream(STREAM_INPUT_STREAM(strm));
618
close_stream(STREAM_OUTPUT_STREAM(strm));
619
break;
620
621
case smm_string_input:
622
break; /* There is nothing to do. */
623
624
case smm_string_output:
625
break; /* There is nothing to do. */
626
627
default:
628
error("illegal stream mode");
629
}
630
}
631
632
object
633
make_two_way_stream(istrm, ostrm)
634
object istrm, ostrm;
635
{
636
object strm;
637
638
strm = alloc_object(t_stream);
639
strm->sm.sm_mode = (short)smm_two_way;
640
strm->sm.sm_fp = NULL;
641
strm->sm.sm_buffer = 0;
642
STREAM_INPUT_STREAM(strm) = istrm;
643
STREAM_OUTPUT_STREAM(strm) = ostrm;
644
strm->sm.sm_int0 = strm->sm.sm_int1 = 0;
645
return(strm);
646
}
647
648
static object
649
make_echo_stream(istrm, ostrm)
650
object istrm, ostrm;
651
{
652
object strm;
653
654
strm = make_two_way_stream(istrm, ostrm);
655
strm->sm.sm_mode = (short)smm_echo;
656
return(strm);
657
}
658
659
object
660
make_string_input_stream(strng, istart, iend)
661
object strng;
662
int istart, iend;
663
{
664
object strm;
665
666
strm = alloc_object(t_stream);
667
strm->sm.sm_mode = (short)smm_string_input;
668
strm->sm.sm_fp = NULL;
669
strm->sm.sm_buffer = 0;
670
STRING_STREAM_STRING(strm) = strng;
671
strm->sm.sm_object1 = OBJNULL;
672
STRING_INPUT_STREAM_NEXT(strm)= istart;
673
STRING_INPUT_STREAM_END(strm)= iend;
674
return(strm);
675
}
676
677
DEFUN_NEW("STRING-INPUT-STREAM-P",object,fSstring_input_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
678
return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_input ? Ct : Cnil;
679
}
680
DEFUN_NEW("STRING-OUTPUT-STREAM-P",object,fSstring_output_stream_p,SI,1,1,NONE,OO,OO,OO,OO,(object x),"") {
681
return type_of(x)==t_stream && x->sm.sm_mode == (short)smm_string_output ? Ct : Cnil;
682
}
683
684
object
685
make_string_output_stream(line_length)
686
int line_length;
687
{
688
object strng, strm;
689
vs_mark;
690
691
strng = alloc_object(t_string);
692
strng->st.st_hasfillp = TRUE;
693
strng->st.st_adjustable = TRUE;
694
strng->st.st_displaced = Cnil;
695
strng->st.st_dim = line_length;
696
strng->st.st_fillp = 0;
697
strng->st.st_self = NULL;
698
/* For GBC not to go mad. */
699
vs_push(strng);
700
/* Saving for GBC. */
701
strng->st.st_self = alloc_relblock(line_length);
702
strm = alloc_object(t_stream);
703
strm->sm.sm_mode = (short)smm_string_output;
704
strm->sm.sm_fp = NULL;
705
strm->sm.sm_buffer = 0;
706
STRING_STREAM_STRING(strm) = strng;
707
strm->sm.sm_object1 = OBJNULL;
708
strm->sm.sm_int0 = STREAM_FILE_COLUMN(strm) = 0;
709
vs_reset;
710
return(strm);
711
}
712
713
static object
714
get_output_stream_string(strm)
715
object strm;
716
{
717
object strng;
718
719
strng = copy_simple_string(STRING_STREAM_STRING(strm));
720
STRING_STREAM_STRING(strm)->st.st_fillp = 0;
721
return(strng);
722
}
723
724
static void
725
cannot_read(object);
726
727
static void
728
closed_stream(object);
729
int
730
readc_stream(strm)
731
object strm;
732
{
733
int c;
734
735
BEGIN:
736
switch (strm->sm.sm_mode) {
737
#ifdef HAVE_NSOCKET
738
case smm_socket:
739
return (getCharGclSocket(strm,Ct));
740
#endif
741
case smm_input:
742
case smm_io:
743
744
if (strm->sm.sm_fp == NULL)
745
closed_stream(strm);
746
#if (1)
747
c = kclgetc(strm->sm.sm_fp);
748
#else
749
c = getOneChar(strm->sm.sm_fp);
750
#endif
751
/* if (c == EOF) { */
752
/* if (xkclfeof(c,strm->sm.sm_fp)) */
753
/* end_of_stream(strm); */
754
/* else c = getOneChar(strm->sm.sm_fp); */
755
/* if (c == EOF) end_of_stream(strm); */
756
/* } */
757
758
/* c &= 0377; */
759
/* strm->sm.sm_int0++; */
760
return(c==EOF ? c : (c&0377));
761
762
case smm_synonym:
763
strm = symbol_value(strm->sm.sm_object0);
764
if (type_of(strm) != t_stream)
765
FEwrong_type_argument(sLstream, strm);
766
goto BEGIN;
767
768
case smm_concatenated:
769
CONCATENATED:
770
if (endp(strm->sm.sm_object0)) {
771
end_of_stream(strm);
772
}
773
if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
774
strm->sm.sm_object0
775
= strm->sm.sm_object0->c.c_cdr;
776
goto CONCATENATED;
777
}
778
c = readc_stream(strm->sm.sm_object0->c.c_car);
779
return(c);
780
781
case smm_two_way:
782
#ifdef UNIX
783
if (strm == terminal_io)
784
flush_stream(STREAM_OUTPUT_STREAM(terminal_io));
785
#endif
786
/* strm->sm.sm_int1 = 0; */
787
strm = STREAM_INPUT_STREAM(strm);
788
goto BEGIN;
789
790
case smm_echo:
791
c = readc_stream(STREAM_INPUT_STREAM(strm));
792
if (ECHO_STREAM_N_UNREAD(strm) == 0)
793
writec_stream(c, STREAM_OUTPUT_STREAM(strm));
794
else
795
--(ECHO_STREAM_N_UNREAD(strm));
796
return(c);
797
798
case smm_string_input:
799
if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm))
800
end_of_stream(strm);
801
return(STRING_STREAM_STRING(strm)->st.st_self
802
[STRING_INPUT_STREAM_NEXT(strm)++]);
803
804
case smm_output:
805
case smm_probe:
806
case smm_broadcast:
807
case smm_string_output:
808
cannot_read(strm);
809
#ifdef USER_DEFINED_STREAMS
810
case smm_user_defined:
811
#define STM_DATA_STRUCT 0
812
#define STM_READ_CHAR 1
813
#define STM_WRITE_CHAR 2
814
#define STM_UNREAD_CHAR 7
815
#define STM_FORCE_OUTPUT 4
816
#define STM_PEEK_CHAR 3
817
#define STM_CLOSE 5
818
#define STM_TYPE 6
819
#define STM_NAME 8
820
{object val;
821
object *old_vs_base = vs_base;
822
object *old_vs_top = vs_top;
823
vs_base = vs_top;
824
vs_push(strm);
825
super_funcall(strm->sm.sm_object1->str.str_self[STM_READ_CHAR]);
826
val = vs_base[0];
827
vs_base = old_vs_base;
828
vs_top = old_vs_top;
829
if (type_of(val) == t_fixnum)
830
return (fix(val));
831
if (type_of(val) == t_character)
832
return (char_code(val));
833
}
834
835
#endif
836
837
default:
838
error("illegal stream mode");
839
return(0);
840
}
841
}
842
843
int
844
rl_ungetc_em(int, FILE *);
845
846
void
847
unreadc_stream(int c, object strm) {
848
BEGIN:
849
switch (strm->sm.sm_mode) {
850
case smm_socket:
851
#ifdef HAVE_NSOCKET
852
ungetCharGclSocket(c,strm);
853
return;
854
#endif
855
case smm_input:
856
case smm_io:
857
858
if (strm->sm.sm_fp == NULL)
859
closed_stream(strm);
860
kclungetc(c, strm->sm.sm_fp);
861
/* --strm->sm.sm_int0; */ /* use ftell now for position */
862
break;
863
864
case smm_synonym:
865
strm = symbol_value(strm->sm.sm_object0);
866
if (type_of(strm) != t_stream)
867
FEwrong_type_argument(sLstream, strm);
868
goto BEGIN;
869
870
case smm_concatenated:
871
if (endp(strm->sm.sm_object0))
872
goto UNREAD_ERROR;
873
strm = strm->sm.sm_object0->c.c_car;
874
goto BEGIN;
875
876
case smm_two_way:
877
strm = STREAM_INPUT_STREAM(strm);
878
goto BEGIN;
879
880
case smm_echo:
881
unreadc_stream(c, STREAM_INPUT_STREAM(strm));
882
ECHO_STREAM_N_UNREAD(strm)++;
883
break;
884
885
case smm_string_input:
886
if (STRING_INPUT_STREAM_NEXT(strm)<= 0)
887
goto UNREAD_ERROR;
888
--STRING_INPUT_STREAM_NEXT(strm);
889
break;
890
891
case smm_output:
892
case smm_probe:
893
case smm_broadcast:
894
case smm_string_output:
895
goto UNREAD_ERROR;
896
897
#ifdef USER_DEFINED_STREAMS
898
case smm_user_defined:
899
{object *old_vs_base = vs_base;
900
object *old_vs_top = vs_top;
901
vs_base = vs_top;
902
vs_push(strm);
903
/* if there is a file pointer and no define unget function,
904
* then call ungetc */
905
if ((strm->sm.sm_fp != NULL ) &&
906
strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR] == Cnil)
907
kclungetc(c, strm->sm.sm_fp);
908
else
909
super_funcall(strm->sm.sm_object1->str.str_self[STM_UNREAD_CHAR]);
910
vs_top = old_vs_top;
911
vs_base = old_vs_base;
912
}
913
break;
914
#endif
915
default:
916
error("illegal stream mode");
917
}
918
return;
919
920
UNREAD_ERROR:
921
FEerror("Cannot unread the stream ~S.", 1, strm);
922
}
923
924
static void
925
putCharGclSocket(object,int);
926
int
927
rl_putc_em(int, FILE *);
928
static void
929
cannot_write(object);
930
931
int
932
writec_stream(int c, object strm) {
933
object x;
934
char *p;
935
int i;
936
937
BEGIN:
938
switch (strm->sm.sm_mode) {
939
case smm_output:
940
case smm_io:
941
case smm_socket:
942
/* strm->sm.sm_int0++; */
943
if (c == '\n')
944
STREAM_FILE_COLUMN(strm) = 0;
945
else if (c == '\t')
946
STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8;
947
else
948
STREAM_FILE_COLUMN(strm)++;
949
if (strm->sm.sm_fp == NULL)
950
{
951
#ifdef HAVE_NSOCKET
952
if (strm->sm.sm_mode == smm_socket && strm->sm.sm_fd>=0)
953
putCharGclSocket(strm,c);
954
else
955
#endif
956
if (!GET_STREAM_FLAG(strm,gcl_sm_had_error))
957
closed_stream(strm);
958
} else {
959
960
kclputc(c, strm->sm.sm_fp);
961
}
962
963
break;
964
965
case smm_synonym:
966
strm = symbol_value(strm->sm.sm_object0);
967
if (type_of(strm) != t_stream)
968
FEwrong_type_argument(sLstream, strm);
969
goto BEGIN;
970
971
case smm_broadcast:
972
for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
973
writec_stream(c, x->c.c_car);
974
break;
975
976
case smm_two_way:
977
/* this should be on the actual streams
978
strm->sm.sm_int0++;
979
if (c == '\n')
980
strm->sm.sm_int1 = 0;
981
else if (c == '\t')
982
strm->sm.sm_int1 = (strm->sm.sm_int1&~07) + 8;
983
else
984
strm->sm.sm_int1++;
985
*/
986
strm = STREAM_OUTPUT_STREAM(strm);
987
goto BEGIN;
988
989
case smm_echo:
990
strm = STREAM_OUTPUT_STREAM(strm);
991
goto BEGIN;
992
993
case smm_string_output:
994
/* strm->sm.sm_int0++; */
995
if (c == '\n')
996
STREAM_FILE_COLUMN(strm) = 0;
997
else if (c == '\t')
998
STREAM_FILE_COLUMN(strm) = (STREAM_FILE_COLUMN(strm)&~07) + 8;
999
else
1000
STREAM_FILE_COLUMN(strm)++;
1001
x = STRING_STREAM_STRING(strm);
1002
if (x->st.st_fillp >= x->st.st_dim) {
1003
if (!x->st.st_adjustable)
1004
FEerror("The string ~S is not adjustable.",
1005
1, x);
1006
p = (inheap((long)x->st.st_self) ? alloc_contblock : alloc_relblock)
1007
(x->st.st_dim * 2 + 16);
1008
for (i = 0; i < x->st.st_dim; i++)
1009
p[i] = x->st.st_self[i];
1010
i = x->st.st_dim * 2 + 16;
1011
#define ADIMLIM 16*1024*1024
1012
if (i >= ADIMLIM)
1013
FEerror("Can't extend the string.", 0);
1014
x->st.st_dim = i;
1015
adjust_displaced(x, p - x->st.st_self);
1016
}
1017
x->st.st_self[x->st.st_fillp++] = c;
1018
break;
1019
1020
case smm_input:
1021
case smm_probe:
1022
case smm_concatenated:
1023
case smm_string_input:
1024
cannot_write(strm);
1025
1026
#ifdef USER_DEFINED_STREAMS
1027
case smm_user_defined:
1028
{object *old_vs_base = vs_base;
1029
object *old_vs_top = vs_top;
1030
vs_base = vs_top;
1031
vs_push(strm);
1032
vs_push(code_char(c));
1033
super_funcall(strm->sm.sm_object1->str.str_self[2]);
1034
vs_base = old_vs_base;
1035
vs_top = old_vs_top;
1036
break;
1037
}
1038
1039
#endif
1040
default:
1041
error("illegal stream mode");
1042
}
1043
return(c);
1044
}
1045
1046
void
1047
writestr_stream(s, strm)
1048
char *s;
1049
object strm;
1050
{
1051
while (*s != '\0')
1052
writec_stream(*s++, strm);
1053
}
1054
1055
void
1056
flush_stream(object strm) {
1057
object x;
1058
1059
BEGIN:
1060
switch (strm->sm.sm_mode) {
1061
case smm_output:
1062
case smm_io:
1063
if (strm->sm.sm_fp == NULL)
1064
closed_stream(strm);
1065
fflush(strm->sm.sm_fp);
1066
break;
1067
case smm_socket:
1068
#ifdef HAVE_NSOCKET
1069
if (SOCKET_STREAM_FD(strm) >0)
1070
gclFlushSocket(strm);
1071
else
1072
#endif
1073
closed_stream(strm);
1074
break;
1075
case smm_synonym:
1076
strm = symbol_value(strm->sm.sm_object0);
1077
if (type_of(strm) != t_stream)
1078
FEwrong_type_argument(sLstream, strm);
1079
goto BEGIN;
1080
1081
case smm_broadcast:
1082
for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr)
1083
flush_stream(x->c.c_car);
1084
break;
1085
1086
case smm_echo:
1087
case smm_two_way:
1088
strm = STREAM_OUTPUT_STREAM(strm);
1089
goto BEGIN;
1090
1091
1092
case smm_string_output:
1093
break;
1094
1095
case smm_input:
1096
case smm_probe:
1097
case smm_concatenated:
1098
case smm_string_input:
1099
FEerror("Cannot flush the stream ~S.", 1, strm);
1100
#ifdef USER_DEFINED_STREAMS
1101
case smm_user_defined:
1102
{object *old_vs_base = vs_base;
1103
object *old_vs_top = vs_top;
1104
vs_base = vs_top;
1105
vs_push(strm);
1106
super_funcall(strm->sm.sm_object1->str.str_self[4]);
1107
vs_base = old_vs_base;
1108
vs_top = old_vs_top;
1109
break;
1110
}
1111
1112
#endif
1113
1114
default:
1115
error("illegal stream mode");
1116
}
1117
}
1118
1119
1120
bool
1121
stream_at_end(object strm) {
1122
#define NON_CHAR -1000
1123
VOL int c = NON_CHAR;
1124
1125
BEGIN:
1126
switch (strm->sm.sm_mode) {
1127
case smm_socket:
1128
listen_stream(strm);
1129
if (SOCKET_STREAM_FD(strm)>=0)
1130
return(FALSE);
1131
else return(TRUE);
1132
case smm_io:
1133
case smm_input:
1134
if (strm->sm.sm_fp == NULL)
1135
closed_stream(strm);
1136
if (isatty(fileno(strm->sm.sm_fp)) && !listen_stream(strm))
1137
return(feof(strm->sm.sm_fp) ? TRUE : FALSE);
1138
{int prev_signals_allowed = signals_allowed;
1139
AGAIN:
1140
signals_allowed= sig_at_read;
1141
c = kclgetc(strm->sm.sm_fp);
1142
/* blocking getchar for sockets */
1143
/* if (c==EOF && (strm)->sm.sm_mode ==smm_socket)
1144
c = getOneChar(strm->sm.sm_fp); */
1145
1146
1147
if (c == NON_CHAR) goto AGAIN;
1148
signals_allowed=prev_signals_allowed;}
1149
1150
if (xkclfeof(c,strm->sm.sm_fp))
1151
return(TRUE);
1152
else {
1153
if (c>=0) kclungetc(c, strm->sm.sm_fp);
1154
return(FALSE);
1155
}
1156
1157
case smm_output:
1158
return(FALSE);
1159
1160
case smm_probe:
1161
return(FALSE);
1162
1163
case smm_synonym:
1164
strm = symbol_value(strm->sm.sm_object0);
1165
check_stream(strm);
1166
goto BEGIN;
1167
1168
case smm_broadcast:
1169
return(FALSE);
1170
1171
case smm_concatenated:
1172
CONCATENATED:
1173
if (endp(strm->sm.sm_object0))
1174
return(TRUE);
1175
if (stream_at_end(strm->sm.sm_object0->c.c_car)) {
1176
strm->sm.sm_object0
1177
= strm->sm.sm_object0->c.c_cdr;
1178
goto CONCATENATED;
1179
} else
1180
return(FALSE);
1181
1182
case smm_two_way:
1183
#ifdef UNIX
1184
if (strm == terminal_io) /**/
1185
flush_stream(terminal_io->sm.sm_object1); /**/
1186
#endif
1187
strm = STREAM_INPUT_STREAM(strm);
1188
goto BEGIN;
1189
1190
case smm_echo:
1191
strm = STREAM_INPUT_STREAM(strm);
1192
goto BEGIN;
1193
1194
case smm_string_input:
1195
if (STRING_INPUT_STREAM_NEXT(strm)>= STRING_INPUT_STREAM_END(strm))
1196
return(TRUE);
1197
else
1198
return(FALSE);
1199
1200
case smm_string_output:
1201
return(FALSE);
1202
1203
#ifdef USER_DEFINED_STREAMS
1204
case smm_user_defined:
1205
return(FALSE);
1206
#endif
1207
default:
1208
error("illegal stream mode");
1209
return(FALSE);
1210
}
1211
}
1212
1213
1214
#ifdef HAVE_SYS_IOCTL_H
1215
#include <sys/ioctl.h>
1216
#endif
1217
1218
1219
#ifdef LISTEN_USE_FCNTL
1220
#include <fcntl.h>
1221
#endif
1222
1223
bool
1224
listen_stream(object strm) {
1225
1226
BEGIN:
1227
1228
switch (strm->sm.sm_mode) {
1229
#ifdef HAVE_NSOCKET
1230
case smm_socket:
1231
1232
if (SOCKET_STREAM_BUFFER(strm)->ust.ust_fillp>0) return TRUE;
1233
1234
/* { */
1235
/* fd_set fds; */
1236
/* struct timeval tv; */
1237
/* FD_ZERO(&fds); */
1238
/* FD_SET(SOCKET_STREAM_FD(strm),&fds); */
1239
/* memset(&tv,0,sizeof(tv)); */
1240
/* return select(SOCKET_STREAM_FD(strm)+1,&fds,NULL,NULL,&tv)>0 ? TRUE : FALSE; */
1241
/* } */
1242
{ int ch = getCharGclSocket(strm,Cnil);
1243
if (ch == EOF) return FALSE;
1244
else unreadc_stream(ch,strm);
1245
return TRUE;
1246
}
1247
#endif
1248
1249
case smm_input:
1250
case smm_io:
1251
1252
#ifdef HAVE_READLINE
1253
if (readline_on && strm->sm.sm_fp==rl_instream)
1254
return *rl_line_buffer ? TRUE : FALSE;
1255
#endif
1256
if (strm->sm.sm_fp == NULL)
1257
closed_stream(strm);
1258
if (feof(strm->sm.sm_fp))
1259
return(FALSE);
1260
#ifdef LISTEN_FOR_INPUT
1261
LISTEN_FOR_INPUT(strm->sm.sm_fp);
1262
#else
1263
#ifdef LISTEN_USE_FCNTL
1264
do { int c = 0;
1265
FILE *fp = strm->sm.sm_fp;
1266
int orig;
1267
int res;
1268
if (feof(fp)) return TRUE;
1269
orig = fcntl(fileno(fp), F_GETFL);
1270
if (! (orig & O_NONBLOCK ) ) {
1271
res=fcntl(fileno(fp),F_SETFL,orig | O_NONBLOCK);
1272
}
1273
c = getc(fp);
1274
if (! (orig & O_NONBLOCK ) ){
1275
fcntl(fileno(fp),F_SETFL,orig );
1276
}
1277
if (c != EOF)
1278
{
1279
ungetc(c,fp);
1280
return TRUE;
1281
}
1282
return FALSE;
1283
} while (0);
1284
#endif
1285
#endif
1286
return TRUE;
1287
1288
case smm_synonym:
1289
strm = symbol_value(strm->sm.sm_object0);
1290
if (type_of(strm) != t_stream)
1291
FEwrong_type_argument(sLstream, strm);
1292
goto BEGIN;
1293
1294
case smm_concatenated:
1295
if (endp(strm->sm.sm_object0))
1296
return(FALSE);
1297
strm = strm->sm.sm_object0->c.c_car; /* Incomplete! */
1298
goto BEGIN;
1299
1300
case smm_two_way:
1301
case smm_echo:
1302
strm = STREAM_INPUT_STREAM(strm);
1303
goto BEGIN;
1304
1305
case smm_string_input:
1306
if (STRING_INPUT_STREAM_NEXT(strm)< STRING_INPUT_STREAM_END(strm))
1307
return(TRUE);
1308
else
1309
return(FALSE);
1310
1311
case smm_output:
1312
case smm_probe:
1313
case smm_broadcast:
1314
case smm_string_output:
1315
FEerror("Can't listen to ~S.", 1, strm);
1316
return(FALSE);
1317
default:
1318
error("illegal stream mode");
1319
return(FALSE);
1320
}
1321
}
1322
1323
int
1324
file_position(strm)
1325
object strm;
1326
{
1327
BEGIN:
1328
switch (strm->sm.sm_mode) {
1329
case smm_input:
1330
case smm_output:
1331
case smm_io:
1332
/* return(strm->sm.sm_int0); */
1333
if (strm->sm.sm_fp == NULL)
1334
closed_stream(strm);
1335
return(ftell(strm->sm.sm_fp));
1336
case smm_socket:
1337
return -1;
1338
1339
1340
case smm_string_output:
1341
return(STRING_STREAM_STRING(strm)->st.st_fillp);
1342
1343
case smm_synonym:
1344
strm = symbol_value(strm->sm.sm_object0);
1345
if (type_of(strm) != t_stream)
1346
FEwrong_type_argument(sLstream, strm);
1347
goto BEGIN;
1348
1349
case smm_probe:
1350
case smm_broadcast:
1351
case smm_concatenated:
1352
case smm_two_way:
1353
case smm_echo:
1354
case smm_string_input:
1355
return(-1);
1356
1357
default:
1358
error("illegal stream mode");
1359
return(-1);
1360
}
1361
}
1362
1363
int
1364
file_position_set(strm, disp)
1365
object strm;
1366
int disp;
1367
{
1368
BEGIN:
1369
switch (strm->sm.sm_mode) {
1370
case smm_socket:
1371
return -1;
1372
case smm_input:
1373
case smm_output:
1374
case smm_io:
1375
1376
if (fseek(strm->sm.sm_fp, disp, 0) < 0)
1377
return(-1);
1378
/* strm->sm.sm_int0 = disp; */
1379
return(0);
1380
1381
case smm_string_output:
1382
if (disp < STRING_STREAM_STRING(strm)->st.st_fillp) {
1383
STRING_STREAM_STRING(strm)->st.st_fillp = disp;
1384
/* strm->sm.sm_int0 = disp; */
1385
} else {
1386
disp -= STRING_STREAM_STRING(strm)->st.st_fillp;
1387
while (disp-- > 0)
1388
writec_stream(' ', strm);
1389
}
1390
return(0);
1391
1392
case smm_synonym:
1393
strm = symbol_value(strm->sm.sm_object0);
1394
if (type_of(strm) != t_stream)
1395
FEwrong_type_argument(sLstream, strm);
1396
goto BEGIN;
1397
1398
case smm_probe:
1399
case smm_broadcast:
1400
case smm_concatenated:
1401
case smm_two_way:
1402
case smm_echo:
1403
case smm_string_input:
1404
return(-1);
1405
1406
default:
1407
error("illegal stream mode");
1408
return(-1);
1409
}
1410
}
1411
1412
static int
1413
file_length(strm)
1414
object strm;
1415
{
1416
BEGIN:
1417
switch (strm->sm.sm_mode) {
1418
case smm_input:
1419
case smm_output:
1420
case smm_io:
1421
1422
if (strm->sm.sm_fp == NULL)
1423
closed_stream(strm);
1424
return(file_len(strm->sm.sm_fp));
1425
1426
1427
1428
case smm_synonym:
1429
strm = symbol_value(strm->sm.sm_object0);
1430
if (type_of(strm) != t_stream)
1431
FEwrong_type_argument(sLstream, strm);
1432
goto BEGIN;
1433
1434
case smm_socket:
1435
case smm_probe:
1436
case smm_broadcast:
1437
case smm_concatenated:
1438
case smm_two_way:
1439
case smm_echo:
1440
case smm_string_input:
1441
case smm_string_output:
1442
return(-1);
1443
1444
default:
1445
error("illegal stream mode");
1446
return(-1);
1447
}
1448
}
1449
1450
int
1451
file_column(object strm) {
1452
int i;
1453
object x;
1454
1455
BEGIN:
1456
switch (strm->sm.sm_mode) {
1457
case smm_output:
1458
case smm_io:
1459
case smm_socket:
1460
case smm_string_output:
1461
return(STREAM_FILE_COLUMN(strm));
1462
1463
case smm_echo:
1464
case smm_two_way:
1465
strm=STREAM_OUTPUT_STREAM(strm);
1466
goto BEGIN;
1467
case smm_synonym:
1468
strm = symbol_value(strm->sm.sm_object0);
1469
if (type_of(strm) != t_stream)
1470
FEwrong_type_argument(sLstream, strm);
1471
goto BEGIN;
1472
1473
1474
case smm_input:
1475
case smm_probe:
1476
case smm_string_input:
1477
return(-1);
1478
1479
case smm_concatenated:
1480
if (endp(strm->sm.sm_object0))
1481
return(-1);
1482
strm = strm->sm.sm_object0->c.c_car;
1483
goto BEGIN;
1484
1485
case smm_broadcast:
1486
for (x = strm->sm.sm_object0; !endp(x); x = x->c.c_cdr) {
1487
i = file_column(x->c.c_car);
1488
if (i >= 0)
1489
return(i);
1490
}
1491
return(-1);
1492
1493
#ifdef USER_DEFINED_STREAMS
1494
case smm_user_defined: /* not right but what is? */
1495
return(-1);
1496
1497
#endif
1498
default:
1499
error("illegal stream mode");
1500
return(-1);
1501
}
1502
}
1503
1504
void
1505
load(const char *s) {
1506
1507
object filename, strm, x;
1508
vs_mark;
1509
1510
if (user_match(s,strlen(s)))
1511
return;
1512
filename = make_simple_string(s);
1513
vs_push(filename);
1514
strm = open_stream(filename, smm_input, Cnil, sKerror);
1515
vs_push(strm);
1516
for (;;) {
1517
preserving_whitespace_flag = FALSE;
1518
detect_eos_flag = TRUE;
1519
x = read_object_non_recursive(strm);
1520
if (x == OBJNULL)
1521
break;
1522
vs_push(x);
1523
ieval(x);
1524
vs_popp;
1525
}
1526
close_stream(strm);
1527
vs_reset;
1528
1529
}
1530
1531
1532
1533
LFD(Lmake_synonym_stream)()
1534
{
1535
object x;
1536
1537
check_arg(1);
1538
check_type_symbol(&vs_base[0]);
1539
x = alloc_object(t_stream);
1540
x->sm.sm_mode = (short)smm_synonym;
1541
x->sm.sm_fp = NULL;
1542
x->sm.sm_buffer = 0;
1543
x->sm.sm_object0 = vs_base[0];
1544
x->sm.sm_object1 = OBJNULL;
1545
x->sm.sm_int0 = x->sm.sm_int1 = 0;
1546
vs_base[0] = x;
1547
}
1548
1549
LFD(Lmake_broadcast_stream)()
1550
{
1551
object x;
1552
int narg, i;
1553
1554
narg = vs_top - vs_base;
1555
for (i = 0; i < narg; i++)
1556
if (type_of(vs_base[i]) != t_stream ||
1557
!output_stream_p(vs_base[i]))
1558
cannot_write(vs_base[i]);
1559
vs_push(Cnil);
1560
for (i = narg; i > 0; --i)
1561
stack_cons();
1562
x = alloc_object(t_stream);
1563
x->sm.sm_mode = (short)smm_broadcast;
1564
x->sm.sm_fp = NULL;
1565
x->sm.sm_buffer = 0;
1566
x->sm.sm_object0 = vs_base[0];
1567
x->sm.sm_object1 = OBJNULL;
1568
x->sm.sm_int0 = x->sm.sm_int1 = 0;
1569
vs_base[0] = x;
1570
}
1571
1572
LFD(Lmake_concatenated_stream)()
1573
{
1574
object x;
1575
int narg, i;
1576
1577
narg = vs_top - vs_base;
1578
for (i = 0; i < narg; i++)
1579
if (type_of(vs_base[i]) != t_stream ||
1580
!input_stream_p(vs_base[i]))
1581
cannot_read(vs_base[i]);
1582
vs_push(Cnil);
1583
for (i = narg; i > 0; --i)
1584
stack_cons();
1585
x = alloc_object(t_stream);
1586
x->sm.sm_mode = (short)smm_concatenated;
1587
x->sm.sm_fp = NULL;
1588
x->sm.sm_buffer = 0;
1589
x->sm.sm_object0 = vs_base[0];
1590
x->sm.sm_object1 = OBJNULL;
1591
x->sm.sm_int0 = x->sm.sm_int1 = 0;
1592
vs_base[0] = x;
1593
}
1594
1595
LFD(Lmake_two_way_stream)()
1596
{
1597
check_arg(2);
1598
1599
if (type_of(vs_base[0]) != t_stream ||
1600
!input_stream_p(vs_base[0]))
1601
cannot_read(vs_base[0]);
1602
if (type_of(vs_base[1]) != t_stream ||
1603
!output_stream_p(vs_base[1]))
1604
cannot_write(vs_base[1]);
1605
vs_base[0] = make_two_way_stream(vs_base[0], vs_base[1]);
1606
vs_popp;
1607
}
1608
1609
LFD(Lmake_echo_stream)()
1610
{
1611
check_arg(2);
1612
1613
if (type_of(vs_base[0]) != t_stream ||
1614
!input_stream_p(vs_base[0]))
1615
cannot_read(vs_base[0]);
1616
if (type_of(vs_base[1]) != t_stream ||
1617
!output_stream_p(vs_base[1]))
1618
cannot_write(vs_base[1]);
1619
vs_base[0] = make_echo_stream(vs_base[0], vs_base[1]);
1620
vs_popp;
1621
}
1622
1623
@(static defun make_string_input_stream (strng &o istart iend)
1624
int s, e;
1625
@
1626
check_type_string(&strng);
1627
if (istart == Cnil)
1628
s = 0;
1629
else if (type_of(istart) != t_fixnum)
1630
goto E;
1631
else
1632
s = fix(istart);
1633
if (iend == Cnil)
1634
e = strng->st.st_fillp;
1635
else if (type_of(iend) != t_fixnum)
1636
goto E;
1637
else
1638
e = fix(iend);
1639
if (s < 0 || e > strng->st.st_fillp || s > e)
1640
goto E;
1641
@(return `make_string_input_stream(strng, s, e)`)
1642
1643
E:
1644
FEerror("~S and ~S are illegal as :START and :END~%\
1645
for the string ~S.",
1646
3, istart, iend, strng);
1647
@)
1648
1649
static void
1650
FFN(Lmake_string_output_stream)()
1651
{
1652
check_arg(0);
1653
vs_push(make_string_output_stream(64));
1654
}
1655
1656
LFD(Lget_output_stream_string)()
1657
{
1658
check_arg(1);
1659
1660
if (type_of(vs_base[0]) != t_stream ||
1661
(enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
1662
FEerror("~S is not a string-output stream.", 1, vs_base[0]);
1663
vs_base[0] = get_output_stream_string(vs_base[0]);
1664
}
1665
1666
/*
1667
(SI:OUTPUT-STREAM-STRING string-output-stream)
1668
1669
extracts the string associated with the given
1670
string-output-stream.
1671
*/
1672
LFD(siLoutput_stream_string)()
1673
{
1674
check_arg(1);
1675
if (type_of(vs_base[0]) != t_stream ||
1676
(enum smmode)vs_base[0]->sm.sm_mode != smm_string_output)
1677
FEerror("~S is not a string-output stream.", 1, vs_base[0]);
1678
vs_base[0] = vs_base[0]->sm.sm_object0;
1679
}
1680
1681
LFD(Lstreamp)()
1682
{
1683
check_arg(1);
1684
1685
if (type_of(vs_base[0]) == t_stream)
1686
vs_base[0] = Ct;
1687
else
1688
vs_base[0] = Cnil;
1689
}
1690
1691
LFD(Linput_stream_p)()
1692
{
1693
check_arg(1);
1694
1695
check_type_stream(&vs_base[0]);
1696
if (input_stream_p(vs_base[0]))
1697
vs_base[0] = Ct;
1698
else
1699
vs_base[0] = Cnil;
1700
}
1701
1702
LFD(Loutput_stream_p)()
1703
{
1704
check_arg(1);
1705
1706
check_type_stream(&vs_base[0]);
1707
if (output_stream_p(vs_base[0]))
1708
vs_base[0] = Ct;
1709
else
1710
vs_base[0] = Cnil;
1711
}
1712
1713
LFD(Lstream_element_type)()
1714
{
1715
check_arg(1);
1716
1717
check_type_stream(&vs_base[0]);
1718
vs_base[0] = stream_element_type(vs_base[0]);
1719
}
1720
1721
@(defun close (strm &key abort)
1722
@
1723
check_type_stream(&strm);
1724
close_stream(strm);
1725
@(return Ct)
1726
@)
1727
1728
@(static defun open (filename
1729
&key (direction sKinput)
1730
(element_type sLstring_char)
1731
(if_exists Cnil iesp)
1732
(if_does_not_exist Cnil idnesp)
1733
&aux strm)
1734
enum smmode smm=0;
1735
@
1736
check_type_or_pathname_string_symbol_stream(&filename);
1737
filename = coerce_to_namestring(filename);
1738
if (direction == sKinput) {
1739
smm = smm_input;
1740
if (!idnesp)
1741
if_does_not_exist = sKerror;
1742
} else if (direction == sKoutput) {
1743
smm = smm_output;
1744
if (!iesp)
1745
if_exists = sKnew_version;
1746
if (!idnesp) {
1747
if (if_exists == sKoverwrite ||
1748
if_exists == sKappend)
1749
if_does_not_exist = sKerror;
1750
else
1751
if_does_not_exist = sKcreate;
1752
}
1753
} else if (direction == sKio) {
1754
smm = smm_io;
1755
if (!iesp)
1756
if_exists = sKnew_version;
1757
if (!idnesp) {
1758
if (if_exists == sKoverwrite ||
1759
if_exists == sKappend)
1760
if_does_not_exist = sKerror;
1761
else
1762
if_does_not_exist = sKcreate;
1763
}
1764
} else if (direction == sKprobe) {
1765
smm = smm_probe;
1766
if (!idnesp)
1767
if_does_not_exist = Cnil;
1768
} else
1769
FEerror("~S is an illegal DIRECTION for OPEN.",
1770
1, direction);
1771
strm = open_stream(filename, smm, if_exists, if_does_not_exist);
1772
if (type_of(strm) == t_stream)
1773
strm->sm.sm_object0 = element_type;
1774
@(return strm)
1775
@)
1776
1777
@(defun file_position (file_stream &o position)
1778
int i=0;
1779
@
1780
check_type_stream(&file_stream);
1781
if (position == Cnil) {
1782
i = file_position(file_stream);
1783
if (i < 0)
1784
@(return Cnil)
1785
@(return `make_fixnum(i)`)
1786
} else {
1787
if (position == sKstart)
1788
i = 0;
1789
else if (position == sKend)
1790
i = file_length(file_stream);
1791
else if (type_of(position) != t_fixnum ||
1792
(i = fix((position))) < 0)
1793
FEerror("~S is an illegal file position~%\
1794
for the file-stream ~S.",
1795
2, position, file_stream);
1796
if (file_position_set(file_stream, i) < 0)
1797
@(return Cnil)
1798
@(return Ct)
1799
}
1800
@)
1801
1802
LFD(Lfile_length)()
1803
{
1804
int i;
1805
1806
check_arg(1);
1807
check_type_stream(&vs_base[0]);
1808
i = file_length(vs_base[0]);
1809
if (i < 0)
1810
vs_base[0] = Cnil;
1811
else
1812
vs_base[0] = make_fixnum(i);
1813
}
1814
1815
object sSAload_pathnameA;
1816
DEFVAR("*COLLECT-BINARY-MODULES*",sSAcollect_binary_modulesA,SI,sLnil,"");
1817
DEFVAR("*BINARY-MODULES*",sSAbinary_modulesA,SI,Cnil,"");
1818
1819
@(static defun load (pathname
1820
&key (verbose `symbol_value(sLAload_verboseA)`)
1821
print
1822
(if_does_not_exist sKerror)
1823
&aux pntype fasl_filename lsp_filename filename
1824
defaults strm stdoutput x
1825
package)
1826
bds_ptr old_bds_top;
1827
int i;
1828
object strm1;
1829
@
1830
check_type_or_pathname_string_symbol_stream(&pathname);
1831
pathname = coerce_to_pathname(pathname);
1832
defaults = symbol_value(Vdefault_pathname_defaults);
1833
defaults = coerce_to_pathname(defaults);
1834
pathname = merge_pathnames(pathname, defaults, sKnewest);
1835
pntype = pathname->pn.pn_type;
1836
filename = coerce_to_namestring(pathname);
1837
if (user_match(filename->st.st_self,filename->st.st_fillp))
1838
@(return Cnil)
1839
old_bds_top=bds_top;
1840
if (pntype == Cnil || pntype == sKwild ||
1841
(type_of(pntype) == t_string &&
1842
#ifdef UNIX
1843
string_eq(pntype, FASL_string))) {
1844
#endif
1845
#ifdef AOSVS
1846
1847
#endif
1848
pathname->pn.pn_type = FASL_string;
1849
fasl_filename = coerce_to_namestring(pathname);
1850
}
1851
if (pntype == Cnil || pntype == sKwild ||
1852
(type_of(pntype) == t_string &&
1853
#ifdef UNIX
1854
string_eq(pntype, LSP_string))) {
1855
#endif
1856
#ifdef AOSVS
1857
1858
#endif
1859
pathname->pn.pn_type = LSP_string;
1860
lsp_filename = coerce_to_namestring(pathname);
1861
}
1862
if (fasl_filename != Cnil && file_exists(fasl_filename)) {
1863
if (verbose != Cnil) {
1864
SETUP_PRINT_DEFAULT(fasl_filename);
1865
if (file_column(PRINTstream) != 0)
1866
write_str("\n");
1867
write_str("Loading ");
1868
PRINTescape = FALSE;
1869
write_object(fasl_filename, 0);
1870
write_str("\n");
1871
CLEANUP_PRINT_DEFAULT;
1872
flush_stream(PRINTstream);
1873
}
1874
package = symbol_value(sLApackageA);
1875
bds_bind(sLApackageA, package);
1876
bds_bind(sSAload_pathnameA,fasl_filename);
1877
if (sSAcollect_binary_modulesA->s.s_dbind==Ct) {
1878
object _x=sSAbinary_modulesA->s.s_dbind;
1879
object _y=Cnil;
1880
while (_x!=Cnil) {
1881
_y=_x;
1882
_x=_x->c.c_cdr;
1883
}
1884
if (_y==Cnil)
1885
sSAbinary_modulesA->s.s_dbind=make_cons(fasl_filename,Cnil);
1886
else
1887
_y->c.c_cdr=make_cons(fasl_filename,Cnil);
1888
}
1889
i = fasload(fasl_filename);
1890
if (print != Cnil) {
1891
SETUP_PRINT_DEFAULT(Cnil);
1892
vs_top = PRINTvs_top;
1893
if (file_column(PRINTstream) != 0)
1894
write_str("\n");
1895
write_str("Fasload successfully ended.");
1896
write_str("\n");
1897
CLEANUP_PRINT_DEFAULT;
1898
flush_stream(PRINTstream);
1899
}
1900
bds_unwind(old_bds_top);
1901
if (verbose != Cnil) {
1902
SETUP_PRINT_DEFAULT(fasl_filename);
1903
if (file_column(PRINTstream) != 0)
1904
write_str("\n");
1905
write_str("Finished loading ");
1906
PRINTescape = FALSE;
1907
write_object(fasl_filename, 0);
1908
write_str("\n");
1909
CLEANUP_PRINT_DEFAULT;
1910
flush_stream(PRINTstream);
1911
}
1912
@(return `make_fixnum(i)`)
1913
}
1914
if (lsp_filename != Cnil && file_exists(lsp_filename)) {
1915
filename = lsp_filename;
1916
}
1917
if (if_does_not_exist != Cnil)
1918
if_does_not_exist = sKerror;
1919
strm1 = strm
1920
= open_stream(filename, smm_input, Cnil, if_does_not_exist);
1921
if (strm == Cnil)
1922
@(return Cnil)
1923
if (verbose != Cnil) {
1924
SETUP_PRINT_DEFAULT(filename);
1925
if (file_column(PRINTstream) != 0)
1926
write_str("\n");
1927
write_str("Loading ");
1928
PRINTescape = FALSE;
1929
write_object(filename, 0);
1930
write_str("\n");
1931
CLEANUP_PRINT_DEFAULT;
1932
flush_stream(PRINTstream);
1933
}
1934
package = symbol_value(sLApackageA);
1935
bds_bind(sSAload_pathnameA,pathname);
1936
bds_bind(sLApackageA, package);
1937
bds_bind(sLAstandard_inputA, strm);
1938
frs_push(FRS_PROTECT, Cnil);
1939
if (nlj_active) {
1940
close_stream(strm1);
1941
nlj_active = FALSE;
1942
frs_pop();
1943
bds_unwind(old_bds_top);
1944
unwind(nlj_fr, nlj_tag);
1945
}
1946
for (;;) {
1947
preserving_whitespace_flag = FALSE;
1948
detect_eos_flag = TRUE;
1949
x = read_object_non_recursive(strm);
1950
if (x == OBJNULL)
1951
break;
1952
{
1953
object *base = vs_base, *top = vs_top, *lex = lex_env;
1954
object xx;
1955
1956
lex_new();
1957
eval(x);
1958
xx = vs_base[0];
1959
lex_env = lex;
1960
vs_top = top;
1961
vs_base = base;
1962
x = xx;
1963
}
1964
if (print != Cnil) {
1965
SETUP_PRINT_DEFAULT(x);
1966
write_object(x, 0);
1967
write_str("\n");
1968
CLEANUP_PRINT_DEFAULT;
1969
flush_stream(PRINTstream);
1970
}
1971
}
1972
close_stream(strm);
1973
frs_pop();
1974
bds_unwind(old_bds_top);
1975
if (verbose != Cnil) {
1976
SETUP_PRINT_DEFAULT(filename);
1977
if (file_column(PRINTstream) != 0)
1978
write_str("\n");
1979
write_str("Finished loading ");
1980
PRINTescape = FALSE;
1981
write_object(filename, 0);
1982
write_str("\n");
1983
CLEANUP_PRINT_DEFAULT;
1984
flush_stream(PRINTstream);
1985
}
1986
@(return Ct)
1987
@)
1988
1989
static void
1990
FFN(siLget_string_input_stream_index)()
1991
{
1992
check_arg(1);
1993
check_type_stream(&vs_base[0]);
1994
if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input)
1995
FEerror("~S is not a string-input stream.", 1, vs_base[0]);
1996
vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0]));
1997
}
1998
1999
LFD(siLmake_string_output_stream_from_string)()
2000
{
2001
object strng, strm;
2002
2003
check_arg(1);
2004
strng = vs_base[0];
2005
if (type_of(strng) != t_string || !strng->st.st_hasfillp)
2006
FEerror("~S is not a string with a fill-pointer.", 1, strng);
2007
strm = alloc_object(t_stream);
2008
strm->sm.sm_mode = (short)smm_string_output;
2009
strm->sm.sm_fp = NULL;
2010
strm->sm.sm_buffer = 0;
2011
STRING_STREAM_STRING(strm) = strng;
2012
strm->sm.sm_object1 = OBJNULL;
2013
/* strm->sm.sm_int0 = strng->st.st_fillp; */
2014
STREAM_FILE_COLUMN(strm) = 0;
2015
vs_base[0] = strm;
2016
}
2017
2018
LFD(siLcopy_stream)()
2019
{
2020
object in, out;
2021
2022
check_arg(2);
2023
check_type_stream(&vs_base[0]);
2024
check_type_stream(&vs_base[1]);
2025
in = vs_base[0];
2026
out = vs_base[1];
2027
while (!stream_at_end(in))
2028
writec_stream(readc_stream(in), out);
2029
flush_stream(out);
2030
vs_base[0] = Ct;
2031
vs_popp;
2032
#ifdef AOSVS
2033
2034
#endif
2035
}
2036
2037
static void
2038
too_long_file_name(fn)
2039
object fn;
2040
{
2041
FEerror("~S is a too long file name.", 1, fn);
2042
}
2043
2044
static void
2045
cannot_open(fn)
2046
object fn;
2047
{
2048
FEerror("Cannot open the file ~A.", 1, fn);
2049
}
2050
2051
static void
2052
cannot_create(fn)
2053
object fn;
2054
{
2055
FEerror("Cannot create the file ~A.", 1, fn);
2056
}
2057
2058
static void
2059
cannot_read(strm)
2060
object strm;
2061
{
2062
FEerror("Cannot read the stream ~S.", 1, strm);
2063
}
2064
2065
static void
2066
cannot_write(strm)
2067
object strm;
2068
{
2069
FEerror("Cannot write to the stream ~S.", 1, strm);
2070
}
2071
2072
#ifdef USER_DEFINED_STREAMS
2073
/* more support for user defined streams */
2074
static void
2075
FFN(siLuser_stream_state)()
2076
{
2077
check_arg(1);
2078
2079
if(vs_base[0]->sm.sm_object1)
2080
vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0];
2081
else
2082
FEerror("sLtream data NULL ~S", 1, vs_base[0]);
2083
}
2084
#endif
2085
2086
static void
2087
closed_stream(strm)
2088
object strm;
2089
{
2090
if (!GET_STREAM_FLAG(strm,gcl_sm_had_error))
2091
{
2092
SET_STREAM_FLAG(strm,gcl_sm_had_error,1);
2093
FEerror("The stream ~S is already closed.", 1, strm);
2094
}
2095
2096
}
2097
2098
2099
2100
/* returns a stream with which one can safely do fwrite to the x->sm.sm_fp
2101
or nil.
2102
*/
2103
2104
2105
/* coerce stream to one so that x->sm.sm_fp is suitable for fread and fwrite,
2106
Return nil if this is not possible.
2107
*/
2108
2109
object
2110
coerce_stream(strm,out)
2111
object strm;
2112
int out;
2113
{
2114
BEGIN:
2115
if (type_of(strm) != t_stream)
2116
FEwrong_type_argument(sLstream, strm);
2117
switch (strm->sm.sm_mode){
2118
case smm_synonym:
2119
strm = symbol_value(strm->sm.sm_object0);
2120
if (type_of(strm) != t_stream)
2121
FEwrong_type_argument(sLstream, strm);
2122
goto BEGIN;
2123
2124
case smm_two_way:
2125
case smm_echo:
2126
if (out)strm = STREAM_OUTPUT_STREAM(strm);
2127
else strm = STREAM_INPUT_STREAM(strm);
2128
goto BEGIN;
2129
case smm_output:
2130
if (!out) cannot_read(strm);
2131
break;
2132
case smm_input:
2133
if (out) cannot_write(strm);
2134
break;
2135
case smm_io:
2136
/* case smm_socket: */
2137
break;
2138
2139
default:
2140
strm=Cnil;
2141
}
2142
if (strm!=Cnil
2143
&& (strm->sm.sm_fp == NULL))
2144
closed_stream(strm);
2145
return(strm);
2146
}
2147
2148
static void
2149
FFN(siLfp_output_stream)()
2150
{check_arg(1);
2151
vs_base[0]=coerce_stream(vs_base[0],1);
2152
}
2153
2154
static void
2155
FFN(siLfp_input_stream)()
2156
{check_arg(1);
2157
vs_base[0]=coerce_stream(vs_base[0],0);
2158
}
2159
2160
2161
@(static defun fwrite (vector start count stream)
2162
unsigned char *p;
2163
int n,beg;
2164
@
2165
stream=coerce_stream(stream,1);
2166
if (stream==Cnil) @(return Cnil);
2167
p = vector->ust.ust_self;
2168
beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
2169
n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
2170
if (fwrite(p+beg,1,n,stream->sm.sm_fp)) @(return Ct);
2171
@(return Cnil);
2172
@)
2173
2174
@(static defun fread (vector start count stream)
2175
char *p;
2176
int n,beg;
2177
@
2178
stream=coerce_stream(stream,0);
2179
if (stream==Cnil) @(return Cnil);
2180
p = vector->st.st_self;
2181
beg = ((type_of(start)==t_fixnum) ? fix(start) : 0);
2182
n = ((type_of(count)==t_fixnum) ? fix(count) : (vector->st.st_fillp - beg));
2183
if ((n=SAFE_FREAD(p+beg,1,n,stream->sm.sm_fp)))
2184
@(return `make_fixnum(n)`);
2185
@(return Cnil);
2186
@)
2187
2188
#ifdef HAVE_NSOCKET
2189
2190
#ifdef DODEBUG
2191
#define dprintf(s,arg) \
2192
do {fprintf(stderr,s,arg); \
2193
fflush(stderr); }\
2194
while(0)
2195
#else
2196
#define dprintf(s,arg)
2197
#endif
2198
2199
2200
2201
/*
2202
putCharGclSocket(strm,ch) -- put one character to a socket
2203
stream.
2204
Results:
2205
Side Effects: The buffer may be filled, and the fill pointer
2206
of the buffer may be changed.
2207
*/
2208
static void
2209
putCharGclSocket(strm,ch)
2210
object strm;
2211
int ch;
2212
{
2213
object bufp = SOCKET_STREAM_BUFFER(strm);
2214
2215
AGAIN:
2216
if (bufp->ust.ust_fillp < bufp->ust.ust_dim) {
2217
dprintf("getchar returns (%c)\n",bufp->ust.ust_self[-1+(bufp->ust.ust_fillp)]);
2218
bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=ch;
2219
return;
2220
}
2221
else {
2222
gclFlushSocket(strm);
2223
goto AGAIN;
2224
}
2225
}
2226
2227
static void
2228
gclFlushSocket(strm)
2229
object strm;
2230
2231
{
2232
int fd = SOCKET_STREAM_FD(strm);
2233
object bufp = SOCKET_STREAM_BUFFER(strm);
2234
int i=0;
2235
int err;
2236
int wrote;
2237
if (!GET_STREAM_FLAG(strm,gcl_sm_output)
2238
|| GET_STREAM_FLAG(strm,gcl_sm_had_error))
2239
return;
2240
#define AMT_TO_WRITE 500
2241
while(i< bufp->ust.ust_fillp) {
2242
wrote =TcpOutputProc ( fd,
2243
&(bufp->st.st_self[i]),
2244
bufp->ust.ust_fillp-i > AMT_TO_WRITE ? AMT_TO_WRITE : bufp->ust.ust_fillp-i,
2245
&err
2246
#ifdef __MINGW32__
2247
, TRUE /* Wild guess as to whether it should block or not */
2248
#endif
2249
);
2250
if (wrote < 0) {
2251
SET_STREAM_FLAG(strm,gcl_sm_had_error,1);
2252
close_stream(strm);
2253
FEerror("error writing to socket: errno= ~a",1,make_fixnum(err));
2254
2255
}
2256
i+= wrote;
2257
}
2258
bufp->ust.ust_fillp=0;
2259
}
2260
2261
static
2262
object
2263
make_socket_stream(fd,mode,server,host,port,async)
2264
int fd;
2265
enum gcl_sm_flags mode;
2266
object server;
2267
object host;
2268
object port;
2269
object async;
2270
{
2271
object x;
2272
if (fd < 0 )
2273
{
2274
FEerror("Could not connect",0);
2275
}
2276
x = alloc_object(t_stream);
2277
x->sm.sm_mode = smm_socket;
2278
x->sm.sm_buffer = 0;
2279
x->sm.sm_object0 = list(3,server,host,port);
2280
x->sm.sm_object1 = 0;
2281
x->sm.sm_int0 = x->sm.sm_int1 = 0;
2282
x->sm.sm_flags=0;
2283
SOCKET_STREAM_FD(x)= fd;
2284
SET_STREAM_FLAG(x,mode,1);
2285
SET_STREAM_FLAG(x,gcl_sm_tcp_async,(async!=Cnil));
2286
/*
2287
if (mode == gcl_sm_output)
2288
{ fp=fdopen(fd,(mode==gcl_sm_input ? "r" : "w"));
2289
if (fp==NULL) FEerror("Could not connect",0);
2290
x->sm.sm_fp = fp;
2291
setup_stream_buffer(x);
2292
} else
2293
*/
2294
{
2295
object buffer;
2296
x->sm.sm_fp = NULL;
2297
buffer=alloc_simple_string((BUFSIZ < 4096 ? 4096 : BUFSIZ));
2298
SOCKET_STREAM_BUFFER(x) =buffer;
2299
buffer->ust.ust_self = alloc_contblock(buffer->st.st_dim);
2300
buffer->ust.ust_fillp = 0;
2301
}
2302
return x;
2303
}
2304
2305
static object
2306
maccept(object x) {
2307
2308
int fd;
2309
socklen_t n;
2310
struct sockaddr_in addr;
2311
object server,host,port;
2312
2313
if (type_of(x) != t_stream)
2314
FEerror("~S is not a steam~%",1,x);
2315
if (x->sm.sm_mode!=smm_two_way)
2316
FEerror("~S is not a two-way steam~%",1,x);
2317
fd=accept(SOCKET_STREAM_FD(STREAM_INPUT_STREAM(x)),(struct sockaddr *)&addr,&n);
2318
if (fd <0) {
2319
FEerror("Error ~S on accepting connection to ~S~%",2,make_simple_string(strerror(errno)),x);
2320
x=Cnil;
2321
} else {
2322
server=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_car;
2323
host=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_car;
2324
port=STREAM_INPUT_STREAM(x)->sm.sm_object0->c.c_cdr->c.c_cdr->c.c_car;
2325
x = make_two_way_stream
2326
(make_socket_stream(fd,gcl_sm_input,server,host,port,Cnil),
2327
make_socket_stream(fd,gcl_sm_output,server,host,port,Cnil));
2328
}
2329
return x;
2330
2331
}
2332
2333
#ifdef BSD
2334
#include <sys/types.h>
2335
#include <sys/resource.h>
2336
#include <signal.h>
2337
2338
#if defined(DARWIN)
2339
#define on_exit(a,b)
2340
#else
2341
static void
2342
rmc(int e,void *pid) {
2343
2344
kill((long)pid,SIGTERM);
2345
2346
}
2347
#endif
2348
#endif
2349
2350
@(static defun socket (port &key host server async myaddr myport daemon)
2351
/*
2352
HOST is a string then connection is made to that
2353
ip or domain address.
2354
SERVER A function to call if this is to be a server
2355
2356
ASYNC socket returned immideiately. read or flush
2357
will block till open if in non blocking mode
2358
MYADDR client's ip address. Useful if have several
2359
net interfaces
2360
MYPORT port to use on client side
2361
*/
2362
int fd;
2363
int isServer = 0;
2364
int inPort;
2365
char buf1[500];
2366
char buf2[500];
2367
char *myaddrPtr=buf1,*hostPtr=buf2;
2368
object x=Cnil;
2369
@
2370
if (type_of(host) == t_string) {
2371
hostPtr=lisp_copy_to_null_terminated(host,hostPtr,sizeof(buf1));
2372
} else { hostPtr = NULL; }
2373
2374
if (fLfunctionp(server) == Ct) {
2375
isServer=1;
2376
}
2377
2378
if (myaddr != Cnil) {
2379
myaddrPtr=lisp_copy_to_null_terminated(myaddr,myaddrPtr,sizeof(buf2));
2380
} else { myaddrPtr = NULL; }
2381
if (isServer == 0 && hostPtr == NULL) {
2382
FEerror("You must supply at least one of :host hostname or :server function",0);
2383
}
2384
Iis_fixnum(port);
2385
inPort = (myport == Cnil ? 0 : fix(Iis_fixnum(myport)));
2386
2387
#ifdef BSD
2388
if (isServer && daemon != Cnil) {
2389
2390
long pid,i;
2391
struct rlimit r;
2392
struct sigaction sa;
2393
2394
sa.sa_handler=SIG_IGN;
2395
sa.sa_flags=SA_NOCLDWAIT;
2396
sigemptyset(&sa.sa_mask);
2397
2398
sigaction(SIGCHLD,&sa,NULL);
2399
2400
switch((pid=fork())) {
2401
case -1:
2402
FEerror("Cannot fork", 0);
2403
break;
2404
case 0:
2405
2406
if (setsid()<0)
2407
FEerror("setsid error", 0);
2408
2409
if (daemon == sKpersistent)
2410
switch(fork()) {
2411
case -1:
2412
FEerror("daemon fork error", 0);
2413
break;
2414
case 0:
2415
break;
2416
default:
2417
exit(0);
2418
break;
2419
}
2420
2421
memset(&r,0,sizeof(r));
2422
if (getrlimit(RLIMIT_NOFILE,&r))
2423
FEerror("Cannot get resourse usage",0);
2424
2425
for (i=0;i<r.rlim_cur;i++)
2426
close(i);
2427
errno=0;
2428
2429
if ((i=open("/dev/null",O_RDWR))==-1)
2430
FEerror("Can't open /dev/null for stdin",0);
2431
if ((i=dup(i))==-1)
2432
FEerror("Can't dup",0);
2433
if ((i=dup(i))==-1)
2434
FEerror("Can't dup twice",0);
2435
2436
if (chdir("/"))
2437
FEerror("Cannot chdir to /",0);
2438
2439
umask(0);
2440
2441
fd = CreateSocket(fix(port),hostPtr,isServer,myaddrPtr,inPort,(async!=Cnil));
2442
2443
x = make_two_way_stream
2444
(make_socket_stream(fd,gcl_sm_input,server,host,port,async),
2445
make_socket_stream(fd,gcl_sm_output,server,host,port,async));
2446
2447
for (;;) {
2448
2449
fd_set fds;
2450
object y;
2451
2452
FD_ZERO(&fds);
2453
FD_SET(fd,&fds);
2454
i=select(fd+1,&fds,NULL,NULL,NULL);
2455
2456
if (i>0) {
2457
2458
y=maccept(x);
2459
2460
sigaction(SIGCHLD,&sa,NULL);
2461
2462
switch((pid=fork())) {
2463
case 0:
2464
ifuncall1(server,y);
2465
exit(0);
2466
break;
2467
case -1:
2468
abort();
2469
break;
2470
default:
2471
close_stream(y);
2472
break;
2473
}
2474
2475
}
2476
}
2477
break;
2478
default:
2479
if (daemon != sKpersistent) {
2480
on_exit(rmc,(void *)pid);
2481
x=make_fixnum(pid);
2482
} else
2483
x=Cnil;
2484
break;
2485
}
2486
2487
} else
2488
2489
#endif
2490
2491
{
2492
fd = CreateSocket(fix(port),hostPtr,isServer,myaddrPtr,inPort,(async!=Cnil));
2493
2494
x = make_two_way_stream
2495
(make_socket_stream(fd,gcl_sm_input,server,host,port,async),
2496
make_socket_stream(fd,gcl_sm_output,server,host,port,async));
2497
2498
}
2499
2500
@(return `x`);
2501
2502
@)
2503
2504
DEF_ORDINARY("MYADDR",sKmyaddr,KEYWORD,"");
2505
DEF_ORDINARY("MYPORT",sKmyport,KEYWORD,"");
2506
DEF_ORDINARY("ASYNC",sKasync,KEYWORD,"");
2507
DEF_ORDINARY("HOST",sKhost,KEYWORD,"");
2508
DEF_ORDINARY("SERVER",sKserver,KEYWORD,"");
2509
DEF_ORDINARY("DAEMON",sKdaemon,KEYWORD,"");
2510
DEF_ORDINARY("PERSISTENT",sKpersistent,KEYWORD,"");
2511
DEF_ORDINARY("SOCKET",sSsocket,SI,"");
2512
2513
2514
@(static defun accept (x)
2515
@
2516
x=maccept(x);
2517
@(return `x`);
2518
@)
2519
2520
#endif /* HAVE_NSOCKET */
2521
2522
object standard_io;
2523
DEFVAR("*STANDARD-INPUT*",sLAstandard_inputA,LISP,(gcl_init_file(),standard_io),"");
2524
DEFVAR("*STANDARD-OUTPUT*",sLAstandard_outputA,LISP,standard_io,"");
2525
DEFVAR("*ERROR-OUTPUT*",sLAerror_outputA,LISP,standard_io,"");
2526
DEFVAR("*TERMINAL-IO*",sLAterminal_ioA,LISP,terminal_io,"");
2527
DEFVAR("*QUERY-IO*",sLAquery_ioA,LISP,
2528
(standard_io->sm.sm_object0 = sLAterminal_ioA,
2529
standard_io),"");
2530
DEFVAR("*DEBUG-IO*",sLAdebug_ioA,LISP,standard_io,"");
2531
DEFVAR("*TRACE-OUTPUT*",sLAtrace_outputA,LISP,standard_io,"");
2532
2533
2534
void
2535
gcl_init_file(void)
2536
{
2537
object standard_input;
2538
object standard_output;
2539
object standard;
2540
object x;
2541
standard_input = alloc_object(t_stream);
2542
standard_input->sm.sm_mode = (short)smm_input;
2543
standard_input->sm.sm_fp = stdin;
2544
standard_input->sm.sm_buffer = 0;
2545
standard_input->sm.sm_object0 = sLstring_char;
2546
standard_input->sm.sm_object1
2547
#ifdef UNIX
2548
= make_simple_string("stdin");
2549
#endif
2550
standard_input->sm.sm_int0 = 0; /* unused */
2551
standard_input->sm.sm_int1 = 0; /* unused */
2552
2553
standard_output = alloc_object(t_stream);
2554
standard_output->sm.sm_mode = (short)smm_output;
2555
standard_output->sm.sm_fp = stdout;
2556
standard_output->sm.sm_buffer = 0;
2557
standard_output->sm.sm_object0 = sLstring_char;
2558
standard_output->sm.sm_object1
2559
#ifdef UNIX
2560
= make_simple_string("stdout");
2561
#endif
2562
standard_output->sm.sm_int0 = 0; /* unused */
2563
STREAM_FILE_COLUMN(standard_output) = 0;
2564
2565
terminal_io = standard
2566
= make_two_way_stream(standard_input, standard_output);
2567
enter_mark_origin(&terminal_io);
2568
2569
x = alloc_object(t_stream);
2570
x->sm.sm_mode = (short)smm_synonym;
2571
x->sm.sm_fp = NULL;
2572
x->sm.sm_buffer = 0;
2573
x->sm.sm_object0 = sLAterminal_ioA;
2574
x->sm.sm_object1 = OBJNULL;
2575
x->sm.sm_int0 = x->sm.sm_int1 = 0; /* unused */
2576
standard_io = x;
2577
enter_mark_origin(&standard_io);
2578
2579
}
2580
2581
DEFVAR("*IGNORE-EOF-ON-TERMINAL-IO*",sSAignore_eof_on_terminal_ioA,SI,Cnil,"");
2582
DEFVAR("*LOAD-PATHNAME*",sSAload_pathnameA,SI,Cnil,"");
2583
DEFVAR("*LOAD-VERBOSE*",sLAload_verboseA,LISP,Ct,"");
2584
2585
DEF_ORDINARY("ABORT",sKabort,KEYWORD,"");
2586
DEF_ORDINARY("APPEND",sKappend,KEYWORD,"");
2587
DEF_ORDINARY("CREATE",sKcreate,KEYWORD,"");
2588
DEF_ORDINARY("DEFAULT",sKdefault,KEYWORD,"");
2589
DEF_ORDINARY("DIRECTION",sKdirection,KEYWORD,"");
2590
DEF_ORDINARY("ELEMENT-TYPE",sKelement_type,KEYWORD,"");
2591
DEF_ORDINARY("ERROR",sKerror,KEYWORD,"");
2592
DEF_ORDINARY("IF-DOES-NOT-EXIST",sKif_does_not_exist,KEYWORD,"");
2593
DEF_ORDINARY("IF-EXISTS",sKif_exists,KEYWORD,"");
2594
DEF_ORDINARY("INPUT",sKinput,KEYWORD,"");
2595
DEF_ORDINARY("IO",sKio,KEYWORD,"");
2596
DEF_ORDINARY("NEW-VERSION",sKnew_version,KEYWORD,"");
2597
DEF_ORDINARY("OUTPUT",sKoutput,KEYWORD,"");
2598
DEF_ORDINARY("OVERWRITE",sKoverwrite,KEYWORD,"");
2599
DEF_ORDINARY("PRINT",sKprint,KEYWORD,"");
2600
DEF_ORDINARY("PROBE",sKprobe,KEYWORD,"");
2601
DEF_ORDINARY("RENAME",sKrename,KEYWORD,"");
2602
DEF_ORDINARY("RENAME-AND-DELETE",sKrename_and_delete,KEYWORD,"");
2603
DEF_ORDINARY("SET-DEFAULT-PATHNAME",sKset_default_pathname,KEYWORD,"");
2604
DEF_ORDINARY("SUPERSEDE",sKsupersede,KEYWORD,"");
2605
DEF_ORDINARY("VERBOSE",sKverbose,KEYWORD,"");
2606
2607
2608
2609
2610
void
2611
gcl_init_file_function()
2612
{
2613
2614
2615
#ifdef UNIX
2616
FASL_string = make_simple_string("o");
2617
make_si_constant("*EOF*",make_fixnum(EOF));
2618
#endif
2619
#ifdef AOSVS
2620
2621
#endif
2622
enter_mark_origin(&FASL_string);
2623
#ifdef UNIX
2624
LSP_string = make_simple_string("lsp");
2625
#endif
2626
#ifdef AOSVS
2627
2628
#endif
2629
enter_mark_origin(&LSP_string);
2630
make_si_function("FP-INPUT-STREAM", siLfp_input_stream);
2631
make_si_function("FP-OUTPUT-STREAM", siLfp_output_stream);
2632
2633
make_function("MAKE-SYNONYM-STREAM", Lmake_synonym_stream);
2634
make_function("MAKE-BROADCAST-STREAM", Lmake_broadcast_stream);
2635
make_function("MAKE-CONCATENATED-STREAM",
2636
Lmake_concatenated_stream);
2637
make_function("MAKE-TWO-WAY-STREAM", Lmake_two_way_stream);
2638
make_function("MAKE-ECHO-STREAM", Lmake_echo_stream);
2639
make_function("MAKE-STRING-INPUT-STREAM",
2640
Lmake_string_input_stream);
2641
make_function("MAKE-STRING-OUTPUT-STREAM",
2642
Lmake_string_output_stream);
2643
make_function("GET-OUTPUT-STREAM-STRING",
2644
Lget_output_stream_string);
2645
2646
make_si_function("OUTPUT-STREAM-STRING", siLoutput_stream_string);
2647
make_si_function("FWRITE",Lfwrite);
2648
make_si_function("FREAD",Lfread);
2649
#ifdef HAVE_NSOCKET
2650
make_si_function("SOCKET",Lsocket);
2651
make_si_function("ACCEPT",Laccept);
2652
#endif
2653
make_function("STREAMP", Lstreamp);
2654
make_function("INPUT-STREAM-P", Linput_stream_p);
2655
make_function("OUTPUT-STREAM-P", Loutput_stream_p);
2656
make_function("STREAM-ELEMENT-TYPE", Lstream_element_type);
2657
make_function("CLOSE", Lclose);
2658
2659
make_function("OPEN", Lopen);
2660
2661
make_function("FILE-POSITION", Lfile_position);
2662
make_function("FILE-LENGTH", Lfile_length);
2663
2664
make_function("LOAD", Lload);
2665
2666
make_si_function("GET-STRING-INPUT-STREAM-INDEX",
2667
siLget_string_input_stream_index);
2668
make_si_function("MAKE-STRING-OUTPUT-STREAM-FROM-STRING",
2669
siLmake_string_output_stream_from_string);
2670
make_si_function("COPY-STREAM", siLcopy_stream);
2671
2672
#ifdef USER_DEFINED_STREAMS
2673
make_si_function("USER-STREAM-STATE", siLuser_stream_state);
2674
#endif
2675
2676
#ifdef HAVE_READLINE
2677
gcl_init_readline_function();
2678
#endif
2679
}
2680
2681
2682
object
2683
read_fasl_data(const char *str) {
2684
2685
object faslfile, data;
2686
#ifndef SEEK_TO_END_OFILE
2687
#if defined(BSD) && defined(UNIX)
2688
FILE *fp;
2689
int i;
2690
#ifdef HAVE_AOUT
2691
struct exec header;
2692
#endif
2693
#endif
2694
#ifdef HAVE_FILEHDR
2695
struct filehdr fileheader;
2696
#endif
2697
#ifdef E15
2698
struct exec header;
2699
#endif
2700
#endif
2701
vs_mark;
2702
2703
faslfile = make_simple_string(str);
2704
vs_push(faslfile);
2705
faslfile = open_stream(faslfile, smm_input, Cnil, sKerror);
2706
vs_push(faslfile);
2707
2708
#ifdef SEEK_TO_END_OFILE
2709
SEEK_TO_END_OFILE(faslfile->sm.sm_fp);
2710
#else
2711
2712
#ifdef BSD
2713
fp = faslfile->sm.sm_fp;
2714
fread(&header, sizeof(header), 1, fp);
2715
fseek(fp,
2716
header.a_text+header.a_data+
2717
header.a_syms+header.a_trsize+header.a_drsize,
2718
1);
2719
fread(&i, sizeof(i), 1, fp);
2720
fseek(fp, i - sizeof(i), 1);
2721
#endif
2722
2723
#ifdef HAVE_FILEHDR
2724
fp = faslfile->sm.sm_fp;
2725
fread(&fileheader, sizeof(fileheader), 1, fp);
2726
fseek(fp,
2727
fileheader.f_symptr+fileheader.f_nsyms*SYMESZ,
2728
0);
2729
fread(&i, sizeof(i), 1, fp);
2730
fseek(fp, i - sizeof(i), 1);
2731
while ((i = getc(fp)) == 0)
2732
;
2733
ungetc(i, fp);
2734
#endif
2735
2736
#ifdef E15
2737
fp = faslfile->sm.sm_fp;
2738
fread(&header, sizeof(header), 1, fp);
2739
fseek(fp,
2740
header.a_text+header.a_data+
2741
header.a_syms+header.a_trsize+header.a_drsize,
2742
1);
2743
#endif
2744
#endif
2745
data = read_fasl_vector(faslfile);
2746
2747
vs_push(data);
2748
close_stream(faslfile);
2749
vs_reset;
2750
return(data);
2751
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1