File: unix.c

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (687 lines) | stat: -rw-r--r-- 18,094 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
/* Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
   See file COPYING. */

/*
   If you have concrete suggestions for improvements, they are quite
   welcome.  Please send them to scheme-48-bugs@martigny.ai.mit.edu.

   Non-Posixisms:

   The most annoying thing here is char_ready_p, which is needed for
   R^nRS and is nonportable in two different ways.  There's no
   portable (Posix or anything else) way to figure whether a stdio
   stream has buffered input.  And even if we knew that, there's no
   portable way to find out whether input would block - select() seems
   to be a BSD thing, and AT&T's ioctl() doesn't work for arbitrary
   devices.  If it can't figure out what to do, it just prints a
   warning and returns #t.

   setitimer(), a Berkeleyism, is used if it's available; otherwise
   alarm() is used, which only has 1-second resolution.  Timer
   interrupts are used by the threads apckage but not by the base
   system.

   gettimeofday() is BSD.  ftime() is Version 7 (!).  The POSIX.1/ANSI
   C alternative to these is time(), which returns a number of
   seconds.  There seems to be some disagreement over the number of
   arguments to gettimeofday().

   nlist() derives from ancient Version 6 and 7 unix, so it's pretty
   widespread, but everyone wants to phase it out because it's not
   very abstract.

   Access to a COFF symbol table via ldtbread is even less abstract,
   really sucks in general, and should be banned from earth.
   Probably only AIX needs it because of the broken nlist.

   Posix/ANSI C things used:
     feof fopen fprintf perror strlen strncpy etc.
     time (if gettimeofday and ftime are unavailable)

   Posix things used: (beware, PC and Mac hackers)
     alarm (if setitimer is unavailable)
     fileno (but only when select is being used)
     getenv getpwnam sigaction sysconf
     times  -- clock() is ANSI but wraps around every 36 minutes

   Other things used (BSD etc.), only when available:
     ftime (if gettimeofday is unavailable)
     gettimeofday
     nlist
     select
     setitimer

   <time.h> is ANSI C, but we apparently don't use anything from it
   that is part of ANSI C.  Under HPUX, the man pages tell one to
   use it in order to get declarations for the things that under SunOS
   are declared in <sys/time.h>.  Oh well, it can't hurt, can it?  Oh
   yeah, this is Unix, of course it can...
*/

#include "sysdep.h"

#include <stdio.h>
#include <stdlib.h>		/* for getenv(), etc. (POSIX?/ANSI) */
#include <string.h>		/* for strncpy(), etc. (POSIX/ANSI) */
#include <pwd.h>		/* for getpwnam() (POSIX.1) */
#include <unistd.h>		/* for sysconf() (POSIX.1/.2)*/
#include <sys/times.h>		/* for times() (POSIX.1) */
#include <signal.h>		/* for sigaction() (POSIX.1) */

#if defined(HAVE_POSIX_TIME_H)
#  include <posix/time.h>	/* RISC/OS + gcc lossage */
#  define _XOPEN_SOURCE 1
#else
#  include <time.h>
#endif

#if defined(HAVE_SETITIMER) || defined(HAVE_GETTIMEOFDAY)
#  include <sys/time.h>		/* for struct itimerval, ITIMER_REAL (Sun) */
#endif

#if defined(HAVE_SELECT)
#  include <sys/types.h>	/* for FD_SET and friends (BSD) */
#if defined(HAVE_SYS_SELECT_H)
#  include <sys/select.h>
#endif
#endif

#if defined(HAVE_SYS_TIMEB_H)
#  include <sys/timeb.h>	/* for ftime() */
#endif

#if defined(HAVE_NLIST_H)
#  include <nlist.h>		/* conforms to "SVID2", whatever that is */
#endif


#define INTERRUPT_ALARM     0	/* Cf. rts/arch.scm */
#define INTERRUPT_KEYBOARD  1

extern long Spending_interruptsS;


/* Signal handlers */

/* Note that we turn off SIGPIPE interrupts in a funny way -- we don't
** set the handler to SIGIGN, we set it to a no-op function. This is so
** that when we exec() some other program, the handler will be reset to
** its default, rather than to SIGIGN.
**
** We don't use SIGPIPE, because all write() calls in scsh correctly check
** for error returns, and raise an error exception. Sleazy Unix C programs,
** however, need to get shot down when writing to a closed pipe or socket.
**     -Olin 4/97
*/


static RETSIGTYPE
when_keyboard_interrupt(sig, code, scp)
     int sig, code;
     struct sigcontext *scp;
{
  Spending_interruptsS |= (1 << INTERRUPT_KEYBOARD);
  /* The following might be necessary with signal(), but shouldn't be
     with sigaction() (I think) */
  /* sigaction(SIGINT, &keyboard_action, NULL); */
  return;
}

static RETSIGTYPE
when_alarm_interrupt(sig, code, scp)
     int sig, code;
     struct sigcontext *scp;
{
  Spending_interruptsS |= (1 << INTERRUPT_ALARM);
  return;
}

static RETSIGTYPE
when_pipe_interrupt(sig, code, scp)
     int sig, code;
     struct sigcontext *scp;
{
  return;
}


/* OS-dependent initialization */

static struct sigaction keyboard_action;
static struct sigaction alarm_action;

void
sysdep_init()
{
  keyboard_action.sa_handler = when_keyboard_interrupt;
  keyboard_action.sa_flags = 0;
  sigemptyset(&keyboard_action.sa_mask);

  alarm_action.sa_handler = when_alarm_interrupt;
  alarm_action.sa_flags = 0;
  sigemptyset(&alarm_action.sa_mask);

  sigaction(SIGINT, &keyboard_action, NULL);

  /* SIGPIPE's are bogus. -Olin */
  {struct sigaction sa;
   sa.sa_handler = when_pipe_interrupt;
   sigemptyset(&sa.sa_mask);
   sa.sa_flags = 0;
   sigaction(SIGPIPE, &sa, NULL);
   }
}

/* ---------------------------------------- */
/* For char-ready? */

int
char_ready_p( FILE* stream )
{
  struct timeval timeout;
  static int warnedp = 0;

  if (feof(stream))
    return EOF;

#ifndef KLUDGY
  if (fbufcount(stream) > 0)
    return 1;
#else
  /* Grossly unportable examination of stdio buffer internals. */
#if defined(FILE_HAS__CNT)
  if (stream->_cnt)
    return 1;
#elif defined(__linux__)
  if (stream->_IO_read_ptr < stream->_IO_read_end)
    return 1;
#elif defined(BSD) && (BSD >= 199306)
  if (stream->_r)
    return 1;
#else

  /* Add new cases here AND SEND THEM TO scheme-48@martigny.ai.mit.edu
     SO THAT THEY CAN GO INTO THE NEXT RELEASE!  (That means you, Olin.)
     It's generally pretty easy to figure out what to put here by
     examining /usr/include/stdio.h.  If the input stream's buffer is
     nonempty, just return any positive value. */
  if (!warnedp) {
    fprintf(stderr, "Warning: incomplete char-ready? implementation.\n");
    warnedp = 1; }
  return 1;
#endif
#endif

  /* Nothing in the buffer.  Find out whether a read would block. */
#if defined(HAVE_SELECT)
  {  fd_set readfds;
     FD_ZERO(&readfds);
     FD_SET(fileno(stream), &readfds);
     timerclear(&timeout);
     return select1(FD_SETSIZE, &readfds, NULL, NULL, &timeout);
     }
#else /* No select() - but there will generally be some other way to do this.*/
  if (!warnedp) {
    fprintf(stderr, "Warning: incomplete char-ready? implementation.\n");
    warnedp = 1; }
  return 1;
#endif
}

/* ---------------------------------------- */
/* For open-xxput-file */

FILE *
ps_open(char *filename, char *spec)
{
# define FILE_NAME_SIZE 256
  char filename_temp[FILE_NAME_SIZE];
  char *expanded;
  extern char *expand_file_name(char *, char *, int);

  expanded = expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
  if (expanded == NULL)
    return NULL;
  return fopen(expanded, spec);
}

/*
   Expanding Unix filenames
   Unix Sucks
   Richard Kelsey Wed Jan 17 21:40:26 EST 1990
   Later modified by others who wish to remain anonymous
   "ps_" stands for "Pre-Scheme"

   Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
   `buffer_len' is the length of `buffer'.

   Note: strncpy(x, y, n) copies from y to x.
*/

char *
expand_file_name (char *name, char *buffer, int buffer_len)
{
# define USER_NAME_SIZE 256
  char *dir, *p, user_name[USER_NAME_SIZE];
  struct passwd *user_data;
  int dir_len, i;
  extern char *getenv();
  int name_len = strlen(name);

  dir = 0;

  if (name[0] == '~') {
    name++; name_len--;

    if (name[0] == '/' || name[0] == 0) {
      dir = getenv("HOME"); }

    else {
      for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
	if (i > (USER_NAME_SIZE - 2)) {
	  fprintf(stderr,
		  "\nexpand_file_name: user name longer than %d characters\n",
		  USER_NAME_SIZE - 3);
	  return(NULL); };
      strncpy(user_name, name, i);
      user_name[i] = 0;
      user_data = getpwnam(user_name);
      if (!user_data) {
	fprintf(stderr, "\nexpand_file_name: unknown user \"%s\"\n",
		user_name);
	return(NULL); };
      name_len -= i;
      name = p;
      dir = user_data->pw_dir; } }

  else if (name[0] == '$') {
    name++; name_len--;

    for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
      if (i > (USER_NAME_SIZE - 2)) {
	fprintf(stderr,
		"\nexpand_file_name: environment variable longer than %d characters\n",
		USER_NAME_SIZE - 3);
	return(NULL); };
    strncpy(user_name, name, i);
    user_name[i] = 0;

    name_len -= i;
    name = p;
    dir = getenv(user_name); }

  if (dir) {
    dir_len = strlen(dir);
    if ((name_len + dir_len + 1) > buffer_len) {
      fprintf(stderr, "\nexpand_file_name: supplied buffer is too small\n");
      return(NULL); };
    strncpy(buffer, dir, dir_len);
    strncpy(buffer + dir_len, name, name_len);
    buffer[name_len + dir_len] = 0; }

  else {
    if ((name_len + 1) > buffer_len) {
      fprintf(stderr, "\nexpand_file_name: supplied buffer is too small\n");
      return(NULL); };
    strncpy(buffer, name, name_len);
    buffer[name_len] = 0; }

  return(buffer);
}

/* test routine
main(argc, argv)
  int argc;
  char *argv[];
{
  char buffer[32];
  expand_file_name(argv[1], buffer, 32);
  printf("%s\n", buffer);
  return(0);
}
*/

/* ---------------------------------------- */
/* Timer functions, for the time instruction.
   gettimeofday() version courtesy Basile Starynkevitch.

   From: Jim.Rees@umich.edu
   Date: Sun, 26 Dec 93 16:06:08 EST

   In unix.c, the gettimeofday code is wrong.  ...
   I suggest the following fix, which will work on both sysV and bsd
   machines.  If you (or your compiler) are squeamish about passing
   too many parameters in to a system call, you might want to do it
   differently....
 */

#define TICKS_PER_SECOND 1000	/* should agree with ps_real_time() */

long
ps_real_time()
{
#if defined(HAVE_GETTIMEOFDAY)
  struct timeval tv;
  static struct timeval tv_orig;
  static int initp = 0;
  if (!initp) {
    gettimeofday(&tv_orig, NULL);
    initp = 1;
  };
  gettimeofday(&tv, NULL);
  return ((long)((tv.tv_sec - tv_orig.tv_sec)*TICKS_PER_SECOND
		 + (tv.tv_usec - tv_orig.tv_usec)/(1000000/TICKS_PER_SECOND)));
#elif defined(HAVE_FTIME)
  struct timeb tb;
  static struct timeb tb_origin;
  static int initp = 0;
  if (!initp) {
    ftime(&tb_origin);
    initp = 1;
  }
  ftime(&tb);
  return((long)((tb.time - tb_origin.time) * TICKS_PER_SECOND
		+ (tb.millitm / (1000 / TICKS_PER_SECOND))));
#else
  return (long)time(NULL) * TICKS_PER_SECOND;
#endif /*HAVE_GETTIMEOFDAY */
}

long
ps_run_time()
{
  struct tms time_buffer;
  static long clock_tick = 0;

  if (clock_tick == 0)
    clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
  times(&time_buffer);		/* On Sun, getrusage() would be better */
  return((long)(time_buffer.tms_utime * TICKS_PER_SECOND) / clock_tick);
}

long
ps_ticks_per_second()
{
  return TICKS_PER_SECOND;
}

long
ps_schedule_interrupt(long delay)
{
  sigaction(SIGALRM, &alarm_action, NULL);

#if defined(HAVE_SETITIMER)
  { struct itimerval new, old;

    delay = delay * (1000000 / TICKS_PER_SECOND);
    new.it_value.tv_sec = delay / 1000000;
    new.it_value.tv_usec = delay % 1000000;
    new.it_interval.tv_sec = 0;
    new.it_interval.tv_usec = 0;
    if (0 == setitimer(ITIMER_REAL, &new, &old))
      return (old.it_value.tv_usec + 1000000 * old.it_value.tv_sec)
	/ (1000000 / TICKS_PER_SECOND);
    else {
      perror("setitimer");
      return -1;
    }
  }
#else
  /* Round up to nearest second.  0 means cancel... */
  return alarm((delay + TICKS_PER_SECOND - 1) / TICKS_PER_SECOND)
	   * TICKS_PER_SECOND;
#endif
}

/*
** External symbol / foreign-function interface.
*******************************************************************************
** This code is ifdef'd. You must arrange it so that when it is handed a C
** identifier "foo" it looks up the corresponding a.out identifier, which can
** be "_foo" or "foo" or perhaps something else entirely.
**
** If USCORE is defined, then (get-external-name "main") will look up
** the a.out symbol "_main". If USCORE is undefined, the it simply looks
** up "main".
**
** lookup_external_name(name, loc):
** - On success, stores location in "loc" and returns 1.
** - On failure, returns 0.
*/

#if defined(_AIX)

/* The problem with AIX is threefold:
   - AIX throws away unused symbols during linking.
     Since the externals only get referenced at runtime, ld throws them out.
     This can, in theory, be turned off by the "nogc" option, but when
     that is used, all hell breaks lose.
   - AIX nlist lies: if you ask for "foobar", and there is a symbol "foo" in
     the symbol table before "foobar", it will give you the value for "foo".
   - AIX function pointers from the symbol table cannot be used directly:
     Rather, all jumps are indirect.  Therefore, the externals mechanism needs
     to set up an "activation record" which contains the actual pointer, followed
     by a toc value which is loaded into r2 in function activation.  I'm not sure what
     the third one is for.  Even then, an offset is involved which is calculated using
     the data of the "main" procedure. */

#include <filehdr.h>
#include <syms.h>
#include <ldfcn.h>

struct s_symbol_table {
    char *name;
    void *value;
    struct s_symbol_table *next;
};

static struct s_symbol_table *the_table = NULL;

#define MALLOC_TO(name, size) \
  if (((name) = malloc(size)) == NULL) { \
    fprintf(stderr, "Malloc error during external name lookup\n"); \
    return; \
  }

static void
fill_the_table(void)
{
  extern char *get_reloc_file();
  char *reloc_info_file;
  LDFILE *f;
  SYMENT entry;
  long i;
  struct s_symbol_table *cur_entry;

  reloc_info_file = get_reloc_file();

  if (reloc_info_file == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }

  if ((f = ldopen(reloc_info_file, NULL)) == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }

  if (!ldtbseek(f)) {
    ldclose(f);
    fprintf(stderr, "Error during external name lookup\n");
    return;
  }

  cur_entry = the_table;


  for (;;) {
    i = ldtbindex(f);
    if (!ldtbread(f, i, &entry))
      break;
    if (entry.n_sclass == C_EXT &&
	entry.n_scnum != N_UNDEF &&
	entry.n_scnum != N_DEBUG)
      {
	extern char *ldgetname(LDFILE *, SYMENT *);
	char *p = ldgetname(f, &entry);

	if (p != NULL && p[0] == '.') {
	  struct s_symbol_table *last_entry = cur_entry;

	  MALLOC_TO(cur_entry, sizeof(struct s_symbol_table));
	  MALLOC_TO(cur_entry->name, strlen(p));
	  strcpy(cur_entry->name, p+1); /* skip the dot */
	  cur_entry->value = (void *) entry.n_value;
	  if (!last_entry)
	    the_table = cur_entry;
	  else
	    last_entry->next = cur_entry;
	}
      }
  }

  if (cur_entry)
    cur_entry->next = NULL;

  ldclose(f);
}

static long
really_lookup_external_name(char *name)
{
  struct s_symbol_table *entry = the_table;

  while (entry) {
    if (!strcmp(entry->name, name))
      return((long) entry->value);
    entry = entry->next;
  }
  return(0);
}

long
lookup_external_name(char *name, long *location)
{
  long r;
  static long val_offset;
  extern int main();

  if (!the_table) {
    fill_the_table();
    val_offset =
      *((unsigned long *) ((void (*)()) main)) - really_lookup_external_name("main");
  }

  r = really_lookup_external_name(name);

  if (r) {
    unsigned long *activate;

    MALLOC_TO(activate, 3 * sizeof(unsigned long));
    memcpy(activate, (void *) main, 3 * sizeof(unsigned long));
    ((unsigned long *)activate)[0] = r + val_offset;
    *location = (long) activate;
    return(1);
  } else
    return(0);
}

#else /* i.e. #if !defined(_AIX) */

#if defined(__hpux)
#include <dl.h>
lookup_external_name (char *name, long *location )
{
    int ret;
    shl_t shlh = PROG_HANDLE;
    *location = 0xdeadbeef;
    ret = shl_findsym (&shlh, name, TYPE_UNDEFINED, location);
    return (!ret);
}

#else /* i.e. #if !defined(__hpux) && !defined(_AIX) */

#if !defined(NLIST_HAS_N_NAME)
#define n_name	n_un.n_name
#endif

long
lookup_external_name(char *name, long *location)
{
  int namelen = strlen(name);
  char buf[20], *nm;

#if defined(HAVE_DLOPEN)
  extern int lookup_dlsym(char*, long*);
#elif defined(HAVE_NLIST)
  extern char *get_reloc_file();
  char *reloc_info_file;
  struct nlist name_list[2];
  int status;
#endif

  /* Compute the actual string being looked up. */
  /* Compute the length of the actual a.out symbol. */
#ifdef USCORE
  namelen++;
#endif

  nm = (namelen<20) ? buf : (char*) malloc(namelen+1);
  if (!nm) {
    fputs("Malloc error in lookup_external_name.\n", stderr);
    return(0);
  }

  /* Build the symbol in nm. */
#ifdef USCORE
  nm[0] = '_';
  strcpy(nm+1,name);
#else
  strcpy(nm,name);
#endif /*! HAVE_DLOPEN */
#if defined(HAVE_DLOPEN)
  return lookup_dlsym(nm, location);
#elif defined(HAVE_NLIST)

  reloc_info_file = get_reloc_file();

  if (reloc_info_file == NULL) {
    fprintf(stderr, "Error during external name lookup\n");
    return(0);
  }

  name_list[0].n_name = nm;
  name_list[1].n_name = 0;

  status = nlist(reloc_info_file, name_list);

  if (status != 0 || (name_list[0].n_value  == 0
		      && name_list[0].n_type == 0))
    return 0;
  else {
    *location = name_list[0].n_value;
    return 1;
  }
#else
  return 0;
#endif /*! HAVE_DLOPEN */
}

#endif /* !defined(__hpux) */
#endif /* !defined(AIX) */

extern char *object_file;   /* specified via a command line argument */
extern char *reloc_file;    /* dynamic loading will set this */

char *
get_reloc_file()
{
  if (reloc_file != NULL)
    return(reloc_file);
  if (object_file != NULL)
    return(object_file);
  else {
    fprintf(stderr, "Object file not specified on command line\n");
    return(NULL);
  }
}