diff --git a/scsh/aix/Makefile.inc b/scsh/aix/Makefile.inc deleted file mode 100644 index 826e6fe..0000000 --- a/scsh/aix/Makefile.inc +++ /dev/null @@ -1,8 +0,0 @@ -AIX_P = exportlist.aix - -exportlist.aix: $(OBJS) - $(RM) exportlist.aix - for f in $(OBJS); do \ - /usr/ccs/bin/nm -B -e $$f | grep ' T [^ ][^ ]*$$' | \ - sed -e 's/^.* T \.*\([^ ][^ ]*\)$$/\1/' >> exportlist.aix; \ - done; diff --git a/scsh/aix/bufpol.scm b/scsh/aix/bufpol.scm deleted file mode 100644 index 1829ecb..0000000 --- a/scsh/aix/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o100) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/aix/errno.scm b/scsh/aix/errno.scm deleted file mode 100644 index 4c976e2..0000000 --- a/scsh/aix/errno.scm +++ /dev/null @@ -1,140 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. -;;; AIX version by Chipsy Sperber - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes - (again 11) ; Resource temporarily unavailable - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - (notblk 15) ; Block device required - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation - (xtbsy 26) ; Text file busy - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; POSIX: - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - (nomsg 35) ; No message of desired type - (idrm 36) ; Identifier removed - (chrng 37) ; Channel number out of range - (l2nsync 38) ; Level 2 not synchronized - (l3hlt 39) ; Level 3 halted - (l3rst 40) ; Level 3 reset - (lnrng 41) ; Link number out of range - (unatch 42) ; Protocol driver not attached - (nocsi 43) ; No CSI structure available - (l2hlt 44) ; Level 2 halted - (deadlk 45) ; Resource deadlock avoided - - (notready 46) ; Device not ready - (wrprotect 47) ; Write-protected media - (format 48) ; Unformatted media - - (nolck 49) ; No locks available - - ;; non-blocking and interrupt i/o - (wouldblock 54) ; Operation would block - - (inprogress 55) ; Operation now in progress - (already 56) ; Operation already in progress - - ;; ipc/network software - (notsock 57) ; Socket operation on non-socket - (destaddrreq 58) ; Destination address required - (msgsize 59) ; Message too long - (prototype 60) ; Protocol wrong type for socket - (noprotoopt 61) ; Protocol not available - (protonosupport 62) ; Protocol not supported - (socktnosupport 63) ; Socket type not supported - (opnotsupp 64) ; Operation not supported on socket - (pfnosupport 65) ; Protocol family not supported - (afnosupport 66) ; Address family not supported by protocol family - (addrinuse 67) ; Address already in use - (addrnotavail 68) ; Can't assign requested address - (netdown 69) ; Network is down - (netunreach 70) ; Network is unreachable - (netreset 71) ; Network dropped connection on reset - (connaborted 72) ; Software caused connection abort - (connreset 73) ; Connection reset by peer - (nobufs 74) ; No buffer space available - (isconn 75) ; Socket is already connected - (notconn 76) ; Socket is not connected - (shutdown 77) ; Can't send after socket shutdown - - (timedout 78) ; Connection timed out - (connrefused 79) ; Connection refused - - (hostdown 80) ; Host is down - (hostunreach 81) ; No route to host - - (restart 82) ; restart the system call - - ;; quotas and limits - (proclim 83) ; Too many processes - (users 84) ; Too many users - (loop 85) ; Too many levels of symbolic links - (nametoolong 86) ; File name too long - - (notempty 87) ; Directory not empty - (dquot 88) ; Disc quota exceeded - - ;; network file system - (remote 93) ; Item is not local to host - - (nosys 109) ; Function not implemented POSIX - - ;; disk device driver - (media 110) ; media surface error - (soft 111) ; I/O completed, but needs relocation - - ;; security - (noattr 112) ; no attribute found - (sad 113) ; security authentication denied - (notrust 114) ; not a trusted program - - ;; BSD 4.3 RENO - (toomanyrefs 115) ; Too many references: can't splice - - (ilseq 116) ; Invalid wide character - (canceled 117) ; asynchronous i/o cancelled - - ;; SVR4 STREAMS - (nosr 118) ; temp out of streams resources - (time 119) ; I_STR ioctl timed out - (badmsg 120) ; wrong message type at stream head - (proto 121) ; STREAMS protocol error - (nodata 122) ; no message ready at stream head - (nostr 123) ; fd is not a stream - - (cloneme 82) ; this is the way we clone a stream -) diff --git a/scsh/aix/fdflags.scm b/scsh/aix/fdflags.scm deleted file mode 100644 index 5b9fb0a..0000000 --- a/scsh/aix/fdflags.scm +++ /dev/null @@ -1,48 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. -;;; AIX version by Chipsy Sperber - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #x0100) - (exclusive #x0400) - (no-control-tty #x0800) - (nonblocking #x0004) - (truncate #x0200) - -;;; Not POSIX. - (no-delay #x8000) - (sync #x0010)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/aix/libansi.c b/scsh/aix/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/aix/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/aix/netconst.scm b/scsh/aix/netconst.scm deleted file mode 100644 index 39a5af4..0000000 --- a/scsh/aix/netconst.scm +++ /dev/null @@ -1,133 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables -(define message/eor #x8) ; data completes record -(define message/trunc #x10) ; data discarded before delivery -(define message/ctrunc #x20) ; control data lost before delivery -(define message/waitall #x40) ; wait for full request or error - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/include-header 2) ; int; header is included with data (raw) -(define ip/type-of-service 3) ; int; IP type of service and precedence -(define ip/time-to-live 4) ; int; IP time to live -(define ip/recvopt 5) ; bool; receive all IP options w/datagram -(define ip/recvret 6) ; bool; receive IP options for response -(define ip/recvdst 7) ; bool; receive IP dst addr w/datagram -(define ip/retopts 8) ; ip_opts; set/get IP per-packet options - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - ip/include-header - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - ip/type-of-service - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/aix/packages.scm b/scsh/aix/packages.scm deleted file mode 100644 index 7bb97d2..0000000 --- a/scsh/aix/packages.scm +++ /dev/null @@ -1,143 +0,0 @@ -;;; Interfaces and packages for the machine specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. -;;; AIX version by Chipsy Sperber - -(define-interface aix-fdflags-extras-interface - (export open/no-delay - open/sync)) - -(define-interface aix-errno-extras-interface - (export errno/nomsg - errno/idrm - errno/chrng - errno/l2nsync - errno/l3hlt - errno/l3rst - errno/lnrng - errno/unatch - errno/nocsi - errno/l2hlt - errno/notready - errno/wrprotect - errno/format - errno/wouldblock - errno/inprogress - errno/already - errno/notsock - errno/destaddrreq - errno/msgsize - errno/prototype - errno/noprotoopt - errno/protonosupport - errno/socktnosupport - errno/opnotsupp - errno/pfnosupport - errno/afnosupport - errno/addrinuse - errno/addrnotavail - errno/netdown - errno/netunreach - errno/netreset - errno/connaborted - errno/connreset - errno/nobufs - errno/isconn - errno/notconn - errno/shutdown - errno/timedout - errno/connrefused - errno/hostdown - errno/hostunreach - errno/restart - errno/proclim - errno/users - errno/loop - errno/dquot - errno/remote - errno/media - errno/soft - errno/noattr - errno/sad - errno/notrust - errno/toomanyrefs - errno/ilseq - errno/canceled - errno/nosr - errno/time - errno/badmsg - errno/proto - errno/nodata - errno/nostr - errno/cloneme)) - -(define-interface aix-signals-extras-interface - (export signal/io - signal/xcpu - signal/xfsz - signal/msg - signal/winch - signal/pwr - signal/prof - signal/danger - signal/vtalrm - signal/migrate - signal/pre - signal/virt)) - -(define-interface aix-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/include-header - ip/type-of-service - ip/time-to-live - ip/recvopt - ip/recvret - ip/recvdst - ip/retopts - tcp/no-delay - tcp/max-segment - message/eor - message/trunc - message/ctrunc - message/waitall - )) - -(define-interface aix-extras-interface - (compound-interface aix-errno-extras-interface - aix-fdflags-extras-interface - aix-network-extras-interface - aix-signals-extras-interface)) - -(define-interface aix-defs-interface - (compound-interface aix-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure aix-defs aix-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface aix-extras-interface) -(define os-dependent aix-defs) diff --git a/scsh/aix/signals.scm b/scsh/aix/signals.scm deleted file mode 100644 index c10a295..0000000 --- a/scsh/aix/signals.scm +++ /dev/null @@ -1,51 +0,0 @@ -;;; Signal constant definitions for AIX -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. -;;; AIX version by Chipsy Sperber - -;;POSIX only defined here. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - (iot 5) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - (fpe 8) ; floating point exception - (igemt 7) ; EMT intruction - (igfpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - (bus 10) ; bus error (specification exception) - (segv 11) ; segmentation violation - (igsys 12) ; bad argument to system call - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - (igurg 16) ; urgent contition on I/O channel - (stop 17) ; sendable stop signal not from tty - (tstp 18) ; stop signal from tty - (cont 19) ; continue a stopped process - (chld 20) ; to parent on child stop or exit - (ttin 21) ; to readers pgrp upon background tty read - (ttou 22) ; like TTIN for output if (tp->t_local<OSTOP) - - (io 23) ; I/O possible, or completed - (xcpu 24) ; cpu time limit exceeded (see setrlimit) - (xfsz 25) ; file size limit exceeded (see setrlimit) - (msg 27) ; input data is in the HFT ring buffer - (winch 28) ; window size changed - (pwr 29) ; power-fail restart - (usr1 30) ; user defined signal 1 - (usr2 31) ; user defined signal 2 - (prof 32) ; profiling time alarm (see setitimer) - (danger 33) ; system crash imminent; free up some page space - (vtalrm 34) ; virtual time alarm (see setitimer) - (migrate 35) ; migrate process (see TCF) - (pre 36) ; programming exception - (virt 37) ; AIX virtual time alarm - ) - - - diff --git a/scsh/aix/sigset.h b/scsh/aix/sigset.h deleted file mode 100644 index ca6e50f..0000000 --- a/scsh/aix/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) ((maskp)->losigs=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=(mask.losigs>>24)&0xff), \ - (*(lop)=(mask.losigs&0xffffff))) diff --git a/scsh/aix/stdio_dep.c b/scsh/aix/stdio_dep.c deleted file mode 100644 index a041ee2..0000000 --- a/scsh/aix/stdio_dep.c +++ /dev/null @@ -1,85 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** AIX version by Chipsy Sperber -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/aix/stdio_dep.h b/scsh/aix/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/aix/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/aix/sysdep.h b/scsh/aix/sysdep.h deleted file mode 100644 index 3f09423..0000000 --- a/scsh/aix/sysdep.h +++ /dev/null @@ -1,4 +0,0 @@ -#undef HAVE_DLOPEN - -#undef HAVE_TZNAME -#define HAVE_TZNAME diff --git a/scsh/aix/time_dep.scm b/scsh/aix/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/aix/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/aix/time_dep1.c b/scsh/aix/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/aix/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/aix/tty-consts.scm b/scsh/aix/tty-consts.scm deleted file mode 100644 index 5b7c943..0000000 --- a/scsh/aix/tty-consts.scm +++ /dev/null @@ -1,216 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for AIX 3.2.x, -;;; and are taken from /usr/include/sys/termio.h -;;; and /usr/include/sys/ttydev.h - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 5) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 9) ; ^z isig -(define ttychar/start 7) ; ^q ixon, ixoff -(define ttychar/stop 8) ; ^s ixon, ixoff -(define ttychar/min 4) ; !icanon ; Not exported -(define ttychar/time 5) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 13) ; ^w icanon -(define ttychar/reprint 11) ; ^r icanon -(define ttychar/literal-next 14) ; ^v iexten -(define ttychar/discard 12) ; ^o iexten -(define ttychar/delayed-suspend 10) ; ^y isig -(define ttychar/eol2 6) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 16) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #xff)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #x00001) ; ignbrk -(define ttyin/interrupt-on-break #x00002) ; brkint -(define ttyin/ignore-bad-parity-chars #x00004) ; ignpar -(define ttyin/mark-parity-errors #x00008) ; parmrk -(define ttyin/check-parity #x00010) ; inpck -(define ttyin/7bits #x00020) ; istrip -(define ttyin/nl->cr #x00040) ; inlcr -(define ttyin/ignore-cr #x00080) ; igncr -(define ttyin/cr->nl #x00100) ; icrnl -(define ttyin/output-flow-ctl #x00200) ; ixon -(define ttyin/input-flow-ctl #x00400) ; ixoff - - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #x1000) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #x10000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #x800) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #x000008) ; ocrnl -(define ttyout/fill-w/del #x000080) ; ofdel -(define ttyout/delay-w/fill-char #x000040) ; ofill -(define ttyout/uppercase #x000002) ; olcuc -(define ttyout/nl-does-cr #x000020) ; onlret -(define ttyout/no-col0-cr #x000010) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #x004000) ; mask (nldly) -(define ttyout/nl-delay0 #x000000) -(define ttyout/nl-delay1 #x004000) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #x000c00) ; mask (tabdly) -(define ttyout/tab-delay0 #x000000) -(define ttyout/tab-delay1 #x000400) ; tty 37 -(define ttyout/tab-delay2 #x000800) -(define ttyout/tab-delayx #x000c00) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #x000300) ; mask (crdly) -(define ttyout/cr-delay0 #x000000) -(define ttyout/cr-delay1 #x000100) ; tn 300 -(define ttyout/cr-delay2 #x000200) ; tty 37 -(define ttyout/cr-delay3 #x000300) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #x008000) ; mask (vtdly) -(define ttyout/vtab-delay0 #x000000) -(define ttyout/vtab-delay1 #x008000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #x001000) ; mask (bsdly) -(define ttyout/bs-delay0 #x000000) -(define ttyout/bs-delay1 #x001000) - -;;; Form-feed delay -(define ttyout/ff-delay #x002000) ; mask (ffdly) -(define ttyout/ff-delay0 #x000000) -(define ttyout/ff-delay1 #x002000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #x00030) ; csize: character size mask -(define ttyc/char-size5 #x00000) ; 5 bits (cs5) -(define ttyc/char-size6 #x00010) ; 6 bits (cs6) -(define ttyc/char-size7 #x00020) ; 7 bits (cs7) -(define ttyc/char-size8 #x00030) ; 8 bits (cs8) -(define ttyc/2-stop-bits #x00040) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #x00080) ; cread: Enable receiver. -(define ttyc/enable-parity #x00100) ; parenb -(define ttyc/odd-parity #x00200) ; parodd -(define ttyc/hup-on-close #x00400) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #x00800) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #x010) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #x020) ; echok: Echo nl after line kill -(define ttyl/echo #x008) ; echo: Enable echoing -(define ttyl/echo-nl #x040) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #x002) ; icanon: Canonicalize input -(define ttyl/enable-signals #x001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #x00200000); iexten: Enable extensions -(define ttyl/ttou-signal #x10000) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #x80) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #x080000); echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #x040000); echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #x020000); echoctl: echo control chars as "^X" -(define ttyl/flush-output #x100000); flusho: output is being flushed -(define ttyl/reprint-unread-chars #x20000000); pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #x4) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400) (14 . exta) (15 . extb))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/aix/waitcodes.scm b/scsh/aix/waitcodes.scm deleted file mode 100644 index 09c832c..0000000 --- a/scsh/aix/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for NeXTSTEP. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (not (zero? (bitwise-and status #x40))) - (bitwise-and #x7F (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (and (not (zero? (bitwise-and status #xFF))) ; Didn't exit. - (zero? (bitwise-and status #x40)) ; Not suspended. - (bitwise-and status #x7F))) - - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/bsd/Makefile.inc b/scsh/bsd/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/bsd/bufpol.scm b/scsh/bsd/bufpol.scm deleted file mode 100644 index 803bdf3..0000000 --- a/scsh/bsd/bufpol.scm +++ /dev/null @@ -1,13 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1995 by Brian D. Carlstrom. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line 1) ; _IOLBF - (none 2)) ; _IONBF diff --git a/scsh/bsd/errno.scm b/scsh/bsd/errno.scm deleted file mode 100644 index b997a59..0000000 --- a/scsh/bsd/errno.scm +++ /dev/null @@ -1,133 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; These are the correct values for BSD4.4-Lite-based systems -;;; such as NetBSD 1.0 and FreeBSD 2.0. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno -;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes -;; BSD4.4-Lite - (deadlk 11) ; Resource deadlock avoided -;; POSIX: - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - -;; BSD4.4-Lite - (notblk 15) ; Block device required - -;; POSIX - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation -;; BSD4.4-Lite - (txtbsy 26) ; Text file busy -;; POSIX - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; Strict ANSI - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - ;; POSIX - (again 35) ; Resource temporarily unavaile (note overlap) - - ;; BSD4.4-Lite - ;; non-blocking and interrupt i/o - (wouldblock 35) ; Operation would block - (inprogress 36) ; Operation now in progress - (already 37) ; Operation already in progress - - ;; ipc/network software - - ;; argument errors - (notsock 38) ; Socket operation on non-socket - (destaddrreq 39) ; Destination address required - (msgsize 40) ; Message too long - (prototype 41) ; Protocol wrong type for socket - (noprotoopt 42) ; Protocol not available - (protonosupport 43) ; Protocol not supported - (socktnosupport 44) ; Socket type not supported - (opnotsupp 45) ; Operation not supported on socket - (pfnosupport 46) ; Protocol family not supported - (afnosupport 47) ; Address family not supported by protocol family - (addrinuse 48) ; Address already in use - (addrnotavail 49) ; Can't assign requested address - - ;; operational errors - (netdown 50) ; Network is down - (netunreach 51) ; Network is unreachable - (netreset 52) ; Network dropped connection on reset - (connaborted 53) ; Software caused connection abort - (connreset 54) ; Connection reset by peer - (nobufs 55) ; No buffer space available - (isconn 56) ; Socket is already connected - (notconn 57) ; Socket is not connected - (shutdown 58) ; Can't send after socket shutdown - (toomanyrefs 59) ; Too many references: can't splice - (timedout 60) ; Connection timed out - (connrefused 61) ; Connection refused - - (loop 62) ; Too many levels of symbolic links - - ;; POSIX: - (nametoolong 63) ; File name too long - - ;; BSD4.4-Lite - (hostdown 64) ; Host is down - (hostunreach 65) ; No route to host - - ;; POSIX: - (notempty 66) ; Directory not empty - - ;; BSD4.4-Lite - ;; quotas & mush - (proclim 67) ; Too many processes - (users 68) ; Too many users - (dquot 69) ; Disc quota exceeded - - ;; Network File System - (stale 70) ; Stale NFS file handle - (remote 71) ; Too many levels of remote in path - (badrpc 72) ; RPC struct is bad - (rpcmismatch 73) ; RPC version wrong - (progunavail 74) ; RPC prog. not avail - (progmismatch 75) ; Program version wrong - (procunavail 76) ; Bad procedure for program - - ;; SystemV Record Locking - (nolck 77) ; No locks available - ;; POSIX - (nosys 78) ; Function not implemented - - ;; BSD4.4-Lite - (ftype 79) ; Inappropriate file type or format - (auth 80) ; Authentication error - (needauth 81) ; Need authenticator - (last 81)) ; Must be equal largest errno diff --git a/scsh/bsd/fdflags.scm b/scsh/bsd/fdflags.scm deleted file mode 100644 index fd342ba..0000000 --- a/scsh/bsd/fdflags.scm +++ /dev/null @@ -1,55 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom - -(define-enum-constants open - ;; POSIX - (read #x0000) - (write #x0001) - (read+write #x0002) - (nonblocking #x0004) ; no delay - (append #x0008) ; set append mode - - ;; BSD4.4-Lite - (shared-lock #x0010) ; open with shared file lock - (exclusive-lock #x0020) ; open with exclusive file lock - (async #x0040) ; signal pgrep when data ready - (fsync #x0080) ; synchronus writes - - ;; POSIX - (create #x0200) ; create if nonexistant - (truncate #x0400) ; truncate to zero length - (exclusive #x0800) ; error if already exists - (no-control-tty #x0000)) ; don't assign controlling terminal - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-owner 5) ; F_GETOWN (Not POSIX) - (set-owner 6) ; F_SETOWN (Not POSIX) - (get-record-lock 7) ; F_GETLK - (set-record-lock-noblock 8) ; F_SETLK - (set-record-lock 9)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (release 2) ; F_UNLCK - (write 3)) ; F_WRLCK diff --git a/scsh/bsd/libansi.c b/scsh/bsd/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/bsd/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/bsd/netconst.scm b/scsh/bsd/netconst.scm deleted file mode 100644 index 2b12ae8..0000000 --- a/scsh/bsd/netconst.scm +++ /dev/null @@ -1,139 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables -(define message/eor 8) ; data completes record -(define message/trunc #x10) ; data discarded before delivery -(define message/ctrunc #x20) ; control data lost before delivery -(define message/wait-all #x40) ; wait for full request or error -(define message/dont-wait #x80) ; this message should be nonblocking - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/reuse-port #x0200) ; allow local address & port reuse -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1 ) ; buf/ip/opts; set/get ip options -(define ip/header-included 2 ) ; int; header is included with data -(define ip/type-of-service 3 ) ; int; ip type of service and preced. -(define ip/time-to-live 4 ) ; int; ip time to live -(define ip/receive-options 5 ) ; bool; receive all ip opts w/dgram -(define ip/response-options 6 ) ; bool; receive ip opts for response -(define ip/destination-address 7 ) ; bool; receive ip dst addr w/dgram -(define ip/ret-options 8 ) ; ip_opts; set/get ip options -(define ip/multicast-if 9 ) ; u_char; set/get ip multicast i/f -(define ip/multicast-ttl 10 ) ; u_char; set/get ip multicast ttl -(define ip/multicast-loop 11 ) ; u_char; set/get ip multicast loopback -(define ip/add-membership 12 ) ; ip_mreq; add an ip group membership -(define ip/drop-membership 13 ) ; ip_mreq; drop an ip group membership - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline - socket/reuse-port ;BSD4.4-Lite -; socket/use-privileged -; socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/bsd/packages.scm b/scsh/bsd/packages.scm deleted file mode 100644 index 1749fd1..0000000 --- a/scsh/bsd/packages.scm +++ /dev/null @@ -1,137 +0,0 @@ -;;; Interfaces and packages for the BSD4.4-Lite specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-interface bsd44lite-fdflags-extras-interface - (export open/shared-lock - open/exclusive-lock - open/async - open/fsync - fcntl/get-owner - fcntl/set-owner)) - -(define-interface bsd44lite-errno-extras-interface - (export errno/notblk - errno/txtbsy - errno/wouldblock - errno/inprogress - errno/already - errno/notsock - errno/destaddrreq - errno/msgsize - errno/prototype - errno/noprotoopt - errno/protonosupport - errno/socktnosupport - errno/opnotsupp - errno/pfnosupport - errno/afnosupport - errno/addrinuse - errno/addrnotavail - errno/netdown - errno/netunreach - errno/netreset - errno/connaborted - errno/connreset - errno/nobufs - errno/isconn - errno/notconn - errno/shutdown - errno/toomanyrefs - errno/timedout - errno/connrefused - errno/loop - errno/hostdown - errno/hostunreach - errno/proclim - errno/users - errno/dquot - errno/stale - errno/remote - errno/badrpc - errno/rpcmismatch - errno/progunavail - errno/progmismatch - errno/ftype - errno/auth - errno/needauth - errno/last)) - -(define-interface bsd44lite-signals-extras-interface - (export signal/trap - signal/emt - signal/bus - signal/sys - signal/urg - signal/cld - signal/io - signal/xcpu - signal/xfsz - signal/vtalrm - signal/prof - signal/winch - signal/info)) - -(define-interface bsd44lite-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/reuse-port ;bsd44lite -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type -;;; all ip/* but ip/options and ip/time-to-live bsd44lite only - ip/options - ip/header-included - ip/type-of-service - ip/time-to-live - ip/receive-options - ip/response-options - ip/destination-address - ip/ret-options - ip/multicast-if - ip/multicast-ttl - ip/multicast-loop - ip/add-membership - ip/drop-membership - tcp/no-delay - tcp/max-segment - message/eor - message/trunc - message/ctrunc - message/wait-all - message/dont-wait)) - -(define-interface bsd44lite-extras-interface - (compound-interface bsd44lite-errno-extras-interface - bsd44lite-fdflags-extras-interface - bsd44lite-network-extras-interface - bsd44lite-signals-extras-interface)) - -(define-interface bsd44lite-defs-interface - (compound-interface bsd44lite-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure bsd44lite-defs bsd44lite-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface bsd44lite-extras-interface) -(define os-dependent bsd44lite-defs) diff --git a/scsh/bsd/signals.scm b/scsh/bsd/signals.scm deleted file mode 100644 index 6a4b933..0000000 --- a/scsh/bsd/signals.scm +++ /dev/null @@ -1,72 +0,0 @@ -;;; Signal constant definitions for BSD4.4-Lite -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - - ;; BSD4.4-Lite - (trap 5) ; trace trap (not reset when caught) - - ;; POSIX - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - - ;; BSD4.4-Lite - (emt 7) ; EMT instruction - - ;; POSIX - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - - ;; BSD4.4-Lite - (bus 10) ; bus error - - ;; POSIX - (segv 11) ; segmentation violation - - ;; BSD4.4-Lite - (sys 12) ; bad argument to system call - - ;; POSIX - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - - ;; BSD4.4-Lite - (urg 16) ; urgent condition on IO channel - - ;; POSIX - (stop 17) ; sendable stop signal not from tty - (tstp 18) ; stop signal from tty - (cont 19) ; continue a stopped process - (chld 20) ; to parent on child stop or exit - - ;; BSD4.4-Lite - (cld 20) ; System V name for SIGCHLD - - ;; POSIX - (ttin 21) ; to readers pgrp upon background tty read - (ttou 22) ; like TTIN for output if (tp->t_local<OSTOP) - - ;; BSD4.4-Lite - (io 23) ; input/output possible signal - (xcpu 24) ; exceeded CPU time limit - (xfsz 25) ; exceeded file size limit - (vtalrm 26) ; virtual time alarm - (prof 27) ; profiling time alarm - (winch 28) ; window changed - (info 29) ; information request - - ;; User defined - (usr1 30) ; user defined signal 1 - (usr2 31) ; user defined signal 2 - ) - -(define signals-ignored-by-default - (list signal/chld signal/cont ; These are Posix. - signal/info signal/io signal/urg signal/winch)) ; These are BSD. diff --git a/scsh/bsd/signals1.c b/scsh/bsd/signals1.c deleted file mode 100644 index 8f077fd..0000000 --- a/scsh/bsd/signals1.c +++ /dev/null @@ -1,129 +0,0 @@ -/* Need to turn off synchronous error signals (SIGPIPE, SIGSYS). */ - -#include "../scsh_aux.h" - -/* Make sure our exports match up w/the implementation: */ -#include "../signals1.h" - -/* This table converts Unix signal numbers to S48/scsh interrupt numbers. -** If the signal doesn't have an interrupt number, the entry is -1. -** (Only asynchronous signals have interrupt numbers.) -** -** Note that we bake into this table the integer values of the signals -- -** i.e., we assume that SIGHUP=1, SIGALRM=15, etc. So this definition is -** very system-dependent. -*/ -const int sig2int[] = { - -1, /* 0 is not a signal */ - scshint_hup, /* SIGHUP */ - scshint_keyboard, /* SIGINT */ - scshint_quit, /* SIGQUIT */ - -1, /* SIGILL */ - -1, /* SIGTRAP */ - -1, /* SIGABRT & SIGIOT */ - -1, /* SIGEMT */ - -1, /* SIGFPE */ - -1, /* SIGKILL */ - -1, /* SIGBUS */ - -1, /* SIGSEGV */ - -1, /* SIGSYS */ - -1, /* SIGPIPE */ - scshint_alarm, /* SIGALRM */ - scshint_term, /* SIGTERM */ - scshint_urg, /* SIGURG */ - -1, /* SIGSTOP */ - scshint_tstp, /* SIGTSTP */ - scshint_cont, /* SIGCONT */ - scshint_chld, /* SIGCHLD */ - -1, /* scshint_ttyin, /* SIGTTIN */ - -1, /* scshint_ttou, /* SIGTTOU */ - scshint_io, /* SIGIO */ - scshint_xcpu, /* SIGXCPU */ - scshint_xfsz, /* SIGXFSZ */ - scshint_vtalrm, /* SIGVTALRM */ - scshint_prof, /* SIGPROF */ - scshint_winch, /* SIGWINCH */ - scshint_info, /* SIGINFO */ - scshint_usr1, /* SIGUSR1 */ - scshint_usr2 /* SIGUSR2 */ - }; - -const int max_sig = 31; /* SIGUSR2 */ - -/* -scshint_alarm -scshint_keyboard -scshint_memory_shortage -scshint_chld -scshint_cont -scshint_hup -scshint_quit -scshint_term -scshint_tstp -scshint_usr1 -scshint_usr2 -scshint_info -scshint_io -scshint_poll -scshint_prof -scshint_pwr -scshint_urg -scshint_vtalrm -scshint_winch -scshint_xcpu -scshint_xfsz - -SIGALRM -SIGCHLD -SIGCONT -SIGHUP -SIGINFO -SIGINT -SIGIO -SIGPROF -SIGQUIT -SIGTERM -SIGTSTP -SIGTTIN -SIGTTOU -SIGURG -SIGUSR1 -SIGUSR2 -SIGVTALRM -SIGWINCH -SIGXCPU -SIGXFSZ - -SIGHUP 1 -SIGINT 2 -SIGQUIT 3 -SIGILL 4 -SIGTRAP 5 -SIGABRT 6 -SIGIOT SIGABRT -SIGEMT 7 -SIGFPE 8 -SIGKILL 9 -SIGBUS 10 -SIGSEGV 11 -SIGSYS 12 -SIGPIPE 13 -SIGALRM 14 -SIGTERM 15 -SIGURG 16 -SIGSTOP 17 -SIGTSTP 18 -SIGCONT 19 -SIGCHLD 20 -SIGTTIN 21 -SIGTTOU 22 -SIGIO 23 -SIGXCPU 24 -SIGXFSZ 25 -SIGVTALRM 26 -SIGPROF 27 -SIGWINCH 28 -SIGINFO 29 -SIGUSR1 30 -SIGUSR2 31 -*/ diff --git a/scsh/bsd/signals1.h b/scsh/bsd/signals1.h deleted file mode 100644 index 64bf896..0000000 --- a/scsh/bsd/signals1.h +++ /dev/null @@ -1,4 +0,0 @@ -/* Exports from signals1.c */ - -const int sig2int[]; -const int max_sig; diff --git a/scsh/bsd/sigset.h b/scsh/bsd/sigset.h deleted file mode 100644 index f30fa8c..0000000 --- a/scsh/bsd/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) (*maskp=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=(mask>>24)&0xff), \ - (*(lop)=(mask&0xffffff))) diff --git a/scsh/bsd/stdio_dep.c b/scsh/bsd/stdio_dep.c deleted file mode 100644 index 4e22af4..0000000 --- a/scsh/bsd/stdio_dep.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_r > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_r); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_r <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_w <= 0;} diff --git a/scsh/bsd/stdio_dep.h b/scsh/bsd/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/bsd/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/bsd/sysdep.h b/scsh/bsd/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/bsd/time_dep.scm b/scsh/bsd/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/bsd/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/bsd/time_dep1.c b/scsh/bsd/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/bsd/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/bsd/tty-consts.scm b/scsh/bsd/tty-consts.scm deleted file mode 100644 index 51cf348..0000000 --- a/scsh/bsd/tty-consts.scm +++ /dev/null @@ -1,220 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. -;;; Constants from NetBSD header files substituted by Bill Sommerfeld - -;;; These constants are for NetBSD 1.1 pre-alpha -;;; and are taken from /usr/include/sys/termios.h. These should -;;; work with any BSD4.4-Lite derived system (such as FreeBSD). - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 0) ; ^d icanon -(define ttychar/eol 1) ; icanon - -(define ttychar/delete-char 3) ; ^? icanon - -(define ttychar/delete-line 5) ; ^u icanon - -(define ttychar/interrupt 8) ; ^c isig -(define ttychar/quit 9) ; ^\ isig -(define ttychar/suspend 10) ; ^z isig - -(define ttychar/start 12) ; ^q ixon, ixoff -(define ttychar/stop 13) ; ^s ixon, ixoff -(define ttychar/min 16) ; !icanon ; Not exported -(define ttychar/time 17) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/eol2 2) ; icanon -(define ttychar/delete-word 4) ; ^w icanon -(define ttychar/reprint 6) ; ^r icanon -(define ttychar/delayed-suspend 11) ; ^y isig -(define ttychar/literal-next 14) ; ^v iexten -(define ttychar/discard 15) ; ^o iexten - -;;; 4.3+BSD -(define ttychar/status 18) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 20) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #xff)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #x00001) ; ignbrk -(define ttyin/interrupt-on-break #x00002) ; brkint -(define ttyin/ignore-bad-parity-chars #x00004) ; ignpar -(define ttyin/mark-parity-errors #x00008) ; parmrk -(define ttyin/check-parity #x00010) ; inpck -(define ttyin/7bits #x00020) ; istrip -(define ttyin/nl->cr #x00040) ; inlcr -(define ttyin/ignore-cr #x00080) ; igncr -(define ttyin/cr->nl #x00100) ; icrnl -(define ttyin/output-flow-ctl #x00200) ; ixon -(define ttyin/input-flow-ctl #x00400) ; ixoff - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #x00800) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #x02000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #f) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #x000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #x000002) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #x000008) ; onoeot -(define ttyout/expand-tabs #x000004) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #f) ; ocrnl -(define ttyout/fill-w/del #f) ; ofdel -(define ttyout/delay-w/fill-char #f) ; ofill -(define ttyout/uppercase #f) ; olcuc -(define ttyout/nl-does-cr #f) ; onlret -(define ttyout/no-col0-cr #f) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #f) ; mask (nldly) -(define ttyout/nl-delay0 #f) -(define ttyout/nl-delay1 #f) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #f) ; mask (tabdly) -(define ttyout/tab-delay0 #f) -(define ttyout/tab-delay1 #f) ; tty 37 -(define ttyout/tab-delay2 #f) -(define ttyout/tab-delayx #f) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #f) ; mask (crdly) -(define ttyout/cr-delay0 #f) -(define ttyout/cr-delay1 #f) ; tn 300 -(define ttyout/cr-delay2 #f) ; tty 37 -(define ttyout/cr-delay3 #f) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #f) ; mask (vtdly) -(define ttyout/vtab-delay0 #f) -(define ttyout/vtab-delay1 #f) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #f) ; mask (bsdly) -(define ttyout/bs-delay0 #f) -(define ttyout/bs-delay1 #f) - -;;; Form-feed delay -(define ttyout/ff-delay #f) ; mask (ffdly) -(define ttyout/ff-delay0 #f) -(define ttyout/ff-delay1 #f) - -(define ttyout/all-delay #f) - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #x00300) ; csize: character size mask -(define ttyc/char-size5 #x00000) ; 5 bits (cs5) -(define ttyc/char-size6 #x00100) ; 6 bits (cs6) -(define ttyc/char-size7 #x00200) ; 7 bits (cs7) -(define ttyc/char-size8 #x00300) ; 8 bits (cs8) -(define ttyc/2-stop-bits #x00400) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #x00800) ; cread: Enable receiver. -(define ttyc/enable-parity #x01000) ; parenb -(define ttyc/odd-parity #x02000) ; parodd -(define ttyc/hup-on-close #x04000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #x08000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #x00001) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #x00010000) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #x00010000) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #x00100000) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #x00000002) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #x00000004) ; echok: Echo nl after line kill -(define ttyl/echo #x00000008) ; echo: Enable echoing -(define ttyl/echo-nl #x00000010) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #x00000100) ; icanon: Canonicalize input -(define ttyl/enable-signals #x00000080) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #x00000400) ; iexten: Enable extensions -(define ttyl/ttou-signal #x00400000) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #x80000000) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #x00000001); echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #x00000020); echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #x00000040); echoctl: echo control chars as "^X" -(define ttyl/flush-output #x00800000); flusho: output is being flushed -(define ttyl/reprint-unread-chars #x20000000); pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #x00000200) ; altwerase -(define ttyl/no-kernel-status #x02000000) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #f) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (50 . 50) (75 . 75) - (110 . 110) (134 . 134) (150 . 150) - (200 . 200) (300 . 300) (600 . 600) - (1200 . 1200) (1800 . 1800) (2400 . 2400) - (4800 . 4800) (7200 . 7200) (9600 . 9600) - (14400 . 14400) (19200 . 19200) (28800 . 28800) - (38400 . 38400) (19200 . exta) (38400 . extb) - (57600 . 57600) (76800 . 76800) (115200 . 115200) - (230400 . 230400))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 1) ; TCIFLUSH -(define %flush-tty/output 2) ; TCOFLUSH -(define %flush-tty/both 3) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 2) ; TCOON -(define %tcflow/stop-out 1) ; TCOOFF -(define %tcflow/start-in 4) ; TCION -(define %tcflow/stop-in 3) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. -(define %set-tty-info/soft #x10) ; flag: don't alter h.w. state diff --git a/scsh/bsd/waitcodes.scm b/scsh/bsd/waitcodes.scm deleted file mode 100644 index ce370ae..0000000 --- a/scsh/bsd/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for BSD4.4-Lite. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #x7F status)) - (arithmetic-shift status -8))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (= #x7F (bitwise-and status #x7F)) - (arithmetic-shift status -8))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (let ((termsig (bitwise-and status #x7F))) - (and (not (zero? termsig)) ; Didn't exit. - (not (= #x7F)) ; Not suspended. - termsig))) - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/cxux/Makefile.inc b/scsh/cxux/Makefile.inc deleted file mode 100644 index 5cecb71..0000000 --- a/scsh/cxux/Makefile.inc +++ /dev/null @@ -1,4 +0,0 @@ -CC="cc -Xa" -CFLAGS="-O" -LDFLAGS="-O -Wl,-Bexport" - diff --git a/scsh/cxux/bufpol.scm b/scsh/cxux/bufpol.scm deleted file mode 100644 index 09e5ad9..0000000 --- a/scsh/cxux/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o200) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/cxux/errno.scm b/scsh/cxux/errno.scm deleted file mode 100644 index d424d6d..0000000 --- a/scsh/cxux/errno.scm +++ /dev/null @@ -1,195 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are the correct values for a Harris NightHawk running CX/UX - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - (perm 1) - (noent 2) - (srch 3) - (intr 4) - (io 5) - (nxio 6) -; (2big 7) - (noexec 8) - (badf 9) - (child 10) - (again 11) - (nomem 12) - (acces 13) - (fault 14) - (notblk 15) - (busy 16) - (exist 17) - (xdev 18) - (nodev 19) - (notdir 20) - (isdir 21) - (inval 22) - (nfile 23) - (mfile 24) - (notty 25) - (fbig 27) - (nospc 28) - (spipe 29) - (rofs 30) - (mlink 31) - (pipe 32) - (dom 33) - (range 34) - (nomsg 35) - (idrm 36) - (deadlk 45) - (nolck 46) - (nametoolong 78) - (nosys 89) - (notempty 158) - (txtbsy 26) - (chrng 37) - (l2nsync 38) - (l3hlt 39) - (l3rst 40) - (lnrng 41) - (unatch 42) - (nocsi 43) - (l2hlt 44) - (bade 50) - (badr 51) - (xfull 52) - (noano 53) - (badrqc 54) - (badslt 55) - (deadlock 56) - (bfont 57) - (nostr 60) - (nodata 61) - (time 62) - (nosr 63) - (nonet 64) - (nopkg 65) - (remote 66) - (nolink 67) - (adv 68) - (srmnt 69) - (comm 70) - (proto 71) - (multihop 74) - (dotdot 76) - (badmsg 77) - (notuniq 80) - (badfd 81) - (remchg 82) - (libacc 83) - (libbad 84) - (libscn 85) - (libmax 86) - (libexec 87) - (loop 90) - (restart 91) - (inprogress 128) - (already 129) - (notsock 130) - (destaddrreq 131) - (msgsize 132) - (prototype 133) - (noprotoopt 134) - (protonosupport 135) - (socktnosupport 136) - (opnotsupp 137) - (pfnosupport 138) - (afnosupport 139) - (addrinuse 140) - (addrnotavail 141) - (netdown 142) - (netunreach 143) - (netreset 144) - (connaborted 145) - (connreset 146) - (nobufs 147) - (isconn 148) - (notconn 149) - (shutdown 150) - (toomanyrefs 151) - (timedout 152) - (connrefused 153) - (hostdown 156) - (hostunreach 157) - (proclim 159) - (users 160) - (dquot 161) - (stale 162) - (powerfail 163) - (chnrst 256) - (xlnerr 257) - (xnfst 258) - (xforbid 259) - (xcancel 260) - (xcollin 261) - (xnone 262) - (xaratt 263) - (xbadcom 264) - (xbadpac 265) - (xbadpar 266) - (xbadstate 267) - (xbadwin 268) - (xdwas 269) - (xexmax 270) - (xlncon 271) - (xlnop 272) - (xlobnd 273) - (xmulrq 274) - (xnatt 275) - (xnofac 276) - (xnres 277) - (xrdexcd 278) - (xtmout 279) - (xwover 280) - (xcaclr 281) - (xrange 282) - (lnkdwn 283) - (reopen 284) - (reclos 285) - (rtryex 286) - (lnkrst 287) - (lidle 288) - (idlestop 289) - (bufok 290) - (rembsy 293) - (xnoact 294) - (xbadfac 295) - (buflow 296) - (verr 297) - (xmit 298) - (vovrfl 299) - (badcmp 300) - (sdopen 301) - (sdkbuf 302) - (sdpu 303) - (sdaddr 304) - (sdfrsize 305) - (sdencode 306) - (pubuf 307) - (puappl 308) - (puludown 309) - (luinit 310) - (lupudown 311) - (lubuf 312) - (lupubad 313) - (iocancel 314) - (areq 315) - (nrlock 316) - (ndatreg 317) - (pagnv 318) - (badspace 319) - (regstale 320) - (norfmode 321) - (adstatavail 322) - (adnostatavail 323) - (adnotconfigured 324) - (adlinkstarted 325) - (strpipe 330) - (mtimers 340) - (fail 341) - (notsup 342)) diff --git a/scsh/cxux/fdflags.scm b/scsh/cxux/fdflags.scm deleted file mode 100644 index 72f4d5c..0000000 --- a/scsh/cxux/fdflags.scm +++ /dev/null @@ -1,21 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #o00400) - (exclusive #o02000) - (no-control-tty #o04000) - (nonblocking #o00100) - (truncate #o01000) - -;;; Not POSIX. - (no-delay #o0004) - (sync #o0020)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) diff --git a/scsh/cxux/libansi.c b/scsh/cxux/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/cxux/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/cxux/netconst.scm b/scsh/cxux/netconst.scm deleted file mode 100644 index 59a4c68..0000000 --- a/scsh/cxux/netconst.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/use-privileged #x4000) ; allocate from privileged port area -(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/time-to-live 2) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline - socket/use-privileged - socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/cxux/packages.scm b/scsh/cxux/packages.scm deleted file mode 100644 index bab9ab8..0000000 --- a/scsh/cxux/packages.scm +++ /dev/null @@ -1,209 +0,0 @@ -;;; Interfaces and packages for the machine specific parts of scsh. -;;; This is a specific to CX/UX -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-interface cxux-fdflags-extras-interface - (export open/no-delay - open/sync)) - -(define-interface cxux-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/adlinkstarted - errno/adnostatavail - errno/adnotconfigured - errno/adstatavail - errno/adv - errno/afnosupport - errno/already - errno/areq - errno/badcmp - errno/bade - errno/badfd - errno/badmsg - errno/badr - errno/badrqc - errno/badslt - errno/badspace - errno/bfont - errno/buflow - errno/bufok - errno/chnrst - errno/chrng - errno/comm - errno/connaborted - errno/connrefused - errno/connreset - errno/deadlock - errno/destaddrreq - errno/dotdot - errno/dquot - errno/fail - errno/hostdown - errno/hostunreach - errno/idlestop - errno/idrm - errno/inprogress - errno/iocancel - errno/isconn - errno/l2hlt - errno/l2nsync - errno/l3hlt - errno/l3rst - errno/libacc - errno/libbad - errno/libexec - errno/libmax - errno/libscn - errno/lidle - errno/lnkdwn - errno/lnkrst - errno/lnrng - errno/loop - errno/lubuf - errno/luinit - errno/lupubad - errno/lupudown - errno/msgsize - errno/mtimers - errno/multihop - errno/ndatreg - errno/netdown - errno/netreset - errno/netunreach - errno/noano - errno/nobufs - errno/nocsi - errno/nodata - errno/nolink - errno/nomsg - errno/nonet - errno/nopkg - errno/noprotoopt - errno/norfmode - errno/nosr - errno/nostr - errno/notblk - errno/notconn - errno/notsock - errno/notsup - errno/notuniq - errno/nrlock - errno/opnotsupp - errno/pagnv - errno/pfnosupport - errno/powerfail - errno/proclim - errno/proto - errno/protonosupport - errno/prototype - errno/puappl - errno/pubuf - errno/puludown - errno/reclos - errno/regstale - errno/rembsy - errno/remchg - errno/remote - errno/reopen - errno/restart - errno/rtryex - errno/sdaddr - errno/sdencode - errno/sdfrsize - errno/sdkbuf - errno/sdopen - errno/sdpu - errno/shutdown - errno/socktnosupport - errno/srmnt - errno/stale - errno/strpipe - errno/time - errno/timedout - errno/toomanyrefs - errno/txtbsy - errno/unatch - errno/users - errno/verr - errno/vovrfl - errno/xaratt - errno/xbadcom - errno/xbadfac - errno/xbadpac - errno/xbadpar - errno/xbadstate - errno/xbadwin - errno/xcaclr - errno/xcancel - errno/xcollin - errno/xdwas - errno/xexmax - errno/xforbid - errno/xfull - errno/xlncon - errno/xlnerr - errno/xlnop - errno/xlobnd - errno/xmit - errno/xmulrq - errno/xnatt - errno/xnfst - errno/xnoact - errno/xnofac - errno/xnone - errno/xnres - errno/xrange - errno/xrdexcd - errno/xtmout - errno/xwover)) - -(define-interface cxux-signals-extras-interface - (export signal/cld - signal/iot)) - -(define-interface cxux-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/use-privileged - socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface cxux-extras-interface - (compound-interface cxux-errno-extras-interface - cxux-fdflags-extras-interface - cxux-network-extras-interface - cxux-signals-extras-interface)) - -(define-interface cxux-defs-interface - (compound-interface cxux-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface)) - -(define-structure cxux-defs cxux-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface cxux-extras-interface) -(define os-dependent cxux-defs) diff --git a/scsh/cxux/signals.scm b/scsh/cxux/signals.scm deleted file mode 100644 index a37faef..0000000 --- a/scsh/cxux/signals.scm +++ /dev/null @@ -1,30 +0,0 @@ -;;; Signal constant definitions for "m88k-cxux" -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;POSIX only defined here. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - (segv 11) ; segmentation violation - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - (stop 23) ; sendable stop signal not from tty - (tstp 24) ; stop signal from tty - (cont 25) ; continue a stopped process - (chld 18) ; to parent on child stop or exit - (ttin 26) ; to readers pgrp upon background tty read - (ttou 27) ; like TTIN for output if (tp->t_local<OSTOP) - ;; User defined - (usr1 16) ; user defined signal 1 - (usr2 17) ; user defined signal 2 - ) diff --git a/scsh/cxux/stdio_dep.c b/scsh/cxux/stdio_dep.c deleted file mode 100644 index 75be4a1..0000000 --- a/scsh/cxux/stdio_dep.c +++ /dev/null @@ -1,70 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} diff --git a/scsh/cxux/stdio_dep.h b/scsh/cxux/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/cxux/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/cxux/sysdep.h b/scsh/cxux/sysdep.h deleted file mode 100644 index 25121a5..0000000 --- a/scsh/cxux/sysdep.h +++ /dev/null @@ -1,2 +0,0 @@ -#undef HAVE_NLIST -#undef USCORE diff --git a/scsh/cxux/time_dep.scm b/scsh/cxux/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/cxux/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/cxux/time_dep1.c b/scsh/cxux/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/cxux/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/cxux/waitcodes.scm b/scsh/cxux/waitcodes.scm deleted file mode 100644 index 09c832c..0000000 --- a/scsh/cxux/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for NeXTSTEP. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (not (zero? (bitwise-and status #x40))) - (bitwise-and #x7F (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (and (not (zero? (bitwise-and status #xFF))) ; Didn't exit. - (zero? (bitwise-and status #x40)) ; Not suspended. - (bitwise-and status #x7F))) - - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/generic/Makefile.inc b/scsh/generic/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/generic/bufpol.scm b/scsh/generic/bufpol.scm deleted file mode 100644 index 09e5ad9..0000000 --- a/scsh/generic/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o200) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/generic/errno.scm b/scsh/generic/errno.scm deleted file mode 100644 index 6f64388..0000000 --- a/scsh/generic/errno.scm +++ /dev/null @@ -1,132 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are the correct values for my SparcStation. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes - (again 11) ; Resource temporarily unavailable - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - (notblk 15) ; Block device required - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation - (xtbsy 26) ; Text file busy - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; POSIX: - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - ;; non-blocking and interrupt i/o - (wouldblock 35) ; Operation would block - (inprogress 36) ; Operation now in progress - (already 37) ; Operation already in progress - - ;; ipc/network software - - ;; argument errors - (notsock 38) ; Socket operation on non-socket - (destaddrreq 39) ; Destination address required - (msgsize 40) ; Message too long - (prototype 41) ; Protocol wrong type for socket - (noprotoopt 42) ; Protocol not available - (protonosupport 43) ; Protocol not supported - (socktnosupport 44) ; Socket type not supported - (opnotsupp 45) ; Operation not supported on socket - (pfnosupport 46) ; Protocol family not supported - (afnosupport 47) ; Address family not supported by protocol family - (addrinuse 48) ; Address already in use - (addrnotavail 49) ; Can't assign requested address - - ;; operational errors - (netdown 50) ; Network is down - (netunreach 51) ; Network is unreachable - (netreset 52) ; Network dropped connection on reset - (connaborted 53) ; Software caused connection abort - (connreset 54) ; Connection reset by peer - (nobufs 55) ; No buffer space available - (isconn 56) ; Socket is already connected - (notconn 57) ; Socket is not connected - (shutdown 58) ; Can't send after socket shutdown - (toomanyrefs 59) ; Too many references: can't splice - (timedout 60) ; Connection timed out - (connrefused 61) ; Connection refused - - (loop 62) ; Too many levels of symbolic links - - ;; POSIX: - (nametoolong 63) ; File name too long - - ;; should be rearranged - (hostdown 64) ; Host is down - (hostunreach 65) ; No route to host - - ;; POSIX: - (notempty 66) ; Directory not empty - - ;; quotas & mush - (proclim 67) ; Too many processes - (users 68) ; Too many users - (dquot 69) ; Disc quota exceeded - - ;; Network File System - (stale 70) ; Stale NFS file handle - (remote 71) ; Too many levels of remote in path - - ;; streams - (nostr 72) ; Device is not a stream - (time 73) ; Timer expired - (nosr 74) ; Out of streams resources - (nomsg 75) ; No message of desired type - (badmsg 76) ; Trying to read unreadable message - - ;; SystemV IPC - (idrm 77) ; Identifier removed - - ;; POSIX - ;; SystemV Record Locking - (deadlk 78) ; Resource deadlock avoided - (nolck 79) ; No locks available - - ;; RFS - (nonet 80) ; Machine is not on the network - (rremote 81) ; Object is remote - (nolink 82) ; the link has been severed - (adv 83) ; advertise error - (srmnt 84) ; srmount error - (comm 85) ; Communication error on send - (proto 86) ; Protocol error - (multihop 87) ; multihop attempted - (dotdot 88) ; Cross mount point (not an error) - (remchg 89) ; Remote address changed - - ;; POSIX - (nosys 90)) ; function not implemented diff --git a/scsh/generic/fdflags.scm b/scsh/generic/fdflags.scm deleted file mode 100644 index 8a17fa5..0000000 --- a/scsh/generic/fdflags.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #x0200) - (exclusive #x0800) - (no-control-tty #x8000) - (nonblocking #x4000) - (truncate #x0400) - -;;; Not POSIX. - (no-delay 4) - (sync #x2000)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/generic/libansi.c b/scsh/generic/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/generic/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/generic/netconst.scm b/scsh/generic/netconst.scm deleted file mode 100644 index 59a4c68..0000000 --- a/scsh/generic/netconst.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/use-privileged #x4000) ; allocate from privileged port area -(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/time-to-live 2) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline - socket/use-privileged - socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/generic/packages.scm b/scsh/generic/packages.scm deleted file mode 100644 index c8096a9..0000000 --- a/scsh/generic/packages.scm +++ /dev/null @@ -1,113 +0,0 @@ -;;; Interfaces and packages for the machine specific parts of scsh. -;;; This is a generic version as a starting point, based on sunos. -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-interface generic-fdflags-extras-interface - (export open/no-delay - open/sync)) - -(define-interface generic-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/adv - errno/afnosupport - errno/already - errno/badmsg - errno/comm - errno/connaborted - errno/connrefused - errno/connreset - errno/destaddrreq - errno/dotdot - errno/dquot - errno/hostdown - errno/hostunreach - errno/idrm - errno/inprogress - errno/isconn - errno/loop - errno/msgsize - errno/multihop - errno/netdown - errno/netreset - errno/netunreach - errno/nobufs - errno/nolink - errno/nomsg - errno/nonet - errno/noprotoopt - errno/nosr - errno/nostr - errno/notblk - errno/notconn - errno/notsock - errno/opnotsupp - errno/pfnosupport - errno/proclim - errno/proto - errno/protonosupport - errno/prototype - errno/remchg - errno/remote - errno/rremote - errno/shutdown - errno/socktnosupport - errno/srmnt - errno/stale - errno/time - errno/timedout - errno/toomanyrefs - errno/users - errno/wouldblock - errno/xtbsy)) - -(define-interface generic-signals-extras-interface - (export signal/cld - signal/iot)) - -(define-interface generic-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/use-privileged - socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface generic-extras-interface - (compound-interface generic-errno-extras-interface - generic-fdflags-extras-interface - generic-network-extras-interface - generic-signals-extras-interface)) - -(define-interface generic-defs-interface - (compound-interface generic-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure generic-defs generic-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface generic-extras-interface) -(define os-dependent generic-defs) diff --git a/scsh/generic/signals.scm b/scsh/generic/signals.scm deleted file mode 100644 index 11dac3d..0000000 --- a/scsh/generic/signals.scm +++ /dev/null @@ -1,30 +0,0 @@ -;;; Signal constant definitions for "generic" -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;POSIX only defined here. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - (segv 11) ; segmentation violation - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - (stop 17) ; sendable stop signal not from tty - (tstp 18) ; stop signal from tty - (cont 19) ; continue a stopped process - (chld 20) ; to parent on child stop or exit - (ttin 21) ; to readers pgrp upon background tty read - (ttou 22) ; like TTIN for output if (tp->t_local<OSTOP) - ;; User defined - (usr1 30) ; user defined signal 1 - (usr2 31) ; user defined signal 2 - ) diff --git a/scsh/generic/stdio_dep.c b/scsh/generic/stdio_dep.c deleted file mode 100644 index 4913d14..0000000 --- a/scsh/generic/stdio_dep.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/generic/stdio_dep.h b/scsh/generic/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/generic/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/generic/sysdep.h b/scsh/generic/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/generic/time_dep.scm b/scsh/generic/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/generic/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/generic/time_dep1.c b/scsh/generic/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/generic/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/generic/waitcodes.scm b/scsh/generic/waitcodes.scm deleted file mode 100644 index 09c832c..0000000 --- a/scsh/generic/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for NeXTSTEP. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (not (zero? (bitwise-and status #x40))) - (bitwise-and #x7F (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (and (not (zero? (bitwise-and status #xFF))) ; Didn't exit. - (zero? (bitwise-and status #x40)) ; Not suspended. - (bitwise-and status #x7F))) - - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/hpux/Makefile.inc b/scsh/hpux/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/hpux/bufpol.scm b/scsh/hpux/bufpol.scm deleted file mode 100644 index 09e5ad9..0000000 --- a/scsh/hpux/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o200) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/hpux/errno.scm b/scsh/hpux/errno.scm deleted file mode 100644 index 1b25e73..0000000 --- a/scsh/hpux/errno.scm +++ /dev/null @@ -1,144 +0,0 @@ -;;; HP-UX errno definitions. This file adapted from errno.h on an HP machine. -;;; Copyright (c) 1994 by Olin Shivers. - -;;; NOTE: When the hp9000s500 symbol is set, errno.h defines ENOMSG to be 250 -;;; instead of 35. What to do? We go with 35 in this file. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - (perm 1) ; Not super-user - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; interrupted system call - (io 5) ; I/O error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file number - (child 10) ; No children - (again 11) ; No more processes - (nomem 12) ; Not enough core - (acces 13) ; Permission denied - (fault 14) ; Bad address - (busy 16) ; Mount device busy - (exist 17) ; File exists - (xdev 18) ; Cross-device link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; File table overflow - (mfile 24) ; Too many open files - (notty 25) ; Not a typewriter - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Illegal seek - (rofs 30) ; Read only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - (dom 33) ; Math arg out of domain of func - (range 34) ; Math result not representable - (deadlk 45) ; A deadlock would occur - (nolck 46) ; System record lock table was full - (ilseq 47) ; Illegal byte sequence - (notempty 247) ; Directory not empty - (nametoolong 248) ; File name too long - (nosys 251) ; Function not implemented - - - ;; Things in XPG3 not in POSIX or ANSI C. - (notblk 15) ; Block device required - (txtbsy 26) ; Text file busy - (nomsg 35) ; No message of desired type - (idrm 36) ; Identifier removed - - ;; Things in AES not in XPG3, POSIX or ANSI C. - (loop 249) ; Too many levels of symbolic links - - ;; Things in HP-UX not in XPG3, POSIX or ANSI C. - - ;; The error numbers between 37 and 44 are not produced by HP-UX. - ;; They will track whatever the UNIX(tm) system does in the future. - (chrng 37) ; Channel number out of range - (l2nsync 38) ; Level 2 not synchronized - (l3hlt 39) ; Level 3 halted - (l3rst 40) ; Level 3 reset - (lnrng 41) ; Link number out of range - (unatch 42) ; Protocol driver not attached - (nocsi 43) ; No CSI structure available - (l2hlt 44) ; Level 2 halted - - (nonet 50) ; Machine is not on the network - (nodata 51) ; no data (for no delay io) - (time 52) ; timer expired - (nosr 53) ; out of streams resources - (nostr 54) ; Device not a stream - (nopkg 55) ; Package not installed - (nolink 57) ; the link has been severed - (adv 58) ; advertise error - (srmnt 59) ; srmount error - (comm 60) ; Communication error on send - (proto 61) ; Protocol error - (multihop 64) ; multihop attempted - (dotdot 66) ; Cross mount point (not really error) - (badmsg 67) ; trying to read unreadable message - - (nosym 215) ; symbol does not exist in executable - - (users 68) ; For Sun compatibilty, will not occur. - (dquot 69) ; Disc quota exceeded - - (stale 70) ; Stale NFS file handle - (remote 71) ; Too many levels of remote in path - - ;; hp9000s500 only - (unexpect 99) ; Unexpected Error - - ;; hp9000s300, hp9000s800 - ;; ipc/network software - - ;; Argument errors - (notsock 216) ; Socket operation on non-socket - (destaddrreq 217) ; Destination address required - (msgsize 218) ; Message too long - (prototype 219) ; Protocol wrong type for socket - (noprotoopt 220) ; Protocol not available - (protonosupport 221) ; Protocol not supported - (socktnosupport 222) ; Socket type not supported - (opnotsupp 223) ; Operation not supported - (pfnosupport 224) ; Protocol family not supported - (afnosupport 225) ; Address family not supported by - ; protocol family - (addrinuse 226) ; Address already in use - (addrnotavail 227) ; Can't assign requested address - - ;; operational errors - (netdown 228) ; Network is down - (netunreach 229) ; Network is unreachable - (netreset 230) ; Network dropped connection on reset - (connaborted 231) ; Software caused connection abort - (connreset 232) ; Connection reset by peer - (nobufs 233) ; No buffer space available - (isconn 234) ; Socket is already connected - (notconn 235) ; Socket is not connected - (shutdown 236) ; Can't send after socket shutdown - (toomanyrefs 237) ; Too many references: can't splice - (timedout 238) ; Connection timed out - (connrefused 239) ; Connection refused - - ;; hp9000s800 only - (refused errno/connrefused) ; Double define for NFS - - (remoterelease 240) ; Remote peer released connection - (hostdown 241) ; Host is down - (hostunreach 242) ; No route to host - ;; endif hp9000s300, hp9000s800 - - (already 244) ; Operation already in progress - (inprogress 245) ; Operation now in progress - (wouldblock 246) ; Operation would block - - ;; hp9000s500 only -; (nomsg 250) ; No message of desired type - ) diff --git a/scsh/hpux/fdflags.scm b/scsh/hpux/fdflags.scm deleted file mode 100644 index 5c4a262..0000000 --- a/scsh/hpux/fdflags.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - ;; POSIX - (read 0) - (write 1) - (read+write 2) - (nonblocking #o200000) - (append #o10) - (no-control-tty #o400000) - (create #o0400) - (truncate #o1000) - (exclusive #o2000) - - ;; NextStep - (sync #o100000)) ; Synchronous writes - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/hpux/libansi.c b/scsh/hpux/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/hpux/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/hpux/netconst.scm b/scsh/hpux/netconst.scm deleted file mode 100644 index 948a638..0000000 --- a/scsh/hpux/netconst.scm +++ /dev/null @@ -1,128 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type -(define socket/send-avoid-copy #x1009) ; avoid copy on send -(define socket/receive-avoid-copy #x100a) ; avoid copy on rcv - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/multicast-if 2) ; set/get ip multicast interface -(define ip/multicast-ttl 3) ; set/get ip multicast timetolive -(define ip/multicast-loop 4) ; set/get ip multicast loopback -(define ip/add-membership 5) ; add an ip group membership -(define ip/drop-membership 6) ; drop an ip group membership -(define ip/time-to-live 16) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/hpux/packages.scm b/scsh/hpux/packages.scm deleted file mode 100644 index 350436e..0000000 --- a/scsh/hpux/packages.scm +++ /dev/null @@ -1,65 +0,0 @@ -;;; Interfaces and packages for the HP-UX specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -(define-interface hpux-fdflags-extras-interface - (export open/sync)) - -(define-interface hpux-errno-extras-interface - (export errno/wouldblock)) - -(define-interface hpux-signals-extras-interface - (export)) - -(define-interface hpux-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - socket/send-avoid-copy ;hpux - socket/receive-avoid-copy ;hpux - ;; all options except ip/options & ip/time-to-live hpux specific - ip/options - ip/multicast-if - ip/multicast-ttl - ip/multicast-loop - ip/add-membership - ip/drop-membership - ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface hpux-extras-interface - (compound-interface hpux-errno-extras-interface - hpux-fdflags-extras-interface - hpux-network-extras-interface - hpux-signals-extras-interface)) - -(define-interface hpux-defs-interface - (compound-interface hpux-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure hpux-defs hpux-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface hpux-extras-interface) -(define os-dependent hpux-defs) diff --git a/scsh/hpux/signals.scm b/scsh/hpux/signals.scm deleted file mode 100644 index 066950e..0000000 --- a/scsh/hpux/signals.scm +++ /dev/null @@ -1,48 +0,0 @@ -;;; Signal constant definitions for HP-UX -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-enum-constants signal - (hup 1) ; floating point exception - (int 2) ; Interrupt - (quit 3) ; quit - (ill 4) ; Illegal instruction (not reset when caught) - (trap 5) ; trace trap (not reset when caught) - (abrt 6) ; Process abort signal - (iot signal/abrt) ; IOT instruction - (emt 7) ; EMT instruction - (fpe 8) ; Floating point exception - (kill 9) ; kill (cannot be caught of ignored) - (bus 10) ; bus error - (segv 11) ; Segmentation violation - (sys 12) ; bad argument to system call - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; Software termination signal from kill - (usr1 16) ; user defined signal 1 - (usr2 17) ; user defined signal 2 - (chld 18) ; Child process terminated or stopped - (cld signal/chld) ; death of a child - (pwr 19) ; power state indication - (vtalrm 20) ; virtual timer alarm - (prof 21) ; profiling timer alarm - (io 22) ; asynchronous I/O - (poll signal/io) ; for HP-UX hpstreams signal - (winch 23) ; window size change signal - (window signal/winch) ; added for compatibility reasons - (stop 24) ; Stop signal (cannot be caught or ignored) - (tstp 25) ; Interactive stop signal - (cont 26) ; Continue if stopped - (ttin 27) ; Read from control terminal attempted by a - ; member of a background process group - (ttou 28) ; Write to control terminal attempted by a - ; member of a background process group - (urg 29) ; urgent condition on IO channel - (lost 30) ; remote lock lost (NFS) - ; Signal 31 is reserved for future use. - (dil 32)) ; DIL signal - - -(define signals-ignored-by-default - (list signal/chld signal/cont ; These are Posix. - signal/io signal/pwr signal/urg signal/winch)) ; These are HP-UX. diff --git a/scsh/hpux/signals1.c b/scsh/hpux/signals1.c deleted file mode 100644 index 6b25fbf..0000000 --- a/scsh/hpux/signals1.c +++ /dev/null @@ -1,99 +0,0 @@ -/* Need to turn off synchronous error signals (SIGPIPE, SIGSYS). */ - -#include "../scsh_aux.h" - -/* Make sure our exports match up w/the implementation: */ -#include "../signals1.h" - -/* This table converts Unix signal numbers to S48/scsh interrupt numbers. -** If the signal doesn't have an interrupt number, the entry is -1. -** (Only asynchronous signals have interrupt numbers.) -** -** Note that we bake into this table the integer values of the signals -- -** i.e., we assume that SIGHUP=1, SIGALRM=15, etc. So this definition is -** very system-dependent. -*/ -const int sig2int[] = { - -1, /* 0 is not a signal */ - scshint_hup, /* 1: SIGHUP */ - scshint_keyboard, /* 2: SIGINT */ - scshint_quit, /* 3: SIGQUIT */ - -1, /* 4: SIGILL */ - -1, /* 5: SIGTRAP */ - -1, /* 6: SIGABRT */ - -1, /* 7: SIGEMT */ - -1, /* 8: SIGFPE */ - -1, /* 9: SIGKILL */ - -1, /* 10: SIGBUS */ - -1, /* 11: SIGSEGV */ - -1, /* 12: SIGSYS */ - -1, /* 13: SIGPIPE */ - scshint_alarm, /* 14: SIGALRM */ - scshint_term, /* 15: SIGTERM */ - scshint_usr1, /* 16: SIGUSR1 */ - scshint_usr2, /* 17: SIGUSR2 */ - scshint_chld, /* 18: SIGCHLD */ - scshint_pwr, /* 19: SIGPWR */ - scshint_vtalrm, /* 20: SIGVTALRM */ - scshint_prof, /* 21: SIGPROF */ - scshint_io, /* 22: SIGIO */ - scshint_winch, /* 23: SIGWINCH */ - -1, /* 24: SIGSTOP */ - scshint_tstp, /* 25: SIGTSTP */ - scshint_cont, /* 26: SIGCONT */ - -1, /* 27: SIGTTIN */ /* scshint_ttyin */ - -1, /* 28: SIGTTOU */ /* scshint_ttyou */ - scshint_urg, /* 29: SIGURG */ - -1, /* 30: SIGLOST */ - -1, /* 32: SIGDIL */ - scshint_xcpu, /* 33: SIGXCPU */ - scshint_xfsz /* 34: SIGXFSZ */ - }; - -const int max_sig = 34; /* SIGXFSZ */ - -/* -scshint_alarm -scshint_keyboard -scshint_memory_shortage -scshint_chld -scshint_cont -scshint_hup -scshint_quit -scshint_term -scshint_tstp -scshint_usr1 -scshint_usr2 -scshint_info -scshint_io -scshint_poll -scshint_prof -scshint_pwr -scshint_urg -scshint_vtalrm -scshint_winch -scshint_xcpu -scshint_xfsz - -scshint_alarm -scshint_chld -scshint_cont -scshint_hup -scshint_info -scshint_io -scshint_keyboard -scshint_memory_shortage -scshint_poll -scshint_prof -scshint_pwr -scshint_quit -scshint_term -scshint_tstp -scshint_urg -scshint_usr1 -scshint_usr2 -scshint_vtalrm -scshint_winch -scshint_xcpu -scshint_xfsz -*/ diff --git a/scsh/hpux/sigset.h b/scsh/hpux/sigset.h deleted file mode 100644 index d66644e..0000000 --- a/scsh/hpux/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) ((maskp)->sigset[0]=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=((mask).sigset[0]>>24)&0xff), \ - (*(lop)=((mask).sigset[0]&0xffffff))) diff --git a/scsh/hpux/stdio_dep.c b/scsh/hpux/stdio_dep.c deleted file mode 100644 index 7c95b9c..0000000 --- a/scsh/hpux/stdio_dep.c +++ /dev/null @@ -1,84 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fs->__fileL = (fd & 0xFF); - fs->__fileH = ((fd>>8) & 0xFF); -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/hpux/stdio_dep.h b/scsh/hpux/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/hpux/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/hpux/sysdep.h b/scsh/hpux/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/hpux/time_dep.scm b/scsh/hpux/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/hpux/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/hpux/time_dep1.c b/scsh/hpux/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/hpux/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/hpux/tty-consts.scm b/scsh/hpux/tty-consts.scm deleted file mode 100644 index 75c2655..0000000 --- a/scsh/hpux/tty-consts.scm +++ /dev/null @@ -1,228 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for HP-UX, -;;; and are taken from /usr/include/sys/termio.h. - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 5) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 13) ; ^z isig -(define ttychar/start 14) ; ^q ixon, ixoff -(define ttychar/stop 15) ; ^s ixon, ixoff -(define ttychar/min 11) ; !icanon ; Not exported -(define ttychar/time 12) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word #f) ; ^w icanon -(define ttychar/reprint #f) ; ^r icanon -(define ttychar/literal-next #f) ; ^v iexten -(define ttychar/discard #f) ; ^o iexten -(define ttychar/delayed-suspend #f) ; ^y isig -(define ttychar/eol2 #f) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 16) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #xff)) ; _POSIX_VDISABLE - -;;; HP-UX brain death: -;;; HP-UX defines NCCS to be 16, then sneaks the DSUSP char (^y) in as -;;; a seventeenth char -- there's another non-standard NLDCC constant -;;; defined to be 1+16 that's used elsewhere. Since the scsh interface -;;; to tcsetattr() uses a char vec of size NCCS, you can't get at this -;;; hidden char. So we do not support the delayed-suspension char; sorry. -;;; -;;; If you are an HP-UX hacker, and know a way to fix this, let me know. - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #o00001) ; ignbrk -(define ttyin/interrupt-on-break #o00002) ; brkint -(define ttyin/ignore-bad-parity-chars #o00004) ; ignpar -(define ttyin/mark-parity-errors #o00010) ; parmrk -(define ttyin/check-parity #o00020) ; inpck -(define ttyin/7bits #o00040) ; istrip -(define ttyin/nl->cr #o00100) ; inlcr -(define ttyin/ignore-cr #o00200) ; igncr -(define ttyin/cr->nl #o00400) ; icrnl -(define ttyin/output-flow-ctl #o02000) ; ixon -(define ttyin/input-flow-ctl #o10000) ; ixoff - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #o4000) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #f) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #o1000) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #o000010) ; ocrnl -(define ttyout/fill-w/del #o000200) ; ofdel -(define ttyout/delay-w/fill-char #o000100) ; ofill -(define ttyout/uppercase #o000002) ; olcuc -(define ttyout/nl-does-cr #o000040) ; onlret -(define ttyout/no-col0-cr #o000020) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #o000400) ; mask (nldly) -(define ttyout/nl-delay0 #o000000) -(define ttyout/nl-delay1 #o000400) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #o014000) ; mask (tabdly) -(define ttyout/tab-delay0 #o000000) -(define ttyout/tab-delay1 #o004000) ; tty 37 -(define ttyout/tab-delay2 #o010000) -(define ttyout/tab-delayx #o014000) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #o003000) ; mask (crdly) -(define ttyout/cr-delay0 #o000000) -(define ttyout/cr-delay1 #o001000) ; tn 300 -(define ttyout/cr-delay2 #o002000) ; tty 37 -(define ttyout/cr-delay3 #o003000) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #o040000) ; mask (vtdly) -(define ttyout/vtab-delay0 #o000000) -(define ttyout/vtab-delay1 #o040000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #o020000) ; mask (bsdly) -(define ttyout/bs-delay0 #o000000) -(define ttyout/bs-delay1 #o020000) - -;;; Form-feed delay -(define ttyout/ff-delay #o100000) ; mask (ffdly) -(define ttyout/ff-delay0 #o000000) -(define ttyout/ff-delay1 #o100000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #o00140) ; csize: character size mask -(define ttyc/char-size5 #o00000) ; 5 bits (cs5) -(define ttyc/char-size6 #o00040) ; 6 bits (cs6) -(define ttyc/char-size7 #o00100) ; 7 bits (cs7) -(define ttyc/char-size8 #o00140) ; 8 bits (cs8) -(define ttyc/2-stop-bits #o00200) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #o00400) ; cread: Enable receiver. -(define ttyc/enable-parity #o01000) ; parenb -(define ttyc/odd-parity #o02000) ; parodd -(define ttyc/hup-on-close #o04000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #o10000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #o020) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #o040) ; echok: Echo nl after line kill -(define ttyl/echo #o010) ; echo: Enable echoing -(define ttyl/echo-nl #o100) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #o002) ; icanon: Canonicalize input -(define ttyl/enable-signals #o001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #o20000000000); iexten: Enable extensions -(define ttyl/ttou-signal #o10000000000); tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #o200) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #f) ; echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #f) ; echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #f) ; echoctl: echo control chars as "^X" -(define ttyl/flush-output #f) ; flusho: output is being flushed -(define ttyl/reprint-unread-chars #f) ; pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #o4) ; xcase: canonical upper/lower presentation - - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 900) (10 . 1200) (11 . 1800) - (12 . 2400) (13 . 3600) (14 . 4800) - (15 . 7200) (16 . 9600) (17 . 19200) - (18 . 38400) (19 . 57600) (20 . 115200) - (21 . 230400) (22 . 460800) ; 23-29 unused. - (30 . exta) (31 . extb))) - - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/hpux/waitcodes.scm b/scsh/hpux/waitcodes.scm deleted file mode 100644 index a960538..0000000 --- a/scsh/hpux/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for HPUX. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (= #x7F (bitwise-and status #xFF)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (let ((low-byte (bitwise-and status #xFF))) - (and (not (= low-byte 0)) ; Didn't exit. - (not (= low-byte #x7F)) ; Not suspended. - (bitwise-and status #x7F)))) - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/irix/Makefile.inc b/scsh/irix/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/irix/bufpol.scm b/scsh/irix/bufpol.scm deleted file mode 100644 index f3667d9..0000000 --- a/scsh/irix/bufpol.scm +++ /dev/null @@ -1,13 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1995 by Brian D. Carlstrom. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o100) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/irix/errno.scm b/scsh/irix/errno.scm deleted file mode 100644 index 45e803b..0000000 --- a/scsh/irix/errno.scm +++ /dev/null @@ -1,158 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are the correct values for my SparcStation. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes - (again 11) ; Resource temporarily unavailable - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - (notblk 15) ; Block device required - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation - (xtbsy 26) ; Text file busy - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; POSIX: - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - ;; SystemV IPC - (idrm 36) ; Identifier removed - (chrng 37) ; channel number out of range - (l2nsync 38) ; level 2 not synchronized - (l3hlt 39) ; level 3 halted - (l3rst 40) ; level 3 reset - (lnrng 41) ; link number out of range - (unatch 42) ; protocol driver not attached - (nocsi 43) ; no csi structure available - (l2hlt 44) ; level 2 halted - - ;; POSIX - ;; SystemV Record Locking - (deadlk 45) ; Resource deadlock avoided - (nolck 46) ; No locks available - - (bade 50) ; bad exchange descriptor - (badr 51) ; bad request descriptor - (xfull 52) ; message tables full - (noano 53) ; anode table overflow - (badrqc 54) ; bad request code - (badslt 55) ; invalid slot - (deadlock 56) ; file locking deadlock - - (bfont 57) ; bad font file format - - ;; streams - (nostr 60) ; Device is not a stream - (time 62) ; Timer expired - (nosr 63) ; Out of streams resources - (nomsg 35) ; No message of desired type - (badmsg 77) ; Trying to read unreadable message - - ;; RFS - (nonet 64) ; Machine is not on the network - (rremote 66) ; Object is remote - (nolink 67) ; the link has been severed - (adv 68) ; advertise error - (srmnt 69) ; srmount error - (comm 70) ; Communication error on send - (proto 71) ; Protocol error - (multihop 74) ; multihop attempted -; (dotdot ) ; Cross mount point (not an error) - (notuniq 80) ; name not unique on network - (badfd 81) ; file descriptor in bad state - (remchg 82) ; Remote address changed - - (libacc 83) ; can not access a needed shared lib. - (libbad 84) ; accessing a corrupted shared lib. - (libscn 85) ; .lib section in a.out corrupted. - (libmax 86) ; attempting to link in more shared libraries than system limit - (libexec 87) ; can not exec a shared library directly - (nosys 88) ; irix uses einval; posix wants enosys - - ;; POSIX - (nosys 88) ; function not implemented - - ;; non-blocking and interrupt i/o - (wouldblock 101) ; Operation would block - (inprogress 102) ; Operation now in progress - (already 103) ; Operation already in progress - - ;; ipc/network software - - ;; argument errors - (notsock 104) ; Socket operation on non-socket - (destaddrreq 105) ; Destination address required - (msgsize 106) ; Message too long - (prototype 107) ; Protocol wrong type for socket - (noprotoopt 108) ; Protocol not available - (protonosupport 109) ; Protocol not supported - (socktnosupport 110) ; Socket type not supported - (opnotsupp 111) ; Operation not supported on socket - (pfnosupport 112) ; Protocol family not supported - (afnosupport 113) ; Address family not supported by protocol family - (addrinuse 114) ; Address already in use - (addrnotavail 115) ; Can't assign requested address - - ;; operational errors - (netdown 116) ; Network is down - (netunreach 117) ; Network is unreachable - (netreset 118) ; Network dropped connection on reset - (connaborted 119) ; Software caused connection abort - (connreset 120) ; Connection reset by peer - (nobufs 121) ; No buffer space available - (isconn 122) ; Socket is already connected - (notconn 123) ; Socket is not connected - (shutdown 124) ; Can't send after socket shutdown - (toomanyrefs 125) ; Too many references: can't splice - (timedout 126) ; Connection timed out - (connrefused 127) ; Connection refused - (hostdown 128) ; Host is down - (hostunreach 129) ; No route to host - - (loop 130) ; Too many levels of symbolic links - - ;; POSIX: - (nametoolong 131) ; File name too long - - ;; POSIX: - (notempty 132) ; Directory not empty - - ;; quotas & mush -; (proclim ) ; Too many processes - (users 133) ; Too many users - (dquot 134) ; Disc quota exceeded - - ;; Network File System - (stale 135) ; Stale NFS file handle - (remote 136) ; Too many levels of remote in path - ) diff --git a/scsh/irix/fdflags.scm b/scsh/irix/fdflags.scm deleted file mode 100644 index 8cadcee..0000000 --- a/scsh/irix/fdflags.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #x100) - (exclusive #x400) - (no-control-tty #x800) - (nonblocking #x80) - (truncate #x200) - -;;; Not POSIX. - (no-delay 4) - (sync #x10)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/irix/libansi.c b/scsh/irix/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/irix/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/irix/netconst.scm b/scsh/irix/netconst.scm deleted file mode 100644 index a448ae6..0000000 --- a/scsh/irix/netconst.scm +++ /dev/null @@ -1,126 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 2) ; stream socket -(define socket-type/datagram 1) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/reuse-port #x020) ; allow local address,port reuse -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/include-header 7) ; int; header is included with data (raw) -(define ip/type-of-service 8) ; int; ip type of service and precedence -(define ip/time-to-live 9) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - ip/include-header - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/type-of-service - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/irix/packages.scm b/scsh/irix/packages.scm deleted file mode 100644 index dc960c7..0000000 --- a/scsh/irix/packages.scm +++ /dev/null @@ -1,152 +0,0 @@ -;;; Interfaces and packages for the machine specific parts of scsh. -;;; This is the IRIX version. -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-interface irix-fdflags-extras-interface - (export open/no-delay - open/sync)) - -(define-interface irix-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/adv - errno/afnosupport - errno/already - errno/badmsg - errno/comm - errno/connaborted - errno/connrefused - errno/connreset - errno/destaddrreq -; errno/dotdot - errno/dquot - errno/hostdown - errno/hostunreach - errno/idrm - errno/inprogress - errno/isconn - errno/loop - errno/msgsize - errno/multihop - errno/netdown - errno/netreset - errno/netunreach - errno/nobufs - errno/nolink - errno/nomsg - errno/nonet - errno/noprotoopt - errno/nosr - errno/nostr - errno/notblk - errno/notconn - errno/notsock - errno/opnotsupp - errno/pfnosupport -; errno/proclim - errno/proto - errno/protonosupport - errno/prototype - errno/remchg - errno/remote - errno/rremote - errno/shutdown - errno/socktnosupport - errno/srmnt - errno/stale - errno/time - errno/timedout - errno/toomanyrefs - errno/users - errno/wouldblock - errno/xtbsy - - errno/chrng - errno/l2nsync - errno/l3hlt - errno/l3rst - errno/lnrng - errno/unatch - errno/nocsi - errno/l2hlt - - errno/bade - errno/badr - errno/xfull - errno/noano - errno/badrqc - errno/badslt - errno/deadlock - errno/bfont - - errno/libacc - errno/libbad - errno/libscn - errno/libmax - errno/libexec - )) - - -(define-interface irix-signals-extras-interface - (export signal/cld - signal/iot - signal/pwr - signal/poll - signal/io - signal/urg - signal/winch - signal/vtalrm - signal/prof - signal/xcpu - signal/xfsz - )) - -(define-interface irix-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/reuse-port ;irix -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/time-to-live - ip/include-header ;irix - ip/type-of-service ;irix - tcp/no-delay - tcp/max-segment)) - -(define-interface irix-extras-interface - (compound-interface irix-errno-extras-interface - irix-fdflags-extras-interface - irix-network-extras-interface - irix-signals-extras-interface)) - -(define-interface irix-defs-interface - (compound-interface irix-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure irix-defs irix-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface irix-extras-interface) -(define os-dependent irix-defs) diff --git a/scsh/irix/signals.scm b/scsh/irix/signals.scm deleted file mode 100644 index 0d0f2ad..0000000 --- a/scsh/irix/signals.scm +++ /dev/null @@ -1,43 +0,0 @@ -;;; Signal constant definitions for "irix" -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;POSIX only defined here. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - (bus 10) ; bus error - (segv 11) ; segmentation violation - (sys 12) ; bad argument to system call - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - (stop 20) ; sendable stop signal not from tty - (tstp 21) ; stop signal from tty - (cont 28) ; continue a stopped process - (chld 18) ; to parent on child stop or exit - (cld 18) ; compat - (ttin 29) ; to readers pgrp upon background tty read - (ttou 30) ; like TTIN for output if (tp->t_local<OSTOP) - ;; User defined - (usr1 16) ; user defined signal 1 - (usr2 17) ; user defined signal 2 - - (pwr 19) ; power-fail restart - (poll 22) ; pollable event occurred - (io 23) ; input/output possible signal - (urg 24) ; urgent condition on io channel - (winch 25) ; window size changes - (vtalrm 26) ; virtual time alarm - (prof 27) ; profiling alarm - (xcpu 31) ; Cpu time limit exceeded - (xfsz 32) ; Filesize limit exceeded - ) diff --git a/scsh/irix/sigset.h b/scsh/irix/sigset.h deleted file mode 100644 index f4a93b9..0000000 --- a/scsh/irix/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) ((maskp)->sigbits[0]=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=((mask).sigbits[0]>>24)&0xff), \ - (*(lop)=((mask).sigbits[0]&0xffffff))) diff --git a/scsh/irix/stdio_dep.c b/scsh/irix/stdio_dep.c deleted file mode 100644 index 4913d14..0000000 --- a/scsh/irix/stdio_dep.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/irix/stdio_dep.h b/scsh/irix/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/irix/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/irix/sysdep.h b/scsh/irix/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/irix/time_dep.scm b/scsh/irix/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/irix/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/irix/time_dep1.c b/scsh/irix/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/irix/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/irix/tty-consts.scm b/scsh/irix/tty-consts.scm deleted file mode 100644 index 95a323a..0000000 --- a/scsh/irix/tty-consts.scm +++ /dev/null @@ -1,216 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for IRIX, -;;; and are taken from /usr/include/sys/termio.h -;;; and /usr/include/sys/termios.h -;;; and /usr/include/sys/ttydev.h (baud rates). - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 5) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 10) ; ^z isig -(define ttychar/start 8) ; ^q ixon, ixoff -(define ttychar/stop 9) ; ^s ixon, ixoff -(define ttychar/min 4) ; !icanon ; Not exported -(define ttychar/time 5) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 14) ; ^w icanon -(define ttychar/reprint 12) ; ^r icanon -(define ttychar/literal-next 15) ; ^v iexten -(define ttychar/discard 13) ; ^o iexten -(define ttychar/delayed-suspend 11) ; ^y isig -(define ttychar/eol2 6) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 23) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #x00)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #o00001) ; ignbrk -(define ttyin/interrupt-on-break #o00002) ; brkint -(define ttyin/ignore-bad-parity-chars #o00004) ; ignpar -(define ttyin/mark-parity-errors #o00010) ; parmrk -(define ttyin/check-parity #o00020) ; inpck -(define ttyin/7bits #o00040) ; istrip -(define ttyin/nl->cr #o00100) ; inlcr -(define ttyin/ignore-cr #o00200) ; igncr -(define ttyin/cr->nl #o00400) ; icrnl -(define ttyin/output-flow-ctl #o02000) ; ixon -(define ttyin/input-flow-ctl #o10000) ; ixoff - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #o4000) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #o20000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #o1000) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #o000010) ; ocrnl -(define ttyout/fill-w/del #o000200) ; ofdel -(define ttyout/delay-w/fill-char #o000100) ; ofill -(define ttyout/uppercase #o000002) ; olcuc -(define ttyout/nl-does-cr #o000040) ; onlret -(define ttyout/no-col0-cr #o000020) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #o000400) ; mask (nldly) -(define ttyout/nl-delay0 #o000000) -(define ttyout/nl-delay1 #o000400) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #o014000) ; mask (tabdly) -(define ttyout/tab-delay0 #o000000) -(define ttyout/tab-delay1 #o004000) ; tty 37 -(define ttyout/tab-delay2 #o010000) -(define ttyout/tab-delayx #o014000) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #o003000) ; mask (crdly) -(define ttyout/cr-delay0 #o000000) -(define ttyout/cr-delay1 #o001000) ; tn 300 -(define ttyout/cr-delay2 #o002000) ; tty 37 -(define ttyout/cr-delay3 #o003000) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #o040000) ; mask (vtdly) -(define ttyout/vtab-delay0 #o000000) -(define ttyout/vtab-delay1 #o040000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #o020000) ; mask (bsdly) -(define ttyout/bs-delay0 #o000000) -(define ttyout/bs-delay1 #o020000) - -;;; Form-feed delay -(define ttyout/ff-delay #o100000) ; mask (ffdly) -(define ttyout/ff-delay0 #o000000) -(define ttyout/ff-delay1 #o100000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #o00060) ; csize: character size mask -(define ttyc/char-size5 #o00000) ; 5 bits (cs5) -(define ttyc/char-size6 #o00020) ; 6 bits (cs6) -(define ttyc/char-size7 #o00040) ; 7 bits (cs7) -(define ttyc/char-size8 #o00060) ; 8 bits (cs8) -(define ttyc/2-stop-bits #o00100) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #o00200) ; cread: Enable receiver. -(define ttyc/enable-parity #o00400) ; parenb -(define ttyc/odd-parity #o01000) ; parodd -(define ttyc/hup-on-close #o02000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #o04000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #o020) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #o040) ; echok: Echo nl after line kill -(define ttyl/echo #o010) ; echo: Enable echoing -(define ttyl/echo-nl #o100) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #o002) ; icanon: Canonicalize input -(define ttyl/enable-signals #o001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #o400) ; iexten: Enable extensions -(define ttyl/ttou-signal #o100000) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #o200) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #o04000) ; echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #o02000) ; echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #o01000) ; echoctl: echo control chars as "^X" -(define ttyl/flush-output #o20000) ; flusho: output is being flushed -(define ttyl/reprint-unread-chars #o40000) ; pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #o4) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400) (14 . exta) (15 . extb))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/irix/waitcodes.scm b/scsh/irix/waitcodes.scm deleted file mode 100644 index 5781461..0000000 --- a/scsh/irix/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for IRIX. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (not (= (bitwise-and #xFF status) #x7F)) - (zero? (bitwise-and #x7F status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (= #x7F (bitwise-and status #xFF)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (let ((termsig (bitwise-and status #x7F))) - (and (not (zero? termsig)) ; Didn't exit. - (not (= #x7F (bitwise-and status #xFF))) ; Not suspended. - termsig))) - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/linux/Makefile.inc b/scsh/linux/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/linux/bufpol.scm b/scsh/linux/bufpol.scm deleted file mode 100644 index 803bdf3..0000000 --- a/scsh/linux/bufpol.scm +++ /dev/null @@ -1,13 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1995 by Brian D. Carlstrom. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line 1) ; _IOLBF - (none 2)) ; _IONBF diff --git a/scsh/linux/errno.scm b/scsh/linux/errno.scm deleted file mode 100644 index e6c86ec..0000000 --- a/scsh/linux/errno.scm +++ /dev/null @@ -1,139 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; These are the correct values for Linux systems. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - - (perm 1 ); Operation Not Permitted - (noent 2 ); No Such File Or Directory - (srch 3 ); No Such Process - (intr 4 ); Interrupted System Call - (io 5 ); I/O Error - (nxio 6 ); No Such Device Or Address - (2big 7 ); Arg List Too Long - (noexec 8 ); Exec Format Error - (badf 9 ); Bad File Number - (child 10 ); No Child Processes - (again 11 ); Try Again - (nomem 12 ); Out Of Memory - (acces 13 ); Permission Denied - (fault 14 ); Bad Address - (notblk 15 ); Block Device Required - (busy 16 ); Device Or Resource Busy - (exist 17 ); File Exists - (xdev 18 ); Cross-Device Link - (nodev 19 ); No Such Device - (notdir 20 ); Not A Directory - (isdir 21 ); Is A Directory - (inval 22 ); Invalid Argument - (nfile 23 ); File Table Overflow - (mfile 24 ); Too Many Open Files - (notty 25 ); Not A Typewriter - (txtbsy 26 ); Text File Busy - (fbig 27 ); File Too Large - (nospc 28 ); No Space Left On Device - (spipe 29 ); Illegal Seek - (rofs 30 ); Read-Only File System - (mlink 31 ); Too Many Links - (pipe 32 ); Broken Pipe - (dom 33 ); Math Argument Out Of Domain Of Func - (range 34 ); Math Result Not Representable - (deadlk 35 ); Resource Deadlock Would Occur - (nametoolong 36 ); File Name Too Long - (nolck 37 ); No Record Locks Available - (nosys 38 ); Function Not Implemented - (notempty 39 ); Directory Not Empty - (loop 40 ); Too Many Symbolic Links Encountered - (wouldblock 11 ); Operation Would Block - (nomsg 42 ); No Message Of Desired Type - (idrm 43 ); Identifier Removed - (chrng 44 ); Channel Number Out Of Range - (l2nsync 45 ); Level 2 Not Synchronized - (l3hlt 46 ); Level 3 Halted - (l3rst 47 ); Level 3 Reset - (lnrng 48 ); Link Number Out Of Range - (unatch 49 ); Protocol Driver Not Attached - (nocsi 50 ); No Csi Structure Available - (l2hlt 51 ); Level 2 Halted - (bade 52 ); Invalid Exchange - (badr 53 ); Invalid Request Descriptor - (xfull 54 ); Exchange Full - (noano 55 ); No Anode - (badrqc 56 ); Invalid Request Code - (badslt 57 ); Invalid Slot - (deadlock 58 ); File Locking Deadlock Error - (bfont 59 ); Bad Font File Format - (nostr 60 ); Device Not A Stream - (nodata 61 ); No Data Available - (time 62 ); Timer Expired - (nosr 63 ); Out Of Streams Resources - (nonet 64 ); Machine Is Not On The Network - (nopkg 65 ); Package Not Installed - (remote 66 ); Object Is Remote - (nolink 67 ); Link Has Been Severed - (adv 68 ); Advertise Error - (srmnt 69 ); Srmount Error - (comm 70 ); Communication Error On Send - (proto 71 ); Protocol Error - (multihop 72 ); Multihop Attempted - (dotdot 73 ); Rfs Specific Error - (badmsg 74 ); Not A Data Message - (overflow 75 ); Value Too Large For Defined Data Type - (notuniq 76 ); Name Not Unique On Network - (badfd 77 ); File Descriptor In Bad State - (remchg 78 ); Remote Address Changed - (libacc 79 ); Can Not Access A Needed Shared Library - (libbad 80 ); Accessing A Corrupted Shared Library - (libscn 81 ); .Lib Section In A.Out Corrupted - (libmax 82 ); Attempting To Link In Too Many Shared Libraries - (libexec 83 ); Cannot Exec A Shared Library Directly - (ilseq 84 ); Illegal Byte Sequence - (restart 85 ); Interrupted System Call Should Be Restarted - (strpipe 86 ); Streams Pipe Error - (users 87 ); Too Many Users - (notsock 88 ); Socket Operation On Non-Socket - (destaddrreq 89 ); Destination Address Required - (msgsize 90 ); Message Too Long - (prototype 91 ); Protocol Wrong Type For Socket - (noprotoopt 92 ); Protocol Not Available - (protonosupport 93 ); Protocol Not Supported - (socktnosupport 94 ); Socket Type Not Supported - (opnotsupp 95 ); Operation Not Supported On Transport Endpoint - (pfnosupport 96 ); Protocol Family Not Supported - (afnosupport 97 ); Address Family Not Supported By Protocol - (addrinuse 98 ); Address Already In Use - (addrnotavail 99 ); Cannot Assign Requested Address - (netdown 100 ); Network Is Down - (netunreach 101 ); Network Is Unreachable - (netreset 102 ); Network Dropped Connection Because Of Reset - (connaborted 103 ); Software Caused Connection Abort - (connreset 104 ); Connection Reset By Peer - (nobufs 105 ); No Buffer Space Available - (isconn 106 ); Transport Endpoint Is Already Connected - (notconn 107 ); Transport Endpoint Is Not Connected - (shutdown 108 ); Cannot Send After Transport Endpoint Shutdown - (toomanyrefs 109 ); Too Many References: Cannot Splice - (timedout 110 ); Connection Timed Out - (connrefused 111 ); Connection Refused - (hostdown 112 ); Host Is Down - (hostunreach 113 ); No Route To Host - (already 114 ); Operation Already In Progress - (inprogress 115 ); Operation Now In Progress - (stale 116 ); Stale Nfs File Handle - (uclean 117 ); Structure Needs Cleaning - (notnam 118 ); Not A Xenix Named Type File - (navail 119 ); No Xenix Semaphores Available - (isnam 120 ); Is A Named Type File - (remoteio 121 ); Remote I/O Error - (dquot 122 ); Quota Exceeded - - ; Should Never Be Seen By User Programs - (restartsys 512) - (restartnointr 513) - (restartnohand 514) ; Restart If No Handler.. - (noioctlcmd 515)) ; No Ioctl Command diff --git a/scsh/linux/fdflags.scm b/scsh/linux/fdflags.scm deleted file mode 100644 index af7ad0b..0000000 --- a/scsh/linux/fdflags.scm +++ /dev/null @@ -1,57 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom - -(define-enum-constants open - ;; POSIX - (read #x0000) - (write #x0001) - (read+write #x0002) - (nonblocking #x0800) ; no delay - (append #x0400) ; set append mode - - ;; Linux - (shared-lock #x0004) ; open with shared file lock - (exclusive-lock #x0008) ; open with exclusive file lock - (async #x2000) ; signal pgrep when data ready - (fsync #x1000) ; synchronus writes - - ;; POSIX - (create #x0040) ; create if nonexistant - (truncate #x0200) ; truncate to zero length - (exclusive #x0080) ; error if already exists - (no-control-tty #x0100)) ; don't assign controlling terminal - - - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-owner 9) ; F_GETOWN (Not POSIX) - (set-owner 8) ; F_SETOWN (Not POSIX) - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 0) ; F_RDLCK - (release 2) ; F_UNLCK - (write 1)) ; F_WRLCK diff --git a/scsh/linux/libansi.c b/scsh/linux/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/linux/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/linux/netconst.scm b/scsh/linux/netconst.scm deleted file mode 100644 index b4b927d..0000000 --- a/scsh/linux/netconst.scm +++ /dev/null @@ -1,128 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #x1) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug 1) ; turn on debugging info recording -;(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address 2) ; allow local address reuse -(define socket/keep-alive 9) ; keep connections alive -(define socket/dont-route 5) ; just use interface addresses -(define socket/broadcast 6) ; permit sending of broadcast msgs -;(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger 13) ; linger on close if data present -(define socket/oob-inline 10) ; leave received OOB data in line -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer 7) ; send buffer size -(define socket/receive-buffer 8) ; receive buffer size -;(define socket/send-low-water #x1003) ; send low-water mark -;(define socket/receive-low-water #x1004) ; receive low-water mark -;(define socket/send-timeout #x1005) ; send timeout -;(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error 4) ; get error status and clear -(define socket/type 3) ; get socket type -(define socket/no-check 11) ; linux -(define socket/priority 12) ; sucks - -;;; ip options -- -(define ip/type-of-service 1) ; set/get IP type of service value -(define ip/time-to-live 2) ; set/get IP time-to-live value -(define ip/include-header 3) ; include header with data -(define ip/options 4) ; set/get IP per-packet options - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug -; socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast -; socket/use-loop-back - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - ip/include-header - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer -; socket/send-low-water -; socket/receive-low-water - socket/error - socket/type - ip/time-to-live - ip/type-of-service - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list ;socket/send-timeout - ;socket/receive-timeout - )) diff --git a/scsh/linux/packages.scm b/scsh/linux/packages.scm deleted file mode 100644 index 5e4069f..0000000 --- a/scsh/linux/packages.scm +++ /dev/null @@ -1,125 +0,0 @@ -;;; Interfaces and packages for the Linux specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-interface linux-fdflags-extras-interface - (export open/shared-lock - open/exclusive-lock - open/async - open/fsync - fcntl/get-owner - fcntl/set-owner)) - -(define-interface linux-errno-extras-interface - (export errno/notblk - errno/txtbsy - errno/wouldblock - errno/inprogress - errno/already - errno/notsock - errno/destaddrreq - errno/msgsize - errno/prototype - errno/noprotoopt - errno/protonosupport - errno/socktnosupport - errno/opnotsupp - errno/pfnosupport - errno/afnosupport - errno/addrinuse - errno/addrnotavail - errno/netdown - errno/netunreach - errno/netreset - errno/connaborted - errno/connreset - errno/nobufs - errno/isconn - errno/notconn - errno/shutdown - errno/toomanyrefs - errno/timedout - errno/connrefused - errno/loop - errno/hostdown - errno/hostunreach -; errno/proclim - errno/users - errno/dquot - errno/stale - errno/remote -; errno/badrpc -; errno/rpcmismatch -; errno/progunavail -; errno/progmismatch -; errno/ftype -; errno/auth -; errno/needauth -; errno/last - )) - -(define-interface linux-signals-extras-interface - (export signal/trap -; signal/emt - signal/bus -; signal/sys - signal/urg - signal/cld - signal/io - signal/xcpu - signal/xfsz - signal/vtalrm - signal/prof - signal/winch - )) - - -(define-interface linux-network-extras-interface - (export socket/debug -; socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast -; socket/use-loop-back - socket/linger - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer -; socket/send-low-water -; socket/receive-low-water -; socket/send-timeout -; socket/receive-timeout - socket/error - socket/type - socket/no-check - socket/priority - ip/options - ip/time-to-live - ip/type-of-service ;linux - ip/include-header ;linux - tcp/no-delay - tcp/max-segment)) - -(define-interface linux-extras-interface - (compound-interface linux-errno-extras-interface - linux-fdflags-extras-interface - linux-network-extras-interface - linux-signals-extras-interface)) - -(define-interface linux-defs-interface - (compound-interface linux-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure linux-defs linux-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface linux-extras-interface) -(define os-dependent linux-defs) diff --git a/scsh/linux/signals.scm b/scsh/linux/signals.scm deleted file mode 100644 index ab520ca..0000000 --- a/scsh/linux/signals.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;; Signal constant definitions for Linux -;;; Copyright (c) 1994 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -(define-enum-constants signal - ;; POSIX - (hup 1) - (int 2) - (quit 3) - (ill 4) - (trap 5) - (abrt 6) - (iot 6) - (bus 7) - (fpe 8) - (kill 9) - (usr1 10) - (segv 11) - (usr2 12) - (pipe 13) - (alrm 14) - (term 15) - (stkflt 16) - (chld 17) - (cld 17) ;compat - (cont 18) - (stop 19) - (tstp 20) - (ttin 21) - (ttou 22) - (io 23) - (poll 23) - (urg 23) - (xcpu 24) - (xfsz 25) - (vtalrm 26) - (prof 27) - (winch 28) - (pwr 30) - (unused 31) - ) - -(define signals-ignored-by-default - (list signal/chld signal/cont signal/winch)) - diff --git a/scsh/linux/sigset.h b/scsh/linux/sigset.h deleted file mode 100644 index f30fa8c..0000000 --- a/scsh/linux/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) (*maskp=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=(mask>>24)&0xff), \ - (*(lop)=(mask&0xffffff))) diff --git a/scsh/linux/stdio_dep.c b/scsh/linux/stdio_dep.c deleted file mode 100644 index dcd800e..0000000 --- a/scsh/linux/stdio_dep.c +++ /dev/null @@ -1,80 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return (f->_IO_read_ptr < f->_IO_read_end) ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fs->_fileno = fd; -} - -int fbufcount(FILE *fs) -{ - return((fs->_IO_read_end)-(fs->_IO_read_ptr)); -} - -int ibuf_empty(FILE *fs) -{ - return((fs->_IO_read_end)-(fs->_IO_read_ptr) <= 0); -} - -int obuf_full(FILE *fs) -{ - return((fs->_IO_write_end)-(fs->_IO_write_ptr) <= 0); -} diff --git a/scsh/linux/stdio_dep.h b/scsh/linux/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/linux/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/linux/sysdep.h b/scsh/linux/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/linux/time_dep.scm b/scsh/linux/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/linux/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/linux/time_dep1.c b/scsh/linux/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/linux/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/linux/tty-consts.scm b/scsh/linux/tty-consts.scm deleted file mode 100644 index 2e2796e..0000000 --- a/scsh/linux/tty-consts.scm +++ /dev/null @@ -1,215 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for Solaris 2.x, -;;; and are taken from /usr/include/sys/termio.h -;;; and /usr/include/sys/termios.h. - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 11) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 10) ; ^z isig -(define ttychar/start 8) ; ^q ixon, ixoff -(define ttychar/stop 9) ; ^s ixon, ixoff -(define ttychar/min 6) ; !icanon ; Not exported -(define ttychar/time 5) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 14) ; ^w icanon -(define ttychar/reprint 12) ; ^r icanon -(define ttychar/literal-next 15) ; ^v iexten -(define ttychar/discard 13) ; ^o iexten -(define ttychar/delayed-suspend #f) ; ^y isig -(define ttychar/eol2 16) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 19) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #x00)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #o00001) ; ignbrk -(define ttyin/interrupt-on-break #o00002) ; brkint -(define ttyin/ignore-bad-parity-chars #o00004) ; ignpar -(define ttyin/mark-parity-errors #o00010) ; parmrk -(define ttyin/check-parity #o00020) ; inpck -(define ttyin/7bits #o00040) ; istrip -(define ttyin/nl->cr #o00100) ; inlcr -(define ttyin/ignore-cr #o00200) ; igncr -(define ttyin/cr->nl #o00400) ; icrnl -(define ttyin/output-flow-ctl #o02000) ; ixon -(define ttyin/input-flow-ctl #o10000) ; ixoff - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #o4000) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #o20000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #o1000) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #o000010) ; ocrnl -(define ttyout/fill-w/del #o000200) ; ofdel -(define ttyout/delay-w/fill-char #o000100) ; ofill -(define ttyout/uppercase #o000002) ; olcuc -(define ttyout/nl-does-cr #o000040) ; onlret -(define ttyout/no-col0-cr #o000020) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #o000400) ; mask (nldly) -(define ttyout/nl-delay0 #o000000) -(define ttyout/nl-delay1 #o000400) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #o014000) ; mask (tabdly) -(define ttyout/tab-delay0 #o000000) -(define ttyout/tab-delay1 #o004000) ; tty 37 -(define ttyout/tab-delay2 #o010000) -(define ttyout/tab-delayx #o014000) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #o003000) ; mask (crdly) -(define ttyout/cr-delay0 #o000000) -(define ttyout/cr-delay1 #o001000) ; tn 300 -(define ttyout/cr-delay2 #o002000) ; tty 37 -(define ttyout/cr-delay3 #o003000) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #o040000) ; mask (vtdly) -(define ttyout/vtab-delay0 #o000000) -(define ttyout/vtab-delay1 #o040000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #o020000) ; mask (bsdly) -(define ttyout/bs-delay0 #o000000) -(define ttyout/bs-delay1 #o020000) - -;;; Form-feed delay -(define ttyout/ff-delay #o100000) ; mask (ffdly) -(define ttyout/ff-delay0 #o000000) -(define ttyout/ff-delay1 #o100000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #o00060) ; csize: character size mask -(define ttyc/char-size5 #o00000) ; 5 bits (cs5) -(define ttyc/char-size6 #o00020) ; 6 bits (cs6) -(define ttyc/char-size7 #o00040) ; 7 bits (cs7) -(define ttyc/char-size8 #o00060) ; 8 bits (cs8) -(define ttyc/2-stop-bits #o00100) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #o00200) ; cread: Enable receiver. -(define ttyc/enable-parity #o00400) ; parenb -(define ttyc/odd-parity #o01000) ; parodd -(define ttyc/hup-on-close #o02000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #o04000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #o020) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #o040) ; echok: Echo nl after line kill -(define ttyl/echo #o010) ; echo: Enable echoing -(define ttyl/echo-nl #o100) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #o002) ; icanon: Canonicalize input -(define ttyl/enable-signals #o001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #o100000) ; iexten: Enable extensions -(define ttyl/ttou-signal #o400) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #o200) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #o04000); echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #o02000); echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #o01000); echoctl: echo control chars as "^X" -(define ttyl/flush-output #o10000); flusho: output is being flushed -(define ttyl/reprint-unread-chars #o40000); pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #o4) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400) (14 . exta) (15 . extb))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/linux/waitcodes.scm b/scsh/linux/waitcodes.scm deleted file mode 100644 index b30ecfe..0000000 --- a/scsh/linux/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for Linux. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (not (= (bitwise-and #xFF status) #x7F)) - (zero? (bitwise-and #x7F status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (= #x7F (bitwise-and status #xFF)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (let ((termsig (bitwise-and status #x7F))) - (and (not (zero? termsig)) ; Didn't exit. - (not (= #x7F (bitwise-and status #xFF))) ; Not suspended. - termsig))) - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/next/Makefile.inc b/scsh/next/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/next/bufpol.scm b/scsh/next/bufpol.scm deleted file mode 100644 index 09e5ad9..0000000 --- a/scsh/next/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o200) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/next/errno.scm b/scsh/next/errno.scm deleted file mode 100644 index 66a935c..0000000 --- a/scsh/next/errno.scm +++ /dev/null @@ -1,142 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are the correct values for NextStep systems. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno -;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes - (again 11) ; Resource temporarily unavailable - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - -;; NextStep - (notblk 15) ; Block device required - -;; POSIX - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation - (txtbsy 26) ; Text file busy - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; Strict ANSI - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - ;; NextStep - ;; non-blocking and interrupt i/o - (wouldblock 35) ; Operation would block - (inprogress 36) ; Operation now in progress - (already 37) ; Operation already in progress - - ;; ipc/network software - - ;; argument errors - (notsock 38) ; Socket operation on non-socket - (destaddrreq 39) ; Destination address required - (msgsize 40) ; Message too long - (prototype 41) ; Protocol wrong type for socket - (noprotoopt 42) ; Protocol not available - (protonosupport 43) ; Protocol not supported - (socktnosupport 44) ; Socket type not supported - (opnotsupp 45) ; Operation not supported on socket - (pfnosupport 46) ; Protocol family not supported - (afnosupport 47) ; Address family not supported by protocol family - (addrinuse 48) ; Address already in use - (addrnotavail 49) ; Can't assign requested address - - ;; operational errors - (netdown 50) ; Network is down - (netunreach 51) ; Network is unreachable - (netreset 52) ; Network dropped connection on reset - (connaborted 53) ; Software caused connection abort - (connreset 54) ; Connection reset by peer - (nobufs 55) ; No buffer space available - (isconn 56) ; Socket is already connected - (notconn 57) ; Socket is not connected - (shutdown 58) ; Can't send after socket shutdown - (toomanyrefs 59) ; Too many references: can't splice - (timedout 60) ; Connection timed out - (connrefused 61) ; Connection refused - - (loop 62) ; Too many levels of symbolic links - - ;; POSIX: - (nametoolong 63) ; File name too long - - ;; NextStep - (hostdown 64) ; Host is down - (hostunreach 65) ; No route to host - - ;; POSIX: - (notempty 66) ; Directory not empty - - ;; NextStep - ;; quotas & mush - (proclim 67) ; Too many processes - (users 68) ; Too many users - (dquot 69) ; Disc quota exceeded - - ;; Network File System - (stale 70) ; Stale NFS file handle - (remote 71) ; Too many levels of remote in path - - ;; streams - the following not defined in errno.h for NextStep -;;(nostr 72) ; Device is not a stream -;;(time 73) ; Timer expired -;;(nosr 74) ; Out of streams resources -;;(nomsg 75) ; No message of desired type -;;(badmsg 76) ; Trying to read unreadable message - - ;; SystemV IPC -;;(idrm 77) ; Identifier removed - - ;; POSIX - ;; SystemV Record Locking - (deadlk 78) ; Resource deadlock avoided - (nolck 79) ; No locks available - - ;; NextStep - (pwroff 80) ; Device power is off - (deverr 81) ; Device error - (noinit 82) ; Device not initialized - (badexec 83) ; Bad executable - (badarch 84) ; Bad CPU type in executable - (shlibvers 85) ; Shared library version mismatch - (badmacho 86) ; Malformed Macho file - -;; POSIX - (nosys 87)) ; Function not implemented - -;; the following not implemented in NextStep -;;(dotdot 88) ; Cross mount point (not an error) -;;(remchg 89) ; Remote address changed - - ;; POSIX -;;(nosys 90)) ; function not implemented diff --git a/scsh/next/fdflags.scm b/scsh/next/fdflags.scm deleted file mode 100644 index 4645bfe..0000000 --- a/scsh/next/fdflags.scm +++ /dev/null @@ -1,51 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - ;; POSIX - (read 0) - (write 1) - (read+write 2) - (nonblocking 4) - (append #o10) - (no-control-tty #o20) - (create #o1000) - (truncate #o2000) - (exclusive #o4000) - - ;; NextStep - (sync #o1000000) ; Synchronous writes - (async #o100)) ; Signal process group when data - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-owner 5) ; F_GETOWN (Not POSIX) - (set-owner 6) ; F_SETOWN (Not POSIX) - (get-record-lock 7) ; F_GETLK - (set-record-lock-noblock 8) ; F_SETLK - (set-record-lock 9)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/next/libansi.c b/scsh/next/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/next/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/next/netconst.scm b/scsh/next/netconst.scm deleted file mode 100644 index 59a4c68..0000000 --- a/scsh/next/netconst.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/use-privileged #x4000) ; allocate from privileged port area -(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -(define ip/time-to-live 2) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline - socket/use-privileged - socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type - ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/next/packages.scm b/scsh/next/packages.scm deleted file mode 100644 index e6c0c94..0000000 --- a/scsh/next/packages.scm +++ /dev/null @@ -1,116 +0,0 @@ -;;; Interfaces and packages for the NeXTSTEP specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -(define-interface next-fdflags-extras-interface - (export open/async - open/sync - fcntl/get-owner - fcntl/set-owner)) - -(define-interface next-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/afnosupport - errno/already - errno/badarch - errno/badexec - errno/badmacho - errno/connaborted - errno/connrefused - errno/connreset - errno/destaddrreq - errno/deverr - errno/dquot - errno/hostdown - errno/hostunreach - errno/inprogress - errno/isconn - errno/loop - errno/msgsize - errno/netdown - errno/netreset - errno/nobufs - errno/noinit - errno/noprotoopt - errno/notblk - errno/notconn - errno/notsock - errno/netunreach - errno/opnotsupp - errno/pfnosupport - errno/proclim - errno/protonosupport - errno/prototype - errno/pwroff - errno/remote - errno/shlibvers - errno/shutdown - errno/socktnosupport - errno/stale - errno/timedout - errno/toomanyrefs - errno/users - errno/wouldblock - errno/txtbsy)) - -(define-interface next-signals-extras-interface - (export signal/bus - signal/cld - signal/emt - signal/io - signal/iot - signal/lost - signal/prof - signal/sys - signal/trap - signal/urg - signal/vtalrm - signal/winch - signal/xcpu - signal/xfsz)) - -(define-interface next-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/use-privileged - socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface next-extras-interface - (compound-interface next-errno-extras-interface - next-fdflags-extras-interface - next-network-extras-interface - next-signals-extras-interface)) - -(define-interface next-defs-interface - (compound-interface next-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure next-defs next-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface next-extras-interface) -(define os-dependent next-defs) diff --git a/scsh/next/signals.scm b/scsh/next/signals.scm deleted file mode 100644 index d8b47c2..0000000 --- a/scsh/next/signals.scm +++ /dev/null @@ -1,67 +0,0 @@ -;;; Signal constant definitions for NextStep -;;; Copyright (c) 1994 by Olin Shivers. - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - - ;; NextStep - (trap 5) ; trace trap (not reset when caught) - - ;; POSIX - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - - ;; NextStep - (emt 7) ; EMT instruction - - ;; POSIX - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - - ;; NextStep - (bus 10) ; bus error - - ;; POSIX - (segv 11) ; segmentation violation - - ;; NextStep - (sys 12) ; bad argument to system call - - ;; POSIX - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - - ;; NextStep - (urg 16) ; urgent condition on IO channel - - ;; POSIX - (stop 17) ; sendable stop signal not from tty - (tstp 18) ; stop signal from tty - (cont 19) ; continue a stopped process - (chld 20) ; to parent on child stop or exit - - ;; NextStep - (cld 20) ; System V name for SIGCHLD - - ;; POSIX - (ttin 21) ; to readers pgrp upon background tty read - (ttou 22) ; like TTIN for output if (tp->t_local<OSTOP) - - ;; NextStep - (io 23) ; input/output possible signal - (xcpu 24) ; exceeded CPU time limit - (xfsz 25) ; exceeded file size limit - (vtalrm 26) ; virtual time alarm - (prof 27) ; profiling time alarm - (winch 28) ; window changed - (lost 29) ; resource lost (eg, record-lock lost) - - ;; User defined - (usr1 30) ; user defined signal 1 - (usr2 31) ; user defined signal 2 - ) diff --git a/scsh/next/sigset.h b/scsh/next/sigset.h deleted file mode 100644 index 702e3d2..0000000 --- a/scsh/next/sigset.h +++ /dev/null @@ -1,7 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ -#define make_sigset(maskp, hi, lo) (*(maskp)=(sigset_t)((hi)<<24)|(lo)) -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=(((int)mask)>>24)&0xff), (*(lop)=(((int)mask)&0xffffff))) diff --git a/scsh/next/stdio_dep.c b/scsh/next/stdio_dep.c deleted file mode 100644 index 6b0d6f5..0000000 --- a/scsh/next/stdio_dep.c +++ /dev/null @@ -1,91 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return fs->_cnt; -} - - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) -{ - return fs->_cnt <= 0; -} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) -{ - return (fs->_flag & _IOLBF) ? (- fs->_cnt >= fs->_bufsiz-1) - : (fs->_cnt <= 0); -} diff --git a/scsh/next/stdio_dep.h b/scsh/next/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/next/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/next/sysdep.h b/scsh/next/sysdep.h deleted file mode 100644 index c349f59..0000000 --- a/scsh/next/sysdep.h +++ /dev/null @@ -1,2 +0,0 @@ -#undef HAVE_SIGACTION -#define HAVE_SIGACTION diff --git a/scsh/next/time_dep.scm b/scsh/next/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/next/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/next/time_dep1.c b/scsh/next/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/next/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/next/tty-consts.scm b/scsh/next/tty-consts.scm deleted file mode 100644 index 7628eef..0000000 --- a/scsh/next/tty-consts.scm +++ /dev/null @@ -1,248 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for NeXTSTEP 3.x, -;;; and are taken from /usr/include/bsd/sys/termios.h and -;;; /usr/include/bsd/sys/ttydev.h - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Useless ttychar/quote char. -;;; - Two extra newline delay values -;;; - Some control and local flags: -;;; ttyc/2-stop-bits-when-110-baud stopb110 -;;; ttyc/parity0 par0 -;;; ttyc/parity1 par1 -;;; ttyl/crt-delete echocrt -;;; ttyl/xlcase xlcase Vas ist das? -;;; ttyl/xeucbksp xeucbksp 'n das? -;;; - Some baud rates - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 0) ; ^d icanon -(define ttychar/eol 1) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 4) ; ^c isig -(define ttychar/quit 5) ; ^\ isig -(define ttychar/suspend 6) ; ^z isig -(define ttychar/start 7) ; ^q ixon, ixoff -(define ttychar/stop 8) ; ^s ixon, ixoff -(define ttychar/min 9) ; !icanon ; Not exported -(define ttychar/time 10) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 11) ; ^w icanon -(define ttychar/reprint 12) ; ^r icanon -(define ttychar/literal-next 13) ; ^v iexten -(define ttychar/discard 14) ; ^o iexten -(define ttychar/delayed-suspend 15) ; ^y isig -(define ttychar/eol2 #f) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; NeXT -(define ttychar/quote 16) ; icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 17) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #xff)) - - - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #x0001) ; ignbrk -(define ttyin/interrupt-on-break #x0002) ; brkint -(define ttyin/ignore-bad-parity-chars #x0004) ; ignpar -(define ttyin/mark-parity-errors #x0008) ; parmrk -(define ttyin/check-parity #x0010) ; inpck -(define ttyin/7bits #x0020) ; istrip -(define ttyin/nl->cr #x0040) ; inlcr -(define ttyin/ignore-cr #x0080) ; igncr -(define ttyin/cr->nl #x0100) ; icrnl -(define ttyin/output-flow-ctl #x0200) ; ixon -(define ttyin/input-flow-ctl #x0400) ; ixoff - - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #x0800) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #x2000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #f) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #x0001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #x0002) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #f) ; ocrnl -(define ttyout/fill-w/del #f) ; ofdel -(define ttyout/delay-w/fill-char #f) ; ofill -(define ttyout/uppercase #f) ; olcuc -(define ttyout/nl-does-cr #f) ; onlret -(define ttyout/no-col0-cr #f) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #x0300) ; mask (nldly) -(define ttyout/nl-delay0 #x0000) -(define ttyout/nl-delay1 #x0100) ; tty 37 -(define ttyout/nl-delay2 #x0200) ; vt05 Non-standard -(define ttyout/nl-delay3 #x0300) ; Non-standard - -;;; Horizontal-tab delay -(define ttyout/tab-delay #x0c00) ; mask (tabdly) -(define ttyout/tab-delay0 #x0000) -(define ttyout/tab-delay1 #x0400) ; tty 37 -(define ttyout/tab-delay2 #x0800) -(define ttyout/tab-delayx #x0c00) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #x3000) ; mask (crdly) -(define ttyout/cr-delay0 #x0000) -(define ttyout/cr-delay1 #x1000) ; tn 300 -(define ttyout/cr-delay2 #x2000) ; tty 37 -(define ttyout/cr-delay3 #x3000) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #x4000) ; mask (vtdly) -(define ttyout/vtab-delay0 #x0000) -(define ttyout/vtab-delay1 #x4000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #x8000) ; mask (bsldy) -(define ttyout/bs-delay0 #x0000) -(define ttyout/bs-delay1 #x8000) - -;;; Form-feed delay -- appears to be rolled into the vertical-tab delay. -(define ttyout/ff-delay ttyout/vtab-delay) ; mask (ffdly) -(define ttyout/ff-delay0 ttyout/vtab-delay0) -(define ttyout/ff-delay1 ttyout/vtab-delay1) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #x0300) ; csize: character size mask -(define ttyc/char-size5 #x0000) ; 5 bits (cs5) -(define ttyc/char-size6 #x0100) ; 6 bits (cs6) -(define ttyc/char-size7 #x0200) ; 7 bits (cs7) -(define ttyc/char-size8 #x0300) ; 8 bits (cs8) -(define ttyc/2-stop-bits #x0400) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #x0800) ; cread: Enable receiver. -(define ttyc/enable-parity #x1000) ; parenb -(define ttyc/odd-parity #x2000) ; parodd -(define ttyc/hup-on-close #x4000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #x8000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #x0001); cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; NeXT -(define ttyc/2-stop-bits-when-110-baud #x010000) ; stopb110 -(define ttyc/parity0 #x20000) ; par0 -(define ttyc/parity1 #x40000) ; par1 - - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #x000002) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #x000004) ; echok: Echo nl after line kill -(define ttyl/echo #x000008) ; echo: Enable echoing -(define ttyl/echo-nl #x000010) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #x000020) ; icanon: Canonicalize input -(define ttyl/enable-signals #x000040) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #x000080) ; iexten: Enable extensions -(define ttyl/ttou-signal #x400000) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #x80000000) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #x001) ; echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #x200) ; echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #x400) ; echoctl: echo control chars as "^X" -(define ttyl/flush-output #f) ; flusho: output is being flushed -(define ttyl/reprint-unread-chars #f) ; pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #x800) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #f) ; xcase: canonical upper/lower presentation - -;;; NeXT -(define ttyl/crt-delete #x00000100) ; visual erase does "\b \b" -(define ttyl/xlcase #x04000000) ; Vas ist das? -(define ttyl/xeucbksp #x08000000) ; 'n das? - -;;; NOTE: xlcase and xeucbksp are in the NeXT , but don't appear -;;; in the tty(4) or termios(4) man pages. Where are they documented? - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400) (14 . exta) (15 . extb) - (16 . 14400) (17 . 28800) (18 . 43200) - (19 . 57600))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/stop-out 1) ; TCOOFF -(define %tcflow/start-out 2) ; TCOON -(define %tcflow/stop-in 3) ; TCIOFF -(define %tcflow/start-in 4) ; TCION - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/next/waitcodes.scm b/scsh/next/waitcodes.scm deleted file mode 100644 index 09c832c..0000000 --- a/scsh/next/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for NeXTSTEP. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (not (zero? (bitwise-and status #x40))) - (bitwise-and #x7F (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (and (not (zero? (bitwise-and status #xFF))) ; Didn't exit. - (zero? (bitwise-and status #x40)) ; Not suspended. - (bitwise-and status #x7F))) - - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/oldfr.scm b/scsh/oldfr.scm deleted file mode 100644 index dd3ce2e..0000000 --- a/scsh/oldfr.scm +++ /dev/null @@ -1,568 +0,0 @@ -;;; Field and record parsing utilities for scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -;;; Notes: -;;; - Comment on the dependencies here... -;;; - Redefine READ-LINE using READ-DELIMITED. -;;; - Awk should deal with case-insensitivity. -;;; - Should I change the field-splitters to return lists? It's the -;;; right thing, and costs nothing in terms of efficiency. - -;;; Looping primitives: -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; It is nicer for loops that loop over a bunch of different things -;;; if you can encapsulate the idea of iterating over a data structure -;;; with a -;;; (next-element state) -> elt next-state -;;; (more-elements? state) -? #t/#f -;;; generator/termination-test pair. You can use the generator with REDUCE -;;; to make a list; you can stick it into a loop macro to loop over the -;;; elements. For example, if we had an extensible Yale-loop style loop macro, -;;; we could have a loop clause like -;;; -;;; (loop (for field in-infix-delimited-string ":" path) -;;; (do (display field) (newline))) -;;; -;;; and it would be simple to expand this into code using the generator. -;;; With procedural inlining, you can get pretty optimal loops over data -;;; structures this way. -;;; -;;; As of now, you are forced to parse fields into a buffer, and loop -;;; over that. This is inefficient of time and space. If I ever manage to do -;;; an extensible loop macro for Scheme 48, I'll have to come back to this -;;; package and rethink how to provide this functionality. - -;;; Forward-progress guarantees and empty string matches. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; A loop that pulls text off a string by matching a regexp against -;;; that string can conceivably get stuck in an infinite loop if the -;;; regexp matches the empty string. For example, the regexps -;;; ^, $, .*, foo|[^f]* can all match the empty string. -;;; -;;; The regexp-loop routines in this code are careful to handle this case. -;;; If a regexp matches the empty string, the next search starts, not from -;;; the end of the match (which in the empty string case is also the -;;; beginning -- there's the rub), but from the next character over. -;;; This is the correct behaviour. Regexps match the longest possible -;;; string at a given location, so if the regexp matched the empty string -;;; at location i, then it is guaranteed they could not have matched -;;; a longer pattern starting with character #i. So we can safely begin -;;; our search for the next match at char i+1. -;;; -;;; So every iteration through the loop makes some forward progress, -;;; and the loop is guaranteed to terminate. -;;; -;;; This has the effect you want with field parsing. For example, if you split -;;; a string with the empty pattern, you will explode the string into its -;;; individual characters: -;;; ((suffix-splitter "") "foo") -> #("" "f" "o" "o") -;;; However, even though this boundary case is handled correctly, we don't -;;; recommend using it. Say what you mean -- just use a field splitter: -;;; ((field-splitter ".") "foo") -> #("f" "o" "o") - - - -;;; (join-strings string-list [delimiter grammar]) => string -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Paste strings together using the delimiter string. -;;; -;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz" -;;; -;;; DELIMITER defaults to a single space " " -;;; GRAMMAR is one of the symbols {infix, suffix} and defaults to 'infix. - -;;; (join-strings strings [delim grammar]) - -(define (join-strings strings . args) - (if (pair? strings) - (receive (delim grammar) (parse-optionals args " " 'infix) - (check-arg string? delim join-strings) - (let ((strings (reverse strings))) - (let lp ((strings (cdr strings)) - (ans (case grammar - ((infix) (list (car strings))) - ((suffix) (list (car strings) delim)) - (else (error "Illegal grammar" grammar))))) - (if (pair? strings) - (lp (cdr strings) - (cons (car strings) (cons delim ans))) - - ; All done - (apply string-append ans))))) - - "")) ; Special-cased for infix grammar. - -;;; FIELD PARSERS -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This section defines routines to split a string into fields. -;;; You can parse by specifying a pattern that *separates* fields, -;;; a pattern that *terminates* fields, or a pattern that *matches* -;;; fields. - -(define (->delim-matcher x) - (if (procedure? x) x ; matcher proc - (let ((re (cond ((regexp? x) x) ; regexp pattern - ((string? x) (make-regexp x)) ; regexp string - (else (error "Illegal pattern/parser" x))))) - - ;; The matcher proc. - (lambda (s i) - (cond ((regexp-exec re s i) => - (lambda (m) (values (match:start m 0) (match:end m 0)))) - (else (values #f #f))))))) - -;;; (infix-splitter [re num-fields handle-delim]) -> parser -;;; (suffix-splitter [re num-fields handle-delim]) -> parser -;;; (sloppy-suffix-splitter [re num-fields handle-delim]) -> parser -;;; (field-splitter [re num-fields]) -> parser -;;; -;;; (parser string [start]) -> string-list - -(define (make-field-parser-generator default-delim-matcher loop-proc) - ;; This is the parser-generator - (lambda args - (receive (delim-spec num-fields handle-delim) - (parse-optionals args default-delim-matcher #f 'trim) - - ;; Process and error-check the args - (let ((match-delim (->delim-matcher delim-spec)) - (cons-field (case handle-delim ; Field is s[i,j). - ((trim) ; Delimiter is s[j,k). - (lambda (s i j k fields) - (cons (substring s i j) fields))) - ((split) - (lambda (s i j k fields) - (cons (substring s j k) - (cons (substring s i j) fields)))) - ((concat) - (lambda (s i j k fields) - (cons (substring s i k) - fields))) - (else - (error "Illegal handle-delim spec" - handle-delim))))) - - (receive (num-fields nfields-exact?) - (cond ((not num-fields) (values #f #f)) - ((not (integer? num-fields)) - (error "Illegal NUM-FIELDS value" num-fields)) - ((<= num-fields 0) (values (- num-fields) #f)) - (else (values num-fields #t))) - - ;; This is the parser. - (lambda (s . maybe-start) - (reverse (loop-proc s (optional-arg maybe-start 0) - match-delim cons-field - num-fields nfields-exact?)))))))) - -(define default-field-matcher (->delim-matcher "[^ \t\n]+")) - -;;; (field-splitter [field-spec num-fields]) - -(define (field-splitter . args) - (receive (field-spec num-fields) - (parse-optionals args default-field-matcher #f) - - ;; Process and error-check the args - (let ((match-field (->delim-matcher field-spec))) - (receive (num-fields nfields-exact?) - (cond ((not num-fields) (values #f #f)) - ((not (integer? num-fields)) - (error "Illegal NUM-FIELDS value" - field-splitter num-fields)) - ((<= num-fields 0) (values (- num-fields) #f)) - (else (values num-fields #t))) - - ;; This is the parser procedure. - (lambda (s . maybe-start) - (reverse (fieldspec-field-loop s (optional-arg maybe-start 0) - match-field num-fields nfields-exact?))))))) - - -;;; These four procedures implement the guts of each parser -;;; (field, infix, suffix, and sloppy-suffix). -;;; -;;; The CONS-FIELD argument is a procedure that parameterises the -;;; HANDLE-DELIM action for the field parser. -;;; -;;; The MATCH-DELIM argument is used to match a delimiter. -;;; (MATCH-DELIM S I) returns two integers [start, end] marking -;;; the next delimiter after index I in string S. If no delimiter is -;;; found, it returns [#f #f]. - -;;; In the main loop of each parser, the loop variable LAST-NULL? tells if the -;;; previous delimiter-match matched the empty string. If it did, we start our -;;; next delimiter search one character to the right of the match, so we won't -;;; loop forever. This means that an empty delimiter regexp "" simply splits -;;; the string at each character, which is the correct thing to do. -;;; -;;; These routines return the answer as a reversed list. - - -(define (fieldspec-field-loop s start match-field num-fields nfields-exact?) - (let ((end (string-length s))) - (let lp ((i start) (nfields 0) (fields '()) (last-null? #f)) - (let ((j (if last-null? (+ i 1) i)) ; Where to start next delim search. - - ;; Check to see if we made our quota before returning answer. - (finish-up (lambda () - (if (and num-fields (< nfields num-fields)) - (error "Too few fields in record." num-fields s) - fields)))) - - (cond ((> j end) (finish-up)) ; We are done. Finish up. - - ;; Read too many fields. Bomb out. - ((and nfields-exact? (> nfields num-fields)) - (error "Too many fields in record." num-fields s)) - - ;; Made our lower-bound quota. Quit early. - ((and num-fields (= nfields num-fields) (not nfields-exact?)) - (if (= i end) fields ; Special case hackery. - (cons (substring s i end) fields))) - - ;; Match off another field & loop. - (else (receive (m0 m1) (match-field s j) - (if m0 (lp m1 (+ nfields 1) - (cons (substring s m0 m1) fields) - (= m0 m1)) - (finish-up))))))))) ; No more matches. Finish up. - - -(define (infix-field-loop s start match-delim cons-field - num-fields nfields-exact?) - (let ((end (string-length s))) - (if (= start end) '() ; Specially hack empty string. - - (let lp ((i start) (nfields 0) (fields '()) (last-null? #f)) - (let ((finish-up (lambda () - ;; s[i,end) is the last field. Terminate the loop. - (cond ((and num-fields (< (+ nfields 1) num-fields)) - (error "Too few fields in record." - num-fields s)) - - ((and nfields-exact? - (>= nfields num-fields)) - (error "Too many fields in record." - num-fields s)) - - (else - (cons (substring s i end) fields))))) - - (j (if last-null? (+ i 1) i))) ; Where to start next search. - - (cond - ;; If we've read NUM-FIELDS fields, quit early . - ((and num-fields (= nfields num-fields)) - (if nfields-exact? - (error "Too many fields in record." num-fields s) - (cons (substring s i end) fields))) - - - ((<= j end) ; Match off another field. - (receive (m0 m1) (match-delim s j) - (if m0 - (lp m1 (+ nfields 1) - (cons-field s i m0 m1 fields) - (= m0 m1)) - (finish-up)))) ; No more delimiters - finish up. - - ;; We've run off the end of the string. This is a weird - ;; boundary case occuring with empty-string delimiters. - (else (finish-up)))))))) - - - -;;; Match off an optional initial delimiter, -;;; then jump off to the suffix parser. - -(define (sloppy-suffix-field-loop s start match-delim cons-field - num-fields nfields-exact?) - ;; If sloppy-suffix, skip an initial delimiter if it's there. - (let ((start (receive (i j) (match-delim s start) - (if (and i (zero? i)) j start)))) - (suffix-field-loop s start match-delim cons-field - num-fields nfields-exact?))) - - -(define (suffix-field-loop s start match-delim cons-field - num-fields nfields-exact?) - (let ((end (string-length s))) - - (let lp ((i start) (nfields 0) (fields '()) (last-null? #f)) - (let ((j (if last-null? (+ i 1) i))) ; Where to start next delim search. - (cond ((= i end) ; We are done. - (if (and num-fields (< nfields num-fields)) ; Didn't make quota. - (error "Too few fields in record." num-fields s) - fields)) - - ;; Read too many fields. Bomb out. - ((and nfields-exact? (= nfields num-fields)) - (error "Too many fields in record." num-fields s)) - - ;; Made our lower-bound quota. Quit early. - ((and num-fields (= nfields num-fields) (not nfields-exact?)) - (cons (substring s i end) fields)) - - (else ; Match off another field. - (receive (m0 m1) (match-delim s j) - (if m0 (lp m1 (+ nfields 1) - (cons-field s i m0 m1 fields) - (= m0 m1)) - (error "Missing field terminator" s))))))))) - - -;;; Now, build the exported procedures: {infix,suffix,sloppy-suffix}-splitter. - -(define default-suffix-matcher (->delim-matcher "[ \t\n]+|$")) -(define default-infix-matcher (->delim-matcher "[ \t\n]+")) - -(define infix-splitter - (make-field-parser-generator default-infix-matcher infix-field-loop)) -(define suffix-splitter - (make-field-parser-generator default-suffix-matcher suffix-field-loop)) -(define sloppy-suffix-splitter - (make-field-parser-generator default-suffix-matcher sloppy-suffix-field-loop)) - - - -;;; Delimited readers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED! -;;; until we hit a delimiter or EOF. Each time through the loop, we -;;; double the total buffer space, so the loop terminates with a log -;;; number of reads, but uses at most double the optimal buffer space. - -(define (read-delimited delims . maybe-port) - (let ((smart-substring (lambda (s end) - (if (= end (string-length s)) s - (substring s 0 end)))) - (delims (->char-set delims))) - - ;; BUFLEN is total amount of buffer space allocated to date. - (let lp ((strs '()) (buflen 80) (buf (make-string 80))) - (cond ((apply read-delimited! delims buf maybe-port) => - (lambda (i) - (if (null? strs) ; Gratuitous optimisation. - (smart-substring buf i) - (apply string-append - (reverse (if (eof-object? i) - strs - (cons (smart-substring buf i) - strs))))))) - - (else (lp (cons buf strs) - (+ buflen buflen) - (make-string buflen))))))) - - -;;; (read-delimited! delims buf [port start end]) - -(define (read-delimited! delims buf . args) ; [port start end] - (receive (port start end) - (parse-optionals args (current-input-port) 0 (string-length buf)) - (check-arg input-port? port read-delimited!) - (let ((delims (->char-set delims))) -; (if (fd-inport? port) ; ??? -; -; ;; Handle fdports in C code for speed. -; (receive (err val) -; (%read-delimited-fdport!/errno delims buf port start end) -; (if err -; (errno-error err read-delimited!) -; val)) - - ;; This is the code for other kinds of ports. - (let lp ((i start)) - (and (< i end) - (let ((c (peek-char port))) - (if (or (eof-object? c) - (char-set-contains? delims c)) - (- i start) - (begin (string-set! buf i (read-char port)) - (lp (+ i 1)))))))))) -;) - -;(define-foreign %read-delimited-fdport!/errno (read_delim (string-desc delims) -; (string-desc buf) -; (desc port) ;??? -; (fixnum start) -; (fixnum end)) -; desc ; errno or #f -; desc) ; nread or #f or eof-object - -(define (skip-char-set cset . maybe-port) - (let ((port (optional-arg maybe-port (current-input-port)))) - (let lp () - (let ((c (peek-char port))) - (cond ((and (char? c) (char-set-contains? cset c)) - (read-char port) - (lp)) - (else c)))))) - - - -;;; Reading records -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define default-record-delims (char-set #\newline)) - -;;; (record-reader [delims elide? handle-delim]) -> reader -;;; (reader [port]) -> string or eof - -(define (record-reader . args) - (receive (delims elide? handle-delim) - (parse-optionals args default-record-delims #f 'trim) - (let ((delims (->char-set delims))) - - (case handle-delim - ((trim) ; TRIM-delimiter reader. - (lambda maybe-port - (let ((s (apply read-delimited delims maybe-port))) - (if (not (eof-object? s)) - (if elide? - (apply skip-char-set delims maybe-port) ; Snarf delims. - (apply read-char maybe-port))) ; Just snarf one. - s))) - - ((concat split) ; CONCAT-delimiter & SPLIT-delimiter reader. - (let ((not-delims (char-set-invert delims))) - (lambda maybe-port - (let ((s (apply read-delimited delims maybe-port))) - (if (eof-object? s) s - (let ((delim (if elide? - (apply read-delimited not-delims maybe-port) - (string (apply read-char maybe-port))))) - (if (eq? handle-delim 'split) - (values s delim) - (if (eof-object? delim) s - (string-append s delim))))))))) - - (else - (error "Illegal delimiter-action" handle-delim)))))) - - -;;; {string, char, char-set, char predicate} -> char-set - -(define (->char-set x) - (cond ((char-set? x) x) - ((string? x) (string->char-set x)) - ((char? x) (char-set x)) - ((procedure? x) (predicate->char-set x)) - (else (error "->char-set: Not a charset, string, char, or predicate." - x)))) - - - -(define blank-line-regexp (make-regexp "^[ \t]*\n$")) - -;;; (read-paragraph [port]) -(define (read-paragraph . maybe-port) - (let ((port (optional-arg maybe-port (current-input-port)))) - - ;; First, skip all blank lines. - (let lp () - (let ((line (read-line port #t))) - (cond ((eof-object? line) line) - ((regexp-exec blank-line-regexp line) (lp)) - - ;; Then, read in non-blank lines. - (else (let ((lines (let lp ((lines (list line))) - (let ((line (read-line port #t))) - (cond ((or (eof-object? line) - (regexp-exec blank-line-regexp - line)) - lines) - (else (lp (cons line lines)))))))) - - ;; Return the paragraph - (apply string-append (reverse lines))))))))) - -;;; Reading and parsing records -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; (field-reader [field-parser rec-reader]) -> reader -;;; (reader [port]) -> [raw-record parsed-record] or [eof #()] -;;; -;;; This is the field reader, which is basically just a composition of -;;; RECORD-READER and FIELD-PARSER. - -(define default-field-parser (field-splitter)) - -(define (field-reader . args) - (receive (parser rec-reader) - (parse-optionals args default-field-parser read-line) - (lambda maybe-port - (let ((record (apply rec-reader maybe-port))) - (if (eof-object? record) - (values record '#()) - (values record (parser record))))))) - - - -;;; Parse fields by regexp -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This code parses up a record into fields by matching a regexp specifying -;;; the field against the record. The regexp describes the *field*. In the -;;; other routines, the regexp describes the *delimiters*. They are -;;; complimentary. - -;;; Repeatedly do (APPLY PROC M STATE) to generate new state values, -;;; where M is a regexp match structure made from matching against STRING. - -;(define (regexp-reduce string start regexp proc . state) -; (let ((end (string-length string)) -; (regexp (if (string? regexp) -; (make-regexp regexp) -; regexp))) -; -; (let lp ((i start) (state state) (last-null? #f)) -; (let ((j (if last-null? (+ i 1) i))) -; (cond ((and (<= j end) (regexp-exec regexp string j)) => -; (lambda (m) -; (receive state (apply proc m state) -; (lp (match:end m) state (= (match:start m) (match:end m)))))) -; (else (apply values state))))))) -; -;(define (all-regexp-matches regexp string) -; (reverse (regexp-reduce string 0 regexp -; (lambda (m ans) (cons (match:substring m 0) ans)) -; '()))) - -;;; Previously in newports.scm - -;;; Read in a line of data. Input is terminated by either a newline or EOF. -;;; The newline is trimmed from the string. - -(define (read-line . rest) - (let ((port (if (null? rest) (current-input-port) (car rest))) ; Optional arg - (retain-newline? (and (not (null? rest)) ; parsing. - (not (null? (cdr rest))) - (cadr rest))) - - ;; S[I] := C. If this overflows S, grow it. - (deposit (lambda (s i c) - (let ((s (if (< i (string-length s)) s - (string-append s s)))) ; doubling hack - (string-set! s i c) - s))) - - ;; Precisely resize S to size NUMCHARS. - (trim (lambda (s numchars) - (if (= numchars (string-length s)) s - (substring s 0 numchars))))) - - (let lp ((s (make-string 81)) (numchars 0)) - (let ((c (read-char port))) - (cond ((eof-object? c) - (if (zero? numchars) c - (trim s numchars))) - - ((char=? c #\newline) - (if retain-newline? - (trim (deposit s numchars c) - (+ numchars 1)) - (trim s numchars))) - - (else (lp (deposit s numchars c) - (+ numchars 1)))))))) - diff --git a/scsh/oldhere.scm b/scsh/oldhere.scm deleted file mode 100644 index 31eef64..0000000 --- a/scsh/oldhere.scm +++ /dev/null @@ -1,100 +0,0 @@ -;;; Here documents in Scheme for scsh scripts. -;;; These are like "here documents" for sh and csh shell scripts -;;; (i.e., the < - (lambda (line-start) - (let ((text (cons line-start text)) - (ls-len (string-length line-start))) - (lp (if (char=? #\newline (string-ref line-start - (- ls-len 1))) - text - (let ((line-rest (read-line port 'concat))) - (if (eof-object? line-rest) - (reading-error port - "EOF while reading #< here-string.") - (cons line-rest text)))))))) - - ;; We're done. The last line, tho, needs its newline - ;; stripped off. - ((null? text) "") - (else (let* ((last-chunk (car text)) - (lc-len (string-length last-chunk)) - (last-chunk (substring last-chunk 0 (- lc-len 1))) - (text (cons last-chunk (cdr text)))) - (make-immutable! (apply string-append - (reverse text))))))))))) - - -;;; If the next chars read from PORT match DELIM, return false. -;;; Otherwise, return the string you read from PORT to determine the non-match. -;;; If EOF is encountered, report an error. - -(define (delimiter-scan delim port) - (let ((len (string-length delim))) - (let lp ((i 0)) - (and (< i len) - (let ((c (read-char port))) - (cond ((eof-object? c) - (reading-error port "EOF while reading #< here string.")) - ((char=? c (string-ref delim i)) - (lp (+ i 1))) - (else (string-append (substring delim 0 i) - (string c))))))))) - -;(define-sharp-macro #\< -; (lambda (c port) (read-here-string port))) diff --git a/scsh/oldtop.scm b/scsh/oldtop.scm deleted file mode 100644 index fd3e415..0000000 --- a/scsh/oldtop.scm +++ /dev/null @@ -1,133 +0,0 @@ -;;; Scsh top level -;;; Copyright (c) 1993 by Olin Shivers. - -;;; Requires -;;; From BUILD: build-image -;;; From COMMAND: start-command-processor, user-context, -;;; package-for-commands - -(define %internal-full-command-line '()) -(define %internal-command-line-arguments '()) -(define (command-line) (append %internal-command-line-arguments '())) - -(define scsh-major-version 0) -(define scsh-minor-version 4) -(define scsh-version-string "0.4.0") - -;;; A scsh starter takes the command line args, parses them, -;;; initialises the scsh system, and either starts up a repl loop -;;; or executes the -s script. -(define (make-scsh-starter) - (let ((env (environment-for-commands)) - (context (user-context))) - (lambda (args) - (receive (script args) (parse-scsh-args args) - (set! command-line-arguments (append args '())) - (cond (script ;Batch - (set! %internal-command-line-arguments - (cons script args)) - (load-quietly1 script env) - 0) ; exit code - - (else ; Interactive - (with-interaction-environment env - (lambda () - (set-batch-mode?! #t) - (set! %internal-command-line-arguments - (cons "scsh" args)) - (start-command-processor "" - context - (lambda () - (display "Scsh ") - (display scsh-version-string) - (newline) - )))))))))) - -;;; Make a different kind of starter. This one initialises the -;;; scsh run time, then simply calls the user's program. -;;; -;;; It should take an arg to determine what kind of a condition -;;; system you'd like in place. - -(define (make-top-level main) - (lambda (args) - (set! %internal-full-command-line args) - (set! %internal-command-line-arguments (cons "" args)) - (init-scsh #f #t) - (set! command-line-arguments (append args '())) - (main) - 0)) - -(define (repl) - (command-loop (lambda () (set-batch-mode?! #f)) - #f)) - - -(define (bad-args arg-list) - (error "Bad argument list to scsh. -Useage: scsh [ ... ] -: -s - -- (Terminates option parsing)" arg-list)) - -(define (parse-scsh-args arg-list) - (if (pair? arg-list) - (let ((arg1 (car arg-list)) - (rest (cdr arg-list))) - (cond ((string=? arg1 "-s") - (if (pair? rest) - (values (car rest) (cdr rest)) - (bad-args arg-list))) - ((string=? arg1 "--") (values #f rest)) - (else (bad-args arg-list)))) - (values #f '()))) - - -;;; BUILD-IMAGE calls the starter after installing a fatal top-level -;;; error handler. MAKE-SCSH-STARTER shadows it in the interactive case. - -(define (dump-scsh fname) - (build-scsh-image (make-scsh-starter) fname)) - -(define (dump-scsh-program main fname) - (build-scsh-image main fname)) - -;;; Hacked because s48's compiler's scanner insists on echoing the file name. - -(define (load-quietly1 fname package) - (call-with-input-file fname - (lambda (port) - (let loop () - (let ((form (read port))) - (if (not (eof-object? form)) - (begin (eval form package) - (loop)))))))) - -;;; Had to define these as the ones in s48's build.scm do not properly -;;; initialise ERROR-OUTPUT-PORT to stderr -- this is a bug in the vm's -;;; handoff to the very first Scheme form (it passes two ports -- not three). -;;; Until Kelsey fixes these, we hack it with these replacements, which -;;; invoke INIT-SCSH, which re-initialises the I/O system to be what -;;; you wanted. - -(define (build-scsh-image start filename) - (let ((filename (translate filename))) - (display (string-append "Writing " filename) (command-output)) - (newline (command-output)) - (flush-the-symbol-table!) ;Gets restored at next use of string->symbol - (write-image filename - (scsh-stand-alone-resumer start) - "") - #t)) - -(define (scsh-stand-alone-resumer start) - (usual-resumer ;sets up exceptions, interrupts, and current input & output - (lambda (args) - (init-scsh #f #f) ; Whatever. Install scsh's I/O system. - (call-with-current-continuation - (lambda (halt) - (set! command-line-arguments (append args '())) - (set! %internal-full-command-line args) - (set! %internal-command-line-arguments (cons "" args)) ; WRONG - (with-handler (simple-condition-handler halt (error-output-port)) - (lambda () - (start args)))))))) diff --git a/scsh/procobj.scm b/scsh/procobj.scm deleted file mode 100644 index d5b3e8e..0000000 --- a/scsh/procobj.scm +++ /dev/null @@ -1,291 +0,0 @@ -;;; Unix wait & process objects for scsh -;;; Copyright (c) 1993, 1994, 1995 by Olin Shivers. - -;;; This is a GC'd abstraction for Unix process id's. -;;; The problem with Unix pids is (a) they clutter up the kernel -;;; process table until you wait(2) them, and (b) you can only -;;; wait(2) them once. Scsh's process objects are similar, but -;;; allow the storage to be allocated in the scsh address space, -;;; and out of the kernel process table, and they can be waited on -;;; multiple times. - -;;; Process objects -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-record proc ; A process object - pid ; Proc's pid. - (%status #f) ; The cached exit status of the process; - ; #f if we haven't wait(2)'d the process yet. - - ;; Make proc objects print like #{proc 2318}. - ((disclose p) (list "proc" (proc:pid p)))) - - -;;; Indexing this table by pid requires a linear scan. -;;; Probably not an important op, tho. - -(define process-table (make-population)) - -(define (maybe-pid->proc pid) - (call/cc (lambda (quit) - ;; Search the table. - (walk-population (lambda (p) - (if (= (proc:pid p) pid) (quit p))) - process-table) - #f))) - -(define (pid->proc pid . maybe-probe?) - (let ((probe? (:optional maybe-probe? #f))) - (or (maybe-pid->proc pid) - (case probe? - ((#f) (error "Pid has no corresponding process object" pid)) - ((create) (let ((p (make-proc pid))) ; Install a new one. - (add-to-population! p process-table) - p)) - (else #f))))) - -;;; Coerce pids and procs to procs. - -(define (->proc proc/pid) - (cond ((proc? proc/pid) proc/pid) - ((and (integer? proc/pid) (>= proc/pid 0)) - (pid->proc proc/pid)) - (else (error "Illegal parameter" ->proc proc/pid)))) - - -;;; Is X a pid or a proc? - -(define (pid/proc? x) (or (proc? x) (and (integer? x) (>= pid 0)))) - - -;;; Process reaping -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; "Reaping" a process means using wait(2) to move its exit status from the -;;; kernel's process table into scsh, thus cleaning up the kernel's process -;;; table and saving the value in a gc'd data structure, where it can be -;;; referenced multiple times. -;;; -;;; - Stopped processes are never reaped, only dead ones. -;;; -;;; - Stopped process status codes are never cached in proc objects, -;;; only status codes for dead processes. So you can wait for a -;;; dead process multiple times, but only once per process-stop. -;;; -;;; - Unfortunately, reaping a process loses the information specifying its -;;; process group, so if a process is reaped into scsh, it cannot be -;;; waited for by WAIT-PROCESS-GROUP. Notice that only dead processes are -;;; reaped, not suspended ones. Programs almost never use WAIT-PROCESS-GROUP -;;; to wait for dead processes, so this is not likely to be a problem. If -;;; it is, turn autoreaping off with (autoreap-policy #f). -;;; -;;; - Reaping can be encouraged by calling (REAP-ZOMBIES). - -;;; (autoreap-policy [new-policy]) - -(define *autoreap-policy* 'early) ; Not exported from this module. - -(define (autoreap-policy . maybe-policy) - (let ((old-policy *autoreap-policy*)) - (if (pair? maybe-policy) - (let ((new-policy (car maybe-policy))) - (cond ((pair? (cdr maybe-policy)) - (error "Too many args to autoreap-policy" maybe-policy)) - ((not (memq new-policy '(early #f))) - (error "Illegal autoreap policy." new-policy)) - (else (set! *autoreap-policy* new-policy))))) - old-policy)) - - -;;; (reap-zombies) => bool -;;; Move any zombies from the kernel process table into scsh. -;;; Return true if no more outstanding children; #f if some still live. - -(define (reap-zombies) - (let lp () - (receive (pid status) (%wait-any wait/poll) - (if pid - (begin (add-reaped-proc! pid status) - (lp)) - status)))) - -;;; This list contains procs that haven't exited yet. FORK adds new -;;; procs to the list. When a proc exits, it is removed from the list. -;;; Being on this list keeps live children's proc objects from being gc'd. - -(define unexited-procs '()) - -(define (new-child-proc pid) - (let ((proc (make-proc pid))) - (add-to-population! proc process-table) - (set! unexited-procs (cons proc unexited-procs)) - proc)) - -(define (mark-proc-exited proc) - (set! unexited-procs (del proc unexited-procs))) - - -;;; (WAIT proc/pid [flags]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; (wait proc/pid [flags]) => status or #f -;;; -;;; FLAGS (default 0) is the exclusive or of the following: -;;; wait/poll -;;; Return #f immediately if there are no -;;; unwaited children available. -;;; wait/stopped-children -;;; Report on suspended children as well. -;;; -;;; If the process hasn't terminated (or suspended, if wait/stopped -;;; is set) and wait/poll is set, return #f. - -;;; WAIT waits for a specific process. Currently, if the autoreap policy is -;;; 'early, it also does a (reap-zombies) Before performing a waitpid(2) -;;; systcall, wait first consults the proc object to see if a/the process has -;;; been reaped already. If so, its saved status is returned immediately. -;;; - -;;; (wait-any [flags]) => [proc status] -;;; [#f #f] => non-blocking, none ready. -;;; [#f #t] => no more. - -;;; (wait-process-group [pid/proc flags]) => [proc status] -;;; [#f #f] => non-blocking, none ready. -;;; [#f #t] => no more. - -(define (wait pid/proc . maybe-flags) - (if (not *autoreap-policy*) (reap-zombies)) - (let ((flags (:optional maybe-flags 0)) - (proc (->proc pid/proc))) - (cond ((proc:%status proc) => ; Already reaped. - (lambda (status) - (mark-proc-waited! proc) ; Not eligible for a WAIT-ANY. - status)) - (else ; Really wait. - (cache-wait-status proc (%wait-pid (proc:pid proc) - flags)))))) - -(define (cache-wait-status proc status) - (cond ((and (integer? status) - (not (status:stop-sig status))) ; He's dead, Jim. - (set-proc:%status proc status) ; Cache exit status. - (mark-proc-exited proc))) ; We're now gc'able. - status) - - -;;; (wait-any [flags]) -> [proc status] - -(define (wait-any . maybe-flags) - (if (not *autoreap-policy*) (reap-zombies)) - (cond ((get-reaped-proc!) => ; Check internal table. - (lambda (proc) (values proc (proc:%status proc)))) ; Hit. - (else - (receive (pid status) (%wait-any (:optional maybe-flags 0)) ; Wait. - (if pid - (let ((proc (pid->proc pid))) - (cache-wait-status proc status) - (values proc status)) - (values pid status)))))) ; pid = #f -- Empty poll. - - -;;; (wait-process-group [proc-group flags]) -;;; -;;; If you are doing process-group waits, you do *not* want to use -;;; early autoreaping, since the reaper loses process-group information. - -(define (wait-process-group . args) - (let-optionals args ((proc-group 0) (flags 0)) - (if (not *autoreap-policy*) (reap-zombies)) - (let ((proc-group (cond ((integer? proc-group) proc-group) - ((proc? proc-group) (proc:pid proc-group)) - (else (error "Illegal argument" wait-process-group - proc-group))))) - (receive (pid status) (%wait-process-group proc-group flags) - (if pid - (let ((proc (pid->proc pid))) - (cache-wait-status proc status) - (values proc status)) - (values pid status)))))) ; pid = #f -- Empty poll. - - - -;;; (%wait-any flags) (%wait-pid pid flags) (%wait-process-group pgrp flags) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Direct interfaces to waitpid(2) call. -;;; [#f #f] means no processes ready on a non-blocking wait. -;;; [#f #t] means no waitable process on wait-any. - -(define (%wait-pid pid flags) - (let lp () - (receive (err pid status) (%wait-pid/errno pid flags) - (cond ((not err) (and (not (zero? pid)) status)) ; pid=0 => none ready. - ((= err errno/intr) (lp)) - (else (errno-error err %wait-pid pid flags)))))) - -(define (%wait-any flags) - (let lp () - (receive (err pid status) (%wait-pid/errno -1 flags) - (cond (err (cond ((= err errno/child) (values #f #t)) ; No more. - ((= err errno/intr) (lp)) - (else (errno-error err %wait-any flags)))) - ((zero? pid) (values #f #f)) ; None ready. - (else (values pid status)))))) - -(define (%wait-process-group pgrp flags) - (let lp () - (receive (err pid status) (%wait-pid/errno (- pgrp) flags) - (cond (err (cond ((= err errno/child) (values #f #t)) ; No more. - ((= err errno/intr) (lp)) - (else (errno-error err %wait-process-group pgrp flags)))) - ((zero? pid) (values #f #f)) ; None ready. - (else (values pid status)))))) - - -;;; Reaped process table -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; We keep track of procs that have been reaped but not yet waited on by -;;; the user's code. These proces are eligible for return by WAIT-ANY. -;;; We keep track of these so that WAIT-ANY will hand them out exactly once. -;;; Whenever WAIT, WAIT-ANY, WAIT-PROCESS-GROUP waits on a process to exit, -;;; it removes the process from this table if it's in it. -;;; This code is bogus -- we use weak pointers. We need populations that -;;; support deletion or filtering. - -(define reaped-procs '()) ; Reaped, but not yet waited. - -(define (filter-weak-ptr-list pred lis) - (reverse (reduce (lambda (wptr result) - (let ((val (weak-pointer-ref wptr))) - (if (and val (pred val)) - (cons wptr result) - result))) - '() - lis))) - -;;; Add a newly-reaped proc to the list. -(define (add-reaped-proc! pid status) - (cond ((maybe-pid->proc pid) => - (lambda (proc) - (set-proc:%status proc status) - (set! reaped-procs (cons (make-weak-pointer proc) - reaped-procs)))) - (else (error "Child pid mysteriously missing proc object." pid)))) - -;;; Pop one off the list. -(define (get-reaped-proc!) - (and (pair? reaped-procs) - (let ((proc (weak-pointer-ref (car reaped-procs)))) - (set! reaped-procs (cdr reaped-procs)) - (or proc (get-reaped-proc!))))) - -;;; PROC no longer eligible to be in the list. Delete it. -(define (mark-proc-waited! proc) - (set! reaped-procs (filter-weak-ptr-list (lambda (elt) (not (eq? proc elt))) - reaped-procs))) - -;;; The mark-proc-waited! machinery above is a crock. It is inefficient -- -;;; we should have a flag in the proc saying if it's eligible for a WAIT-ANY. -;;; Starts off #t, changes to #f after a wait. On a #t->#f transition, we -;;; delete it from the WAIT-ANY population. Right now, every time the user -;;; waits on the proc, we re-delete it from the population -- which is -;;; a no-op after the first time. diff --git a/scsh/pty.scm b/scsh/pty.scm deleted file mode 100644 index 85c07c9..0000000 --- a/scsh/pty.scm +++ /dev/null @@ -1,102 +0,0 @@ -;;; Pseudo terminals -;;; Copyright (c) 1995 by Olin Shivers. - -;;; (fork-pty-session thunk) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Fork the process with stdio (fd's 0, 1, & 2 and also the current i/o ports) -;;; bound to a tty device. In the parent process, returns four values: -;;; [process pty-inport pty-outport ttyname] -;;; - PROCESS is a process object for the child. -;;; - PTY-{IN,OUT}PORT are input and output ports open on the controlling pty -;;; device. PTY-OUTPORT is unbuffered. -;;; - TTYNAME is the name of the child's tty, e.g. "/dev/ttyk4". -;;; -;;; The subprocess is placed in its own session, and the tty device -;;; becomes the control tty for the new session/process-group/process. -;;; The child runs with stio hooked up to the tty; the (error-output-port) -;;; port is unbuffered. - -(define (fork-pty-session thunk) - (receive (pty-in ttyname) (open-pty) - (let* ((process (fork (lambda () - (close-input-port pty-in) - (become-session-leader) - (let ((tty (open-control-tty ttyname))) - (move->fdes tty 0) - (dup->outport tty 1) - (set-port-buffering (dup->outport tty 2) - bufpol/none)) - (with-stdio-ports* thunk)))) - (pty-out (dup->outport pty-in))) - - (set-port-buffering pty-out bufpol/none) - (values process pty-in pty-out ttyname)))) - -;;; (open-pty) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Returns two values: [pty-inport ttyname] -;;; PTY-PORT is a port open on the pty. -;;; TTYNAME is the name of the tty, e.g., "/dev/ttyk4" -;;; -;;; Scheme doesn't allow bidirectional ports, so the returned port -;;; is an input port -- however, the underlying file descriptor is -;;; opened read+write, and you can use DUP->OUTPORT to map it to -;;; corresponding output ports. - -(define (open-pty) - (let ((next-pty (make-pty-generator))) - (let loop () - (cond ((next-pty) => - (lambda (pty-name) - (cond ((with-errno-handler ((errno packet) (else #f)) - (open-file pty-name open/read+write)) => - (lambda (pty) ; Score! - (values pty (pty-name->tty-name pty-name)))) - - (else (loop))))) ; Open failed; try another pty. - - (else (error "open-pty: could not open new pty")))))) - -;;; The following code may in fact be system dependent. -;;; If so, we'll move it out to the architecture specific directories. - -;;; Map between corresponding pty and tty filenames. - -(define (pty/tty-name-mapper char) - (lambda (name) - (let ((ans (string-copy name))) - (string-set! ans 5 char) ; Change X in "/dev/Xtyzz" to CHAR. - ans))) - -(define pty-name->tty-name (pty/tty-name-mapper #\t)) ;/dev/ttyk3 -> /dev/ptyk3 -(define tty-name->pty-name (pty/tty-name-mapper #\p)) ;/dev/ptyk3 -> /dev/ttyk3 - - -;;; Generator for the set of possible pty names. - -(define (make-pty-generator) - (let* ((pattern (string-copy"/dev/ptyLN")) ; L=letter N=number - (l-pos 8) - (n-pos 9) - -; (letters "pqrstuvwxyzPQRST") ; From telnetd source in BSD4.4. -; (numbers "0123456789abcdef") - (letters "pq") ; From telnetd source in BSD4.4. - (numbers "0123456789abcdef") - (num-letters (string-length letters)) - (num-numbers (string-length numbers)) - - (l num-letters) ; Generator's state vars. The value - (n 0)) ; of the last elt that was generated. - ; (We count backwards to (0,0); n fastest.) - (lambda () - (call-with-current-continuation - (lambda (abort) - (if (zero? n) - (if (zero? l) (abort #f) ; No more. - (begin (set! l (- l 1)) - (set! n (- num-numbers 1)) - (string-set! pattern l-pos (string-ref letters l)))) - (set! n (- n 1))) - (string-set! pattern n-pos (string-ref numbers n)) - (string-copy pattern)))))) diff --git a/scsh/putenv.c b/scsh/putenv.c deleted file mode 100644 index d165930..0000000 --- a/scsh/putenv.c +++ /dev/null @@ -1,181 +0,0 @@ -/* My very own implementation of putenv() and friends, -** because NeXTSTEP is a lame UNIX. -** -** Copyright (c) 1994 by Olin Shivers. -** You may use this software for any purpose provided I am not held -** accountable for its effects and you leave this copyright notice -** intact. -*/ - -/* This file exports three names: -** extern int putenv(const char *str); -** extern int unsetenv(const char *name); -** extern int setenv(const char *name, const char *val); -*/ - -/* This code leaks memory. It is unavoidable. */ - -#include - -/* Don't want to include stdlib.h because it declares putenv to take -** a const string -- bogus. So we'll just declare malloc directly. -*/ -extern void *malloc(size_t size); - -#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n))) - -extern char **environ; -/*****************************************************************************/ - -/* Internal utility. -** Copy the entire env to a new block, and add the new definition. -** Drop the old block on the floor; can't free() it. -** Return 0 if win -** non-zero if the malloc fails. -*/ -static int append_envvar(char *str, int old_envsize) -{ - char **envp, **nenvp; - char **newenv = Malloc(char*, 1+old_envsize); - if( !newenv ) return 1; - - for( envp=environ, nenvp=newenv; *envp; envp++, nenvp++ ) - *nenvp = *envp; - *nenvp++ = str; - *nenvp = 0; - environ = newenv; - return 0; - } - - -/* int putenv(char *str) -*************************** -** Change or add a value to the environment. -** -** str is an env string of the form "=". -** The environ vector is scanned for a matching binding. -** If one is found, str is installed in that slot in the vector. -** Otherwise, the environ vector is copied into a new vector of one greater -** size, and str is added in the new slot. Note: in either case, str -** becomes part of the environment structure (until is later replaced by -** another putenv() call), so altering str changes the environment. -** -** Malloc is used to allocate new environ vectors. -** In neither replacement strategy are we able to free() the unused -** storage; it is simply dropped on the floor. -** Putenv returns -** 0 if it wins; -** non-zero if str doesn't contain an '=' char or if the malloc fails. -*/ - -int putenv(char *str) -{ - char **envp; - char *equalsign = strchr(str, '='); - int namelen; - - if( ! equalsign ) return 0; /* No equals sign in str! */ - namelen = 1 + equalsign - str; /* Count the terminating =. */ - - for(envp = environ; *envp; envp++) - if( ! memcmp(*envp, str, namelen) ) { - *envp = str; - return 0; - } - - /* The env var wasn't defined. Copy the entire env to a new - ** block, and add the new definition. - */ - return append_envvar(str, envp-environ+1); - } - - -/* int unsetenv(const char *name) -*********************************** -** Delete an environment var from environ. -** name is an environment variable . All strings in environ -** beginning with "=" are deleted from environ. unsetenv -** returns the number of occurrences it found and deleted; if -** it returns 0, then the variable wasn't in environ to begin with. -** If name is the null pointer, unsetenv returns -1 immediately. -*/ - -int unsetenv(const char *name) -{ - char **envp, **target; - int hits; - int slen; - - if( !name ) return -1; - slen = strlen(name); - hits = 0; - target = environ; - - for( envp=environ; *envp; envp++ ) - if( !strncmp(*envp, name, slen) && (*envp)[slen] == '=' ) - hits++; - else - *target++ = *envp; - *target = 0; - - return hits; - } - - -/* int setenv(const char *name, const char *val) -************************************************ -** Sets an existing env var or adds a new one. -** - If val is the null pointer, the env var is deleted. -** - If name is the null pointer, setenv() returns an error and does nothing. -** -** If env var is already defined in environ, then -** the new value is copied over the var's old value if -** there is space. Otherwise a fresh string is allocated -** with malloc. If the var is not defined, then environ -** is copied to a fresh block of storage, of size one greater, -** and the new "=" binding installed in that block. -** -** Returns 0 if it wins. -** Returns non-zero if there is an error. -*/ - -int setenv(const char *name, const char *val) -{ - char **envp; - char *s; - int val_len, name_len; - - if( !name ) return 1; - if( !val ) { - unsetenv(name); - return 0; - } - - name_len = strlen(name); - val_len = strlen(val); - - for( envp=environ; *envp; envp++ ) - if( !strncmp(*envp, name, name_len) && (*envp)[name_len] == '=' ) { - char *equal = name_len + *envp; - - if( strlen(equal+1) >= val_len ) - memcpy(equal+1, val, val_len+1); /* Copy in place. */ - else { - char *s = Malloc(char, name_len + val_len + 2); - if( !s ) return 1; - memcpy(s, name, name_len); - s[name_len] = '='; - memcpy(s+name_len+1, val, val_len+1); - *envp=s; - } - return 0; - } - - /* Not found. Add. */ - s = Malloc(char, val_len + name_len + 2); - if( !s ) return 1; - memcpy(s, name, name_len); - s[name_len] = '='; - memcpy(s+name_len+1, val, val_len+1); - return append_envvar(s, 1+envp-environ); - } diff --git a/scsh/rdelim.c b/scsh/rdelim.c deleted file mode 100644 index 7b7964e..0000000 --- a/scsh/rdelim.c +++ /dev/null @@ -1,41 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -#include - -/* Make sure foreign-function stubs interface to the C funs correctly: */ -#include "fdports1.h" - -scheme_value df_read_delim(long nargs, scheme_value *args) -{ - extern scheme_value read_delim(const char *, char *, int , scheme_value , int , int , int *); - scheme_value ret1; - scheme_value r1; - int r2; - - cig_check_nargs(7, nargs, "read_delim"); - r1 = read_delim(cig_string_body(args[6]), cig_string_body(args[5]), EXTRACT_BOOLEAN(args[4]), args[3], EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_skip_chars(long nargs, scheme_value *args) -{ - extern scheme_value skip_chars(const char *, scheme_value , int *); - scheme_value ret1; - scheme_value r1; - int r2; - - cig_check_nargs(3, nargs, "skip_chars"); - r1 = skip_chars(cig_string_body(args[2]), args[1], &r2); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - return ret1; - } - diff --git a/scsh/rdelim.scm b/scsh/rdelim.scm deleted file mode 100644 index 1827ac3..0000000 --- a/scsh/rdelim.scm +++ /dev/null @@ -1,298 +0,0 @@ -;;; Delimited readers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These procedures run their inner I/O loop in a C primitive, so they -;;; should be quite fast. -;;; -;;; N.B.: -;;; The C primitive %READ-DELIMITED-FDPORT!/ERRNO relies on knowing the -;;; representation of character sets. If these are changed from their -;;; current representation as 256-element strings, this code must be changed -;;; as well. - -;;; (read-delimited delims [port delim-action]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Returns a string or the EOF object. DELIM-ACTION determines what to do -;;; with the terminating delimiter: -;;; - PEEK -;;; Leave it in the input stream for later reading. -;;; - TRIM (the default) -;;; Drop it on the floor. -;;; - CONCAT -;;; Append it to the returned string. -;;; - SPLIT -;;; Return it as a second return value. -;;; -;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED! -;;; until we hit a delimiter or EOF. Each time through the loop, we -;;; double the total buffer space, so the loop terminates with a log -;;; number of reads, but uses at most double the optimal buffer space. - -(define (read-delimited delims . args) - (let-optionals args ((port (current-input-port)) - (delim-action 'trim)) - (let ((substr (lambda (s end) ; Smart substring. - (if (= end (string-length s)) s - (substring s 0 end)))) - (delims (->char-set delims)) - (gobble? (not (eq? delim-action 'peek)))) - - ;; BUFLEN is total amount of buffer space allocated to date. - (let lp ((strs '()) (buflen 80) (buf (make-string 80))) - (receive (terminator num-read) - (%read-delimited! delims buf gobble? port) - (if terminator - - ;; We are done. NUM-READ is either a read count or EOF. - (let ((retval (if (and (zero? num-read) - (eof-object? terminator) - (null? strs)) - terminator ; EOF -- got nothing. - - ;; Got something. Stick all the strings - ;; together, plus the terminator if the - ;; client said 'CONCAT. - (let ((s (substr buf num-read))) - (cond ((and (eq? delim-action 'concat) - (char? terminator)) - (apply string-append - (reverse `(,(string terminator) - ,s . ,strs)))) - - ((null? strs) s) ; Gratuitous opt. - (else (apply string-append - (reverse (cons s strs))))))))) - (if (eq? delim-action 'split) - (values retval terminator) - retval)) - - ;; We are not done. Loop and read in some more. - (lp (cons buf strs) - (+ buflen buflen) - (make-string buflen)))))))) - - -;;; (read-delimited! delims buf [port delim-action start end]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Returns: -;;; - EOF if at end of file, and a non-zero read was requested. -;;; - Integer j if that many chars read into BUF. -;;; - #f if the buffer was filled w/o finding a delimiter. -;;; -;;; DELIM-ACTION determines what to do with the terminating delimiter; -;;; it is as in READ-DELIMITED. -;;; -;;; In determining the return value, there is an ambiguous case: when the -;;; buffer is full, *and* the following char is a delimiter char or EOF. -;;; Ties are broken favoring termination over #f -- after filling the buffer, -;;; READ-DELIMITED! won't return #f until it has peeked one past the end -;;; of the buffer to ensure the next char doesn't terminate input (or is EOF). -;;; However, this rule is relaxed with delim-action = CONCAT -- if the buffer -;;; is full, READ-DELIMITED! won't wait around trying to peek at the following -;;; char to determine whether or not it is a delimiter char, since it doesn't -;;; have space to store the character anyway. It simply immediately returns #f; -;;; a following read can pick up the delimiter char. - -(define (read-delimited! delims buf . args) ; [port delim-action start end] - (let-optionals args ((port (current-input-port)) - (delim-action 'trim) - (start 0) - (end (string-length buf))) - (receive (terminator num-read) - (%read-delimited! delims buf - (not (eq? delim-action 'peek)) ;Gobble delim? - port - start - (if (eq? delim-action 'concat) - (- end 1) ; Room for terminator. - end)) - - (if terminator ; Check for buffer overflow. - (let ((retval (if (and (zero? num-read) - (eof-object? terminator)) - terminator ; EOF -- got nothing. - num-read))) ; Got something. - - (case delim-action - ((peek trim) retval) - ((split) (values retval terminator)) - ((concat) (cond ((char? terminator) - (string-set! buf (+ start num-read) terminator) - (+ num-read 1)) - (else retval))))) - - ;; Buffer overflow. - (case delim-action - ((peek trim) #f) - ((split) (values #f #f)) - ((concat) (let ((last (read-char port))) - (if (char? last) - (string-set! buf (+ start num-read) last)) - (and (or (eof-object? last) - (char-set-contains? (->char-set delims) - last)) - (+ num-read 1))))))))) - - -;;; (%read-delimited! delims buf gobble? [port start end]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This low-level routine uses a different interface. It returns two values: -;;; - TERMINATOR: A value describing why the read was terminated: -;;; + character or eof-object => read terminated by this value; -;;; + #f => filled buffer w/o terminating read. -;;; - NUM-READ: Number of chars read into buf. -;;; -;;; Note: -;;; - Invariant: TERMINATOR = #f => NUM-READ = END - START. -;;; - Invariant: TERMINATOR = eof-object and NUM-READ = 0 => at EOF. -;;; - When determining the TERMINATOR return value, ties are broken -;;; favoring character or the eof-object over #f. That is, if the buffer -;;; fills up, %READ-DELIMITED! will peek at one more character from the -;;; input stream to determine if it terminates the input. If so, that -;;; is returned, not #f. -;;; -;;; If GOBBLE? is true, then a terminator character is removed from -;;; the input stream. Otherwise, it is left in place for a following input -;;; operation. - -(define (%read-delimited! delims buf gobble? . args) - (let-optionals args ((port (current-input-port)) - (start 0) - (end (string-length buf))) - - (check-arg input-port? port %read-delimited!) ; Arg checking. - (check-arg char-set? delims %read-delimited!) ; Required, since - (if (bogus-substring-spec? buf start end) ; we're calling C. - (error "Illegal START/END substring indices" - buf start end %read-delimited!)) - - (let ((delims (->char-set delims))) - - (if (fdport? port) - - ;; Direct C support for Unix file ports -- zippy quick. - (let lp ((start start) (total 0)) - (receive (terminator num-read) - (%read-delimited-fdport!/errno delims buf gobble? - port start end) - (let ((total (+ num-read total))) - (cond ((not (integer? terminator)) (values terminator total)) - ((= terminator errno/intr) (lp (+ start num-read) total)) - (else (errno-error terminator %read-delimited! - num-read total - delims buf gobble? port start end)))))) - - ;; This is the code for other kinds of ports. - ;; Mighty slow -- we read each char twice (peek first, then read). - (let lp ((i start)) - (let ((c (peek-char port))) - (cond ((or (eof-object? c) ; Found terminating char or eof - (char-set-contains? delims c)) - (if gobble? (read-char port)) - (values c (- i start))) - - ((>= i end) ; Filled the buffer. - (if gobble? (read-char port)) - (values #f (- i start))) - - (else (string-set! buf i (read-char port)) - (lp (+ i 1)))))))))) - - -(foreign-source - "#include " - "" - "/* Make sure foreign-function stubs interface to the C funs correctly: */" - "#include \"fdports1.h\"" - "" "") - -(define-foreign %read-delimited-fdport!/errno (read_delim (string delims) - (var-string buf) - (bool gobble?) - (desc port) - (fixnum start) - (fixnum end)) - desc ; int => errno; char => terminating char; eof-object; #f => buf ovflow - fixnum) ; number of chars read into BUF. - - -(define-foreign %skip-char-set-fdport/errno (skip_chars (string skip-set) - (desc port)) - desc ; int => errno; #f => win. - fixnum) ; number of chars skipped. - - -(define (skip-char-set skip-chars . maybe-port) - (let ((port (:optional maybe-port (current-input-port))) - (cset (->char-set skip-chars))) - - (cond ((not (input-port? port)) - (error "Illegal value -- not an input port." port)) - - ;; Direct C support for Unix file ports -- zippy quick. - ((fdport? port) - (let lp ((total 0)) - (receive (err num-read) (%skip-char-set-fdport/errno cset port) - (let ((total (+ total num-read))) - (cond ((not err) total) - ((= errno/intr err) (lp total)) - (errno-error err skip-char-set cset port total)))))) - - ;; This is the code for other kinds of ports. - ;; Mighty slow -- we read each char twice (peek first, then read). - (else (let lp ((i 0)) - (let ((c (peek-char port))) - (cond ((and (char? c) (char-set-contains? cset c)) - (read-char port) - (lp (+ i 1))) - (else i)))))))) - - - - -;;; (read-line [port delim-action]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read in a line of data. Input is terminated by either a newline or EOF. -;;; The newline is trimmed from the string by default. - -(define charset:newline (char-set #\newline)) - -(define (read-line . rest) (apply read-delimited charset:newline rest)) - - -;;; (read-paragraph [port handle-delim]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define blank-line-regexp (make-regexp "^[ \t]*\n$")) - -(define (read-paragraph . args) - (let-optionals args ((port (current-input-port)) - (handle-delim 'trim)) - ;; First, skip all blank lines. - (let lp () - (let ((line (read-line port 'concat))) - (cond ((eof-object? line) - (if (eq? handle-delim 'split) (values line line) line)) - - ((regexp-exec blank-line-regexp line) (lp)) - - ;; Then, read in non-blank lines. - (else - (let lp ((lines (list line))) - (let ((line (read-line port 'concat))) - (if (and (string? line) - (not (regexp-exec blank-line-regexp line))) - - (lp (cons line lines)) - - ;; Return the paragraph - (let ((->str (lambda (lns) (apply string-append (reverse lns))))) - (case handle-delim - ((trim) (->str lines)) - - ((concat) - (->str (if (eof-object? line) lines (cons line lines)))) - - ((split) - (values (->str lines) line)) - - (else (error "Illegal HANDLE-DELIM parameter to READ-PARAGRAPH"))))))))))))) diff --git a/scsh/re.c b/scsh/re.c deleted file mode 100644 index c32166a..0000000 --- a/scsh/re.c +++ /dev/null @@ -1,114 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -/* Make sure foreign-function stubs interface to the C funs correctly: */ -#include "re1.h" - -scheme_value df_re_byte_len(long nargs, scheme_value *args) -{ - extern char *re_byte_len(const char *, int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(2, nargs, "re_byte_len"); - r1 = re_byte_len(cig_string_body(args[1]), &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_re_compile(long nargs, scheme_value *args) -{ - extern char *re_compile(const char *, scheme_value ); - scheme_value ret1; - char *r1; - - cig_check_nargs(3, nargs, "re_compile"); - r1 = re_compile(cig_string_body(args[2]), args[1]); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - return ret1; - } - -scheme_value df_re_exec(long nargs, scheme_value *args) -{ - extern char *re_exec(scheme_value , const char *, int , scheme_value , scheme_value , int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(6, nargs, "re_exec"); - r1 = re_exec(args[5], cig_string_body(args[4]), EXTRACT_FIXNUM(args[3]), args[2], args[1], &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_BOOLEAN(r2); - return ret1; - } - -scheme_value df_re_match(long nargs, scheme_value *args) -{ - extern char *re_match(const char *, const char *, int , scheme_value , scheme_value , int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(6, nargs, "re_match"); - r1 = re_match(cig_string_body(args[5]), cig_string_body(args[4]), EXTRACT_FIXNUM(args[3]), args[2], args[1], &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_BOOLEAN(r2); - return ret1; - } - -scheme_value df_re_subst(long nargs, scheme_value *args) -{ - extern char *re_subst(scheme_value , const char *, const char *, int , scheme_value , scheme_value , scheme_value , int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(8, nargs, "re_subst"); - r1 = re_subst(args[7], cig_string_body(args[6]), cig_string_body(args[5]), EXTRACT_FIXNUM(args[4]), args[3], args[2], args[1], &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_re_subst_len(long nargs, scheme_value *args) -{ - extern char *re_subst_len(scheme_value , const char *, const char *, int , scheme_value , scheme_value , int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(7, nargs, "re_subst_len"); - r1 = re_subst_len(args[6], cig_string_body(args[5]), cig_string_body(args[4]), EXTRACT_FIXNUM(args[3]), args[2], args[1], &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_filter_stringvec(long nargs, scheme_value *args) -{ - extern char *filter_stringvec(const char *, char const ** , int *); - scheme_value ret1; - char *r1; - int r2; - - cig_check_nargs(3, nargs, "filter_stringvec"); - r1 = filter_stringvec(cig_string_body(args[2]), (char const ** )AlienVal(args[1]), &r2); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - VECTOR_REF(*args,1) = ENTER_FIXNUM(r2); - return ret1; - } - diff --git a/scsh/re.scm b/scsh/re.scm deleted file mode 100644 index ba202f1..0000000 --- a/scsh/re.scm +++ /dev/null @@ -1,174 +0,0 @@ -;;; Regular expression matching for scsh -;;; Copyright (c) 1994 by Olin Shivers. - -(foreign-source - "/* Make sure foreign-function stubs interface to the C funs correctly: */" - "#include \"re1.h\"" - "" "" - ) - -;;; Match data for regexp matches. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-record regexp-match - string ; The string against which we matched. - start ; 10 elt vec - end) ; 10 elt vec - -(define (match:start match . maybe-index) - (let ((i (:optional maybe-index 0))) - (or (vector-ref (regexp-match:start match) i) - (error match:start "No sub-match found." match i)))) - -(define (match:end match . maybe-index) - (let ((i (:optional maybe-index 0))) - (or (vector-ref (regexp-match:end match) i) - (error match:start "No sub-match found." match i)))) - -(define (match:substring match . maybe-index) - (let* ((i (:optional maybe-index 0)) - (start (vector-ref (regexp-match:start match) i))) - (if start - (substring (regexp-match:string match) - start - (vector-ref (regexp-match:end match) i)) - (error match:substring "No sub-match found." match i)))) - - -;;; Compiling regexps -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-record %regexp - string ; The string form of the regexp. - bytes ; The compiled representation, stuffed into a Scheme string. - ((disclose self) (list "Regexp" (%regexp:string self)))) - -(define regexp? %regexp?) - - -(define (make-regexp pattern) - (receive (err len) (%regexp-compiled-length pattern) - (if err (error err make-regexp pattern) - (let ((buf (make-string len))) - (%regexp-compile pattern buf) - (make-%regexp pattern buf))))) - -(define-foreign %regexp-compiled-length (re_byte_len (string pattern)) - static-string ; Error msg or #f - integer) ; number of bytes needed to compile REGEXP. - -(define-foreign %regexp-compile (re_compile (string pattern) - (string-desc bytes)) - static-string) ; Error msg or #f - - -;;; Executing compiled regexps -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (regexp-exec regexp str . maybe-start) - (let ((start (:optional maybe-start 0)) - (start-vec (make-vector 10)) - (end-vec (make-vector 10))) - (receive (err match?) - (%regexp-exec (%regexp:bytes regexp) str start start-vec end-vec) - (if err (error err regexp-exec regexp str start) - (and match? - (make-regexp-match str start-vec end-vec)))))) - -(define-foreign %regexp-exec (re_exec (string-desc compiled-regexp) - (string s) - (integer start) - (vector-desc start-vec) - (vector-desc end-vec)) - static-string ; Error msg or #f - bool) ; Matched? - - -;;; Compile&match regexps in one go -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; I could do this with the separate compile and execute procedures, -;;; but I go straight to C just for fun. - -(define (string-match pattern string . maybe-start) - (let ((start (:optional maybe-start 0)) - (start-vec (make-vector 10)) - (end-vec (make-vector 10))) - (receive (err match?) (%string-match pattern string start - start-vec end-vec) - (if err (error err string-match pattern string start) - (and match? (make-regexp-match string start-vec end-vec)))))) - -(define-foreign %string-match (re_match (string pattern) - (string s) - (integer start) - (vector-desc start-vec) - (vector-desc end-vec)) - static-string ; Error string or #f if all is ok. - bool) ; match? - - - -;;; Substitutions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign %regexp-subst (re_subst (string-desc compiled-regexp) - (string match) - (string str) - (integer start) - (vector-desc start-vec) - (vector-desc end-vec) - (string-desc outbuf)) - static-string ; Error msg or #f - integer) - -(define-foreign %regexp-subst-len (re_subst_len (string-desc compiled-regexp) - (string match) - (string str) - (integer start) - (vector-desc start-vec) - (vector-desc end-vec)) - static-string ; Error msg or #f - integer) - -;;; What does this do? - -(define (regexp-subst re match replacement) - (let ((cr (%regexp:bytes re)) - (str (regexp-match:string match)) - (start-vec (regexp-match:start match)) - (end-vec (regexp-match:end match))) - (receive (err out-len) (%regexp-subst-len cr str replacement 0 - start-vec end-vec) - (if err (error err regexp-subst str replacement) ; More data here - (let ((out-buf (make-string out-len))) - (receive (err out-len) (%regexp-subst cr str replacement 0 - start-vec end-vec out-buf) - (if err (error err regexp-subst str replacement) - (substring out-buf 0 out-len)))))))) - -;;; Miscellaneous -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; I do this one in C, I'm not sure why: -;;; It is used by MATCH-FILES. - -(define-foreign %filter-C-strings! - (filter_stringvec (string pattern) ((C "char const ** ~a") cvec)) - static-string ; error message -- #f if no error. - integer) ; number of files that pass the filter. - - -;;; Convert a string into a regex pattern that matches that string exactly -- -;;; in other words, quote the special chars with backslashes. - -(define (regexp-quote string) - (let lp ((i (- (string-length string) 1)) - (result '())) - (if (< i 0) (list->string result) - (lp (- i 1) - (let* ((c (string-ref string i)) - (result (cons c result))) - (if (memv c '(#\[ #\] #\. #\* #\? #\( #\) #\| #\\ #\$ #\^ #\+)) - (cons #\\ result) - result)))))) diff --git a/scsh/re1.c b/scsh/re1.c deleted file mode 100644 index 3a4cf49..0000000 --- a/scsh/re1.c +++ /dev/null @@ -1,194 +0,0 @@ -/* Scheme48 interface to Henry Spencer's regular expression package. -** Copyright (c) 1993, 1994 by Olin Shivers. -*/ - -#include -#include "regexp.h" -#include "cstuff.h" - -/* Make sure our exports match up w/the implementation: */ -#include "re1.h" - -/* Not multi-threaded reentrant. */ -static char *regexp_error; - -/* Stash error msg in global. */ -void regerror(char *msg) {regexp_error = msg;} - -/* -** Return NULL normally, error string on error. -** Stash number of bytes needed for compiled regexp into `*len' -*/ - -char *re_byte_len(const char *re, int *len) -{ - int l; - - regexp_error = 0; - *len = regcomp_len(re); - return regexp_error; - } - -/* -** Return NULL normally, error string on error. -** Compile regexp into string described by `cr'. -*/ - -char *re_compile(const char *re, scheme_value cr) -{ - int len = STRING_LENGTH(cr); - regexp *r = (regexp *) &STRING_REF(cr, 0); - - regexp_error = 0; - r = regcomp_comp(re, r, len); - return regexp_error; - } - -/* Return NULL normally, error string on error. -** Stash match info in start_vec and end_vec. -** Returns boolean match/no-match in hit. -*/ - -char *re_exec(scheme_value cr, const char *string, int start, - scheme_value start_vec, scheme_value end_vec, int *hit) -{ - regexp *r = (regexp *) &STRING_REF(cr, 0); - - *hit = 0; - - if( VECTOR_LENGTH(start_vec) != NSUBEXP ) /* These tests should */ - return "Illegal start vector"; /* never trigger. */ - if( VECTOR_LENGTH(end_vec) != NSUBEXP ) - return "Illegal end vector"; - - regexp_error = 0; - - if( regexec(r, string+start) ) { - int i; - for(i=0; istartp[i]; - const char *e = r->endp[i]; - VECTOR_REF(start_vec,i) = s ? ENTER_FIXNUM(s - string) : SCHFALSE; - VECTOR_REF(end_vec,i) = e ? ENTER_FIXNUM(e - string) : SCHFALSE; - r->startp[i] = 0; /* Why did Sommerfeld */ - r->endp[i] = 0; /* put these here? */ - } - *hit = 1; - } - - return regexp_error; - } - - -char *re_subst(scheme_value cr, const char *match, - const char *src, int start, - scheme_value start_vec, scheme_value end_vec, - scheme_value outbuf, int *len) -{ - int i; - regexp *r = (regexp *) &STRING_REF(cr, 0); - - if( VECTOR_LENGTH(start_vec) != NSUBEXP ) /* These tests should */ - return "Illegal start vector"; /* never trigger. */ - if( VECTOR_LENGTH(end_vec) != NSUBEXP ) - return "Illegal end vector"; - - for (i=0; istartp[i] = FIXNUMP(se) ? (match + EXTRACT_FIXNUM(se)) : 0; - r->endp[i] = FIXNUMP(ee) ? (match + EXTRACT_FIXNUM(ee)) : 0; - } - - regexp_error = 0; - regnsub(r, src, &STRING_REF(outbuf, 0), STRING_LENGTH(outbuf)); - *len = strlen(&STRING_REF(outbuf, 0)); - return regexp_error; - } - -char *re_subst_len(scheme_value cr, const char *match, - const char *src, int start, - scheme_value start_vec, scheme_value end_vec, - int *len) -{ - int i; - regexp *r = (regexp *) &STRING_REF(cr, 0); - - if( VECTOR_LENGTH(start_vec) != NSUBEXP ) /* These tests should */ - return "Illegal start vector"; /* never trigger. */ - if( VECTOR_LENGTH(end_vec) != NSUBEXP ) - return "Illegal end vector"; - - for (i=0; istartp[i] = FIXNUMP(se) ? (match + EXTRACT_FIXNUM(se)) : 0; - r->endp[i] = FIXNUMP(ee) ? (match + EXTRACT_FIXNUM(ee)) : 0; - } - - regexp_error = 0; - *len = regsublen(r, src); - return regexp_error; - } - - -/* Return NULL normally, error string on error. -** Stash match info in start_vec and end_vec. -** Returns boolean match/no-match in hit. -*/ - -char *re_match(const char *re, const char *string, int start, - scheme_value start_vec, scheme_value end_vec, int *hit) -{ - regexp *prog; - - regexp_error = 0; - *hit = 0; - prog = regcomp(re); - if( !prog ) return regexp_error; - - if( VECTOR_LENGTH(start_vec) != NSUBEXP ) { /* These two tests */ - Free(prog); - return "Illegal start vector"; - } - - if( VECTOR_LENGTH(end_vec) != NSUBEXP ) { /* should never trigger. */ - Free(prog); - return "Illegal end vector"; - } - - if( regexec(prog, string+start) ) { - int i; - for(i=0; istartp[i]; - const char *e = prog->endp[i]; - VECTOR_REF(start_vec,i) = s ? ENTER_FIXNUM(s - string) : SCHFALSE; - VECTOR_REF(end_vec,i) = e ? ENTER_FIXNUM(e - string) : SCHFALSE; - } - *hit = 1; - } - - Free(prog); - return regexp_error; - } - - -char *filter_stringvec(const char *re, char const **stringvec, int *nummatch) -{ - regexp *prog; - regexp_error = 0; - - if( prog=regcomp(re) ) { - char const **p = stringvec; - char const **q = p; - - while(*p) { - if( regexec(prog, *p) ) *q++ = *p; - p++; - } - Free(prog); - *nummatch = q-stringvec; - } - - return regexp_error; - } diff --git a/scsh/re1.h b/scsh/re1.h deleted file mode 100644 index 3938f7e..0000000 --- a/scsh/re1.h +++ /dev/null @@ -1,24 +0,0 @@ -/* Exports from re1.c */ - -char *re_byte_len(const char *re, int *len); -char *re_compile(const char *re, scheme_value target); - -char *re_exec(scheme_value cr, const char *string, int start, - scheme_value start_vec, scheme_value end_vec, int *hit); - -char *re_match(const char *re, const char *string, int start, - scheme_value start_vec, scheme_value end_vec, - int *hit); - -char *re_subst_len(scheme_value cr, const char *match, - const char *src, int start, - scheme_value start_vec, scheme_value end_vec, - int *len); - -char *re_subst(scheme_value cr, const char *match, - const char *src, int start, - scheme_value start_vec, scheme_value end_vec, - scheme_value outbuf, int *len); - -char *filter_stringvec(const char *re, char const **stringvec, - int *nummatch); diff --git a/scsh/regexp/.gitignore b/scsh/regexp/.gitignore deleted file mode 100644 index f3c7a7c..0000000 --- a/scsh/regexp/.gitignore +++ /dev/null @@ -1 +0,0 @@ -Makefile diff --git a/scsh/regexp/COPYRIGHT b/scsh/regexp/COPYRIGHT deleted file mode 100644 index 36b9804..0000000 --- a/scsh/regexp/COPYRIGHT +++ /dev/null @@ -1,19 +0,0 @@ -Copyright (c) 1986, 1993, 1995 by University of Toronto. -Written by Henry Spencer. Not derived from licensed software. - -Permission is granted to anyone to use this software for any -purpose on any computer system, and to redistribute it in any way, -subject to the following restrictions: - -1. The author is not responsible for the consequences of use of - this software, no matter how awful, even if they arise - from defects in it. - -2. The origin of this software must not be misrepresented, either - by explicit claim or by omission. - -3. Altered versions must be plainly marked as such, and must not - be misrepresented (by explicit claim or omission) as being - the original software. - -4. This notice must not be removed or altered. diff --git a/scsh/regexp/Makefile.in b/scsh/regexp/Makefile.in deleted file mode 100644 index 6aed9ad..0000000 --- a/scsh/regexp/Makefile.in +++ /dev/null @@ -1,118 +0,0 @@ -srcdir = @srcdir@ -VPATH = @srcdir@ -CC = @CC@ -CFLAGS1 = @CFLAGS1@ - -RANLIB = @RANLIB@ - -# Things you might want to put in ENV: -# -DERRAVAIL have utzoo-compatible error() function and friends -ENV= - -# Things you might want to put in TEST: -# -DDEBUG debugging hooks -# -I. regexp.h from current directory, not /usr/include -TEST=-I. -I$(srcdir) - -# Things you might want to put in PROF: -# -pg profiler -# PROF= - -CFLAGS=$(CFLAGS1) $(ENV) $(TEST) $(PROF) -LDFLAGS=$(PROF) - -LIB=libregexp.a -OBJ=regexp.o regsub.o regerror.o -TMP=dtr.tmp - -default: r - -try: try.o $(LIB) - $(CC) $(LDFLAGS) try.o $(LIB) -o try - -# Making timer will probably require putting stuff in $(PROF) and then -# recompiling everything; the following is just the final stage. -timer: timer.o $(LIB) - $(CC) $(LDFLAGS) timer.o $(LIB) -o timer - -timer.o: timer.c timer.t.h - -timer.t.h: tests - sed 's/ /","/g;s/\\/&&/g;s/.*/{"&"},/' tests >timer.t.h - -# Regression test. -r: try tests - ./try $@ - -ch.sml: ch $(BITS) smlize splitfigs - splitfigs ch | soelim | smlize >$@ - -fig0 fig1 fig2: ch splitfigs - splitfigs ch >/dev/null - -f: fig0 fig1 fig2 figs - groff -Tps -s $(OPT) figs | lpr - -fig1.ps: fig0 fig1 - ( cat fig0 ; echo ".LP" ; cat fig1 ) | groff -Tps $(OPT) >$@ - -fig2.ps: fig0 fig2 - ( cat fig0 ; echo ".LP" ; cat fig2 ) | groff -Tps $(OPT) >$@ - -fp: fig1.ps fig2.ps - -r.1: regexp.c splitter - splitter regexp.c - -rs.1: regsub.c splitter - splitter regsub.c - -re.1: regerror.c splitter - splitter regerror.c - -rm.h: regmagic.h splitter - splitter regmagic.h - -re.h: regexp.h splitter - splitter regexp.h - -PLAIN=COPYRIGHT README Makefile regexp.3 try.c timer.c tests -FIX=regexp.h regexp.c regsub.c regerror.c regmagic.h -DTR=$(PLAIN) $(FIX) - -dtr: r $(DTR) - rm -rf $(TMP) - mkdir $(TMP) - cp $(PLAIN) $(TMP) - for f in $(FIX) ; do normalize $$f >$(TMP)/$$f ; done - ( cd $(TMP) ; makedtr $(DTR) ) >$@ - rm -rf $(TMP) - -ch.ps: ch Makefile $(BITS) - groff -Tps $(OPT) ch >$@ - -copy: ch.soe ch.sml fp - makedtr REMARKS ch.sml fig*.ps ch.soe >$@ - -go: copy dtr diff --git a/scsh/regexp/README b/scsh/regexp/README deleted file mode 100644 index bcb9cf5..0000000 --- a/scsh/regexp/README +++ /dev/null @@ -1,57 +0,0 @@ -This is a revision of my well-known regular-expression package, regexp(3). -It gives C programs the ability to use egrep-style regular expressions, and -does it in a much cleaner fashion than the analogous routines in SysV. -It is not, alas, fully POSIX.2-compliant; that is hard. (I'm working on -a full reimplementation that will do that.) - -This version is the one which is examined and explained in one chapter of -"Software Solutions in C" (Dale Schumacher, ed.; AP Professional 1994; -ISBN 0-12-632360-7), plus a couple of insignificant updates, plus one -significant bug fix (done 10 Nov 1995). - -Although this package was inspired by the Bell V8 regexp(3), this -implementation is *NOT* AT&T/Bell code, and is not derived from licensed -software. Even though U of T is a V8 licensee. This software is based on -a V8 manual page sent to me by Dennis Ritchie (the manual page enclosed -here is a complete rewrite and hence is not covered by AT&T copyright). -I admit to some familiarity with regular-expression implementations of -the past, but the only one that this code traces any ancestry to is the -one published in Kernighan & Plauger's "Software Tools" (from which -this one draws ideas but not code). - -Simplistically: put this stuff into a source directory, inspect Makefile -for compilation options that need changing to suit your local environment, -and then do "make". This compiles the regexp(3) functions, builds a -library containing them, compiles a test program, and runs a large set of -regression tests. If there are no complaints, then put regexp.h into -/usr/include, add regexp.o, regsub.o, and regerror.o into your C library -(or put libre.a into /usr/lib), and install regexp.3 (perhaps with slight -modifications) in your manual-pages directory. - -The files are: - -COPYRIGHT copyright notice -README this text -Makefile instructions to make everything -regexp.3 manual page -regexp.h header file, for /usr/include -regexp.c source for regcomp() and regexec() -regsub.c source for regsub() -regerror.c source for default regerror() -regmagic.h internal header file -try.c source for test program -timer.c source for timing program -tests test list for try and timer - -This implementation uses nondeterministic automata rather than the -deterministic ones found in some other implementations, which makes it -simpler, smaller, and faster at compiling regular expressions, but slower -at executing them. Many users have found the speed perfectly adequate, -although replacing the insides of egrep with this code would be a mistake. - -This stuff should be pretty portable, given an ANSI C compiler and -appropriate option settings. There are no "reserved" char values except for -NUL, and no special significance is attached to the top bit of chars. -The string(3) functions are used a fair bit, on the grounds that they are -probably faster than coding the operations in line. Some attempts at code -tuning have been made, but this is invariably a bit machine-specific. diff --git a/scsh/regexp/patch-msg b/scsh/regexp/patch-msg deleted file mode 100644 index 36a7ff9..0000000 --- a/scsh/regexp/patch-msg +++ /dev/null @@ -1,803 +0,0 @@ -Date: Mon, 1 Jul 1996 23:22:47 GMT -From: Bill Sommerfeld -To: shivers@lcs.mit.edu, bdc@ai.mit.edu -Subject: scsh patch for precompiled regexps.. - -I meant to send this out months ago but I was just too hosed with work. - -Here's what I have right now: - -There are three pieces here: - diffs to the "core" scsh - diffs to Henry Spencer's latest regexp library - a copy of Henry Spencer's latest regexp library.. - -It appears to work (it passes the same regression tests as the C library..). - -Let me know if I didn't include something needed for this to work.. - - - Bill - -diff -rc scsh-0.4.2/scsh/re.scm scsh-0.4.2-regexp/scsh/re.scm -*** scsh-0.4.2/scsh/re.scm Fri Oct 27 04:58:56 1995 ---- scsh-0.4.2-regexp/scsh/re.scm Sat Apr 6 21:07:41 1996 -*************** -*** 34,49 **** - - ;;; Bogus stub definitions for low-level match routines: - -! (define regexp? string?) -! (define (make-regexp str) str) - -! (define (regexp-exec regexp str . maybe-start) - (let ((start (optional-arg maybe-start 0)) - (start-vec (make-vector 10)) - (end-vec (make-vector 10))) -! (and (%regexp-match regexp str start start-vec end-vec) -! (make-regexp-match str start-vec end-vec)))) -! - - ;;; Convert a string into a regex pattern that matches that string exactly -- - ;;; in other words, quote the special chars with backslashes. ---- 34,53 ---- - - ;;; Bogus stub definitions for low-level match routines: - -! (define-record iregexp -! string) - -! (define regexp? iregexp?) -! -! (define (make-regexp str) -! (make-iregexp (compile-regexp str))) -! -! (define (regexp-exec r s . maybe-start) - (let ((start (optional-arg maybe-start 0)) - (start-vec (make-vector 10)) - (end-vec (make-vector 10))) -! (and (%regexp-exec-1 (iregexp:string r) s start start-vec end-vec) -! (make-regexp-match s start-vec end-vec)))) - - ;;; Convert a string into a regex pattern that matches that string exactly -- - ;;; in other words, quote the special chars with backslashes. -*************** -*** 58,75 **** - (cons #\\ result) - result)))))) - -! (define-foreign %regexp-match/errno (reg_match (string regexp) -! (string s) -! (integer start) -! (vector-desc start-vec) -! (vector-desc end-vec)) -! static-string ; Error string or #f if all is ok. -! bool) ; match? -! -! (define (%regexp-match regexp string start start-vec end-vec) -! (receive (err match?) (%regexp-match/errno regexp string start -! start-vec end-vec) -! (if err (error err %regexp-match regexp string start) match?))) - - - ;;; I do this one in C, I'm not sure why: ---- 62,79 ---- - (cons #\\ result) - result)))))) - -! ;;;(define-foreign %regexp-match/errno (reg_match (string regexp) -! ;;; (string s) -! ;;; (integer start) -! ;;; (vector-desc start-vec) -! ;;; (vector-desc end-vec)) -! ;;; static-string ; Error string or #f if all is ok. -! ;;; bool) ; match? -! -! ;;;(define (%regexp-match regexp string start start-vec end-vec) -! ;;; (receive (err match?) (%regexp-match/errno regexp string start -! ;;; start-vec end-vec) -! ;;; (if err (error err %regexp-match regexp string start) match?))) - - - ;;; I do this one in C, I'm not sure why: -*************** -*** 79,81 **** ---- 83,166 ---- - (filter_stringvec (string regexp) ((C "char const ** ~a") cvec)) - static-string ; error message -- #f if no error. - integer) ; number of files that pass the filter. -+ -+ ;;; precompiled regexps. -+ -+ (define-foreign %regexp-compiled-length (reg_comp_len (string regexp)) -+ static-string -+ integer) -+ -+ (define-foreign %regexp-compile (reg_comp_comp (string regexp) -+ (string-desc re-buf)) -+ static-string) -+ -+ (define (%regexp-exec-1 r s start sv ev) -+ (receive (err match?) (%regexp-exec r s start sv ev) -+ (if err (error err s start) -+ match?))) -+ -+ (define-foreign %regexp-exec (reg_exec (string-desc regexp) -+ (string s) -+ (integer start) -+ (vector-desc start-vec) -+ (vector-desc end-vec)) -+ static-string -+ bool) -+ -+ -+ (define (compile-regexp e) -+ (receive (err len) -+ (%regexp-compiled-length e) -+ (if err (error err e) -+ (let ((buf (make-string len))) -+ (%regexp-compile e buf) -+ buf)))) -+ -+ -+ -+ (define-foreign %regexp-subst (reg_subst (string-desc regexp) -+ (string m) -+ (string s) -+ (integer start) -+ (vector-desc start-vec) -+ (vector-desc end-vec) -+ (string-desc outbuf)) -+ static-string -+ integer) -+ -+ (define-foreign %regexp-subst-len (reg_subst_len (string-desc regexp) -+ (string m) -+ (string s) -+ (integer start) -+ (vector-desc start-vec) -+ (vector-desc end-vec)) -+ static-string -+ integer) -+ -+ -+ (define (regexp-subst re match replacement) -+ (let ((cr (iregexp:string re)) -+ (matchstr (regexp-match:string match)) -+ (startvec (regexp-match:start match)) -+ (endvec (regexp-match:end match))) -+ (receive (err outlen) -+ (%regexp-subst-len cr -+ matchstr -+ replacement -+ 0 -+ startvec -+ endvec) -+ (if err (error err matchstr replacement) -+ (let ((outbuf (make-string outlen))) -+ (receive (err outlen) -+ (%regexp-subst cr -+ matchstr -+ replacement -+ 0 -+ startvec -+ endvec -+ outbuf) -+ (if err (error err matchstr replacement) -+ (substring outbuf 0 outlen)))))))) -+ -+ -\ No newline at end of file -diff -rc scsh-0.4.2/scsh/re1.c scsh-0.4.2-regexp/scsh/re1.c -*** scsh-0.4.2/scsh/re1.c Fri Oct 27 04:58:58 1995 ---- scsh-0.4.2-regexp/scsh/re1.c Sat Apr 6 21:01:15 1996 -*************** -*** 19,24 **** ---- 19,150 ---- - /* Stash error msg in global. */ - void regerror(char *msg) {regexp_error = msg;} - -+ /* -+ ** Return NULL normally, error string on error. -+ ** Stash number of bytes needed for compiled regexp into `*len' -+ */ -+ -+ char *reg_comp_len(const char *re, int *len) -+ { -+ int l; -+ -+ regexp_error = NULL; -+ *len = regcomp_len(re); -+ return regexp_error; -+ } -+ -+ /* -+ ** Return NULL normally, error string on error. -+ ** Compile regexp into string described by `cr'. -+ */ -+ -+ char *reg_comp_comp(const char *re, scheme_value cr) -+ { -+ int len = STRING_LENGTH(cr); -+ regexp *r = (regexp *)&STRING_REF(cr, 0); -+ -+ regexp_error = NULL; -+ r = regcomp_comp(re, r, len); -+ return regexp_error; -+ } -+ -+ /* Return NULL normally, error string on error. -+ ** Stash match info in start_vec and end_vec. -+ ** Returns boolean match/no-match in hit. -+ */ -+ -+ char *reg_exec(scheme_value cr, const char *string, int start, -+ scheme_value start_vec, scheme_value end_vec, int *hit) -+ { -+ regexp *r = (regexp *)&STRING_REF(cr, 0); -+ -+ if( VECTOR_LENGTH(start_vec) != NSUBEXP ) { -+ return "Illegal start vector"; -+ } -+ -+ if( VECTOR_LENGTH(end_vec) != NSUBEXP ) { -+ return "Illegal end vector"; -+ } -+ -+ regexp_error = 0; -+ *hit = 0; -+ -+ if( regexec(r, string+start) ) { -+ int i; -+ for(i=0; istartp[i]; -+ const char *e = r->endp[i]; -+ VECTOR_REF(start_vec,i) = s?ENTER_FIXNUM(s - string):SCHFALSE; -+ VECTOR_REF(end_vec,i) = e?ENTER_FIXNUM(e - string):SCHFALSE; -+ r->startp[i] = NULL; -+ r->endp[i] = NULL; -+ } -+ *hit = 1; -+ } -+ return regexp_error; -+ } -+ -+ char *reg_subst(scheme_value cr, const char *match, -+ const char *src, int start, -+ scheme_value start_vec, scheme_value end_vec, -+ scheme_value outbuf, int *len) -+ { -+ int i; -+ regexp *r = (regexp *)&STRING_REF(cr, 0); -+ -+ if( VECTOR_LENGTH(start_vec) != NSUBEXP ) { -+ return "Illegal start vector"; -+ } -+ -+ if( VECTOR_LENGTH(end_vec) != NSUBEXP ) { -+ return "Illegal end vector"; -+ } -+ -+ for (i=0; istartp[i] = FIXNUMP(se)?(match + EXTRACT_FIXNUM(se)):NULL; -+ r->endp[i] = FIXNUMP(ee)? (match + EXTRACT_FIXNUM(ee)):NULL; -+ } -+ -+ regexp_error = NULL; -+ regnsub (r, src, &STRING_REF(outbuf, 0), STRING_LENGTH(outbuf)); -+ *len = strlen(&STRING_REF(outbuf, 0)); -+ return regexp_error; -+ } -+ -+ char *reg_subst_len(scheme_value cr, const char *match, -+ const char *src, int start, -+ scheme_value start_vec, scheme_value end_vec, -+ int *len) -+ { -+ int i; -+ regexp *r = (regexp *)&STRING_REF(cr, 0); -+ -+ if( VECTOR_LENGTH(start_vec) != NSUBEXP ) { -+ return "Illegal start vector"; -+ } -+ -+ if( VECTOR_LENGTH(end_vec) != NSUBEXP ) { -+ return "Illegal end vector"; -+ } -+ -+ for (i=0; istartp[i] = FIXNUMP(se)?(match + EXTRACT_FIXNUM(se)):NULL; -+ r->endp[i] = FIXNUMP(ee)? (match + EXTRACT_FIXNUM(ee)):NULL; -+ } -+ -+ regexp_error = NULL; -+ *len = regsublen (r, src); -+ return regexp_error; -+ } -+ -+ -+ #if 0 - /* Return NULL normally, error string on error. - ** Stash match info in start_vec and end_vec. - ** Returns boolean match/no-match in hit. -*************** -*** 56,61 **** ---- 182,188 ---- - Free(prog); - return regexp_error; - } -+ #endif - - - char *filter_stringvec(const char *re, char const **stringvec, int *nummatch) -diff -rc scsh-0.4.2/scsh/re1.h scsh-0.4.2-regexp/scsh/re1.h -*** scsh-0.4.2/scsh/re1.h Sun Oct 22 08:34:34 1995 ---- scsh-0.4.2-regexp/scsh/re1.h Sat Apr 6 17:54:09 1996 -*************** -*** 1,6 **** ---- 1,21 ---- -+ #if 0 - char *reg_match(const char *re, const char *string, int start, - scheme_value start_vec, scheme_value end_vec, - int *hit); -+ #endif - - char *filter_stringvec(const char *re, char const **stringvec, - int *nummatch); -+ -+ char *reg_comp_len(const char *re, int *len); -+ char *reg_comp_comp(const char *re, scheme_value cr); -+ -+ char *reg_exec(scheme_value cr, const char *string, int start, -+ scheme_value start_vec, scheme_value end_vec, int *hit); -+ -+ char *reg_subst(scheme_value cr, const char *match, -+ const char *src, int start, -+ scheme_value start_vec, scheme_value end_vec, -+ scheme_value outbuf, int *len); -+ -+ - -Only in scsh-0.4.2-regexp/scsh: re2.scm -diff -rc scsh-0.4.2/scsh/scsh-interfaces.scm scsh-0.4.2-regexp/scsh/scsh-interfaces.scm -*** scsh-0.4.2/scsh/scsh-interfaces.scm Tue Oct 31 19:19:30 1995 ---- scsh-0.4.2-regexp/scsh/scsh-interfaces.scm Sat Apr 6 18:48:12 1996 -*************** -*** 413,418 **** ---- 413,419 ---- - make-regexp - regexp? - regexp-exec -+ regexp-subst - regexp-quote)) - - - -regexp library changes: - -*** Makefile 1996/04/06 19:24:49 1.1 ---- Makefile 1996/04/06 20:46:26 -*************** -*** 5,11 **** - # Things you might want to put in TEST: - # -DDEBUG debugging hooks - # -I. regexp.h from current directory, not /usr/include -! TEST=-I. - - # Things you might want to put in PROF: - # -pg profiler ---- 5,11 ---- - # Things you might want to put in TEST: - # -DDEBUG debugging hooks - # -I. regexp.h from current directory, not /usr/include -! TEST=-I. -DDEBUG - - # Things you might want to put in PROF: - # -pg profiler -*** regexp.c 1996/04/06 19:24:49 1.1 ---- regexp.c 1996/04/06 22:34:55 -*************** -*** 105,110 **** ---- 105,111 ---- - * Utility definitions. - */ - #define FAIL(m) { regerror(m); return(NULL); } -+ #define FAILN(m) { regerror(m); return(-1); } - #define ISREPN(c) ((c) == '*' || (c) == '+' || (c) == '?') - #define META "^$.[()|?+*\\" - -*************** -*** 162,173 **** - const char *exp; - { - register regexp *r; -! register char *scan; - int flags; - struct comp co; - - if (exp == NULL) -! FAIL("NULL argument to regcomp"); - - /* First pass: determine size, legality. */ - co.regparse = (char *)exp; ---- 163,193 ---- - const char *exp; - { - register regexp *r; -! size_t len; -! -! len = regcomp_len(exp); -! if (len <= 0) -! return NULL; -! -! /* Allocate space. */ -! r = (regexp *)malloc(len); -! -! if (r == NULL) -! FAIL("out of space"); -! return regcomp_comp(exp, r, len); -! } -! -! -! size_t -! regcomp_len(exp) -! const char *exp; -! { - int flags; -+ register regexp *r; - struct comp co; - - if (exp == NULL) -! FAILN("NULL argument to regcomp"); - - /* First pass: determine size, legality. */ - co.regparse = (char *)exp; -*************** -*** 178,198 **** - co.regcode = co.regdummy; - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) -! return(NULL); - - /* Small enough for pointer-storage convention? */ - if (co.regsize >= 0x7fffL) /* Probably could be 0xffffL. */ -! FAIL("regexp too big"); - -! /* Allocate space. */ -! r = (regexp *)malloc(sizeof(regexp) + (size_t)co.regsize); -! if (r == NULL) -! FAIL("out of space"); - - /* Second pass: emit code. */ - co.regparse = (char *)exp; - co.regnpar = 1; - co.regcode = r->program; - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) - return(NULL); ---- 198,228 ---- - co.regcode = co.regdummy; - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) -! return -1; - - /* Small enough for pointer-storage convention? */ - if (co.regsize >= 0x7fffL) /* Probably could be 0xffffL. */ -! FAILN("regexp too big"); - -! return (sizeof(regexp) + (size_t)co.regsize); -! } -! -! -! regexp * -! regcomp_comp(exp, r, len) -! const char *exp; -! register regexp *r; -! size_t len; -! { -! register char *scan; -! int flags; -! struct comp co; - - /* Second pass: emit code. */ - co.regparse = (char *)exp; - co.regnpar = 1; - co.regcode = r->program; -+ co.regsize = len - sizeof(regexp); - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) - return(NULL); -*************** -*** 200,206 **** - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; -! r->regmust = NULL; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ ---- 230,236 ---- - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; -! r->regmust = 0; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ -*************** -*** 229,235 **** - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } -! r->regmust = longest; - r->regmlen = (int)len; - } - } ---- 259,265 ---- - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } -! r->regmust = longest - r->program; - r->regmlen = (int)len; - } - } -*************** -*** 648,655 **** - struct exec { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ -! char **regstartp; /* Pointer to startp array. */ -! char **regendp; /* Ditto for endp. */ - }; - - /* ---- 678,685 ---- - struct exec { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ -! const char **regstartp; /* Pointer to startp array. */ -! const char **regendp; /* Ditto for endp. */ - }; - - /* -*************** -*** 690,696 **** - } - - /* If there is a "must appear" string, look for it. */ -! if (prog->regmust != NULL && strstr(string, prog->regmust) == NULL) - return(0); - - /* Mark beginning of line for ^ . */ ---- 720,727 ---- - } - - /* If there is a "must appear" string, look for it. */ -! if ((prog->regmlen > 0) && -! strstr(string, &prog->program[prog->regmust]) == NULL) - return(0); - - /* Mark beginning of line for ^ . */ -*************** -*** 729,736 **** - char *string; - { - register int i; -! register char **stp; -! register char **enp; - - ep->reginput = string; - ---- 760,767 ---- - char *string; - { - register int i; -! register const char **stp; -! register const char **enp; - - ep->reginput = string; - -*************** -*** 1004,1011 **** - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); -! if (r->regmust != NULL) -! printf("must have \"%s\"", r->regmust); - printf("\n"); - } - ---- 1035,1042 ---- - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); -! if (r->regmlen > 0) -! printf("must have \"%s\"", &r->program[r->regmust]); - printf("\n"); - } - -*** regexp.h 1996/04/06 19:24:49 1.1 ---- regexp.h 1996/04/07 01:52:19 -*************** -*** 6,16 **** - */ - #define NSUBEXP 10 - typedef struct regexp { -! char *startp[NSUBEXP]; -! char *endp[NSUBEXP]; - char regstart; /* Internal use only. */ - char reganch; /* Internal use only. */ -! char *regmust; /* Internal use only. */ - int regmlen; /* Internal use only. */ - char program[1]; /* Unwarranted chumminess with compiler. */ - } regexp; ---- 6,16 ---- - */ - #define NSUBEXP 10 - typedef struct regexp { -! const char *startp[NSUBEXP]; -! const char *endp[NSUBEXP]; - char regstart; /* Internal use only. */ - char reganch; /* Internal use only. */ -! int regmust; /* Internal use only. */ - int regmlen; /* Internal use only. */ - char program[1]; /* Unwarranted chumminess with compiler. */ - } regexp; -*************** -*** 18,21 **** ---- 18,27 ---- - extern regexp *regcomp(const char *re); - extern int regexec(regexp *rp, const char *s); - extern void regsub(const regexp *rp, const char *src, char *dst); -+ extern void regnsub(const regexp *rp, const char *src, char *dst, size_t len); -+ extern size_t regsublen(const regexp *rp, const char *src); -+ - extern void regerror(char *message); -+ extern size_t regcomp_len(const char *exp); -+ extern regexp *regcomp_comp(const char *exp, struct regexp *r, size_t len); -+ -*** regsub.c 1996/04/06 19:24:49 1.1 ---- regsub.c 1996/04/07 02:10:29 -*************** -*** 11,25 **** - /* - - regsub - perform substitutions after a regexp match - */ - void -! regsub(rp, source, dest) - const regexp *rp; - const char *source; - char *dest; - { - register regexp * const prog = (regexp *)rp; -! register char *src = (char *)source; - register char *dst = dest; - register char c; - register int no; - register size_t len; ---- 11,42 ---- - /* - - regsub - perform substitutions after a regexp match - */ -+ -+ void regsub(rp, source, dest) -+ const regexp *rp; -+ const char *source; -+ char *dest; -+ { -+ regnsub(rp, source, dest, BUFSIZ); -+ } -+ -+ -+ -+ /* -+ - regnsub - perform bounds-checked substitutions after a regexp match -+ */ - void -! regnsub(rp, source, dest, destlen) - const regexp *rp; - const char *source; - char *dest; -+ size_t destlen; - { - register regexp * const prog = (regexp *)rp; -! register const char *src = (char *)source; - register char *dst = dest; -+ char *dstend = dest + destlen; -+ char *odst; - register char c; - register int no; - register size_t len; -*************** -*** 45,55 **** - if (c == '\\' && (*src == '\\' || *src == '&')) - c = *src++; - *dst++ = c; - } else if (prog->startp[no] != NULL && prog->endp[no] != NULL && -! prog->endp[no] > prog->startp[no]) { - len = prog->endp[no] - prog->startp[no]; -! (void) strncpy(dst, prog->startp[no], len); - dst += len; - if (*(dst-1) == '\0') { /* strncpy hit NUL. */ - regerror("damaged match string"); - return; ---- 62,83 ---- - if (c == '\\' && (*src == '\\' || *src == '&')) - c = *src++; - *dst++ = c; -+ if (dst >= dstend) -+ { -+ regerror("output buffer too small"); -+ return; -+ } - } else if (prog->startp[no] != NULL && prog->endp[no] != NULL && -! prog->endp[no] > prog->startp[no]) { - len = prog->endp[no] - prog->startp[no]; -! odst = dst; - dst += len; -+ if (dst >= dstend) -+ { -+ regerror("output buffer too small"); -+ return; -+ } -+ (void) strncpy(odst, prog->startp[no], len); - if (*(dst-1) == '\0') { /* strncpy hit NUL. */ - regerror("damaged match string"); - return; -*************** -*** 58,60 **** ---- 86,131 ---- - } - *dst++ = '\0'; - } -+ -+ size_t regsublen(rp, source) -+ const regexp *rp; -+ const char *source; -+ { -+ register regexp * const prog = (regexp *)rp; -+ register char *src = (char *)source; -+ register char c; -+ register int no; -+ register int len = 0; -+ -+ if (prog == NULL || source == NULL) { -+ regerror("NULL parameter to regsublen"); -+ return -1; -+ } -+ -+ if ((unsigned char)*(prog->program) != MAGIC) { -+ regerror("damaged regexp"); -+ return -1; -+ } -+ while ((c = *src++) != '\0') { -+ if (c == '&') -+ no = 0; -+ else if (c == '\\' && isdigit(*src)) -+ no = *src++ - '0'; -+ else -+ no = -1; -+ if (no < 0) { /* Ordinary character. */ -+ if (c == '\\' && (*src == '\\' || *src == '&')) -+ src++; -+ len++; -+ } else { -+ const char *s = prog->startp[no]; -+ const char *e = prog->endp[no]; -+ if ((s != NULL) && (e != NULL) && (e > s)) { -+ len += e-s; -+ } -+ } -+ } -+ return len+1; -+ } -+ -+ - -Original regexp code from henry: -[unpacked & deleted -Olin] diff --git a/scsh/regexp/regerror.c b/scsh/regexp/regerror.c deleted file mode 100644 index a280cee..0000000 --- a/scsh/regexp/regerror.c +++ /dev/null @@ -1,18 +0,0 @@ -/* - * regerror - */ -#include -#include - -void -regerror(s) -char *s; -{ -#ifdef ERRAVAIL - error("regexp: %s", s); -#else - fprintf(stderr, "regexp(3): %s\n", s); - exit(EXIT_FAILURE); -#endif - /* NOTREACHED */ -} diff --git a/scsh/regexp/regexp.3 b/scsh/regexp/regexp.3 deleted file mode 100644 index 6d2555b..0000000 --- a/scsh/regexp/regexp.3 +++ /dev/null @@ -1,186 +0,0 @@ -.TH REGEXP 3 "2 Sept 1995" -.SH NAME -regcomp, regexec, regsub, regerror \- regular expression handler -.SH SYNOPSIS -.ft B -.nf -#include - -regexp *regcomp(exp) -const char *exp; - -int regexec(prog, string) -regexp *prog; -const char *string; - -void regsub(prog, source, dest) -const regexp *prog; -const char *source; -char *dest; - -void regerror(msg) -char *msg; -.SH DESCRIPTION -These functions implement -.IR egrep (1)-style -regular expressions and supporting facilities. -.PP -.I Regcomp -compiles a regular expression into a structure of type -.IR regexp , -and returns a pointer to it. -The space has been allocated using -.IR malloc (3) -and may be released by -.IR free . -.PP -.I Regexec -matches a NUL-terminated \fIstring\fR against the compiled regular expression -in \fIprog\fR. -It returns 1 for success and 0 for failure, and adjusts the contents of -\fIprog\fR's \fIstartp\fR and \fIendp\fR (see below) accordingly. -.PP -The members of a -.I regexp -structure include at least the following (not necessarily in order): -.PP -.RS -char *startp[NSUBEXP]; -.br -char *endp[NSUBEXP]; -.RE -.PP -where -.I NSUBEXP -is defined (as 10) in the header file. -Once a successful \fIregexec\fR has been done using the \fIregexp\fR, -each \fIstartp\fR-\fIendp\fR pair describes one substring -within the \fIstring\fR, -with the \fIstartp\fR pointing to the first character of the substring and -the \fIendp\fR pointing to the first character following the substring. -The 0th substring is the substring of \fIstring\fR that matched the whole -regular expression. -The others are those substrings that matched parenthesized expressions -within the regular expression, with parenthesized expressions numbered -in left-to-right order of their opening parentheses. -.PP -.I Regsub -copies \fIsource\fR to \fIdest\fR, making substitutions according to the -most recent \fIregexec\fR performed using \fIprog\fR. -Each instance of `&' in \fIsource\fR is replaced by the substring -indicated by \fIstartp\fR[\fI0\fR] and -\fIendp\fR[\fI0\fR]. -Each instance of `\e\fIn\fR', where \fIn\fR is a digit, is replaced by -the substring indicated by -\fIstartp\fR[\fIn\fR] and -\fIendp\fR[\fIn\fR]. -To get a literal `&' or `\e\fIn\fR' into \fIdest\fR, prefix it with `\e'; -to get a literal `\e' preceding `&' or `\e\fIn\fR', prefix it with -another `\e'. -.PP -.I Regerror -is called whenever an error is detected in \fIregcomp\fR, \fIregexec\fR, -or \fIregsub\fR. -The default \fIregerror\fR writes the string \fImsg\fR, -with a suitable indicator of origin, -on the standard -error output -and invokes \fIexit\fR(2). -.I Regerror -can be replaced by the user if other actions are desirable. -.SH "REGULAR EXPRESSION SYNTAX" -A regular expression is zero or more \fIbranches\fR, separated by `|'. -It matches anything that matches one of the branches. -.PP -A branch is zero or more \fIpieces\fR, concatenated. -It matches a match for the first, followed by a match for the second, etc. -.PP -A piece is an \fIatom\fR possibly followed by `*', `+', or `?'. -An atom followed by `*' matches a sequence of 0 or more matches of the atom. -An atom followed by `+' matches a sequence of 1 or more matches of the atom. -An atom followed by `?' matches a match of the atom, or the null string. -.PP -An atom is a regular expression in parentheses (matching a match for the -regular expression), a \fIrange\fR (see below), `.' -(matching any single character), `^' (matching the null string at the -beginning of the input string), `$' (matching the null string at the -end of the input string), a `\e' followed by a single character (matching -that character), or a single character with no other significance -(matching that character). -.PP -A \fIrange\fR is a sequence of characters enclosed in `[]'. -It normally matches any single character from the sequence. -If the sequence begins with `^', -it matches any single character \fInot\fR from the rest of the sequence. -If two characters in the sequence are separated by `\-', this is shorthand -for the full list of ASCII characters between them -(e.g. `[0-9]' matches any decimal digit). -To include a literal `]' in the sequence, make it the first character -(following a possible `^'). -To include a literal `\-', make it the first or last character. -.SH AMBIGUITY -If a regular expression could match two different parts of the input string, -it will match the one which begins earliest. -If both begin in the same place but match different lengths, or match -the same length in different ways, life gets messier, as follows. -.PP -In general, the possibilities in a list of branches are considered in -left-to-right order, the possibilities for `*', `+', and `?' are -considered longest-first, nested constructs are considered from the -outermost in, and concatenated constructs are considered leftmost-first. -The match that will be chosen is the one that uses the earliest -possibility in the first choice that has to be made. -If there is more than one choice, the next will be made in the same manner -(earliest possibility) subject to the decision on the first choice. -And so forth. -.PP -For example, `(ab|a)b*c' could match `abc' in one of two ways. -The first choice is between `ab' and `a'; since `ab' is earlier, and does -lead to a successful overall match, it is chosen. -Since the `b' is already spoken for, -the `b*' must match its last possibility\(emthe empty string\(emsince -it must respect the earlier choice. -.PP -In the particular case where the regular expression does not use `|' -and does not apply `*', `+', or `?' to parenthesized subexpressions, -the net effect is that the longest possible -match will be chosen. -So `ab*', presented with `xabbbby', will match `abbbb'. -Note that if `ab*' is tried against `xabyabbbz', it -will match `ab' just after `x', due to the begins-earliest rule. -(In effect, the decision on where to start the match is the first choice -to be made, hence subsequent choices must respect it even if this leads them -to less-preferred alternatives.) -.SH SEE ALSO -egrep(1), expr(1) -.SH DIAGNOSTICS -\fIRegcomp\fR returns NULL for a failure -(\fIregerror\fR permitting), -where failures are syntax errors, exceeding implementation limits, -or applying `+' or `*' to a possibly-null operand. -.SH HISTORY -This is a revised version. -Both code and manual page were -originally written by Henry Spencer at University of Toronto. -They are intended to be compatible with the Bell V8 \fIregexp\fR(3), -but are not derived from Bell code. -.SH BUGS -Empty branches and empty regular expressions are not portable -to other, otherwise-similar, implementations. -.PP -The ban on -applying `*' or `+' to a possibly-null operand is an artifact of the -simplistic implementation. -.PP -The match-choice rules are complex. -A simple ``longest match'' rule would be preferable, -but is harder to implement. -.PP -Although there is a general similarity to POSIX.2 ``extended'' regular -expressions, neither the regular-expression syntax nor the programming -interface is an exact match. -.PP -Due to emphasis on -compactness and simplicity, -it's not strikingly fast. -It does give some attention to handling simple cases quickly. diff --git a/scsh/regexp/regexp.c b/scsh/regexp/regexp.c deleted file mode 100644 index 65d7e88..0000000 --- a/scsh/regexp/regexp.c +++ /dev/null @@ -1,1124 +0,0 @@ -/* - * regcomp and regexec -- regsub and regerror are elsewhere - */ -#include -#include -#include -#include -#include "regmagic.h" - -/* - * The "internal use only" fields in regexp.h are present to pass info from - * compile to execute that permits the execute phase to run lots faster on - * simple cases. They are: - * - * regstart char that must begin a match; '\0' if none obvious - * reganch is the match anchored (at beginning-of-line only)? - * regmust string (pointer into program) that match must include, or NULL - * regmlen length of regmust string - * - * Regstart and reganch permit very fast decisions on suitable starting points - * for a match, cutting down the work a lot. Regmust permits fast rejection - * of lines that cannot possibly match. The regmust tests are costly enough - * that regcomp() supplies a regmust only if the r.e. contains something - * potentially expensive (at present, the only such thing detected is * or + - * at the start of the r.e., which can involve a lot of backup). Regmlen is - * supplied because the test in regexec() needs it and regcomp() is computing - * it anyway. - */ - -/* - * Structure for regexp "program". This is essentially a linear encoding - * of a nondeterministic finite-state machine (aka syntax charts or - * "railroad normal form" in parsing technology). Each node is an opcode - * plus a "next" pointer, possibly plus an operand. "Next" pointers of - * all nodes except BRANCH implement concatenation; a "next" pointer with - * a BRANCH on both ends of it is connecting two alternatives. (Here we - * have one of the subtle syntax dependencies: an individual BRANCH (as - * opposed to a collection of them) is never concatenated with anything - * because of operator precedence.) The operand of some types of node is - * a literal string; for others, it is a node leading into a sub-FSM. In - * particular, the operand of a BRANCH node is the first node of the branch. - * (NB this is *not* a tree structure: the tail of the branch connects - * to the thing following the set of BRANCHes.) The opcodes are: - */ - -/* definition number opnd? meaning */ -#define END 0 /* no End of program. */ -#define BOL 1 /* no Match beginning of line. */ -#define EOL 2 /* no Match end of line. */ -#define ANY 3 /* no Match any character. */ -#define ANYOF 4 /* str Match any of these. */ -#define ANYBUT 5 /* str Match any but one of these. */ -#define BRANCH 6 /* node Match this, or the next..\&. */ -#define BACK 7 /* no "next" ptr points backward. */ -#define EXACTLY 8 /* str Match this string. */ -#define NOTHING 9 /* no Match empty string. */ -#define STAR 10 /* node Match this 0 or more times. */ -#define PLUS 11 /* node Match this 1 or more times. */ -#define OPEN 20 /* no Sub-RE starts here. */ - /* OPEN+1 is number 1, etc. */ -#define CLOSE 30 /* no Analogous to OPEN. */ - -/* - * Opcode notes: - * - * BRANCH The set of branches constituting a single choice are hooked - * together with their "next" pointers, since precedence prevents - * anything being concatenated to any individual branch. The - * "next" pointer of the last BRANCH in a choice points to the - * thing following the whole choice. This is also where the - * final "next" pointer of each individual branch points; each - * branch starts with the operand node of a BRANCH node. - * - * BACK Normal "next" pointers all implicitly point forward; BACK - * exists to make loop structures possible. - * - * STAR,PLUS '?', and complex '*' and '+', are implemented as circular - * BRANCH structures using BACK. Simple cases (one character - * per match) are implemented with STAR and PLUS for speed - * and to minimize recursive plunges. - * - * OPEN,CLOSE ...are numbered at compile time. - */ - -/* - * A node is one char of opcode followed by two chars of "next" pointer. - * "Next" pointers are stored as two 8-bit pieces, high order first. The - * value is a positive offset from the opcode of the node containing it. - * An operand, if any, simply follows the node. (Note that much of the - * code generation knows about this implicit relationship.) - * - * Using two bytes for the "next" pointer is vast overkill for most things, - * but allows patterns to get big without disasters. - */ -#define OP(p) (*(p)) -#define NEXT(p) (((*((p)+1)&0177)<<8) + (*((p)+2)&0377)) -#define OPERAND(p) ((p) + 3) - -/* - * See regmagic.h for one further detail of program structure. - */ - - -/* - * Utility definitions. - */ -#define FAIL(m) { regerror(m); return(NULL); } -#define FAILN(m) { regerror(m); return(-1); } -#define ISREPN(c) ((c) == '*' || (c) == '+' || (c) == '?') -#define META "^$.[()|?+*\\" - -/* - * Flags to be passed up and down. - */ -#define HASWIDTH 01 /* Known never to match null string. */ -#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 04 /* Starts with * or +. */ -#define WORST 0 /* Worst case. */ - -/* - * Work-variable struct for regcomp(). - */ -struct comp { - char *regparse; /* Input-scan pointer. */ - int regnpar; /* () count. */ - char *regcode; /* Code-emit pointer; ®dummy = don't. */ - char regdummy[3]; /* NOTHING, 0 next ptr */ - long regsize; /* Code size. */ -}; -#define EMITTING(cp) ((cp)->regcode != (cp)->regdummy) - -/* - * Forward declarations for regcomp()'s friends. - */ -static char *reg(struct comp *cp, int paren, int *flagp); -static char *regbranch(struct comp *cp, int *flagp); -static char *regpiece(struct comp *cp, int *flagp); -static char *regatom(struct comp *cp, int *flagp); -static char *regnode(struct comp *cp, int op); -static char *regnext(char *node); -static void regc(struct comp *cp, int c); -static void reginsert(struct comp *cp, int op, char *opnd); -static void regtail(struct comp *cp, char *p, char *val); -static void regoptail(struct comp *cp, char *p, char *val); - -/* - - regcomp - compile a regular expression into internal code - * - * We can't allocate space until we know how big the compiled form will be, - * but we can't compile it (and thus know how big it is) until we've got a - * place to put the code. So we cheat: we compile it twice, once with code - * generation turned off and size counting turned on, and once "for real". - * This also means that we don't allocate space until we are sure that the - * thing really will compile successfully, and we never have to move the - * code and thus invalidate pointers into it. (Note that it has to be in - * one piece because free() must be able to free it all.) - * - * Beware that the optimization-preparation code in here knows about some - * of the structure of the compiled regexp. - */ -regexp * -regcomp(exp) -const char *exp; -{ - register regexp *r; - size_t len; - - len = regcomp_len(exp); - if (len <= 0) - return NULL; - - /* Allocate space. */ - r = (regexp *)malloc(len); - - if (r == NULL) - FAIL("out of space"); - return regcomp_comp(exp, r, len); -} - - -size_t -regcomp_len(exp) -const char *exp; -{ - int flags; - register regexp *r; - struct comp co; - - if (exp == NULL) - FAILN("NULL argument to regcomp"); - - /* First pass: determine size, legality. */ - co.regparse = (char *)exp; - co.regnpar = 1; - co.regsize = 0L; - co.regdummy[0] = NOTHING; - co.regdummy[1] = co.regdummy[2] = 0; - co.regcode = co.regdummy; - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) - return -1; - - /* Small enough for pointer-storage convention? */ - if (co.regsize >= 0x7fffL) /* Probably could be 0xffffL. */ - FAILN("regexp too big"); - - return (sizeof(regexp) + (size_t)co.regsize); -} - - -regexp * -regcomp_comp(exp, r, len) -const char *exp; -register regexp *r; -size_t len; -{ - register char *scan; - int flags; - struct comp co; - - /* Second pass: emit code. */ - co.regparse = (char *)exp; - co.regnpar = 1; - co.regcode = r->program; - co.regsize = len - sizeof(regexp); - regc(&co, MAGIC); - if (reg(&co, 0, &flags) == NULL) - return(NULL); - - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; - r->regmust = 0; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ - scan = OPERAND(scan); - - /* Starting-point info. */ - if (OP(scan) == EXACTLY) - r->regstart = *OPERAND(scan); - else if (OP(scan) == BOL) - r->reganch = 1; - - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - */ - if (flags&SPSTART) { - register char *longest = NULL; - register size_t len = 0; - - for (; scan != NULL; scan = regnext(scan)) - if (OP(scan) == EXACTLY && strlen(OPERAND(scan)) >= len) { - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } - r->regmust = longest - r->program; - r->regmlen = (int)len; - } - } - - return(r); -} - -/* - - reg - regular expression, i.e. main body or parenthesized thing - * - * Caller must absorb opening parenthesis. - * - * Combining parenthesis handling with the base level of regular expression - * is a trifle forced, but the need to tie the tails of the branches to what - * follows makes it hard to avoid. - */ -static char * -reg(cp, paren, flagp) -register struct comp *cp; -int paren; /* Parenthesized? */ -int *flagp; -{ - register char *ret; - register char *br; - register char *ender; - register int parno; - int flags; - - *flagp = HASWIDTH; /* Tentatively. */ - - if (paren) { - /* Make an OPEN node. */ - if (cp->regnpar >= NSUBEXP) - FAIL("too many ()"); - parno = cp->regnpar; - cp->regnpar++; - ret = regnode(cp, OPEN+parno); - } - - /* Pick up the branches, linking them together. */ - br = regbranch(cp, &flags); - if (br == NULL) - return(NULL); - if (paren) - regtail(cp, ret, br); /* OPEN -> first. */ - else - ret = br; - *flagp &= ~(~flags&HASWIDTH); /* Clear bit if bit 0. */ - *flagp |= flags&SPSTART; - while (*cp->regparse == '|') { - cp->regparse++; - br = regbranch(cp, &flags); - if (br == NULL) - return(NULL); - regtail(cp, ret, br); /* BRANCH -> BRANCH. */ - *flagp &= ~(~flags&HASWIDTH); - *flagp |= flags&SPSTART; - } - - /* Make a closing node, and hook it on the end. */ - ender = regnode(cp, (paren) ? CLOSE+parno : END); - regtail(cp, ret, ender); - - /* Hook the tails of the branches to the closing node. */ - for (br = ret; br != NULL; br = regnext(br)) - regoptail(cp, br, ender); - - /* Check for proper termination. */ - if (paren && *cp->regparse++ != ')') { - FAIL("unterminated ()"); - } else if (!paren && *cp->regparse != '\0') { - if (*cp->regparse == ')') { - FAIL("unmatched ()"); - } else - FAIL("internal error: junk on end"); - /* NOTREACHED */ - } - - return(ret); -} - -/* - - regbranch - one alternative of an | operator - * - * Implements the concatenation operator. - */ -static char * -regbranch(cp, flagp) -register struct comp *cp; -int *flagp; -{ - register char *ret; - register char *chain; - register char *latest; - int flags; - register int c; - - *flagp = WORST; /* Tentatively. */ - - ret = regnode(cp, BRANCH); - chain = NULL; - while ((c = *cp->regparse) != '\0' && c != '|' && c != ')') { - latest = regpiece(cp, &flags); - if (latest == NULL) - return(NULL); - *flagp |= flags&HASWIDTH; - if (chain == NULL) /* First piece. */ - *flagp |= flags&SPSTART; - else - regtail(cp, chain, latest); - chain = latest; - } - if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(cp, NOTHING); - - return(ret); -} - -/* - - regpiece - something followed by possible [*+?] - * - * Note that the branching code sequences used for ? and the general cases - * of * and + are somewhat optimized: they use the same NOTHING node as - * both the endmarker for their branch list and the body of the last branch. - * It might seem that this node could be dispensed with entirely, but the - * endmarker role is not redundant. - */ -static char * -regpiece(cp, flagp) -register struct comp *cp; -int *flagp; -{ - register char *ret; - register char op; - register char *next; - int flags; - - ret = regatom(cp, &flags); - if (ret == NULL) - return(NULL); - - op = *cp->regparse; - if (!ISREPN(op)) { - *flagp = flags; - return(ret); - } - - if (!(flags&HASWIDTH) && op != '?') - FAIL("*+ operand could be empty"); - switch (op) { - case '*': *flagp = WORST|SPSTART; break; - case '+': *flagp = WORST|SPSTART|HASWIDTH; break; - case '?': *flagp = WORST; break; - } - - if (op == '*' && (flags&SIMPLE)) - reginsert(cp, STAR, ret); - else if (op == '*') { - /* Emit x* as (x&|), where & means "self". */ - reginsert(cp, BRANCH, ret); /* Either x */ - regoptail(cp, ret, regnode(cp, BACK)); /* and loop */ - regoptail(cp, ret, ret); /* back */ - regtail(cp, ret, regnode(cp, BRANCH)); /* or */ - regtail(cp, ret, regnode(cp, NOTHING)); /* null. */ - } else if (op == '+' && (flags&SIMPLE)) - reginsert(cp, PLUS, ret); - else if (op == '+') { - /* Emit x+ as x(&|), where & means "self". */ - next = regnode(cp, BRANCH); /* Either */ - regtail(cp, ret, next); - regtail(cp, regnode(cp, BACK), ret); /* loop back */ - regtail(cp, next, regnode(cp, BRANCH)); /* or */ - regtail(cp, ret, regnode(cp, NOTHING)); /* null. */ - } else if (op == '?') { - /* Emit x? as (x|) */ - reginsert(cp, BRANCH, ret); /* Either x */ - regtail(cp, ret, regnode(cp, BRANCH)); /* or */ - next = regnode(cp, NOTHING); /* null. */ - regtail(cp, ret, next); - regoptail(cp, ret, next); - } - cp->regparse++; - if (ISREPN(*cp->regparse)) - FAIL("nested *?+"); - - return(ret); -} - -/* - - regatom - the lowest level - * - * Optimization: gobbles an entire sequence of ordinary characters so that - * it can turn them into a single node, which is smaller to store and - * faster to run. Backslashed characters are exceptions, each becoming a - * separate node; the code is simpler that way and it's not worth fixing. - */ -static char * -regatom(cp, flagp) -register struct comp *cp; -int *flagp; -{ - register char *ret; - int flags; - - *flagp = WORST; /* Tentatively. */ - - switch (*cp->regparse++) { - case '^': - ret = regnode(cp, BOL); - break; - case '$': - ret = regnode(cp, EOL); - break; - case '.': - ret = regnode(cp, ANY); - *flagp |= HASWIDTH|SIMPLE; - break; - case '[': { - register int range; - register int rangeend; - register int c; - - if (*cp->regparse == '^') { /* Complement of range. */ - ret = regnode(cp, ANYBUT); - cp->regparse++; - } else - ret = regnode(cp, ANYOF); - if ((c = *cp->regparse) == ']' || c == '-') { - regc(cp, c); - cp->regparse++; - } - while ((c = *cp->regparse++) != '\0' && c != ']') { - if (c != '-') - regc(cp, c); - else if ((c = *cp->regparse) == ']' || c == '\0') - regc(cp, '-'); - else { - range = (unsigned char)*(cp->regparse-2); - rangeend = (unsigned char)c; - if (range > rangeend) - FAIL("invalid [] range"); - for (range++; range <= rangeend; range++) - regc(cp, range); - cp->regparse++; - } - } - regc(cp, '\0'); - if (c != ']') - FAIL("unmatched []"); - *flagp |= HASWIDTH|SIMPLE; - break; - } - case '(': - ret = reg(cp, 1, &flags); - if (ret == NULL) - return(NULL); - *flagp |= flags&(HASWIDTH|SPSTART); - break; - case '\0': - case '|': - case ')': - /* supposed to be caught earlier */ - FAIL("internal error: \\0|) unexpected"); - break; - case '?': - case '+': - case '*': - FAIL("?+* follows nothing"); - break; - case '\\': - if (*cp->regparse == '\0') - FAIL("trailing \\"); - ret = regnode(cp, EXACTLY); - regc(cp, *cp->regparse++); - regc(cp, '\0'); - *flagp |= HASWIDTH|SIMPLE; - break; - default: { - register size_t len; - register char ender; - - cp->regparse--; - len = strcspn(cp->regparse, META); - if (len == 0) - FAIL("internal error: strcspn 0"); - ender = *(cp->regparse+len); - if (len > 1 && ISREPN(ender)) - len--; /* Back off clear of ?+* operand. */ - *flagp |= HASWIDTH; - if (len == 1) - *flagp |= SIMPLE; - ret = regnode(cp, EXACTLY); - for (; len > 0; len--) - regc(cp, *cp->regparse++); - regc(cp, '\0'); - break; - } - } - - return(ret); -} - -/* - - regnode - emit a node - */ -static char * /* Location. */ -regnode(cp, op) -register struct comp *cp; -char op; -{ - register char *const ret = cp->regcode; - register char *ptr; - - if (!EMITTING(cp)) { - cp->regsize += 3; - return(ret); - } - - ptr = ret; - *ptr++ = op; - *ptr++ = '\0'; /* Null next pointer. */ - *ptr++ = '\0'; - cp->regcode = ptr; - - return(ret); -} - -/* - - regc - emit (if appropriate) a byte of code - */ -static void -regc(cp, b) -register struct comp *cp; -char b; -{ - if (EMITTING(cp)) - *cp->regcode++ = b; - else - cp->regsize++; -} - -/* - - reginsert - insert an operator in front of already-emitted operand - * - * Means relocating the operand. - */ -static void -reginsert(cp, op, opnd) -register struct comp *cp; -char op; -char *opnd; -{ - register char *place; - - if (!EMITTING(cp)) { - cp->regsize += 3; - return; - } - - (void) memmove(opnd+3, opnd, (size_t)(cp->regcode - opnd)); - cp->regcode += 3; - - place = opnd; /* Op node, where operand used to be. */ - *place++ = op; - *place++ = '\0'; - *place++ = '\0'; -} - -/* - - regtail - set the next-pointer at the end of a node chain - */ -static void -regtail(cp, p, val) -register struct comp *cp; -char *p; -char *val; -{ - register char *scan; - register char *temp; - register int offset; - - if (!EMITTING(cp)) - return; - - /* Find last node. */ - for (scan = p; (temp = regnext(scan)) != NULL; scan = temp) - continue; - - offset = (OP(scan) == BACK) ? scan - val : val - scan; - *(scan+1) = (offset>>8)&0177; - *(scan+2) = offset&0377; -} - -/* - - regoptail - regtail on operand of first argument; nop if operandless - */ -static void -regoptail(cp, p, val) -register struct comp *cp; -char *p; -char *val; -{ - /* "Operandless" and "op != BRANCH" are synonymous in practice. */ - if (!EMITTING(cp) || OP(p) != BRANCH) - return; - regtail(cp, OPERAND(p), val); -} - -/* - * regexec and friends - */ - -/* - * Work-variable struct for regexec(). - */ -struct exec { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ - const char **regstartp; /* Pointer to startp array. */ - const char **regendp; /* Ditto for endp. */ -}; - -/* - * Forwards. - */ -static int regtry(struct exec *ep, regexp *rp, char *string); -static int regmatch(struct exec *ep, char *prog); -static size_t regrepeat(struct exec *ep, char *node); - -#ifdef DEBUG -int regnarrate = 0; -void regdump(); -static char *regprop(); -#endif - -/* - - regexec - match a regexp against a string - */ -int -regexec(prog, str) -register regexp *prog; -const char *str; -{ - register char *string = (char *)str; /* avert const poisoning */ - register char *s; - struct exec ex; - - /* Be paranoid. */ - if (prog == NULL || string == NULL) { - regerror("NULL argument to regexec"); - return(0); - } - - /* Check validity of program. */ - if ((unsigned char)*prog->program != MAGIC) { - regerror("corrupted regexp"); - return(0); - } - - /* If there is a "must appear" string, look for it. */ - if ((prog->regmlen > 0) && - strstr(string, &prog->program[prog->regmust]) == NULL) - return(0); - - /* Mark beginning of line for ^ . */ - ex.regbol = string; - ex.regstartp = prog->startp; - ex.regendp = prog->endp; - - /* Simplest case: anchored match need be tried only once. */ - if (prog->reganch) - return(regtry(&ex, prog, string)); - - /* Messy cases: unanchored match. */ - if (prog->regstart != '\0') { - /* We know what char it must start with. */ - for (s = string; s != NULL; s = strchr(s+1, prog->regstart)) - if (regtry(&ex, prog, s)) - return(1); - return(0); - } else { - /* We don't -- general case. */ - for (s = string; !regtry(&ex, prog, s); s++) - if (*s == '\0') - return(0); - return(1); - } - /* NOTREACHED */ -} - -/* - - regtry - try match at specific point - */ -static int /* 0 failure, 1 success */ -regtry(ep, prog, string) -register struct exec *ep; -regexp *prog; -char *string; -{ - register int i; - register const char **stp; - register const char **enp; - - ep->reginput = string; - - stp = prog->startp; - enp = prog->endp; - for (i = NSUBEXP; i > 0; i--) { - *stp++ = NULL; - *enp++ = NULL; - } - if (regmatch(ep, prog->program + 1)) { - prog->startp[0] = string; - prog->endp[0] = ep->reginput; - return(1); - } else - return(0); -} - -/* - - regmatch - main matching routine - * - * Conceptually the strategy is simple: check to see whether the current - * node matches, call self recursively to see whether the rest matches, - * and then act accordingly. In practice we make some effort to avoid - * recursion, in particular by going through "ordinary" nodes (that don't - * need to know whether the rest of the match failed) by a loop instead of - * by recursion. - */ -static int /* 0 failure, 1 success */ -regmatch(ep, prog) -register struct exec *ep; -char *prog; -{ - register char *scan; /* Current node. */ - char *next; /* Next node. */ - -#ifdef DEBUG - if (prog != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(prog)); -#endif - for (scan = prog; scan != NULL; scan = next) { -#ifdef DEBUG - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); -#endif - next = regnext(scan); - - switch (OP(scan)) { - case BOL: - if (ep->reginput != ep->regbol) - return(0); - break; - case EOL: - if (*ep->reginput != '\0') - return(0); - break; - case ANY: - if (*ep->reginput == '\0') - return(0); - ep->reginput++; - break; - case EXACTLY: { - register size_t len; - register char *const opnd = OPERAND(scan); - - /* Inline the first character, for speed. */ - if (*opnd != *ep->reginput) - return(0); - len = strlen(opnd); - if (len > 1 && strncmp(opnd, ep->reginput, len) != 0) - return(0); - ep->reginput += len; - break; - } - case ANYOF: - if (*ep->reginput == '\0' || - strchr(OPERAND(scan), *ep->reginput) == NULL) - return(0); - ep->reginput++; - break; - case ANYBUT: - if (*ep->reginput == '\0' || - strchr(OPERAND(scan), *ep->reginput) != NULL) - return(0); - ep->reginput++; - break; - case NOTHING: - break; - case BACK: - break; - case OPEN+1: case OPEN+2: case OPEN+3: - case OPEN+4: case OPEN+5: case OPEN+6: - case OPEN+7: case OPEN+8: case OPEN+9: { - register const int no = OP(scan) - OPEN; - register char *const input = ep->reginput; - - if (regmatch(ep, next)) { - /* - * Don't set startp if some later - * invocation of the same parentheses - * already has. - */ - if (ep->regstartp[no] == NULL) - ep->regstartp[no] = input; - return(1); - } else - return(0); - break; - } - case CLOSE+1: case CLOSE+2: case CLOSE+3: - case CLOSE+4: case CLOSE+5: case CLOSE+6: - case CLOSE+7: case CLOSE+8: case CLOSE+9: { - register const int no = OP(scan) - CLOSE; - register char *const input = ep->reginput; - - if (regmatch(ep, next)) { - /* - * Don't set endp if some later - * invocation of the same parentheses - * already has. - */ - if (ep->regendp[no] == NULL) - ep->regendp[no] = input; - return(1); - } else - return(0); - break; - } - case BRANCH: { - register char *const save = ep->reginput; - - if (OP(next) != BRANCH) /* No choice. */ - next = OPERAND(scan); /* Avoid recursion. */ - else { - while (OP(scan) == BRANCH) { - if (regmatch(ep, OPERAND(scan))) - return(1); - ep->reginput = save; - scan = regnext(scan); - } - return(0); - /* NOTREACHED */ - } - break; - } - case STAR: case PLUS: { - register const char nextch = - (OP(next) == EXACTLY) ? *OPERAND(next) : '\0'; - register size_t no; - register char *const save = ep->reginput; - register const size_t min = (OP(scan) == STAR) ? 0 : 1; - - for (no = regrepeat(ep, OPERAND(scan)) + 1; no > min; no--) { - ep->reginput = save + no - 1; - /* If it could work, try it. */ - if (nextch == '\0' || *ep->reginput == nextch) - if (regmatch(ep, next)) - return(1); - } - return(0); - break; - } - case END: - return(1); /* Success! */ - break; - default: - regerror("regexp corruption"); - return(0); - break; - } - } - - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - regerror("corrupted pointers"); - return(0); -} - -/* - - regrepeat - report how many times something simple would match - */ -static size_t -regrepeat(ep, node) -register struct exec *ep; -char *node; -{ - register size_t count; - register char *scan; - register char ch; - - switch (OP(node)) { - case ANY: - return(strlen(ep->reginput)); - break; - case EXACTLY: - ch = *OPERAND(node); - count = 0; - for (scan = ep->reginput; *scan == ch; scan++) - count++; - return(count); - break; - case ANYOF: - return(strspn(ep->reginput, OPERAND(node))); - break; - case ANYBUT: - return(strcspn(ep->reginput, OPERAND(node))); - break; - default: /* Oh dear. Called inappropriately. */ - regerror("internal error: bad call of regrepeat"); - return(0); /* Best compromise. */ - break; - } - /* NOTREACHED */ -} - -/* - - regnext - dig the "next" pointer out of a node - */ -static char * -regnext(p) -register char *p; -{ - register const int offset = NEXT(p); - - if (offset == 0) - return(NULL); - - return((OP(p) == BACK) ? p-offset : p+offset); -} - -#ifdef DEBUG - -static char *regprop(); - -/* - - regdump - dump a regexp onto stdout in vaguely comprehensible form - */ -void -regdump(r) -regexp *r; -{ - register char *s; - register char op = EXACTLY; /* Arbitrary non-END op. */ - register char *next; - - - s = r->program + 1; - while (op != END) { /* While that wasn't END last time... */ - op = OP(s); - printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ - next = regnext(s); - if (next == NULL) /* Next ptr. */ - printf("(0)"); - else - printf("(%d)", (s-r->program)+(next-s)); - s += 3; - if (op == ANYOF || op == ANYBUT || op == EXACTLY) { - /* Literal string, where present. */ - while (*s != '\0') { - putchar(*s); - s++; - } - s++; - } - putchar('\n'); - } - - /* Header fields of interest. */ - if (r->regstart != '\0') - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); - if (r->regmlen > 0) - printf("must have \"%s\"", &r->program[r->regmust]); - printf("\n"); -} - -/* - - regprop - printable representation of opcode - */ -static char * -regprop(op) -char *op; -{ - register char *p; - static char buf[50]; - - (void) strcpy(buf, ":"); - - switch (OP(op)) { - case BOL: - p = "BOL"; - break; - case EOL: - p = "EOL"; - break; - case ANY: - p = "ANY"; - break; - case ANYOF: - p = "ANYOF"; - break; - case ANYBUT: - p = "ANYBUT"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACTLY: - p = "EXACTLY"; - break; - case NOTHING: - p = "NOTHING"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - default: - regerror("corrupted opcode"); - break; - } - if (p != NULL) - (void) strcat(buf, p); - return(buf); -} -#endif diff --git a/scsh/regexp/regexp.h b/scsh/regexp/regexp.h deleted file mode 100644 index 48af08c..0000000 --- a/scsh/regexp/regexp.h +++ /dev/null @@ -1,27 +0,0 @@ -/* - * Definitions etc. for regexp(3) routines. - * - * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], - * not the System V one. - */ -#define NSUBEXP 10 -typedef struct regexp { - const char *startp[NSUBEXP]; - const char *endp[NSUBEXP]; - char regstart; /* Internal use only. */ - char reganch; /* Internal use only. */ - int regmust; /* Internal use only. */ - int regmlen; /* Internal use only. */ - char program[1]; /* Unwarranted chumminess with compiler. */ -} regexp; - -extern regexp *regcomp(const char *re); -extern int regexec(regexp *rp, const char *s); -extern void regsub(const regexp *rp, const char *src, char *dst); -extern void regnsub(const regexp *rp, const char *src, char *dst, size_t len); -extern size_t regsublen(const regexp *rp, const char *src); - -extern void regerror(char *message); -extern size_t regcomp_len(const char *exp); -extern regexp *regcomp_comp(const char *exp, struct regexp *r, size_t len); - diff --git a/scsh/regexp/regmagic.h b/scsh/regexp/regmagic.h deleted file mode 100644 index 5acf447..0000000 --- a/scsh/regexp/regmagic.h +++ /dev/null @@ -1,5 +0,0 @@ -/* - * The first byte of the regexp internal "program" is actually this magic - * number; the start node begins in the second byte. - */ -#define MAGIC 0234 diff --git a/scsh/regexp/regsub.c b/scsh/regexp/regsub.c deleted file mode 100644 index bc98845..0000000 --- a/scsh/regexp/regsub.c +++ /dev/null @@ -1,131 +0,0 @@ -/* - * regsub - */ -#include -#include -#include -#include -#include -#include "regmagic.h" - -/* - - regsub - perform substitutions after a regexp match - */ - -void regsub(rp, source, dest) -const regexp *rp; -const char *source; -char *dest; -{ - regnsub(rp, source, dest, BUFSIZ); -} - - - -/* - - regnsub - perform bounds-checked substitutions after a regexp match - */ -void -regnsub(rp, source, dest, destlen) -const regexp *rp; -const char *source; -char *dest; -size_t destlen; -{ - register regexp * const prog = (regexp *)rp; - register const char *src = (char *)source; - register char *dst = dest; - char *dstend = dest + destlen; - char *odst; - register char c; - register int no; - register size_t len; - - if (prog == NULL || source == NULL || dest == NULL) { - regerror("NULL parameter to regsub"); - return; - } - if ((unsigned char)*(prog->program) != MAGIC) { - regerror("damaged regexp"); - return; - } - - while ((c = *src++) != '\0') { - if (c == '&') - no = 0; - else if (c == '\\' && isdigit(*src)) - no = *src++ - '0'; - else - no = -1; - - if (no < 0) { /* Ordinary character. */ - if (c == '\\' && (*src == '\\' || *src == '&')) - c = *src++; - *dst++ = c; - if (dst >= dstend) - { - regerror("output buffer too small"); - return; - } - } else if (prog->startp[no] != NULL && prog->endp[no] != NULL && - prog->endp[no] > prog->startp[no]) { - len = prog->endp[no] - prog->startp[no]; - odst = dst; - dst += len; - if (dst >= dstend) - { - regerror("output buffer too small"); - return; - } - (void) strncpy(odst, prog->startp[no], len); - if (*(dst-1) == '\0') { /* strncpy hit NUL. */ - regerror("damaged match string"); - return; - } - } - } - *dst++ = '\0'; -} - -size_t regsublen(rp, source) -const regexp *rp; -const char *source; -{ - register regexp * const prog = (regexp *)rp; - register char *src = (char *)source; - register char c; - register int no; - register int len = 0; - - if (prog == NULL || source == NULL) { - regerror("NULL parameter to regsublen"); - return -1; - } - - if ((unsigned char)*(prog->program) != MAGIC) { - regerror("damaged regexp"); - return -1; - } - while ((c = *src++) != '\0') { - if (c == '&') - no = 0; - else if (c == '\\' && isdigit(*src)) - no = *src++ - '0'; - else - no = -1; - if (no < 0) { /* Ordinary character. */ - if (c == '\\' && (*src == '\\' || *src == '&')) - src++; - len++; - } else { - const char *s = prog->startp[no]; - const char *e = prog->endp[no]; - if ((s != NULL) && (e != NULL) && (e > s)) { - len += e-s; - } - } - } - return len+1; -} - - diff --git a/scsh/regexp/tests b/scsh/regexp/tests deleted file mode 100644 index 10aa6f9..0000000 --- a/scsh/regexp/tests +++ /dev/null @@ -1,127 +0,0 @@ -abc abc y & abc -abc xbc n - - -abc axc n - - -abc abx n - - -abc xabcy y & abc -abc ababc y & abc -ab*c abc y & abc -ab*bc abc y & abc -ab*bc abbc y & abbc -ab*bc abbbbc y & abbbbc -ab+bc abbc y & abbc -ab+bc abc n - - -ab+bc abq n - - -ab+bc abbbbc y & abbbbc -ab?bc abbc y & abbc -ab?bc abc y & abc -ab?bc abbbbc n - - -ab?c abc y & abc -^abc$ abc y & abc -^abc$ abcc n - - -^abc abcc y & abc -^abc$ aabc n - - -abc$ aabc y & abc -^ abc y & -$ abc y & -a.c abc y & abc -a.c axc y & axc -a.*c axyzc y & axyzc -a.*c axyzd n - - -a[bc]d abc n - - -a[bc]d abd y & abd -a[b-d]e abd n - - -a[b-d]e ace y & ace -a[b-d] aac y & ac -a[-b] a- y & a- -a[b-] a- y & a- -[k] ab n - - -a[b-a] - c - - -a[]b - c - - -a[ - c - - -a] a] y & a] -a[]]b a]b y & a]b -a[^bc]d aed y & aed -a[^bc]d abd n - - -a[^-b]c adc y & adc -a[^-b]c a-c n - - -a[^]b]c a]c n - - -a[^]b]c adc y & adc -ab|cd abc y & ab -ab|cd abcd y & ab -()ef def y &-\1 ef- -()* - c - - -*a - c - - -^* - c - - -$* - c - - -(*)b - c - - -$b b n - - -a\ - c - - -a\(b a(b y &-\1 a(b- -a\(*b ab y & ab -a\(*b a((b y & a((b -a\\b a\b y & a\b -abc) - c - - -(abc - c - - -((a)) abc y &-\1-\2 a-a-a -(a)b(c) abc y &-\1-\2 abc-a-c -a+b+c aabbabc y & abc -a** - c - - -a*? - c - - -(a*)* - c - - -(a*)+ - c - - -(a|)* - c - - -(a*|b)* - c - - -(a+|b)* ab y &-\1 ab-b -(a+|b)+ ab y &-\1 ab-b -(a+|b)? ab y &-\1 a-a -[^ab]* cde y & cde -(^)* - c - - -(ab|)* - c - - -)( - c - - - abc y & -abc n - - -a* y & -abcd abcd y &-\&-\\& abcd-&-\abcd -a(bc)d abcd y \1-\\1-\\\1 bc-\1-\bc -([abc])*d abbbcd y &-\1 abbbcd-c -([abc])*bcd abcd y &-\1 abcd-a -a|b|c|d|e e y & e -(a|b|c|d|e)f ef y &-\1 ef-e -((a*|b))* - c - - -abcd*efg abcdefg y & abcdefg -ab* xabyabbbz y & ab -ab* xayabbbz y & a -(ab|cd)e abcde y &-\1 cde-cd -[abhgefdc]ij hij y & hij -^(ab|cd)e abcde n x\1y xy -(abc|)ef abcdef y &-\1 ef- -(a|b)c*d abcd y &-\1 bcd-b -(ab|ab*)bc abc y &-\1 abc-a -a([bc]*)c* abc y &-\1 abc-bc -a([bc]*)(c*d) abcd y &-\1-\2 abcd-bc-d -a([bc]+)(c*d) abcd y &-\1-\2 abcd-bc-d -a([bc]*)(c+d) abcd y &-\1-\2 abcd-b-cd -a[bcd]*dcdcde adcdcde y & adcdcde -a[bcd]+dcdcde adcdcde n - - -(ab|a)b*c abc y &-\1 abc-ab -((a)(b)c)(d) abcd y \1-\2-\3-\4 abc-a-b-d -[ -~]* abc y & abc -[ -~ -~]* abc y & abc -[ -~ -~ -~]* abc y & abc -[ -~ -~ -~ -~]* abc y & abc -[ -~ -~ -~ -~ -~]* abc y & abc -[ -~ -~ -~ -~ -~ -~]* abc y & abc -[ -~ -~ -~ -~ -~ -~ -~]* abc y & abc -[a-zA-Z_][a-zA-Z0-9_]* alpha y & alpha -^a(bc+|b[eh])g|.h$ abh y &-\1 bh- -(bc+d$|ef*g.|h?i(j|k)) effgz y &-\1-\2 effgz-effgz- -(bc+d$|ef*g.|h?i(j|k)) ij y &-\1-\2 ij-ij-j -(bc+d$|ef*g.|h?i(j|k)) effg n - - -(bc+d$|ef*g.|h?i(j|k)) bcdd n - - -(bc+d$|ef*g.|h?i(j|k)) reffgz y &-\1-\2 effgz-effgz- -((((((((((a)))))))))) - c - - -(((((((((a))))))))) a y & a -multiple words of text uh-uh n - - -multiple words multiple words, yeah y & multiple words -(.*)c(.*) abcde y &-\1-\2 abcde-ab-de -\((.*), (.*)\) (a, b) y (\2, \1) (b, a) diff --git a/scsh/regexp/timer.c b/scsh/regexp/timer.c deleted file mode 100644 index c104a4f..0000000 --- a/scsh/regexp/timer.c +++ /dev/null @@ -1,164 +0,0 @@ -/* - * Simple timing program for regcomp(). - * Usage: timer ncomp nexec nsub - * or - * timer ncomp nexec nsub regexp string [ answer [ sub ] ] - * - * The second form is for timing repetitions of a single test case. - * The first form's test data is a compiled-in copy of the "tests" file. - * Ncomp, nexec, nsub are how many times to do each regcomp, regexec, - * and regsub. The way to time an operation individually is to do something - * like "timer 1 50 1". - */ -#include - -struct try { - char *re, *str, *ans, *src, *dst; -} tests[] = { -#include "timer.t.h" -{ NULL, NULL, NULL, NULL, NULL } -}; - -#include - -int errreport = 0; /* Report errors via errseen? */ -char *errseen = NULL; /* Error message. */ - -char *progname; - -/* ARGSUSED */ -main(argc, argv) -int argc; -char *argv[]; -{ - int ncomp, nexec, nsub; - struct try one; - char dummy[512]; - - if (argc < 4) { - ncomp = 1; - nexec = 1; - nsub = 1; - } else { - ncomp = atoi(argv[1]); - nexec = atoi(argv[2]); - nsub = atoi(argv[3]); - } - - progname = argv[0]; - if (argc > 5) { - one.re = argv[4]; - one.str = argv[5]; - if (argc > 6) - one.ans = argv[6]; - else - one.ans = "y"; - if (argc > 7) { - one.src = argv[7]; - one.dst = "xxx"; - } else { - one.src = "x"; - one.dst = "x"; - } - errreport = 1; - try(one, ncomp, nexec, nsub); - } else - multiple(ncomp, nexec, nsub); - exit(0); -} - -void -regerror(s) -char *s; -{ - if (errreport) - errseen = s; - else - error(s, ""); -} - -#ifndef ERRAVAIL -error(s1, s2) -char *s1; -char *s2; -{ - fprintf(stderr, "regexp: "); - fprintf(stderr, s1, s2); - fprintf(stderr, "\n"); - exit(1); -} -#endif - -int lineno = 0; - -multiple(ncomp, nexec, nsub) -int ncomp, nexec, nsub; -{ - register int i; - extern char *strchr(); - - errreport = 1; - for (i = 0; tests[i].re != NULL; i++) { - lineno++; - try(tests[i], ncomp, nexec, nsub); - } -} - -try(fields, ncomp, nexec, nsub) -struct try fields; -int ncomp, nexec, nsub; -{ - regexp *r; - char dbuf[BUFSIZ]; - register int i; - - errseen = NULL; - r = regcomp(fields.re); - if (r == NULL) { - if (*fields.ans != 'c') - complain("regcomp failure in `%s'", fields.re); - return; - } - if (*fields.ans == 'c') { - complain("unexpected regcomp success in `%s'", fields.re); - free((char *)r); - return; - } - for (i = ncomp-1; i > 0; i--) { - free((char *)r); - r = regcomp(fields.re); - } - if (!regexec(r, fields.str)) { - if (*fields.ans != 'n') - complain("regexec failure in `%s'", ""); - free((char *)r); - return; - } - if (*fields.ans == 'n') { - complain("unexpected regexec success", ""); - free((char *)r); - return; - } - for (i = nexec-1; i > 0; i--) - (void) regexec(r, fields.str); - errseen = NULL; - for (i = nsub; i > 0; i--) - regsub(r, fields.src, dbuf); - if (errseen != NULL) { - complain("regsub complaint", ""); - free((char *)r); - return; - } - if (strcmp(dbuf, fields.dst) != 0) - complain("regsub result `%s' wrong", dbuf); - free((char *)r); -} - -complain(s1, s2) -char *s1; -char *s2; -{ - fprintf(stderr, "try: %d: ", lineno); - fprintf(stderr, s1, s2); - fprintf(stderr, " (%s)\n", (errseen != NULL) ? errseen : ""); -} diff --git a/scsh/regexp/try.c b/scsh/regexp/try.c deleted file mode 100644 index 9b6424b..0000000 --- a/scsh/regexp/try.c +++ /dev/null @@ -1,220 +0,0 @@ -/* - * Simple test program for regexp(3) stuff. Knows about debugging hooks. - * Usage: try re [string [output [-]]] - * The re is compiled and dumped, regexeced against the string, the result - * is applied to output using regsub(). The - triggers a running narrative - * from regexec(). Dumping and narrative don't happen unless DEBUG. - * - * If there are no arguments, stdin is assumed to be a stream of lines with - * five fields: a r.e., a string to match it against, a result code, a - * source string for regsub, and the proper result. Result codes are 'c' - * for compile failure, 'y' for match success, 'n' for match failure. - * Field separator is tab. - */ -#include -#include - -#ifdef ERRAVAIL -char *progname; -extern char *mkprogname(); -#endif - -#ifdef DEBUG -extern int regnarrate; -#endif - -char buf[BUFSIZ]; - -int errreport = 0; /* Report errors via errseen? */ -char *errseen = NULL; /* Error message. */ -int status = 0; /* Exit status. */ - -/* ARGSUSED */ -main(argc, argv) -int argc; -char *argv[]; -{ - regexp *r; - int i; - -#ifdef ERRAVAIL - progname = mkprogname(argv[0]); -#endif - - if (argc == 1) { - multiple(); - exit(status); - } - - r = regcomp(argv[1]); - if (r == NULL) - error("regcomp failure", ""); -#ifdef DEBUG - regdump(r); - if (argc > 4) - regnarrate++; -#endif - if (argc > 2) { - i = regexec(r, argv[2]); - printf("%d", i); - for (i = 1; i < NSUBEXP; i++) - if (r->startp[i] != NULL && r->endp[i] != NULL) - printf(" \\%d", i); - printf("\n"); - } - if (argc > 3) { - regsub(r, argv[3], buf); - printf("%s\n", buf); - } - exit(status); -} - -void -regerror(s) -char *s; -{ - if (errreport) - errseen = s; - else - error(s, ""); -} - -#ifndef ERRAVAIL -error(s1, s2) -char *s1; -char *s2; -{ - fprintf(stderr, "regexp: "); - fprintf(stderr, s1, s2); - fprintf(stderr, "\n"); - exit(1); -} -#endif - -int lineno; - -regexp badregexp; /* Implicit init to 0. */ - -multiple() -{ - char rbuf[BUFSIZ]; - char *field[5]; - char *scan; - int i; - regexp *r; - extern char *strchr(); - - errreport = 1; - lineno = 0; - while (fgets(rbuf, sizeof(rbuf), stdin) != NULL) { - rbuf[strlen(rbuf)-1] = '\0'; /* Dispense with \n. */ - lineno++; - scan = rbuf; - for (i = 0; i < 5; i++) { - field[i] = scan; - if (field[i] == NULL) { - complain("bad testfile format", ""); - exit(1); - } - scan = strchr(scan, '\t'); - if (scan != NULL) - *scan++ = '\0'; - } - try(field); - } - - /* And finish up with some internal testing... */ - lineno = 9990; - errseen = NULL; - if (regcomp((char *)NULL) != NULL || errseen == NULL) - complain("regcomp(NULL) doesn't complain", ""); - lineno = 9991; - errseen = NULL; - if (regexec((regexp *)NULL, "foo") || errseen == NULL) - complain("regexec(NULL, ...) doesn't complain", ""); - lineno = 9992; - r = regcomp("foo"); - if (r == NULL) { - complain("regcomp(\"foo\") fails", ""); - return; - } - lineno = 9993; - errseen = NULL; - if (regexec(r, (char *)NULL) || errseen == NULL) - complain("regexec(..., NULL) doesn't complain", ""); - lineno = 9994; - errseen = NULL; - regsub((regexp *)NULL, "foo", rbuf); - if (errseen == NULL) - complain("regsub(NULL, ..., ...) doesn't complain", ""); - lineno = 9995; - errseen = NULL; - regsub(r, (char *)NULL, rbuf); - if (errseen == NULL) - complain("regsub(..., NULL, ...) doesn't complain", ""); - lineno = 9996; - errseen = NULL; - regsub(r, "foo", (char *)NULL); - if (errseen == NULL) - complain("regsub(..., ..., NULL) doesn't complain", ""); - lineno = 9997; - errseen = NULL; - if (regexec(&badregexp, "foo") || errseen == NULL) - complain("regexec(nonsense, ...) doesn't complain", ""); - lineno = 9998; - errseen = NULL; - regsub(&badregexp, "foo", rbuf); - if (errseen == NULL) - complain("regsub(nonsense, ..., ...) doesn't complain", ""); -} - -try(fields) -char **fields; -{ - regexp *r; - char dbuf[BUFSIZ]; - - errseen = NULL; - r = regcomp(fields[0]); - if (r == NULL) { - if (*fields[2] != 'c') - complain("regcomp failure in `%s'", fields[0]); - return; - } - if (*fields[2] == 'c') { - complain("unexpected regcomp success in `%s'", fields[0]); - free((char *)r); - return; - } - if (!regexec(r, fields[1])) { - if (*fields[2] != 'n') - complain("regexec failure in `%s'", fields[0]); - free((char *)r); - return; - } - if (*fields[2] == 'n') { - complain("unexpected regexec success", ""); - free((char *)r); - return; - } - errseen = NULL; - regsub(r, fields[3], dbuf); - if (errseen != NULL) { - complain("regsub complaint", ""); - free((char *)r); - return; - } - if (strcmp(dbuf, fields[4]) != 0) - complain("regsub result `%s' wrong", dbuf); - free((char *)r); -} - -complain(s1, s2) -char *s1; -char *s2; -{ - fprintf(stderr, "try: %d: ", lineno); - fprintf(stderr, s1, s2); - fprintf(stderr, " (%s)\n", (errseen != NULL) ? errseen : ""); - status = 1; -} diff --git a/scsh/rw.scm b/scsh/rw.scm deleted file mode 100644 index d030280..0000000 --- a/scsh/rw.scm +++ /dev/null @@ -1,202 +0,0 @@ -;;; Basic read and write -;;; Copyright (c) 1993 by Olin Shivers. - -;;; Note: read ops should check to see if their string args are mutable. - -(define (bogus-substring-spec? s start end) - (or (< start 0) - (< (string-length s) end) - (< end start))) - - -;;; Best-effort/forward-progress reading -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (generic-read-string!/partial s start end reader source) - (if (bogus-substring-spec? s start end) - (error "Bad substring indices" reader source s start end)) - - (if (= start end) 0 ; Vacuous request. - (let loop () - (receive (err nread) (reader s start end source) - (cond ((not err) (and (not (zero? nread)) nread)) - ((= err errno/intr) (loop)) - ((or (= err errno/wouldblock) ; No forward-progess here. - (= err errno/again)) - 0) - (else (errno-error err reader s start start end source))))))) - -(define (read-string!/partial s . args) - (let-optionals args ((fd/port (current-input-port)) - (start 0) - (end (string-length s))) - (cond ((integer? fd/port) - (generic-read-string!/partial s start end - read-fdes-substring!/errno fd/port)) - ((fdport? fd/port) - (generic-read-string!/partial s start end - read-fdport*-substring!/errno - (extensible-port-local-data fd/port))) - - (else ; Hack it for base S48 ports - ;; This case is a little gross in order to get - ;; the forward-progress guarantee and handle non-blocking i/o. - ;; Unix sux. So do low-level Scheme looping constructs. - (if (>= start end) 0 - (let lp ((i start)) - (let ((c (with-errno-handler - ((err data) ((errno/wouldblock errno/again) #f)) - (read-char fd/port)))) - (cond ((not c) (- i start)) ; non-blocking i/o bailout - ((eof-object? c) - (let ((nread (- i start))) - (and (not (zero? nread)) nread))) - (else - (string-set! s i c) - (let ((i (+ i 1))) - (if (or (= i end) (not (char-ready? fd/port))) - (- i start) - (lp i)))))))))))) - -(define (read-string/partial len . maybe-fd/port) - (let* ((s (make-string len)) - (fd/port (:optional maybe-fd/port (current-input-port))) - (nread (read-string!/partial s fd/port 0 len))) - (cond ((not nread) #f) ; EOF - ((= nread len) s) - (else (substring s 0 nread))))) - - -;;; Persistent reading -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (generic-read-string! s start end reader source) - (if (bogus-substring-spec? s start end) - (error "Bad substring indices" reader source s start end)) - - (let loop ((i start)) - (if (>= i end) (- i start) - (receive (err nread) (reader s i end source) - (cond (err (if (= err errno/intr) (loop i) - ;; Give info on partially-read data in error packet. - (errno-error err reader - s start i end source))) - - ((zero? nread) ; EOF - (let ((result (- i start))) - (and (not (zero? result)) result))) - - (else (loop (+ i nread)))))))) - -(define (read-string! s . args) - (let-optionals args ((fd/port (current-input-port)) - (start 0) - (end (string-length s))) - (cond ((integer? fd/port) - (generic-read-string! s start end - read-fdes-substring!/errno fd/port)) - - ((fdport? fd/port) - (generic-read-string! s start end - read-fdport*-substring!/errno - (extensible-port-local-data fd/port))) - - ;; Hack it - (else (let lp ((i start)) - (if (= i end) (- end start) - (let ((c (read-char fd/port))) - (if (eof-object? c) - (let ((nread (- i start))) - (and (not (zero? nread)) nread)) - (begin (string-set! s i c) - (lp (+ i 1))))))))))) - -(define (read-string len . maybe-fd/port) - (let* ((s (make-string len)) - (fd/port (:optional maybe-fd/port (current-input-port))) - (nread (read-string! s fd/port 0 len))) - (cond ((not nread) #f) ; EOF - ((= nread len) s) - (else (substring s 0 nread))))) - - -;;; Best-effort/forward-progress writing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Non-blocking output to a buffered port is not defined. - -(define (generic-write-string/partial s start end writer target) - (if (bogus-substring-spec? s start end) - (error "Bad substring indices" writer s start end target)) - - (if (= start end) 0 ; Vacuous request. - (let loop () - (receive (err nwritten) (writer s start end target) - (cond ((not err) nwritten) - ((= err errno/intr) (loop)) - ((or (= err errno/again) (= err errno/wouldblock)) 0) - (else (errno-error err writer - s start start end target))))))) - -(define (write-string/partial s . args) - (let-optionals args ((fd/port (current-output-port)) - (start 0) - (end (string-length s))) - (cond ((integer? fd/port) - (generic-write-string/partial s start end - write-fdes-substring/errno fd/port)) - ((fdport? fd/port) - (generic-write-string/partial s start end - write-fdport*-substring/errno - (extensible-port-local-data fd/port))) - (else (display (substring s start end) fd/port))))) ; hack - - -;;; Persistent writing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (generic-write-string s start end writer target) - (if (bogus-substring-spec? s start end) - (error "Bad substring indices" writer s start end target)) - - (let loop ((i start)) - (if (< i end) - (receive (err nwritten) (writer s i end target) - (cond ((not err) (loop (+ i nwritten))) - ((= err errno/intr) (loop i)) - (else (errno-error err writer - s start i end target))))))) - -(define (write-string s . args) - (let-optionals args ((fd/port (current-output-port)) - (start 0) - (end (string-length s))) - (cond ((integer? fd/port) - (generic-write-string s start end - write-fdes-substring/errno fd/port)) - ((fdport? fd/port) - (generic-write-string s start end - write-fdport*-substring/errno - (extensible-port-local-data fd/port))) - - (else (display (substring s start end) fd/port))))) ; hack - -(define (y-or-n? question . maybe-eof-value) - (let loop ((count *y-or-n-eof-count*)) - (display question) - (display " (y/n)? ") - (let ((line (read-line))) - (cond ((eof-object? line) - (newline) - (if (= count 0) - (:optional maybe-eof-value (error "EOF in y-or-n?")) - (begin (display "I'll only ask another ") - (write count) - (display " times.") - (newline) - (loop (- count 1))))) - ((< (string-length line) 1) (loop count)) - ((char=? (string-ref line 0) #\y) #t) - ((char=? (string-ref line 0) #\n) #f) - (else (loop count)))))) - -(define *y-or-n-eof-count* 100) diff --git a/scsh/scsh-condition.scm b/scsh/scsh-condition.scm deleted file mode 100644 index b86e6cf..0000000 --- a/scsh/scsh-condition.scm +++ /dev/null @@ -1,90 +0,0 @@ -;;; Copyright (c) 1994 by Olin Shivers -;;; Add scsh conditions to s48. - -;;; A syscall-error condition-type: - -(define-condition-type 'syscall-error '(error)) - -(define syscall-error? (condition-predicate 'syscall-error)) - -(define (errno-error errno syscall . stuff) - (let ((msg (errno-msg errno))) - (apply signal 'syscall-error errno msg syscall stuff))) - - -(define (with-errno-handler* handler thunk) - (with-handler - (lambda (condition more) - (if (syscall-error? condition) - (let ((stuff (condition-stuff condition))) - (handler (car stuff) ; errno - (cdr stuff)))) ; (msg syscall . packet) - (more)) - thunk)) - -;;; (with-errno-handler -;;; ((errno data) ; These are vars bound in this scope. -;;; ((errno/exist) . body1) -;;; ((errno/wouldblock errno/again) . body2) -;;; (else . body3)) -;;; -;;; . body) - -(define-syntax with-errno-handler - (lambda (exp rename compare) - (let* ((%lambda (rename 'lambda)) - (%cond (rename 'cond)) - (%else (rename 'else)) - (%weh (rename 'with-errno-handler*)) - (%= (rename '=)) - (%begin (rename `begin)) - (%or (rename `or)) - (%call/cc (rename 'call-with-current-continuation)) - (%cwv (rename 'call-with-values)) - - (%ret (rename 'ret)) ; I think this is the way to gensym. - - (err-var (caaadr exp)) - (data-var (car (cdaadr exp))) - (clauses (cdadr exp)) - (body (cddr exp)) - - (arms (map (lambda (clause) - (let ((test (if (compare (car clause) %else) - %else - (let ((errs (car clause))) - `(,%or . ,(map (lambda (err) - `(,%= ,err ,err-var)) - errs)))))) - `(,test - (,%cwv (,%lambda () . ,(cdr clause)) ,%ret)))) - clauses))) - - `(,%call/cc (,%lambda (,%ret) - (,%weh - (,%lambda (,err-var ,data-var) - (,%cond . ,arms)) - (,%lambda () . ,body))))))) - -;;;; S48 already has this machinery, i.e., (SET-INTERACTIVE?! flag) -;;;; Interactive => breakpoint on errors. -;;;; Noninteractive => exit on errors. -; -;(define $interactive-errors? (make-fluid #f)) -; -;(define (with-interactive-errors val thunk) -; (let-fluid $interactive-errors? val thunk)) -; -;(define (set-interactive-errors! val) -; (set-fluid! $interactive-errors? val)) -; -;;;; Just quit if non-interactive. Otherwise, punt to next handler. -;;;; A hack, because we use the default handler for the interactive -;;;; case. -; -;(define (scsh-error-handler condition more) -; (if (and (error? condition) -; (not (fluid $interactive-errors?))) -; (begin (display condition (error-output-port)) -; (exit -1)) -; (more))) diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm deleted file mode 100644 index 025bc6c..0000000 --- a/scsh/scsh-interfaces.scm +++ /dev/null @@ -1,995 +0,0 @@ -;;; The module interfaces for scsh. -;;; Copyright (c) 1994 by Olin Shivers and David Albertz. -;;; Copyright (c) 1994 by Brian D. Carlstrom - -(define-interface posix-fdflags-interface - (export open/read - open/write - open/read+write - open/nonblocking - open/append - open/no-control-tty - open/create - open/truncate - open/exclusive - open/access-mask - - fcntl/dup-fdes - fcntl/get-fdes-flags - fcntl/set-fdes-flags - fcntl/get-status-flags - fcntl/set-status-flags - fcntl/get-record-lock - fcntl/set-record-lock - fcntl/set-record-lock-noblock - - fdflags/close-on-exec - - lock/read - lock/write - lock/release)) - -(define-interface posix-errno-interface - (export errno/2big - errno/acces - errno/again - errno/badf - errno/busy - errno/child - errno/deadlk - errno/dom - errno/exist - errno/fault - errno/fbig - errno/intr - errno/inval - errno/io - errno/isdir - errno/mfile - errno/mlink - errno/nametoolong - errno/nfile - errno/nodev - errno/noent - errno/noexec - errno/nolck - errno/nomem - errno/nospc - errno/nosys - errno/notdir - errno/notempty - errno/notty - errno/nxio - errno/perm - errno/pipe - errno/range - errno/rofs - errno/spipe - errno/srch - errno/xdev)) - - -(define-interface posix-signals-interface - (export signal/abrt - signal/alrm - signal/chld - signal/cont - signal/fpe - signal/hup - signal/ill - signal/int - signal/kill - signal/pipe - signal/quit - signal/segv - signal/stop - signal/term - signal/tstp - signal/ttin - signal/ttou - signal/usr1 - signal/usr2)) - -(define-interface signals-internals-interface - (export signals-ignored-by-default)) - -(define-interface scsh-errors-interface - (export errno-error - error - with-errno-handler* - (with-errno-handler :syntax))) - - - -(define buffered-io-flags-interface - (export bufpol/block - bufpol/line - bufpol/none)) - -(define-interface scsh-io-interface - (compound-interface buffered-io-flags-interface - (export close - close-after - error-output-port - dup - dup->inport - dup->outport - dup->fdes - open-file - - fdes-flags - set-fdes-flags - fdes-status - set-fdes-status - - force-output - set-port-buffering - bufpol/block - bufpol/line - bufpol/none - - seek - tell - seek/set - seek/delta - seek/end - - select - select! - - flush-all-ports - y-or-n? - *y-or-n-eof-count* - ;; R4RS I/O procedures that scsh provides. - write - char-ready? - read-char - write-char - display - newline - input-port? - output-port? - call-with-input-file - call-with-output-file - with-input-from-file - with-output-to-file - open-input-file - open-output-file - format - - lock-region? - lock-region:exclusive? - lock-region:whence - lock-region:start - lock-region:len - lock-region:pid - make-lock-region - - lock-region - lock-region/no-block - get-lock-region - unlock-region - with-region-lock* - (with-region-lock :syntax) - - fork-pty-session - open-pty - pty-name->tty-name - tty-name->pty-name - make-pty-generator - - with-current-input-port* - (with-current-input-port :syntax) - with-current-output-port* - (with-current-output-port :syntax) - with-error-output-port* - (with-error-output-port :syntax) - set-current-input-port! - set-current-output-port! - set-error-output-port! - - stdports->stdio - stdio->stdports - with-stdio-ports* - (with-stdio-ports :syntax) - - call/fdes - release-port-handle - port-revealed - fdes->inport - fdes->outport - move->fdes - open-fdes - pipe - port->string - port->sexp-list - port->string-list - port->list - reduce-port - port->fdes - read-string - read-string! - read-string/partial - read-string!/partial - write-string - write-string/partial))) - - -(define-interface scsh-file-interface - (export create-directory - create-fifo - create-hard-link - create-symlink - - delete-directory - delete-file - delete-filesys-object - rename-file - set-file-mode - set-file-owner - set-file-group - set-file-times - truncate-file - - read-symlink ; Not POSIX. - - file-attributes ; Deprecated; - file-info ; preferred. - - file-info:type - file-info:device - file-info:inode - file-info:mode - file-info:nlinks - file-info:uid - file-info:gid - file-info:size - file-info:atime - file-info:mtime - file-info:ctime - file-type - file-group - file-inode - file-last-access - file-last-mod - file-last-status-change - file-mode - file-nlinks - file-owner - file-size - file-symlink? - file-directory? - file-fifo? - file-regular? - file-socket? - file-special? - file-not-readable? - file-not-writable? - file-not-writeable? ; Deprecated - file-not-executable? - file-readable? - file-writeable? - file-writable? ; Deprecated - file-executable? - file-not-exists? - file-exists? - - sync-file - sync-file-system - - directory-files - glob - glob-quote - file-match - - create-temp-file - temp-file-iterate - temp-file-channel - *temp-file-template*)) - - -(define-interface scsh-process-interface - (export exec - exec-path - exec/env - exec-path/env - %exec - exec-path-search - - exit - %exit - - suspend - - fork - %fork - - proc? - proc:pid - pid->proc - - autoreap-policy - reap-zombies - - wait - wait-any - wait-process-group - - status:exit-val - status:stop-sig - status:term-sig - wait/poll - wait/stopped-children - - call-terminally - halts?)) - - -(define-interface scsh-process-state-interface - (export umask - set-umask - with-umask* - (with-umask :syntax) - - chdir - cwd - with-cwd* - (with-cwd :syntax) - - pid - parent-pid - process-group - set-process-group - become-session-leader - - user-login-name - user-uid - user-effective-uid - user-gid - user-effective-gid - user-supplementary-gids - set-uid - set-gid - - system-name - process-times - cpu-ticks/sec)) - - -(define-interface scsh-user/group-db-interface - (export user-info - user-info:name - user-info:uid - user-info:gid - user-info:home-dir - user-info:shell - - ->uid - ->username - - group-info - group-info:name - group-info:gid - group-info:members - - ->gid - ->groupname)) - - -(define-interface scsh-command-line-interface - (export command-line-arguments - command-line - arg - arg* - argv)) - - -(define-interface scsh-signals-interface - (export signal-process - signal-process-group - pause-until-interrupt - sleep - itimer)) - - -(define-interface scsh-environment-interface - (export setenv - getenv - env->alist - alist->env - alist-delete - alist-update - alist-compress - with-env* - with-total-env* - (with-env :syntax) - (with-total-env :syntax) - add-before - add-after)) - - -(define-interface scsh-home-interface - (export home-directory - exec-path-list)) - - -(define-interface scsh-regexp-interface - (export string-match - regexp-match? - match:start - match:end - match:substring - make-regexp - regexp? - regexp-exec - regexp-subst - regexp-quote)) - - -(define-interface scsh-string-interface - (compound-interface (export substitute-env-vars - index - rindex) - scsh-regexp-interface)) - - -(define-interface scsh-file-names-interface - (export file-name-as-directory - file-name-directory? - file-name-non-directory? - directory-as-file-name - file-name-absolute? - file-name-directory - file-name-nondirectory - split-file-name - path-list->file-name - file-name-extension - file-name-sans-extension - replace-extension - parse-file-name - expand-file-name - simplify-file-name - resolve-tilde-file-name - resolve-file-name - home-dir - home-file)) - - -(define-interface scsh-time-interface - (export make-date - date? - - date:seconds - date:minute - date:hour - date:month-day - date:month - date:year - date:tz-name - date:tz-secs - date:summer? - date:week-day - date:year-day - - set-date:seconds - set-date:minute - set-date:hour - set-date:month-day - set-date:month - set-date:year - set-date:tz-name - set-date:tz-secs - set-date:summer? - set-date:week-day - set-date:year-day - - time+ticks - ticks/sec - time - date - date->string - format-date)) - - -(define-interface scsh-misc-interface - (export (receive :syntax) - - arithmetic-shift - bitwise-and - bitwise-ior - bitwise-not - bitwise-xor)) - - -(define-interface scsh-high-level-process-interface - (export (run :syntax) - (exec-epf :syntax) - (& :syntax) - (|| :syntax) -; (:or: :syntax) ; Alternate R4RS syntax for ||. - (&& :syntax) - (run/collecting :syntax) - (run/port+proc :syntax) - (run/port :syntax) - (run/strings :syntax) - (run/file :syntax) - (run/string :syntax) - (run/sexp :syntax) - (run/sexps :syntax) - - fork/pipe - %fork/pipe - fork/pipe+ - %fork/pipe+ - tail-pipe - tail-pipe+ - run/collecting* - run/port+proc* - run/port* - run/file* - run/string* - run/sexp* - run/sexps* - run/strings* - - char-filter - string-filter)) - - -(define-interface scsh-version-interface - (export scsh-major-version - scsh-minor-version - scsh-version-string)) - - -;;; This is probably bogus. -(define-interface string-ports-interface - (export make-string-input-port - call-with-string-output-port - make-string-output-port - string-output-port-output)) - - -(define-interface scsh-utilities-interface - (export del delete index rindex reduce filter first any first? nth - any? every? mapv mapv! vector-every? copy-vector initialize-vector - check-arg conjoin disjoin negate compose reverse! call/cc - deprecated-proc - deposit-bit-field - real->exact-integer)) - -;;; semi-standard network magic numbers -;;; should be available on all platforms -;;; if not, tell us, and we'll move it -;;; to the os-dependent directory - -;;; for now, all socket option magic numbers -;;; are considered machine dependent until -;;; there is a standard or a clear portable subset - -(define-interface sockets-network-interface - (export shutdown/receives - shutdown/sends - shutdown/sends+receives - herror/host-not-found - herror/try-again - herror/no-recovery - herror/no-data - herror/no-address - address-family/unspecified - address-family/unix - address-family/internet - socket-type/stream - socket-type/datagram - socket-type/raw - ;;socket-type/rdm - ;;socket-type/seqpacket - protocol-family/unspecified - protocol-family/unix - protocol-family/internet - internet-address/any - internet-address/loopback - internet-address/broadcast - message/out-of-band - message/peek - message/dont-route - level/socket - options/boolean - options/value - options/linger - options/timeout)) - -;;; actual functions interface -(define-interface scsh-sockets-interface - (export socket-connect - bind-listen-accept-loop - socket? - socket:family - socket:inport - socket:outport - socket-address? - socket-address:family - internet-address->socket-address - socket-address->internet-address - unix-address->socket-address - socket-address->unix-address - create-socket - close-socket - bind-socket - connect-socket - listen-socket - accept-connection - socket-remote-address - socket-local-address - shutdown-socket - create-socket-pair - receive-message - receive-message! - receive-message/partial - receive-message!/partial - send-message - send-message/partial - socket-option - set-socket-option - - host-info - host-info? - host-info:name - host-info:aliases - host-info:addresses - network-info - network-info? - network-info:name - network-info:aliases - network-info:net - service-info - service-info? - service-info:name - service-info:aliases - service-info:port - service-info:protocol - protocol-info - protocol-info? - protocol-info:name - protocol-info:aliases - protocol-info:number - - net-to-host-32 - net-to-host-16 - host-to-net-32 - host-to-net-16 - )) - - -(define-interface char-set-interface - (export char:newline char:tab char:linefeed char:page char:return char:space - char-ascii? - char-set? - - char-set - chars->char-set - string->char-set - ascii-range->char-set - predicate->char-set - ->char-set - - char-set-members - char-set-contains? - - char-set-invert - char-set-union - char-set-intersection - char-set-difference - - char-set:upper-case - char-set:lower-case - char-set:numeric - char-set:whitespace - char-set:not-whitespace - char-set:alphabetic - char-set:alphanumeric - char-set:graphic - - char-upper-case? - char-lower-case? - char-numeric? - char-whitespace? - char-alphabetic? - char-alphanumeric? - char-graphic?)) - - -(define-interface scsh-field-reader-interface - (export join-strings - field-splitter infix-splitter suffix-splitter sloppy-suffix-splitter - record-reader - field-reader - nth)) ; Kinda handy. - -(define-interface scsh-delimited-readers-interface - (export read-line - read-paragraph - read-delimited read-delimited! - %read-delimited! - skip-char-set)) - -(define-interface awk-interface - (export (awk :syntax))) - -(define-interface scsh-dbm-interface - (export dbm-open - dbm-close - dbm-delete - dbm-fetch - dbm-insert - dbm-replace - dbm-firstkey - dbm-nextkey - dbm-record? - dbm-record:open? - btree/method - btree-info:flags - btree-info:cachesize - btree-info:maxkeypage - btree-info:minkeypage - btree-info:psize - btree-info:lorder - btree-info? - make-btree-info - hash/method - hash-info:bsize - hash-info:ffactor - hash-info:nelem - hash-info:cachesize - hash-info:lorder - hash-info? - make-hash-info - recno/method - recno-info:flags - recno-info:cachesize - recno-info:psize - recno-info:lorder - recno-info:reclen - recno-info:bval - recno-info:bfname - recno-info? - make-recno-info)) - -;;; Magic flags for SCSH-TTY-INTERFACE. -(define-interface tty-flags-interface - (export - ;; Indices into the control char string - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Posix - ttychar/eof - ttychar/eol - ttychar/delete-char - ttychar/delete-line - ttychar/interrupt - ttychar/quit - ttychar/suspend - ttychar/start - ttychar/stop - ttychar/min - ttychar/time - - ;; SVR4 & 4.3+BSD - ttychar/delete-word - ttychar/reprint - ttychar/literal-next - ttychar/discard - ttychar/delayed-suspend - ttychar/eol2 - - ;; 4.3+BSD - ttychar/status - - disable-tty-char - - ;; Input flag bits - ;;;;;;;;;;;;;;;;;; - ;; Posix - ttyin/ignore-break - ttyin/interrupt-on-break - ttyin/ignore-bad-parity-chars - ttyin/mark-parity-errors - ttyin/check-parity - ttyin/7bits - ttyin/nl->cr - ttyin/ignore-cr - ttyin/cr->nl - ttyin/output-flow-ctl - ttyin/input-flow-ctl - - ;; SVR4 & 4.3+BSD - ttyin/xon-any - ttyin/beep-on-overflow - - ;; SVR4 - ttyin/lowercase - - ;; Output flag bits - ;;;;;;;;;;;;;;;;;;; - ttyout/enable ; opost: enable output processing - - ;; SVR4 & 4.3+BSD - ttyout/nl->crnl ; onlcr: map nl to cr-nl - - ;; 4.3+BSD - ttyout/discard-eot ; onoeot - ttyout/expand-tabs ; oxtabs (NOT xtabs) - - ;; SVR4 - ttyout/cr->nl ; ocrnl - ttyout/fill-w/del ; ofdel - ttyout/delay-w/fill-char ; ofill - ttyout/uppercase ; olcuc - ttyout/nl-does-cr ; onlret - ttyout/no-col0-cr ; onocr - - ;; Newline delay - ttyout/nl-delay ; mask (nldly) - ttyout/nl-delay0 - ttyout/nl-delay1 ; tty 37 - - ;; Horizontal-tab delay - ttyout/tab-delay ; mask (tabdly) - ttyout/tab-delay0 - ttyout/tab-delay1 ; tty 37 - ttyout/tab-delay2 - ttyout/tab-delayx ; Expand tabs (xtabs, tab3) - - ;; Carriage-return delay - ttyout/cr-delay ; mask (crdly) - ttyout/cr-delay0 - ttyout/cr-delay1 ; tn 300 - ttyout/cr-delay2 ; tty 37 - ttyout/cr-delay3 ; concept 100 - - ;; Vertical tab delay - ttyout/vtab-delay ; mask (vtdly) - ttyout/vtab-delay0 - ttyout/vtab-delay1 ; tty 37 - - ;; Backspace delay - ttyout/bs-delay ; mask (bsdly) - ttyout/bs-delay0 - ttyout/bs-delay1 - - ;; Form-feed delay - ttyout/ff-delay ; mask (ffdly) - ttyout/ff-delay0 - ttyout/ff-delay1 - - ttyout/all-delay - - - ;; Control flag bits - ;;;;;;;;;;;;;;;;;;;; - ;; Posix - ttyc/char-size ; csize: character size mask - ttyc/char-size5 ; 5 bits (cs5) - ttyc/char-size6 ; 6 bits (cs6) - ttyc/char-size7 ; 7 bits (cs7) - ttyc/char-size8 ; 8 bits (cs8) - ttyc/2-stop-bits ; cstopb: Send 2 stop bits. - ttyc/enable-read ; cread: Enable receiver. - ttyc/enable-parity ; parenb - ttyc/odd-parity ; parodd - ttyc/hup-on-close ; hupcl: Hang up on last close. - ttyc/no-modem-sync ; clocal: Ignore modem lines. - - ;; 4.3+BSD - ttyc/ignore-flags ; cignore: ignore control flags - ttyc/CTS-output-flow-ctl ; ccts_oflow: CTS flow control of output - ttyc/RTS-input-flow-ctl ; crts_iflow: RTS flow control of input - ttyc/carrier-flow-ctl ; mdmbuf - - ;; Local flag bits - ;;;;;;;;;;;;;;;;;; - ;; POSIX - ttyl/visual-delete ; echoe: Visually erase chars - ttyl/echo-delete-line ; echok: Echo nl after line kill - ttyl/echo ; echo: Enable echoing - ttyl/echo-nl ; echonl: Echo nl even if echo is off - ttyl/canonical ; icanon: Canonicalize input - ttyl/enable-signals ; isig: Enable ^c, ^z signalling - ttyl/extended ; iexten: Enable extensions - ttyl/ttou-signal ; tostop: SIGTTOU on background output - ttyl/no-flush-on-interrupt ; noflsh - - ;; SVR4 & 4.3+BSD - ttyl/visual-delete-line ; echoke: visually erase a line-kill - ttyl/hardcopy-delete ; echoprt: visual erase for hardcopy - ttyl/echo-ctl ; echoctl: echo control chars as "^X" - ttyl/flush-output ; flusho: output is being flushed - ttyl/reprint-unread-chars ; pendin: retype pending input - - ;; 4.3+BSD - ttyl/alt-delete-word ; altwerase - ttyl/no-kernel-status ; nokerninfo: no kernel status on ^T - - ;; SVR4 - ttyl/case-map ; xcase: canonical upper/lower presentation - )) - -;;; Non-exported values required by the tty code. -(define-interface scsh-internal-tty-flags-interface - (export baud-rates - num-ttychars - - ;; tcflush() constants - %flush-tty/input ; TCIFLUSH - %flush-tty/output ; TCOFLUSH - %flush-tty/both ; TCIOFLUSH - - ;; tcflow() constants - %tcflow/start-out ; TCOON - %tcflow/stop-out ; TCOOFF - %tcflow/start-in ; TCION - %tcflow/stop-in ; TCIOFF - - ;; tcsetattr() constants - %set-tty-info/now ; TCSANOW Make change immediately. - %set-tty-info/drain ; TCSADRAIN Drain output, then change. - %set-tty-info/flush ; TCSAFLUSH Drain output, flush input. - )) - - -;;; POSIX termios tty control. -(define-interface tty-interface - (compound-interface - tty-flags-interface - (export - ;; The tty-info record - tty-info? type/tty-info - tty-info:control-chars set-tty-info:control-chars - tty-info:input-flags set-tty-info:input-flags - tty-info:output-flags set-tty-info:output-flags - tty-info:control-flags set-tty-info:control-flags - tty-info:local-flags set-tty-info:local-flags - tty-info:input-speed set-tty-info:input-speed - tty-info:output-speed set-tty-info:output-speed - tty-info:min set-tty-info:min - tty-info:time set-tty-info:time - - make-tty-info copy-tty-info - - tty-info - set-tty-info/now - set-tty-info/drain - set-tty-info/flush - - send-tty-break - drain-tty - flush-tty/input - flush-tty/output - flush-tty/both - - start-tty-output - stop-tty-output - start-tty-input - stop-tty-input - - encode-baud-rate - decode-baud-rate - - open-control-tty - set-tty-process-group - tty-process-group - - tty? - tty-file-name - control-tty-file-name - ))) - -(define-interface signal-handler-interface - (export signal->interrupt - interrupt-set - (with-enabled-interrupts :syntax) - with-enabled-interrupts* - set-signal-handler! - signal-handler - %set-unix-signal-handler! - %unix-signal-handler - )) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm deleted file mode 100644 index 53b0f3f..0000000 --- a/scsh/scsh-package.scm +++ /dev/null @@ -1,307 +0,0 @@ -;;; The packages that scsh uses/defines. -;;; Copyright (c) 1994 by Olin Shivers. - -;;; Note: field-reader package (fr.scm) and here docs use READ-LINE. -;;; It is defined in rdelim.scm. - -;;; You link up a scsh package by defining a package named OS-DEPENDENT -;;; that satisfies the interfaces for packages -;;; buffered-io-flags -;;; posix-fdflags -;;; posix-errno -;;; posix-signals -;;; Anything else it provides should be specified in an interface called -;;; os-extras-interface. See the scsh structure below. -;;; Then the scsh structure can be instantiated. -;;; -;;; The architecture directories, like next/ and irix/ and so forth, -;;; provide packages that can serve as the os-dependent package. E.g., -;;; the next-defs package, defined in next/packages. -;;; -;;; This whole mechanism would be better solved with a functor. -;;; -Olin - - -;;; The LET-OPT package for optional argument parsing & defaulting -;;; is found in the let-opt.scm file. - - -(define-structure error-package (export error warn) - (open signals)) - - -(define-structure scsh-utilities scsh-utilities-interface - (open bitwise error-package let-opt scheme) - (files utilities)) - - -;;; This guy goes into the FOR-SYNTAX part of scsh's syntax exports. -(define-structure scsh-syntax-helpers - (export transcribe-extended-process-form) - (open receiving ; receive - error-package - syntactic ; generated? - scsh-utilities ; check-arg - scheme - ) - (files syntax-helpers)) - - -;;; The bufpol/{block, line, none} values -(define-structure buffered-io-flags buffered-io-flags-interface - (open defenum-package scheme) - (files (machine bufpol))) - -(define-structures ((scsh-regexp-package scsh-regexp-interface) - (scsh-regexp-internals (export %filter-C-strings!))) - (open defrec-package - scsh-utilities - define-foreign-syntax - receiving - error-package - let-opt ; optional-arg parsing & defaulting - scheme) - (files re)) - - -(define-structure char-set-package char-set-interface - (open error-package ascii scheme) - (files char-set)) - - -(define-structure field-reader-package scsh-field-reader-interface - (open receiving ; receive - char-set-package - scsh-utilities - error-package ; error - scsh-level-0 ; regexes and delimited readers - let-opt ; optional-arg parsing & defaulting - scheme - ) - (files fr)) - - -(define-structures - ((awk-expander-package (export expand-awk)) - (awk-support-package (export next-range next-:range - next-range: next-:range:))) - (open receiving ; receive - scsh-utilities - error-package ; error - char-set-package - scheme - ) - (files awk)) - - -(define-structure awk-package awk-interface - (open awk-support-package scsh-regexp-package receiving scheme) - (for-syntax (open awk-expander-package scheme)) - (begin (define-syntax awk expand-awk))) - - -(define-structures ((tty-flags tty-flags-interface) - (scsh-internal-tty-flags scsh-internal-tty-flags-interface)) - (open scheme ascii bitwise) - (files (machine tty-consts))) - - -(define-structure scsh-version scsh-version-interface - (open scheme) - (files scsh-version)) - -;;; The scsh-level-0 package is for implementation convenience. -;;; The scsh startup and top-level modules need access to scsh -;;; procedures, but they export procedures that are themselves -;;; part of scsh. So scsh-level-0 is the core scsh stuff, which is -;;; imported by these two modules. These modules all collectively -;;; export the whole scsh enchilada. - -(define-structures - ((scsh-level-0-internals (export set-command-line-args! - init-scsh-hindbrain - init-scsh-vars)) - (scsh-level-0 - (compound-interface posix-fdflags-interface - posix-errno-interface - posix-signals-interface - sockets-network-interface ; Standard Network Interface - os-extras-interface ; Extra stuff from OS. - scsh-delimited-readers-interface - scsh-errors-interface - scsh-io-interface - scsh-file-interface - scsh-process-interface - scsh-process-state-interface - scsh-user/group-db-interface - scsh-command-line-interface - scsh-signals-interface - scsh-environment-interface - scsh-home-interface - scsh-string-interface - scsh-file-names-interface - scsh-misc-interface - scsh-high-level-process-interface - scsh-time-interface ; new in 0.2 - scsh-sockets-interface ; new in 0.3 - tty-interface ; new in 0.4 - scsh-version-interface - char-set-interface - signal-handler-interface - ;; This stuff would probably be better off kept - ;; in separate modules, but we'll toss it in for now. - (interface-of ascii) ; char<->ascii - string-ports-interface - ))) - (for-syntax (open scsh-syntax-helpers scheme)) - (open externals - structure-refs - cig-aux - receiving - defrec-package - define-foreign-syntax - formats - os-dependent ; OS dependent stuff - buffered-io-flags ; stdio dependent - ascii - records - extended-ports - ports - build - bigbit - bitwise - signals - conditions - scsh-utilities - handle - fluids - weak - - scsh-regexp-package - scsh-regexp-internals - char-set-package - scsh-version - tty-flags - scsh-internal-tty-flags ; Not exported - let-opt ; optional-arg parsing & defaulting - - interrupts ; signal handler code - - scheme - ) - - (access command-processor - escapes - ports ; S48's force-output - formats - records ; I don't think this is necessary. !!! - scheme) ; For accessing the normal I/O operators. - - (begin (define set-batch-mode?! - (structure-ref command-processor set-batch-mode?!)) - (define with-continuation (structure-ref escapes with-continuation))) - - (files syntax - syscalls - select - fname - stringcoll - scsh-condition - rw - newports - fdports - procobj ; New in release 0.4. - (machine waitcodes) ; OS dependent code. - filesys - fileinfo - glob - filemtch - rdelim - time ; New in release 0.2. - (machine time_dep) - network ; New in release 0.3. - endian ; New in release 0.4. - flock ; New in release 0.4. - tty ; New in release 0.4. - pty ; New in release 0.4. - sighandlers ; New in release 0.5. - scsh - )) - -(define-structure defrec-package (export (define-record :syntax)) - (open records scheme) - (for-syntax (open scheme error-package receiving)) - (files defrec)) - -(define-structure defenum-package (export (define-enum-constant :syntax) - (define-enum-constants :syntax)) - (open scheme) - (files enumconst)) - -;;; This code opens so many modules of gruesome, low-level S48 internals -;;; that these two modules are segregated into separate packages, each -;;; exporting just two definitions. - -(define-structure scsh-startup-package (export dump-scsh-program dump-scsh) - (open scsh-level-0-internals ; init-scsh-* set-command-line-args! - scsh-level-0 ; error-output-port command-line-arguments - scsh-top-package ; parse-switches-and-execute - handle ; with-handler - command-processor ; user-context - write-images ; write-image - build-internals ; simple-condition-handler - low-level ; flush-the-symbol-table! - command-processor ; command-output - filenames ; translate - scheme-level-2-internal ; usual-resumer - scheme) - (files startup)) - -(define-structure scsh-top-package (export parse-switches-and-execute repl) - (open command-processor - ensures-loaded - environments - error-package - evaluation - extended-ports - interfaces - interrupts - package-commands-internal - package-mutation - packages - receiving - scsh-version - scsh-level-0 ; with-current-input-port error-output-port - ; with-current-output-port exit regexp - scsh-level-0-internals ; set-command-line-args! init-scsh-vars - scheme) - (files top meta-arg)) - - -(define-structure scsh - (compound-interface (interface-of scsh-level-0) - (interface-of scsh-startup-package) - scsh-field-reader-interface ; new in 0.3 -; scsh-dbm-interface - (export repl) - awk-interface) - - (open structure-refs - scsh-level-0 - scsh-level-0-internals - scsh-startup-package -; dbm - awk-package - field-reader-package - scheme) - - (access scsh-top-package) - (begin (define repl (structure-ref scsh-top-package repl)))) - -(define-structure scsh-here-string-hax (export) - (open reading - receiving - scsh ; Just need the delimited readers. - features ; make-immutable! - scheme) - (files here)) diff --git a/scsh/scsh-read.scm b/scsh/scsh-read.scm deleted file mode 100644 index 7a7b6b8..0000000 --- a/scsh/scsh-read.scm +++ /dev/null @@ -1,125 +0,0 @@ -;;; Copyright (c) 1993, 1994 by Olin Shivers. -;;; #! comment read-macro -;;; no case-folding -;;; -flag is a symbol - -;;; #! means: skip chars until newline-bang-splat-newline. -;;; For Unix script headers. - -(define script-skip - (lambda (c port) - (read-char port) - (let lp ((state 0)) - (let ((advance-if (lambda (look-for) - (let ((c (read-char port))) - (if (eof-object? c) - (error - "EOF inside block comment -- #! missing a closing !#") - (lp (cond ((char=? c look-for) (+ state 1)) - ((char=? c #\newline) 1) - (else 0)))))))) - (case state - ((0) (advance-if #\newline)) - ((1) (advance-if #\!)) ; Found \n - ((2) (advance-if #\#)) ; Found \n! - ((3) (advance-if #\newline)) ; Found \n!# - ((4) (read port))))))) ; Found \n!#\n -- done. -; was sub-read ^ - -(define-sharp-macro #\! script-skip) - - -;;; Readme and readme are distinct symbols. - -(define preferred-case (lambda (x) x)) - -;;; These are now OK symbols: .. -geometry -O2 9x15 80x5+5+5 +Wn - -(define (parse-token string port) - (if (let ((c (string-ref string 0))) - (or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.))) - (cond ((string->number string)) - ((string=? string ".") dot) - (else (string->symbol string))) - (string->symbol string))) - - -;;; | is now an OK symbol (for pipes). - -(set-standard-syntax! #\| #f - (lambda (c port) - (parse-token (sub-read-token c port) port))) - -(define bel (ascii->char 7)) -(define bs (ascii->char 8)) -(define ff (ascii->char 12)) -(define cr (ascii->char 13)) -(define ht (ascii->char 9)) -(define vt (ascii->char 11)) - -;;; Full ANSI C strings: -;;; - read as themselves: \\ \? \" \' -;;; - control chars: -;;; \a alert (bell -- ^g) -;;; \b backspace (^h) -;;; \f form feed (^l) -;;; \n newline (^j) -;;; \r carriage return (^m) -;;; \t tab (^i) -;;; \v vertical tab (^k) -;;; - octal escapes \nnn -;;; - hex escapes \xnn - -;;; Is this the elegant thing to do? Too much might make it hard to shift -;;; to Unicode implementations. How about \^g for embedding control chars? -;;; And I haven't done anything about chars (as opposed to strings). - -(set-standard-read-macro! #\" #t - (lambda (c port) - c ;ignored - (let* ((readc (lambda () - (let ((c (read-char port))) - (if (eof-object? c) - (reading-error port "end of file within a string") - c)))) - (read-digit (lambda (base base-name) - (let* ((c (readc)) - (d (- (char->ascii c) (char->ascii #\0)))) - (if (and (<= 0 d) (< d base)) d - (reading-error port - (string-append "invalid " - base-name - " code in string.") - d)))))) - - (let loop ((l '()) (i 0)) - (let ((c (readc))) - (cond ((char=? c #\\) - (let* ((c (readc)) - (rc (case c - ((#\\ #\" #\? #\') c) - ((#\a) bel) - ((#\b) bs) - ((#\f) ff) - ((#\n) #\newline) - ((#\r) cr) - ((#\t) ht) - ((#\v) vt) - ((#\0 #\1 #\2 #\3) - (let* ((d1 (- (char->ascii c) (char->ascii #\0))) - (d2 (read-digit 8 "octal")) - (d3 (read-digit 8 "octal"))) - (ascii->char (+ (* 64 d1) (+ (* 8 d2) d3))))) - ((#\x) - (let ((d1 (read-digit 16 "hex")) - (d2 (read-digit 16 "hex"))) - (ascii->char (+ (* 16 d1) d2)))) - (else - (reading-error port - "invalid escaped character in string" - c))))) - (loop (cons rc l) (+ i 1)))) - ((char=? c #\") - (reverse-list->string l i)) - (else - (loop (cons c l) (+ i 1))))))))) diff --git a/scsh/scsh-tramp.c b/scsh/scsh-tramp.c deleted file mode 100644 index b947fc6..0000000 --- a/scsh/scsh-tramp.c +++ /dev/null @@ -1,73 +0,0 @@ -/* -** Shell-script trampoline. -** Copyright (c) 1994 by Olin Shivers. -/* - -/* Unix #! shell scripts are not recursive. The interpreter you specify -** on the #! line cannot itself be a shell script. This is a problem for -** the Scheme shell, since it is implemented as a heap image executed -** by the Scheme 48 vm. This means that users cannot write shell scripts -** of the form: -** #!/usr/local/bin/scsh -s -** !# -** ...Scheme code goes here... -** -** They must instead write: -** #!/usr/local/lib/scsh/scshvm \ -** -o /usr/local/lib/scsh/scshvm -i /usr/local/lib/scsh/scsh.image -s -** ...Scheme code goes here... -** -** This is gruesome and probably confusing to novices. -** -** What we do is have this tiny little stub program play the role of scsh. -** It is compiled to a real Unix binary, but when it is executed, it simply -** execs the scsh virtual machine, passing it an argv composed of -** { "-o" "scshvm" "-i" "scsh.image"} -** prepended to whatever argv it was given. Now you can write shell scripts -** with -** #!/usr/local/bin/scsh -s -** triggers. -** -** There are two downsides to doing things this way. -** 1. You pay an extra exec(2) at startup time. -** And scsh starts up slow enough as it is. -** 2. You cannot specify extra arguments for the vm this way. The most -** important one you might want to specify is the heap size arg, -h. -*/ - -#include -#include - -#ifndef VM -#define VM "/usr/local/lib/scsh/scshvm" -#endif -#ifndef IMAGE -#define IMAGE "/usr/local/lib/scsh/scsh.image" -#endif - -main(int argc, char *argv[]) -{ - char **ap, **aq, **newav; - - /* Insert "-o" VM "-i" IMAGE between argv[0] and argv[1]. */ - - argc += 4; /* We're adding 4 new elts. */ - newav = (char **) malloc((argc+1) * sizeof(char*)); /* Alloc new argv. */ - if( !newav ) { - perror(argv[0]); - exit(1); - } - - newav[0] = argv[0]; /* Install new header args. */ - newav[1] = "-o"; - newav[2] = VM; - newav[3] = "-i"; - newav[4] = IMAGE; - - for(ap=&argv[0], aq=&newav[4]; *ap;) /* Copy over orignal argv */ - *++aq = *++ap; /* & the terminating NULL. */ - - execv(VM, newav); /* Do it. */ - perror(argv[0]); - exit(-1); - } diff --git a/scsh/scsh-version.scm b/scsh/scsh-version.scm deleted file mode 100644 index 4113265..0000000 --- a/scsh/scsh-version.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define scsh-major-version 0) -(define scsh-minor-version 4) -(define scsh-version-string "0.4") diff --git a/scsh/scsh.scm b/scsh/scsh.scm deleted file mode 100644 index 79b845c..0000000 --- a/scsh/scsh.scm +++ /dev/null @@ -1,731 +0,0 @@ -;;; A Scheme shell. -;;; Copyright (c) 1992 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; Call THUNK, then die. -;;; A clever definition in a clever implementation allows the caller's stack -;;; and dynamic env to be gc'd away, since this procedure never returns. - -(define (call-terminally thunk) - (with-continuation #f (lambda () (thunk) (exit 0)))) - ;; Alternatively: (with-continuation #f thunk) - -;;; More portably, but less usefully: -;;; (define (call-terminally thunk) -;;; (thunk) -;;; (exit 0)) - -;;; Like FORK, but the parent and child communicate via a pipe connecting -;;; the parent's stdin to the child's stdout. This function side-effects -;;; the parent by changing his stdin. - -(define (fork/pipe . maybe-thunk) - (really-fork/pipe fork maybe-thunk)) - -(define (%fork/pipe . maybe-thunk) - (really-fork/pipe %fork maybe-thunk)) - -;;; Common code for FORK/PIPE and %FORK/PIPE. -(define (really-fork/pipe forker maybe-thunk) - (receive (r w) (pipe) - (let ((proc (forker))) - (cond (proc ; Parent - (close w) - (move->fdes r 0)) - (else ; Child - (close r) - (move->fdes w 1) - (if (pair? maybe-thunk) - (call-terminally (car maybe-thunk))))) - proc))) - - -;;; FORK/PIPE with a connection list. -;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t) - -(define (%fork/pipe+ conns . maybe-thunk) - (really-fork/pipe+ %fork conns maybe-thunk)) - -(define (fork/pipe+ conns . maybe-thunk) - (really-fork/pipe+ fork conns maybe-thunk)) - -;;; Common code. -(define (really-fork/pipe+ forker conns maybe-thunk) - (let* ((pipes (map (lambda (conn) (call-with-values pipe cons)) - conns)) - (rev-conns (map reverse conns)) - (froms (map (lambda (conn) (reverse (cdr conn))) - rev-conns)) - (tos (map car rev-conns))) - - (let ((proc (forker))) - (cond (proc ; Parent - (for-each (lambda (to r/w) - (let ((w (cdr r/w)) - (r (car r/w))) - (close w) - (move->fdes r to))) - tos pipes)) - - (else ; Child - (for-each (lambda (from r/w) - (let ((r (car r/w)) - (w (cdr r/w))) - (close r) - (for-each (lambda (fd) (dup w fd)) from) - (close w))) ; Unrevealed ports win. - froms pipes) - (if (pair? maybe-thunk) - (call-terminally (car maybe-thunk))))) - proc))) - -(define (tail-pipe a b) - (fork/pipe a) - (call-terminally b)) - -(define (tail-pipe+ conns a b) - (fork/pipe+ conns a) - (call-terminally b)) - -;;; Lay a pipeline, one process for each thunk. Last thunk is called -;;; in this process. PIPE* never returns. - -(define (pipe* . thunks) - (letrec ((lay-pipe (lambda (thunks) - (let ((thunk (car thunks)) - (thunks (cdr thunks))) - (if (pair? thunks) - (begin (fork/pipe thunk) - (lay-pipe thunks)) - (call-terminally thunk)))))) ; Last one. - (if (pair? thunks) - (lay-pipe thunks) - (error "No thunks passed to PIPE*")))) - -;;; Splice the processes into the i/o flow upstream from us. -;;; First thunk's process reads from our stdin; last thunk's process' -;;; output becomes our new stdin. Essentially, n-ary fork/pipe. -;;; -;;; This procedure is so trivial it isn't included. -;;; (define (pipe-splice . thunks) (for-each fork/pipe thunks)) - - - -;;; Environment stuff -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; These two functions are obsoleted by the more general INFIX-SPLITTER and -;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined -;;; internally so the top-level startup code (INIT-SCSH) can use it -;;; to split up $PATH without requiring the field-splitter or regexp code. - -(define (split-colon-list clist) - (let ((len (string-length clist))) - (if (= 0 len) '() ; Special case "" -> (). - - ;; Main loop. - (let split ((i 0)) - (cond ((index clist #\: i) => - (lambda (colon) - (cons (substring clist i colon) - (split (+ colon 1))))) - (else (list (substring clist i len)))))))) - -;;; Unix colon lists typically use colons as separators, which -;;; is not as clean to deal with as terminators, but that's Unix. -;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "". - -; (define (string-list->colon-list slist) -; (if (pair? slist) -; (apply string-append -; (let colonise ((lis slist)) ; LIS is always -; (let ((tail (cdr lis))) ; a pair. -; (cons (car lis) -; (if (pair? tail) -; (cons ":" (colonise tail)) -; '()))))) -; "")) ; () case. - - -(define (alist-delete key alist) - (filter (lambda (key/val) (not (equal? key (car key/val)))) alist)) - -(define (alist-update key val alist) - (cons (cons key val) - (alist-delete key alist))) - -;;; Remove shadowed entries from ALIST. Preserves element order. -;;; (This version shares no structure.) - -(define (alist-compress alist) - (reverse (let compress ((alist alist) (ans '())) - (if (pair? alist) - (let ((key/val (car alist)) - (alist (cdr alist))) - (compress alist (if (assoc (car key/val) ans) ans - (cons key/val ans)))) - ans)))) - -;; Tail-recursive loops suck. -;; (define (alist-compress alist) -;; (loop (initial (ans '())) -;; (for key/val in alist) -;; -;; (when (not (assoc (car key/val) ans))) -;; (next (ans (cons key/val ans))) -;; -;; (result (reverse ans)))) - -(define (add-before elt before list) - (let rec ((list list)) - (if (pair? list) - (let ((x (car list))) - (if (equal? x before) - (cons elt list) - (cons x (rec (cdr list))))) - (cons elt list)))) - -;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER -;;; in LIST, and returns the list. However, if the LET finds no occurrence -;;; of AFTER in LIST, it returns #F instead. - -(define (add-after elt after list) - (or (let rec ((list list)) - (if (pair? list) - (let* ((x (car list)) - (tail (cdr list)) - (ans (rec tail))) ; #f if AFTER wasn't encountered. - (cond (ans (cons x ans)) - ((equal? x after) - (cons x (cons elt tail))) - (else #f))) ; AFTER doesn't appear in LIST. - #f)) ; AFTER doesn't appear in LIST. - (cons elt list))) - -;;; Or, just say... -;;; (reverse (add-before elt after (reverse list))) - -(define (with-env* alist-delta thunk) - (let* ((old-env #f) - (new-env (reduce (lambda (alist key/val) - (alist-update (car key/val) (cdr key/val) alist)) - (env->alist) - alist-delta))) - (dynamic-wind - (lambda () - (set! old-env (env->alist)) - (alist->env new-env)) - thunk - (lambda () - (set! new-env (env->alist)) - (alist->env old-env))))) - -(define (with-total-env* alist thunk) - (let ((old-env (env->alist))) - (dynamic-wind - (lambda () - (set! old-env (env->alist)) - (alist->env alist)) - thunk - (lambda () - (set! alist (env->alist)) - (alist->env old-env))))) - - -(define (with-cwd* dir thunk) - (let ((old-wd #f)) - (dynamic-wind - (lambda () - (set! old-wd (cwd)) - (chdir dir)) - thunk - (lambda () - (set! dir (cwd)) - (chdir old-wd))))) - -(define (with-umask* mask thunk) - (let ((old-mask #f)) - (dynamic-wind - (lambda () - (set! old-mask (umask)) - (set-umask mask)) - thunk - (lambda () - (set! mask (umask)) - (set-umask old-mask))))) - -;;; Sugar: - -(define-simple-syntax (with-cwd dir . body) - (with-cwd* dir (lambda () . body))) - -(define-simple-syntax (with-umask mask . body) - (with-umask* mask (lambda () . body))) - -(define-simple-syntax (with-env delta . body) - (with-env* `delta (lambda () . body))) - -(define-simple-syntax (with-total-env env . body) - (with-total-env* `env (lambda () . body))) - - -(define (call/temp-file writer user) - (let ((fname #f)) - (dynamic-wind - (lambda () (if fname (error "Can't wind back into a CALL/TEMP-FILE") - (set! fname (create-temp-file)))) - (lambda () - (with-output-to-file fname writer) - (user fname)) - (lambda () (if fname (delete-file fname)))))) - -;;; Create a new temporary file and return its name. -;;; The optional argument specifies the filename prefix to use, and defaults -;;; to "/usr/tmp/.", where is the current process' id. The procedure -;;; scans through the files named 0, 1, ... until it finds a -;;; filename that doesn't exist in the filesystem. It creates the file with -;;; permission #o600, and returns the filename. -;;; - -(define (create-temp-file . maybe-prefix) - (let ((oflags (bitwise-ior open/write - (bitwise-ior open/create open/exclusive)))) - (apply temp-file-iterate - (lambda (fname) - (close-fdes (open-fdes fname oflags #o600)) - fname) - (if (null? maybe-prefix) '() - (list (string-append (car maybe-prefix) ".~a")))))) - -(define *temp-file-template* - (make-fluid (string-append "/usr/tmp/" (number->string (pid)) ".~a"))) - - -(define (temp-file-iterate maker . maybe-template) - (let ((template (:optional maybe-template (fluid *temp-file-template*)))) - (let loop ((i 0)) - (if (> i 1000) (error "Can't create temp-file") - (let ((fname (format #f template (number->string i)))) - (receive retvals (with-errno-handler - ((errno data) - ((errno/exist) #f)) - (maker fname)) - (if (car retvals) (apply values retvals) - (loop (+ i 1))))))))) - - - -;;; Roughly equivalent to (pipe). -;;; Returns two file ports [iport oport] open on a temp file. -;;; Use this when you may have to buffer large quantities between -;;; writing and reading. Note that if the consumer gets ahead of the -;;; producer, it won't hang waiting for input, it will just return -;;; EOF. To play it safe, make sure that the producer runs to completion -;;; before starting the consumer. -;;; -;;; The temp file is deleted before TEMP-FILE-CHANNEL returns, so as soon -;;; as the ports are closed, the file's disk storage is reclaimed. - -(define (temp-file-channel) - (let* ((fname (create-temp-file)) - (iport (open-input-file fname)) - (oport (open-output-file fname))) - (delete-file fname) - (values iport oport))) - - -;; Return a Unix port such that reads on it get the chars produced by -;; DISPLAYing OBJ. For example, if OBJ is a string, then reading from -;; the port produces the characters of OBJ. -;; -;; This implementation works by writing the string out to a temp file, -;; but that isn't necessary. It could work, for example, by forking off a -;; writer process that outputs to a pipe, i.e., -;; (run/port (begin (display obj (fdes->outport 1)))) - -(define (open-string-source obj) - (receive (inp outp) (temp-file-channel) - (display obj outp) - (close-output-port outp) - inp)) - - -;;;; Process->Scheme interface forms: run/collecting, run/port, run/string, ... - -;;; (run/collecting FDS . EPF) -;;; -------------------------- -;;; RUN/COLLECTING and RUN/COLLECTING* run processes that produce multiple -;;; output streams and return ports open on these streams. -;;; -;;; To avoid issues of deadlock, RUN/COLLECTING first runs the process -;;; with output to temp files, then returns the ports open on the temp files. -;;; -;;; (run/collecting (1 2) (ls)) -;;; runs ls with stdout (fd 1) and stderr (fd 2) redirected to temporary files. -;;; When ls is done, RUN/COLLECTING returns two ports open on the temporary -;;; files. The files are deleted before RUN/COLLECTING returns, so when -;;; the ports are closed, they vanish. -;;; -;;; The FDS list of file descriptors is implicitly backquoted. -;;; -;;; RUN/COLLECTING* is the procedural abstraction of RUN/COLLECTING. - -(define (run/collecting* fds thunk) - ;; First, generate a pair of ports for each communications channel. - ;; Each channel buffers through a temp file. - (let* ((channels (map (lambda (ignore) - (call-with-values temp-file-channel cons)) - fds)) - (read-ports (map car channels)) - (write-ports (map cdr channels)) - - ;; In a subprocess, close the read ports, redirect input from - ;; the write ports, and run THUNK. - (status (run (begin (for-each close-input-port read-ports) - (for-each move->fdes write-ports fds) - (thunk))))) - - ;; In this process, close the write ports and return the exit status - ;; and all the the read ports. - (for-each close-output-port write-ports) - (apply values status read-ports))) - - -;;; Single-stream collectors: -;;; Syntax: run/port, run/file, run/string, run/strings, run/sexp, run/sexps -;;; Procedures: run/port*, run/file*, run/string*, run/strings*, run/sexp*, -;;; run/sexps* -;;; port->string, port->string-list, port->sexp-list, -;;; port->list -;;; -;;; Syntax: -;;; (run/port . epf) -;;; Fork off the process EPF and return a port on its stdout. -;;; (run/file . epf) -;;; Run process EPF with stdout redirected into a temp file. -;;; When the process exits, return the name of the file. -;;; (run/string . epf) -;;; Read the process' stdout into a string and return it. -;;; (run/strings . epf) -;;; Run process EPF, reading newline-terminated strings from its stdout -;;; until EOF. After process exits, return list of strings read. Delimiting -;;; newlines are trimmed from the strings. -;;; (run/sexp . epf) -;;; Run process EPF, read and return one sexp from its stdout with READ. -;;; (run/sexps . epf) -;;; Run process EPF, read sexps from its stdout with READ until EOF. -;;; After process exits, return list of items read. -;;; -;;; Procedural abstractions: -;;; run/port*, run/file*, run/string*, run/strings*, run/sexp*, run/sexps* -;;; -;;; These are all procedural equivalents for the macros. They all take -;;; one argument: the process to be executed passed as a thunk. For example, -;;; (RUN/PORT . epf) expands into (RUN/PORT* (LAMBDA () (EXEC-EPF . epf))) -;;; -;;; Other useful procedures: -;;; -;;; (port->string port) -;;; Read characters from port until EOF; return string collected. -;;; (port->string-list port) -;;; Read newline-terminated strings from port until EOF. Return -;;; the list of strings collected. -;;; (port->sexp-list port) -;;; Read sexps from port with READ until EOF. Return list of items read. -;;; (port->list reader port) -;;; Repeatedly applies READER to PORT, accumulating results into a list. -;;; On EOF, returns the list of items thus collected. -;;; (reduce-port port reader op . seeds) -;;; Repeatedly read things from PORT with READER. Each time you read -;;; some value V, compute a new set of seeds with (apply OP V SEEDS). -;;; (More than 1 seed means OP must return multiple values). -;;; On eof, return the seeds. -;;; PORT->LIST is just (REDUCE-PORT PORT READ CONS '()) - -(define (run/port+proc* thunk) - (receive (r w) (pipe) - (let ((proc (fork (lambda () - (close r) - (move->fdes w 1) - (with-current-output-port* w thunk))))) - (close w) - (values r proc)))) - -(define (run/port* thunk) - (receive (port proc) (run/port+proc* thunk) - port)) - -(define (run/file* thunk) - (let ((fname (create-temp-file))) - (run (begin (thunk)) (> ,fname)) - fname)) - -(define (run/string* thunk) - (close-after (run/port* thunk) port->string)) - -(define (run/sexp* thunk) - (close-after (run/port* thunk) read)) - -(define (run/sexps* thunk) - (close-after (run/port* thunk) port->sexp-list)) - -(define (run/strings* thunk) - (close-after (run/port* thunk) port->string-list)) - - -;;; Read characters from PORT until EOF, collect into a string. - -(define (port->string port) - (let ((sc (make-string-collector))) - (letrec ((lp (lambda () - (cond ((read-string 1024 port) => - (lambda (s) - (collect-string! sc s) - (lp))) - (else (string-collector->string sc)))))) - (lp)))) - -;;; (loop (initial (sc (make-string-collector))) -;;; (bind (s (read-string 1024 port))) -;;; (while s) -;;; (do (collect-string! sc s)) -;;; (result (string-collector->string sc))) - -;;; Read items from PORT with READER until EOF. Collect items into a list. - -(define (port->list reader port) - (let lp ((ans '())) - (let ((x (reader port))) - (if (eof-object? x) (reverse! ans) - (lp (cons x ans)))))) - -(define (port->sexp-list port) - (port->list read port)) - -(define (port->string-list port) - (port->list read-line port)) - -(define (reduce-port port reader op . seeds) - (letrec ((reduce (lambda seeds - (let ((x (reader port))) - (if (eof-object? x) (apply values seeds) - (call-with-values (lambda () (apply op x seeds)) - reduce)))))) - (apply reduce seeds))) - -;;; Not defined: -;;; (field-reader field-delims record-delims) -;;; Returns a reader that reads strings delimited by 1 or more chars from -;;; the string FIELD-DELIMS. These strings are collected in a list until -;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the -;;; accumulated list of strings is returned. For example, if we want -;;; a procedure that reads one line of input, splitting it into -;;; whitespace-delimited strings, we can use -;;; (field-reader " \t" "\n") -;;; for a reader. - - - -;; Loop until EOF reading characters or strings and writing (FILTER char) -;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE. - -(define (char-filter filter) - (lambda () - (let lp () - (let ((c (read-char))) - (if (not (eof-object? c)) - (begin (write-char (filter c)) - (lp))))))) - -(define (string-filter filter . maybe-buflen) - (let* ((buflen (:optional maybe-buflen 1024)) - (buf (make-string buflen))) - (lambda () - (let lp () - (cond ((read-string! buf 0 buflen) => - (lambda (nread) - (display (filter (if (= nread buflen) buf - (substring buf 0 nread)))) ; last one. - (lp)))))))) - - -;;; Stdio/stdport sync procedures -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (stdio->stdports) - (set-current-input-port! (fdes->inport 0)) - (set-current-output-port! (fdes->inport 1)) - (set-error-output-port! (fdes->inport 2))) - -(define (with-stdio-ports* thunk) - (with-current-input-port (fdes->inport 0) - (with-current-output-port (fdes->outport 1) - (with-error-output-port (fdes->outport 2) - (thunk))))) - -(define-simple-syntax (with-stdio-ports body ...) - (with-stdio-ports* (lambda () body ...))) - - -(define (stdports->stdio) - (dup (current-input-port) 0) - (dup (current-output-port) 1) - (dup (error-output-port) 2)) - - -;;; Command-line argument access -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Some globals. -(define %command-line '()) ; Includes program. -(define command-line-arguments #f) ; Doesn't include program. - -(define (set-command-line-args! args) - (set! %command-line args) - (set! command-line-arguments (append (cdr args) '()))) - -(define (arg* arglist n . maybe-default-thunk) - (let ((oops (lambda () (error "argument out of bounds" arglist n)))) - (if (< n 1) (oops) - (let lp ((al arglist) (n n)) - (if (pair? al) - (if (= n 1) (car al) - (lp (cdr al) (- n 1))) - (if (and (pair? maybe-default-thunk) - (null? (cdr maybe-default-thunk))) - ((car maybe-default-thunk)) - (oops))))))) - -(define (arg arglist n . maybe-default) - (if maybe-default (arg* arglist n (lambda () (car maybe-default))) - (arg* arglist n))) - -(define (argv n . maybe-default) - (apply arg (cdr %command-line) n maybe-default)) - -(define (command-line) (append %command-line '())) - -;;; EXEC support -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Assumes a low-level %exec procedure: -;;; (%exec prog arglist env) -;;; ENV is either #t, meaning the current environment, or a string->string -;;; alist. -;;; %EXEC stringifies PROG and the elements of ARGLIST. - -(define (stringify thing) - (cond ((string? thing) thing) - ((symbol? thing) - (symbol->string thing)) -; ((symbol? thing) -; (list->string (map char-downcase -; (string->list (symbol->string thing))))) - ((integer? thing) - (number->string thing)) - (else (error "Can only stringify strings, symbols, and integers." - thing)))) - -(define (exec-path-search prog path-list) - (if (file-name-absolute? prog) - (and (file-executable? prog) prog) - (first? (lambda (dir) - (let ((fname (string-append dir "/" prog))) - (and (file-executable? fname) fname))) - path-list))) - -(define (exec/env prog env . arglist) - (flush-all-ports) - (%exec prog (cons prog arglist) env)) - -;(define (exec-path/env prog env . arglist) -; (cond ((exec-path-search (stringify prog) exec-path-list) => -; (lambda (binary) -; (apply exec/env binary env arglist))) -; (else (error "No executable found." prog arglist)))) - -;;; This procedure is bummed by tying in directly to %%exec/errno -;;; and pulling some of %exec's code out of the inner loop so that -;;; the inner loop will be fast. Folks don't like waiting... - -(define (exec-path/env prog env . arglist) - (flush-all-ports) - (let ((prog (stringify prog))) - (if (index prog #\/) - - ;; Contains a slash -- no path search. - (%exec prog (cons prog arglist) env) - - ;; Try each directory in PATH-LIST. - (let ((argv (list->vector (cons prog (map stringify arglist))))) - (for-each (lambda (dir) - (let ((binary (string-append dir "/" prog))) - (%%exec/errno binary argv env))) - exec-path-list)))) - - (error "No executable found." prog arglist)) - -(define (exec-path prog . arglist) - (apply exec-path/env prog #t arglist)) - -(define (exec prog . arglist) - (apply exec/env prog #t arglist)) - - -;;; Assumes niladic primitive %%FORK. - -(define (fork . maybe-thunk) - (flush-all-ports) - (really-fork #t maybe-thunk)) - -(define (%fork . maybe-thunk) - (really-fork #f maybe-thunk)) - -(define (really-fork clear-interactive? maybe-thunk) - (let ((pid (%%fork))) - (cond ((zero? pid) ; Child - (set! reaped-procs '()) - (if clear-interactive? - (set-batch-mode?! #t)) ; Children are non-interactive. - (and (pair? maybe-thunk) - (call-terminally (car maybe-thunk)))) - (else (new-child-proc pid))))) ; Parent - - -(define (exit . maybe-status) - (flush-all-ports) - (exit/errno (:optional maybe-status 0)) - (display "The evil undead walk the earth." 2) - (error "(exit) returned.")) - - -;;; The classic T 2.0 primitive. -;;; This definition works for procedures running on top of Unix systems. -(define (halts? proc) #t) - - -;;; Low-level init absolutely required for any scsh program. - -(define (init-scsh-hindbrain relink-ff?) - (if relink-ff? (lookup-all-externals)) ; Re-link C calls. - (init-fdports!)) - - -;;; Some globals: -(define home-directory "") -(define exec-path-list '()) - -(define (init-scsh-vars quietly?) - (set! home-directory - (cond ((getenv "HOME") => ensure-file-name-is-nondirectory) - (else (if (not quietly?) - (warn "Starting up with no home directory ($HOME).")) - "/"))) - (set! exec-path-list - (cond ((getenv "PATH") => split-colon-list) - (else (if (not quietly?) - (warn "Starting up with no path ($PATH).")) - '())))) - - -; SIGTSTP blows s48 away. ??? -(define (suspend) (signal-process 0 signal/stop)) diff --git a/scsh/scsh_aux.h b/scsh/scsh_aux.h deleted file mode 100644 index d5bdcf3..0000000 --- a/scsh/scsh_aux.h +++ /dev/null @@ -1,35 +0,0 @@ -/* String equality predicate. */ -#define streq(a,b) (!strcmp((a),(b))) - -#define Alloc(type) ((type *) malloc(sizeof(type))) -#define Malloc(type,n) ((type *) malloc(sizeof(type)*(n))) -#define Free(p) (free((char *)(p))) -#define Realloc(type,p,n) ((type *) realloc(p, (n)*sizeof(type))) - - -/* These are the interrupt numbers used by the S48/scsh VM. -** The first three are S48 interrupts. The rest were added for -** scsh to support Unix signals. Note that not all Unixes support -** all these signals. -*/ -#define scshint_alarm (0) /* S48 Unix SIGALRM signal */ -#define scshint_keyboard (1) /* S48 Unix SIGINT signal */ -#define scshint_memory_shortage (2) -#define scshint_chld (3) /* Interrupts from here down are */ -#define scshint_cont (4) /* Unix signals. The last ten are */ -#define scshint_hup (5) /* non-Posix, hence not necessarily */ -#define scshint_quit (6) /* found on all Unixes. */ -#define scshint_term (7) -#define scshint_tstp (8) -#define scshint_usr1 (9) -#define scshint_usr2 (10) -#define scshint_info (11) /* BSD */ -#define scshint_io (12) /* BSD + SVR4 */ -#define scshint_poll (13) /* SVR4 */ -#define scshint_prof (14) /* BSD + SVR4 */ -#define scshint_pwr (15) /* SVR4 */ -#define scshint_urg (16) /* BSD + SVR4 */ -#define scshint_vtalrm (17) /* BSD + SVR4 */ -#define scshint_winch (18) /* BSD + SVR4 */ -#define scshint_xcpu (19) /* BSD + SVR4 */ -#define scshint_xfsz (20) /* BSD + SVR4 */ diff --git a/scsh/select.c b/scsh/select.c deleted file mode 100644 index c8952b1..0000000 --- a/scsh/select.c +++ /dev/null @@ -1,47 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -/* Make sure foreign-function stubs interface to the C funs correctly: */ -#include "select1.h" - -scheme_value df_select_copyback(long nargs, scheme_value *args) -{ - extern scheme_value select_copyback(scheme_value , scheme_value , scheme_value , scheme_value , int *, int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - int r4; - - cig_check_nargs(5, nargs, "select_copyback"); - r1 = select_copyback(args[4], args[3], args[2], args[1], &r2, &r3, &r4); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - return ret1; - } - -scheme_value df_select_filter(long nargs, scheme_value *args) -{ - extern scheme_value select_filter(scheme_value , scheme_value , scheme_value , scheme_value , int *, int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - int r4; - - cig_check_nargs(5, nargs, "select_filter"); - r1 = select_filter(args[4], args[3], args[2], args[1], &r2, &r3, &r4); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - return ret1; - } - diff --git a/scsh/select.scm b/scsh/select.scm deleted file mode 100644 index bdc5a7d..0000000 --- a/scsh/select.scm +++ /dev/null @@ -1,136 +0,0 @@ -;;; select(2) syscall for scsh. -*- Scheme -*- -;;; Copyright (c) 1995 by Olin Shivers. - -(foreign-source - "/* Make sure foreign-function stubs interface to the C funs correctly: */" - "#include \"select1.h\"" - "" "") - -;;; TIMEOUT is 0 for immediate, >0 for timeout, #f for infinite; -;;; default is #f. -;;; The sets are vectors of file descriptors & fd ports. -;;; You get three new vectors back. - -(define (select read-vec write-vec exception-vec . maybe-timeout) - (let ((rv (copy-vector read-vec)) - (wv (copy-vector write-vec)) - (ev (copy-vector exception-vec))) - (receive (nr nw ne) (apply select!/copyback rv wv ev maybe-timeout) - (values (vector-take rv nr) - (vector-take wv nw) - (vector-take ev ne))))) - - -(define (select!/copyback read-vec write-vec exception-vec . maybe-timeout) - (receive (errno nr nw ne) - (apply select!/copyback/errno read-vec write-vec exception-vec - maybe-timeout) - (if errno - (apply errno-error errno select!/copyback - read-vec write-vec exception-vec maybe-timeout) - (values nr nw ne)))) - - -(define (select!/copyback/errno read-vec write-vec - exception-vec . maybe-timeout) - (let ((timeout (and (pair? maybe-timeout) - (if (pair? (cdr maybe-timeout)) - (apply error "Too many arguments" - select!/copyback/errno - read-vec write-vec exception-vec - maybe-timeout) - (real->exact-integer (check-arg real? - (car maybe-timeout) - select!/copyback/errno))))) - - (vec-ok? (lambda (v) - (vector-every? (lambda (elt) - (or (and (integer? elt) (>= elt 0)) - (fdport? elt))) - v)))) - ;; Type-check input vectors. - (check-arg vec-ok? read-vec select!/copyback/errno) - (check-arg vec-ok? write-vec select!/copyback/errno) - (check-arg vec-ok? exception-vec select!/copyback/errno) - (check-arg (lambda (x) (or (not x) (integer? x))) timeout - select!/copyback/errno) - - (let lp () - (receive (errno nr nw ne) - (%select/copyback/errno read-vec write-vec exception-vec timeout) - (if (and errno (= errno errno/intr)) ; Retry on interrupts. - (lp) - (values errno nr nw ne)))))) - - -(define-foreign %select/copyback/errno - (select_copyback (vector-desc rvec) - (vector-desc wvec) - (vector-desc evec) - (desc nsecs)) ; Integer or #f for infinity. - desc ; errno or #f - fixnum ; nread - number of hits in RVEC - fixnum ; nwrite - number of hits in WVEC - fixnum) ; nexcept - number of hits in EVEC - - -(define (vector-take vec nelts) - (let ((short (make-vector nelts))) - (do ((i (- nelts 1) (- i 1))) - ((< i 0)) - (vector-set! short i (vector-ref vec i))) - short)) - - -;;; SELECT! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The side-effecting variant. To be documented. - -(define (select! read-vec write-vec exception-vec . maybe-timeout) - (receive (errno nr nw ne) - (apply select!/errno read-vec write-vec exception-vec maybe-timeout) - (if errno - (apply errno-error errno select! read-vec write-vec exception-vec - maybe-timeout) - (values nr nw ne)))) - -(define (select!/errno read-vec write-vec exception-vec . maybe-timeout) - (let ((timeout (and (pair? maybe-timeout) - (if (pair? (cdr maybe-timeout)) - (apply error "Too many arguments" - select!/copyback/errno - read-vec write-vec exception-vec - maybe-timeout) - (real->exact-integer (check-arg real? - (car maybe-timeout) - select!/copyback/errno))))) - - (vec-ok? (lambda (v) - (vector-every? (lambda (elt) - (or (and (integer? elt) (>= elt 0)) - (not elt) - (fdport? elt))) - v)))) - ;; Type-check input vectors. - (check-arg vec-ok? read-vec select!/errno) - (check-arg vec-ok? write-vec select!/errno) - (check-arg vec-ok? exception-vec select!/errno) - (check-arg (lambda (x) (or (not x) (integer? x))) timeout select!/errno) - - (let lp () - (receive (errno nr nw ne) - (%select!/errno read-vec write-vec exception-vec timeout) - (if (and errno (= errno errno/intr)) ; Retry on interrupts. - (lp) - (values errno nr nw ne)))))) - - -(define-foreign %select!/errno - (select_filter (vector-desc rvec) - (vector-desc wvec) - (vector-desc evec) - (desc nsecs)) ; Integer or #f for infinity. - desc ; errno or #f - fixnum ; nread - number of hits in RVEC - fixnum ; nwrite - number of hits in WVEC - fixnum) ; nexcept - number of hits in EVEC diff --git a/scsh/select1.c b/scsh/select1.c deleted file mode 100644 index 2aa20c3..0000000 --- a/scsh/select1.c +++ /dev/null @@ -1,262 +0,0 @@ -/* C support for scsh select call. -** Copyright (c) 1995 by Olin Shivers. -*/ - -#include "sysdep.h" - -#include -#if defined(HAVE_SYS_SELECT_H) -# include -#endif -#include - -#include -#include - -#include "cstuff.h" -#include "fdports.h" /* Accessors for Scheme I/O port internals. */ -#include "fdports1.h" /* Import fdes2fstar(). */ -#include "machine/stdio_dep.h" /* Import stdio buf-peeking ops. */ - -/* Make sure our exports match up w/the implementation: */ -#include "select1.h" - -/* the traditional sleazy max non-function. */ -#define max(a,b) (((a) > (b)) ? (a) : (b)) - -extern int errno; -extern FILE *fdes2fstar(int fd); - -static void or2_fdset(fd_set *x, fd_set *y, int max_elt); -static int copyback_fdvec(scheme_value portvec, fd_set *fdset); - -/* RVEC, WVEC, and EVEC are Scheme vectors of integer file descriptors, -** I/O ports, and #f's. NSECS is an integer timeout value, or #f for -** infinite wait. Do the select() call, returning result fd_sets in the -** passed pointers. Return 0 for OK, otherwise error is in errno. -*/ - -int do_select(scheme_value rvec, scheme_value wvec, - scheme_value evec, scheme_value nsecs, - fd_set *rset_ans, fd_set *wset_ans, fd_set *eset_ans) -{ - struct timeval timeout, *tptr; - fd_set rset_bufrdy, wset_bufrdy, eset_bufrdy; /* Buffered port hits. */ - int rbuf_rdy=0, wbuf_rdy=0, bufrdy; /* Set if we find buffered I/O hits. */ - int max_fd = -1; /* Max fdes in the sets. */ - int nelts, i; - int nfound; - - FD_ZERO(rset_ans); FD_ZERO(wset_ans); FD_ZERO(eset_ans); - FD_ZERO(&rset_bufrdy); FD_ZERO(&wset_bufrdy); FD_ZERO(&eset_bufrdy); - - /* Scan the readvec elts. */ - nelts = VECTOR_LENGTH(rvec); - for(i=nelts; --i >= 0; ) { - scheme_value elt = VECTOR_REF(rvec,i); - int fd; - - if( FIXNUMP(elt) ) { /* It's an integer fdes. */ - fd = EXTRACT_FIXNUM(elt); - FD_SET(fd, rset_ans); - } - - else if( elt != SCHFALSE ) { /* It better be a port. */ - FILE *f; - scheme_value data = *Port_PortData(elt); - fd = EXTRACT_FIXNUM(*PortData_Fd(data)); - f = fdes2fstar(fd); - if( !f ) return -1; - else if( *PortData_Peek(data) != SCHFALSE /* Port has a peekchar */ - || !ibuf_empty(f) ) { /* Stdio buf has chars. */ - FD_SET(fd, &rset_bufrdy); - rbuf_rdy = 1; /* Hit. */ - } - else FD_SET(fd, rset_ans); /* No buffered data. */ - } - - max_fd = max(max_fd, fd); - } - - /* Scan the writevec elts. */ - nelts = VECTOR_LENGTH(wvec); - for(i=nelts; --i >= 0; ) { - scheme_value elt = VECTOR_REF(wvec,i); - int fd; - - if( FIXNUMP(elt) ) { /* It's an integer fdes. */ - fd = EXTRACT_FIXNUM(elt); - FD_SET(fd, wset_ans); - } - - else if( elt != SCHFALSE ) { /* It better be a port. */ - FILE *f; - fd = EXTRACT_FIXNUM(*PortFd(elt)); - f = fdes2fstar(fd); - if( !f ) return -1; - else if( !obuf_full(f) ) { /* I/O buf has room. */ - FD_SET(fd, &wset_bufrdy); - wbuf_rdy = 1; /* Hit. */ - } - else FD_SET(fd, wset_ans); /* No room. */ - } - - max_fd = max(max_fd, fd); - } - - /* Scan the exception-vec elts. */ - nelts = VECTOR_LENGTH(evec); - for(i=nelts; --i >= 0; ) { - scheme_value elt = VECTOR_REF(evec,i); - int fd; - - if( FIXNUMP(elt) ) { /* It's an integer fdes. */ - fd = EXTRACT_FIXNUM(elt); - FD_SET(fd, rset_ans); - } - - else if( elt != SCHFALSE ) { /* It better be a port. */ - fd = EXTRACT_FIXNUM(*PortFd(elt)); - FD_SET(fd, rset_ans); - } - - max_fd = max(max_fd, fd); - } - - bufrdy = rbuf_rdy || wbuf_rdy; - if( bufrdy ) { /* Already have some hits on buffered ports, */ - timeout.tv_sec = 0; /* so we only poll the others. */ - timeout.tv_usec = 0; - tptr = &timeout; - } - else if ( FIXNUMP(nsecs) ) { - timeout.tv_sec = EXTRACT_FIXNUM(nsecs); /* Wait n seconds. */ - timeout.tv_usec = 0; - tptr = &timeout; - } - else tptr = NULL; /* #f => Infinite wait. */ - - /* select1() is defined in sysdep.h -- bogus compatibility macro. */ - nfound = select1(max_fd+1, rset_ans, wset_ans, eset_ans, tptr); /* Do it.*/ - - /* EINTR is not an error return if we have hits on buffered ports - ** to report. - */ - if( nfound < 0 ) - if ( errno != EINTR || !bufrdy ) return -1; - else { /* EINTR, but we have hits on buffered ports to report. */ - FD_ZERO(rset_ans); /* This should never happen -- */ - FD_ZERO(wset_ans); /* EINTR on a zero-sec select() */ - FD_ZERO(eset_ans); /* -- but I'm paranoid. */ - } - - /* OR together the buffered-io ready sets and the fd ready sets. */ - if( rbuf_rdy ) or2_fdset(rset_ans, &rset_bufrdy, max_fd); - if( wbuf_rdy ) or2_fdset(wset_ans, &wset_bufrdy, max_fd); - - return 0; - } - - - -/* x = x or y */ -static void or2_fdset(fd_set *x, fd_set *y, int max_elt) -{ - int i; - for(i=max_elt+1; --i >= 0;) - if( FD_ISSET(i,y) ) FD_SET(i,x); - } - - - -/* PORTVEC is a vector of integer file descriptors and Scheme ports. -** Scan over the vector, and copy any elt whose file descriptor is in FDSET -** to the front of the vector. Return the number of elts thus copied. -*/ -static int copyback_fdvec(scheme_value portvec, fd_set *fdset) -{ - int vlen = VECTOR_LENGTH(portvec); - int i, j=0; - for( i = -1; ++i < vlen; ) { - scheme_value elt = VECTOR_REF(portvec, i); - int fd = EXTRACT_FIXNUM((FIXNUMP(elt)) ? elt : *PortFd(elt)); - if( FD_ISSET(fd,fdset) ) { - FD_CLR(fd,fdset); /* In case luser put elt in multiple times. */ - VECTOR_REF(portvec, j) = elt; - j++; - } - } - return j; - } - - -/* Overwrite every inactive element in the vector with #f; -** Return count of active elements. -*/ - -static int clobber_inactives(scheme_value portvec, fd_set *fdset) -{ - int count = 0; - int i = VECTOR_LENGTH(portvec); - - while( --i >= 0 ) { - scheme_value elt = VECTOR_REF(portvec, i); - if( elt != SCHFALSE ) { - int fd = EXTRACT_FIXNUM((FIXNUMP(elt)) ? elt : *PortFd(elt)); - if( FD_ISSET(fd,fdset) ) { - FD_CLR(fd,fdset); /* In case luser put elt in multiple times. */ - ++count; - } - else VECTOR_REF(portvec, i) = SCHFALSE; /* Clobber. */ - } - } - return count; - } - - -/* These two functions are the entry points to this file. -********************************************************* -*/ - -/* Copy active elts back to the front of their vector; -** Return error indicator & number of hits for each vector. -*/ - -scheme_value select_copyback(scheme_value rvec, scheme_value wvec, - scheme_value evec, scheme_value nsecs, - int *r_numrdy, int *w_numrdy, int *e_numrdy) -{ - fd_set rset, wset, eset; - - if( do_select(rvec, wvec, evec, nsecs, &rset, &wset, &eset) ) { - *r_numrdy = *w_numrdy = *e_numrdy = 0; - return ENTER_FIXNUM(errno); - } - - *r_numrdy = copyback_fdvec(rvec, &rset); - *w_numrdy = copyback_fdvec(wvec, &wset); - *e_numrdy = copyback_fdvec(evec, &eset); - return SCHFALSE; - } - - -/* Overwrite non-active elements in the vectors with #f; -** return error indicator & number of hits for each vector. -*/ - -scheme_value select_filter(scheme_value rvec, scheme_value wvec, - scheme_value evec, scheme_value nsecs, - int *r_numrdy, int *w_numrdy, int *e_numrdy) -{ - fd_set rset, wset, eset; - - if( do_select(rvec, wvec, evec, nsecs, &rset, &wset, &eset) ) { - *r_numrdy = *w_numrdy = *e_numrdy = 0; - return ENTER_FIXNUM(errno); - } - - *r_numrdy = clobber_inactives(rvec, &rset); - *w_numrdy = clobber_inactives(wvec, &wset); - *e_numrdy = clobber_inactives(evec, &eset); - return SCHFALSE; - } diff --git a/scsh/select1.h b/scsh/select1.h deleted file mode 100644 index fde8bfb..0000000 --- a/scsh/select1.h +++ /dev/null @@ -1,9 +0,0 @@ -/* Exports from select1.c. */ - -scheme_value select_copyback(scheme_value rvec, scheme_value wvec, - scheme_value evec, scheme_value nsecs, - int *r_numrdy, int *w_numrdy, int *e_numrdy); - -scheme_value select_filter(scheme_value rvec, scheme_value wvec, - scheme_value evec, scheme_value nsecs, - int *r_numrdy, int *w_numrdy, int *e_numrdy); diff --git a/scsh/sighandlers.c b/scsh/sighandlers.c deleted file mode 100644 index 3724f22..0000000 --- a/scsh/sighandlers.c +++ /dev/null @@ -1,87 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -extern int errno; - -/* Make sure foreign-function stubs interface to the C funs correctly: */ -#include "sighandlers1.h" - -scheme_value df_sig2interrupt(long nargs, scheme_value *args) -{ - extern int sig2interrupt(int ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "sig2interrupt"); - r1 = sig2interrupt(EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_do_default_sigaction(long nargs, scheme_value *args) -{ - extern void do_default_sigaction(int ); - - cig_check_nargs(1, nargs, "do_default_sigaction"); - do_default_sigaction(EXTRACT_FIXNUM(args[0])); - return SCHFALSE; - } - -scheme_value df_scsh_set_sig(long nargs, scheme_value *args) -{ - extern scheme_value scsh_set_sig(int , int , int , int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - - cig_check_nargs(4, nargs, "scsh_set_sig"); - r1 = scsh_set_sig(EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2, &r3); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_scsh_get_sig(long nargs, scheme_value *args) -{ - extern scheme_value scsh_get_sig(int , int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - - cig_check_nargs(2, nargs, "scsh_get_sig"); - r1 = scsh_get_sig(EXTRACT_FIXNUM(args[1]), &r2, &r3); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_install_scsh_handlers(long nargs, scheme_value *args) -{ - extern void install_scsh_handlers(void); - - cig_check_nargs(0, nargs, "install_scsh_handlers"); - install_scsh_handlers(); - return SCHFALSE; - } - -scheme_value df_get_int_handlers(long nargs, scheme_value *args) -{ - extern scheme_value get_int_handlers(void); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(0, nargs, "get_int_handlers"); - r1 = get_int_handlers(); - ret1 = r1; - return ret1; - } - diff --git a/scsh/sighandlers.scm b/scsh/sighandlers.scm deleted file mode 100644 index 0877b20..0000000 --- a/scsh/sighandlers.scm +++ /dev/null @@ -1,162 +0,0 @@ -;;; Copyright (c) 1993 by Olin Shivers. -;;; Signal handler system - -;;; The principal trickiness here is that we have to interface to Unix signals -;;; *through* an intermediate interface, the S48 vm's idea of interrupts. -;;; So there is a difference between delivering a signal to the underlying -;;; Unix process and delivering it to the program that runs on the VM. -;;; -;;; One effect is that we have two separate codes for the same thing -- the -;;; Unix signal code, and the S48 interrupt value. E.g., SIGNAL/TSTP and -;;; INTERRUPT/TSTP. - -;;; These system calls can return EINTR or restart. In order for the S48 vm's -;;; interrupt system to detect a signal and invoke the handler, they *must* -;;; return EINTR, and this must cause a return from C to Scheme. -;;; -;;; open close dup2 accept connect -;;; read recv recvfrom recvmsg -;;; write send sendto sendmsg -;;; select -;;; wait -;;; fcntl* ioctl -;;; sigsuspend -;;; HP-UX, but I don't use: poll lockf msem_lock msgsnd msgrcv semop -;;; -;;; * Only during a F_SETLKW -;;; -;;; From rts/interrupt.scm (package interrupts, interface interrupts-interface) -;;; WITH-INTERRUPTS INTERRUPT-HANDLERS SET-ENABLED-INTERRUPTS! -;;; ENABLED-INTERRUPTS -;;; Must define WITH-INTERRUPTS* and WITH-INTERRUPTS. - -(foreign-source - "extern int errno;" - "" - "/* Make sure foreign-function stubs interface to the C funs correctly: */" - "#include \"sighandlers1.h\"" - "" "") - -;;; Map a Unix async signal to its S48 interrupt value. -;;; -1 => Not defined. -(define-foreign %signal->interrupt (sig2interrupt (integer sig)) - integer) - -(define (signal->interrupt sig) - (let ((int (%signal->interrupt sig))) - (if (>= int 0) int - (error "Unix signal has no Scheme 48 interrupt." sig)))) - - -(define (interrupt-set . interrupts) - (let lp ((ints interrupts) (ans 0)) - (if (pair? ints) - (lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1)))) - ans))) - -(define-simple-syntax (with-enabled-interrupts mask body ...) - (with-interrupts mask (lambda () body ...))) - -(define with-enabled-interrupts* with-interrupts) - - -;;; Get/Set signal handlers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; When you set a signal's handler to "default," if the default for that -;;; signal is something other than "ignore," we actually install this guy. -;;; When he is called by the S48 interrupt system, he'll magically make -;;; the default action happen (by calling C code that *really* sets the -;;; handler to SIGDFL, and then re-sending the signal). This basically -;;; terminates the process, since if the default isn't "ignore," it's always -;;; "terminate" of some kind. Doing it this way means the exit code given -;;; to our waiting parent proc correctly reflects how we died, and also -;;; makes the core dump happen if it should. Details, details. - -(define-foreign %do-default-sigaction (do_default_sigaction (fixnum signal)) - ignore) - -;;; This gives the default handler for each signal. -(define default-handler-vec - (initialize-vector 32 (lambda (sig) - ;; This is the guy to call when you want signal - ;; SIG handled in the default manner. - (if (memv sig signals-ignored-by-default) - (lambda (enabled-interrupts) #f) - (lambda (enabled-interrupts) - (%do-default-sigaction sig)))))) - - -;;; HANDLER is #f (ignore), #t (default), or a procedure taking an integer -;;; argument. The interrupt is delivered to a procedure by (1) setting the -;;; ENABLED-INTERRUPTS register to 0 (i.e., blocking all interrupts), and (2) -;;; applying the procedure to the previous value of the ENABLED-INTERRUPTS -;;; register. If the procedure returns normally (i.e., it doesn't throw to a -;;; continuation), the ENABLED-INTERRUPTS register will be restored to its -;;; previous value. - -(define (set-signal-handler! sig handler) - (let ((nhandler (if (eq? handler #t) ; Get SIG's default handler. - (vector-ref default-handler-vec sig) - handler)) - (int (signal->interrupt sig))) - (with-enabled-interrupts 0 - (let ((ohandler (vector-ref interrupt-handlers int))) - (vector-set! interrupt-handlers int nhandler) - ohandler)))) - -(define (signal-handler sig) - (vector-ref interrupt-handlers (signal->interrupt sig))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Set the Unix signal handler. One doesn't usually use this; one usually -;;; uses the S48 VM's interrupt system. -;;; HANDLER-CODE: 0 => ignore, 1 => default, 2 => S48 VM -;;; Returns equivalent code, additionally 3 => other handler. -;;; Raises an error exception if there's a problem. - -(define (%set-unix-signal-handler! sig handler-code) - (check-arg (lambda (x) (and (integer? sig) (< 0 sig 32))) - sig - %set-unix-signal-handler!) - (check-arg (lambda (x) (and (integer? handler-code) (<= 0 handler-code 2))) - handler-code - %set-unix-signal-handler!) - (let retry () - (receive (err old-hc) (%%set-unix-signal-handler! sig handler-code) - (cond ((not err) old-hc) - ((= err errno/intr) (retry)) - (else (errno-error err %set-unix-signal-handler! sig handler-code)))))) - -(define-foreign %%set-unix-signal-handler! - (scsh_set_sig (fixnum sig) (fixnum hc) (fixnum flags)) - desc ; #f or errno - integer ; previous handler-code - integer) ; previous handler flags - -(define (%unix-signal-handler sig) - (check-arg (lambda (x) (and (integer? sig) (< 0 sig 32))) - sig - %unix-signal-handler) - (let retry () - (receive (err hc flags) (%%unix-signal-handler sig) - (cond ((not err) hc) - ((= err errno/intr) (retry)) - (else (errno-error err %unix-signal-handler sig)))))) - -(define-foreign %%unix-signal-handler (scsh_get_sig (fixnum sig)) - desc ; #f or errno - integer ; previous handler-code - integer) ; previous handler flags - -(define-foreign %install-unix-scsh-handlers (install_scsh_handlers) ignore) - -(define-foreign %%get-int-handlers (get_int_handlers) desc) - -(define (%install-scsh-handlers) - (do ((sig 32 (- sig 1))) - ((< sig 0)) - (let ((i (%signal->interrupt sig))) - (if (not (or (= i -1) (= sig signal/int) (= sig signal/alrm))) - (vector-set! interrupt-handlers i - (vector-ref default-handler-vec sig)))))) diff --git a/scsh/sighandlers1.c b/scsh/sighandlers1.c deleted file mode 100644 index a49f861..0000000 --- a/scsh/sighandlers1.c +++ /dev/null @@ -1,193 +0,0 @@ -/* Need to define sig2interrupt vector. -** Interrupt-system mutators should probably hold interrupts while they -** operate. -*/ - -#include -#include -#include -#include -#include "cstuff.h" - -/* Make sure our exports match up w/the implementation: */ -#include "sighandlers1.h" - -#include "signals1.h" - -extern int errno; - -extern scheme_value Spending_interruptsS, Sinterrupt_handlersS; - -/* Translate Unix signal numbers to S48 interrupt numbers. */ - -int sig2interrupt(int signal) -{ - return ( signal < 0 || signal > max_sig ) ? -1 : sig2int[signal]; - } - - -/* Hack the blocked-signal mask. -******************************************************************************* -*/ - - -#include "machine/sigset.h" - -int set_procmask(int hi, int lo, int *old_lo_p) -{ - sigset_t mask, old_mask; - int old_hi; - - make_sigset(&mask, hi, lo); - - sigprocmask(SIG_SETMASK, &mask, &old_mask); - split_sigset(old_mask, &old_hi, old_lo_p); - return old_hi; - } - - -int get_procmask(int *old_lo_p) -{ - sigset_t old_mask; - int old_hi; - - sigprocmask(SIG_SETMASK, NULL, &old_mask); - split_sigset(old_mask, &old_hi, old_lo_p); - return old_hi; - } - - -/* Set/Get signal handlers -******************************************************************************* -*/ - -static void scm_handle_sig(int sig) -{ - /* fprintf(stderr, "scm_handle_sig(%d)\n", sig); */ - Spending_interruptsS |= (1< ignore, 1 => default, 2 => S48 VM */ - -/* Common code for two functions above. */ -static scheme_value scsh_ret_sig(int retval, struct sigaction *oldsa, - int *old_hc, int *oflags) -{ - if( retval ) { - *old_hc = -1; - *oflags = -1; - return ENTER_FIXNUM(errno); - } - if( oldsa->sa_handler == SIG_IGN ) *old_hc = 0; - else if( oldsa->sa_handler == SIG_DFL ) *old_hc = 1; - else if( oldsa->sa_handler == scm_handle_sig ) *old_hc = 2; - else *old_hc = ENTER_FIXNUM(3); /* Unknown signal handler. */ - - *oflags = oldsa->sa_flags; - return SCHFALSE; - } - - -scheme_value scsh_set_sig(int sig, int handler_code, int flags, - int *old_hc, int *oflags) -{ - struct sigaction new, old; - - sigemptyset(&new.sa_mask); /* WTF */ - new.sa_flags = flags; - - switch( handler_code ) { - case 0: new.sa_handler = SIG_IGN; break; - case 1: new.sa_handler = SIG_DFL; break; - case 2: new.sa_handler = scm_handle_sig; break; - default: - fprintf(stderr, "Impossible handler_code in set_sig_handler: %d\n", - handler_code); - exit(-1); - } - - return scsh_ret_sig(sigaction(sig, &new, &old), - &old, old_hc, oflags); - } - - -scheme_value scsh_get_sig(int signal, int *old_hc, int *oflags) -{ - struct sigaction old; - return scsh_ret_sig(sigaction(signal, NULL, &old), - &old, old_hc, oflags); - } - - -/* This guy is responsible for making the default action for a -** Unix signal happen. Because S48's signal handler system is -** interposed between delivery-to-the-process and -** delivery-to-the-scheme-handler, when the user sets a signal -** handler to default, we install a Scheme proc that calls this -** guy, instead of just slapping a SIGDFL in as the Unix handler. -** We only have to do this for signals whose default isn't "ignore," i.e.: -** Posix: SIGALRM SIGHUP SIGINT SIGQUIT SIGTERM SIGUSR1 SIGUSR2 -** Non-Posix: SIGINFO SIGPOLL SIGPROF SIGVTALRM SIGXCPU SIGXFSZ SIGIO -** This way, the S48 signal-blocking mechanism can work. -** -** Weird, I know. -*/ -void do_default_sigaction(int signal) -{ - sigset_t ss, old_ss; - struct sigaction default_action, old_action; - - /* fprintf(stderr, "Doing default for signal %d\n", signal); */ - - sigfillset(&ss); /* Block everyone. */ - sigprocmask(SIG_SETMASK, &ss, &old_ss); - - default_action.sa_handler = SIG_DFL; /* Set for default. */ - sigemptyset(&default_action.sa_mask); - default_action.sa_flags = 0; - sigaction(signal, &default_action, &old_action); - - raise(signal); /* Raise the signal. */ - sigdelset(&ss, signal); - sigprocmask(SIG_SETMASK, &ss, 0); /* Handle it. */ - - /* Most likely, we'll never get to here, as the default for - ** the signals we're handling is "terminate," but we'll play it safe. - */ - sigaction(signal, &old_action, 0); /* Restore old handler, */ - sigprocmask(SIG_SETMASK, &old_ss, 0); /* and mask. */ - } - - -/* Set up the Unix signal system the way we want it for scsh. */ - -void install_scsh_handlers(void) -{ - struct sigaction new; - int i; - - sigemptyset(&new.sa_mask); /* WTF */ - new.sa_handler = scm_handle_sig; - - for(i=max_sig; i>=0; i--) - if( sig2int[i] ) { - /* This is a signal we want the S48 interrupt system to handle. */ - sigaction(i, &new, 0); - } - - /* Turn off SIGPIPE and SIGSYS -- they are handled by synchronous exceptions - ** triggered by errno returns. - */ - new.sa_handler = SIG_IGN; - sigaction(SIGPIPE, &new, 0); -#ifdef SIGSYS - sigaction(SIGSYS, &new, 0); -#endif - } - -/* Sneak me the S48 interrupt handlers vector. */ -scheme_value get_int_handlers(void) -{ - return Sinterrupt_handlersS; - } diff --git a/scsh/sighandlers1.h b/scsh/sighandlers1.h deleted file mode 100644 index c3a5720..0000000 --- a/scsh/sighandlers1.h +++ /dev/null @@ -1,16 +0,0 @@ -/* Exports from sighandlers1.c */ - -int sig2interrupt(int signal); - -int set_procmask(int hi, int lo, int *old_lo_p); -int get_procmask(int *old_lo_p); - -scheme_value scsh_set_sig(int sig, int handler_code, int flags, - int *ohc, int *oflags); -scheme_value scsh_get_sig(int signal, int *handler_code, int *flags); - -void do_default_sigaction(int signal); - -void install_scsh_handlers(void); - -scheme_value get_int_handlers(void); diff --git a/scsh/signals1.h b/scsh/signals1.h deleted file mode 100644 index 64bf896..0000000 --- a/scsh/signals1.h +++ /dev/null @@ -1,4 +0,0 @@ -/* Exports from signals1.c */ - -const int sig2int[]; -const int max_sig; diff --git a/scsh/solaris/Makefile.inc b/scsh/solaris/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/solaris/bufpol.scm b/scsh/solaris/bufpol.scm deleted file mode 100644 index 1829ecb..0000000 --- a/scsh/solaris/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o100) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/solaris/errno.scm b/scsh/solaris/errno.scm deleted file mode 100644 index 43c1230..0000000 --- a/scsh/solaris/errno.scm +++ /dev/null @@ -1,178 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. -;;; Revised for Solaris 1994 by tvb@math.ufl.edu - -;;; These are the correct values for my SparcStation. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - (perm 1) ; Not Super-User - (noent 2) ; No Such File Or Directory - (srch 3) ; No Such Process - (intr 4) ; Interrupted System Call - (io 5) ; I/O Error - (nxio 6) ; No Such Device Or Address -; (2big 7) ; Arg List Too Long - (noexec 8) ; Exec Format Error - (badf 9) ; Bad File Number - (child 10) ; No Children - (again 11) ; Resource Temporarily Unavailable - (nomem 12) ; Not Enough Core - (acces 13) ; Permission Denied - (fault 14) ; Bad Address - - (notblk 15) ; Block Device Required - - ;; POSIX: - (busy 16) ; Mount Device Busy - (exist 17) ; File Exists - (xdev 18) ; Cross-Device Link - (nodev 19) ; No Such Device - (notdir 20) ; Not A Directory - (isdir 21) ; Is A Directory - (inval 22) ; Invalid Argument - (nfile 23) ; File Table Overflow - (mfile 24) ; Too Many Open Files - (notty 25) ; Inappropriate Ioctl For Device -;; - (txtbsy 26) ; Text File Busy - - ;; POSIX: - (fbig 27) ; File Too Large - (nospc 28) ; No Space Left On Device - (spipe 29) ; Illegal Seek - (rofs 30) ; Read Only File System - (mlink 31) ; Too Many Links - (pipe 32) ; Broken Pipe - (dom 33) ; Math Arg Out Of Domain Of Func - (range 34) ; Math Result Not Representable -;; - (nomsg 35) ; No Message Of Desired Type - (idrm 36) ; Identifier Removed - (chrng 37) ; Channel Number Out Of Range - (l2nsync 38) ; Level 2 Not Synchronized - (l3hlt 39) ; Level 3 Halted - (l3rst 40) ; Level 3 Reset - (lnrng 41) ; Link Number Out Of Range - (unatch 42) ; Protocol Driver Not Attached - (nocsi 43) ; No Csi Structure Available - (l2hlt 44) ; Level 2 Halted - - ;; POSIX: - (deadlk 45) ; Deadlock Condition. - (nolck 46) ; No Record Locks Available. - -;; - (canceled 47) ; Operation Canceled - (notsup 48) ; Operation Not Supported - - ; Convergent Error Returns - (bade 50) ; Invalid Exchange - (badr 51) ; Invalid Request Descriptor - (xfull 52) ; Exchange Full - (noano 53) ; No Anode - (badrqc 54) ; Invalid Request Code - (badslt 55) ; Invalid Slot - (deadlock 56) ; File Locking Deadlock Error - - (bfont 57) ; Bad Font File Fmt - - ; Stream Problems - (nostr 60) ; Device Not A Stream - (nodata 61) ; No Data (for No Delay Io) - (time 62) ; Timer Expired - (nosr 63) ; Out Of Streams Resources - - (nonet 64) ; Machine Is Not On The Network - (nopkg 65) ; Package Not Installed - (remote 66) ; The Object Is Remote - (nolink 67) ; The Link Has Been Severed - (adv 68) ; Advertise Error - (srmnt 69) ; Srmount Error - - (comm 70) ; Communication Error On Send - (proto 71) ; Protocol Error - (multihop 74) ; Multihop Attempted - (badmsg 77) ; Trying To Read Unreadable Message - (nametoolong 78) ; Path Name Is Too Long (POSIX) - (overflow 79) ; Value Too Large To Be Stored In Data Type - (notuniq 80) ; Given Log. Name Not Unique - (badfd 81) ; F.D. Invalid For This Operation - (remchg 82) ; Remote Address Changed - - ; Shared Library Problems - (libacc 83) ; Can'T Access A Needed Shared Lib. - (libbad 84) ; Accessing A Corrupted Shared Lib. - (libscn 85) ; .Lib Section In A.Out Corrupted. - (libmax 86) ; Attempting To Link In Too Many Libs. - (libexec 87) ; Attempting To Exec A Shared Library. - (ilseq 88) ; Illegal Byte Sequence. - (nosys 89) ; Unsupported File System Operation (POSIX) - (loop 90) ; Symbolic Link Loop - (restart 91) ; Restartable System Call - (strpipe 92) ; If Pipe/Fifo, Don'T Sleep In Stream Head - (notempty 93) ; Directory Not Empty (POSIX) - (users 94) ; Too Many Users (for Ufs) - - ; Bsd Networking Software -; Argument Errors - (notsock 95) ; Socket Operation On Non-Socket - (destaddrreq 96) ; Destination Address Required - (msgsize 97) ; Message Too Long - (prototype 98) ; Protocol Wrong Type For Socket - (noprotoopt 99) ; Protocol Not Available - (protonosupport 120) ; Protocol Not Supported - (socktnosupport 121) ; Socket Type Not Supported - (opnotsupp 122) ; Operation Not Supported On Socket - (pfnosupport 123) ; Protocol Family Not Supported - (afnosupport 124) ; Address Family Not Supported By -; Protocol Family - (addrinuse 125) ; Address Already In Use - (addrnotavail 126) ; Can'T Assign Requested Address -; Operational Errors - (netdown 127) ; Network Is Down - (netunreach 128) ; Network Is Unreachable - (netreset 129) ; Network Dropped Connection Because - ; Of Reset - (connaborted 130) ; Software Caused Connection Abort - (connreset 131) ; Connection Reset By Peer - (nobufs 132) ; No Buffer Space Available - (isconn 133) ; Socket Is Already Connected - (notconn 134) ; Socket Is Not Connected -; Xenix Has 135 - 142 - (shutdown 143) ; Can'T Send After Socket Shutdown - (toomanyrefs 144) ; Too Many References: Can'T Splice - (timedout 145) ; Connection Timed Out - (connrefused 146) ; Connection Refused - (hostdown 147) ; Host Is Down - (hostunreach 148) ; No Route To Host - (wouldblock 11) ; (again) - (already 149) ; Operation Already In Progress - (inprogress 150) ; Operation Now In Progress - - ; Sun Network File System - (stale 151) ; Stale Nfs File Handle -) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Non-POSIX messages -; Some of these Solaris messages are better. Some are stupid. -; -; Error Solaris POSIX -; perm Not super-user Operation not permitted -; intr Interrupted system call Interrupted function call -; io I/O error Input/output error -; badf Bad file number Bad file descriptor -; child No children No child processes -; nomem Not enough core Not enough space -; busy Mount device busy Resource busy -; xdev Cross-device link Improper link -; nfile File table overflow Too many open files in system -; notty Inappropriate ioctl for device Inappropriate I/O control operation -; spipe Illegal seek Invalid seek -; dom Math arg out of domain of func Domain error -; deadlk Deadlock condition Resource deadlock avoided -; nolck No record locks available No locks available diff --git a/scsh/solaris/fdflags.scm b/scsh/solaris/fdflags.scm deleted file mode 100644 index 7993307..0000000 --- a/scsh/solaris/fdflags.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. -;;; Modified for Solaris by tvb@math.ufl.edu - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #x0100) - (exclusive #x0400) - (no-control-tty #x800) ;claims to be POSIX - (nonblocking #x80) ;claims to be POSIX - (truncate #x0200) - -;;; Not POSIX. - (no-delay 4) - (sync #x10)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - - -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-owner 23) ; F_GETOWN (Not Posix) - (set-owner 24) ; F_SETOWN (Not Posix) - (get-record-lock 5) ; F_GETLK - (set-record-lock-noblock 6) ; F_SETLK - (set-record-lock 7)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/solaris/libansi.c b/scsh/solaris/libansi.c deleted file mode 100644 index bcd6e0e..0000000 --- a/scsh/solaris/libansi.c +++ /dev/null @@ -1,3 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -*/ diff --git a/scsh/solaris/netconst.scm b/scsh/solaris/netconst.scm deleted file mode 100644 index 845e94e..0000000 --- a/scsh/solaris/netconst.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 2) ; stream socket -(define socket-type/datagram 1) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -;(define ip/options 1) ; set/get IP per-packet options -;(define ip/time-to-live 2) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline - socket/use-privileged -; socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type -; ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/solaris/packages.scm b/scsh/solaris/packages.scm deleted file mode 100644 index 71ef64b..0000000 --- a/scsh/solaris/packages.scm +++ /dev/null @@ -1,160 +0,0 @@ -;;; Interfaces and packages for the Sun specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -(define-interface solaris-fdflags-extras-interface - (export open/no-delay - open/sync - fcntl/get-owner - fcntl/set-owner - )) - -(define-interface solaris-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/adv - errno/afnosupport - errno/already - errno/bade - errno/badfd - errno/badmsg - errno/badr - errno/badrqc - errno/badslt - errno/bfont - errno/canceled - errno/chrng - errno/comm - errno/connaborted - errno/connrefused - errno/connreset - errno/deadlock - errno/destaddrreq - errno/hostdown - errno/hostunreach - errno/idrm - errno/ilseq - errno/inprogress - errno/isconn - errno/l2hlt - errno/l2nsync - errno/l3hlt - errno/l3rst - errno/libacc - errno/libbad - errno/libexec - errno/libmax - errno/libscn - errno/lnrng - errno/loop - errno/msgsize - errno/multihop - errno/netdown - errno/netreset - errno/netunreach - errno/noano - errno/nobufs - errno/nocsi - errno/nodata - errno/nolink - errno/nomsg - errno/nonet - errno/nopkg - errno/noprotoopt - errno/nosr - errno/nostr - errno/notblk - errno/notconn - errno/notsock - errno/notsup - errno/notuniq - errno/opnotsupp - errno/overflow - errno/pfnosupport - errno/proto - errno/protonosupport - errno/prototype - errno/remchg - errno/remote - errno/restart - errno/shutdown - errno/socktnosupport - errno/srmnt - errno/stale - errno/strpipe - errno/time - errno/timedout - errno/toomanyrefs - errno/txtbsy - errno/unatch - errno/users - errno/wouldblock - errno/xfull - )) - -(define-interface solaris-signals-extras-interface - (export signal/bus - signal/cld - signal/emt - signal/freeze - signal/io - signal/iot - signal/lwp - signal/poll - signal/prof - signal/pwr - signal/sys - signal/thaw - signal/trap - signal/urg - signal/vtalrm - signal/waiting - signal/winch - signal/xcpu - signal/xfsz - )) - -(define-interface solaris-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline - socket/use-privileged - socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options - ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface solaris-extras-interface - (compound-interface solaris-errno-extras-interface - solaris-fdflags-extras-interface - solaris-network-extras-interface - solaris-signals-extras-interface)) - -(define-interface solaris-defs-interface - (compound-interface solaris-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure solaris-defs solaris-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface solaris-extras-interface) -(define os-dependent solaris-defs) diff --git a/scsh/solaris/signals.scm b/scsh/solaris/signals.scm deleted file mode 100644 index c50914d..0000000 --- a/scsh/solaris/signals.scm +++ /dev/null @@ -1,54 +0,0 @@ -;;; Signal constant definitions for Sun4 -;;; Copyright (c) 1994 by Olin Shivers. -;;; Modified for Solaris by tvb@math.ufl.edu - -;; Adapted from signal.h - tvb - -(define-enum-constants signal - ;; POSIX - (hup 1) ; Hangup - (int 2) ; Interrupt (Rubout) - (quit 3) ; Quit (Ascii Fs) - (ill 4) ; Illegal Instruction (Not Reset When Caught) -;; - (trap 5) ; Trace Trap (Not Reset When Caught) - (iot 6) ; Iot Instruction - (abrt 6) ; Used By Abort, Replace SIGIOT In The Future (POSIX) - (emt 7) ; Emt Instruction - (fpe 8) ; Floating Point Exception (POSIX) - (kill 9) ; Kill (Cannot Be Caught Or Ignored) (POSIX) - (bus 10) ; Bus Error - (segv 11) ; Segmentation Violation (POSIX) - (sys 12) ; Bad Argument To System Call - (pipe 13) ; Write On A Pipe With No One To Read It (POSIX) - (alrm 14) ; Alarm Clock - (term 15) ; Software Termination Signal From Kill (POSIX) - (usr1 16) ; User Defined Signal 1 (POSIX) - (usr2 17) ; User Defined Signal 2 (POSIX) - (cld 18) ; Child Status Change - (chld 18) ; Child Status Change Alias (Posix) - (pwr 19) ; Power-Fail Restart - (winch 20) ; Window Size Change - (urg 21) ; Urgent Socket Condition - (poll 22) ; Pollable Event Occured - (io 22) ; Socket I/O Possible (poll Alias) - (stop 23) ; Stop (Cannot Be Caught Or Ignored) (POSIX) - (tstp 24) ; User Stop Requested From Tty (POSIX) - (cont 25) ; Stopped Process Has Been Continued (POSIX) - (ttin 26) ; Background Tty Read Attempted (POSIX) - (ttou 27) ; Background Tty Write Attempted (POSIX) - (vtalrm 28) ; Virtual Timer Expired - (prof 29) ; Profiling Timer Expired - (xcpu 30) ; Exceeded Cpu Limit - (xfsz 31) ; Exceeded File Size Limit - (waiting 32) ; Process's Lwps Are Blocked - (lwp 33) ; Special Signal Used By Thread Library - (freeze 34) ; Special Signal Used By Cpr - (thaw 35) ; Special Signal Used By Cpr - (cancel 36) ; Thread cancellation signal used by libthread - ) - -(define signals-ignored-by-default - (list signal/chld signal/cont ; These are Posix. - signal/pwr signal/urg signal/winch ; These are Solaris. - signal/waiting signal/lwp signal/freeze signal/thaw signal/cancel)) diff --git a/scsh/solaris/sigset.h b/scsh/solaris/sigset.h deleted file mode 100644 index 429f675..0000000 --- a/scsh/solaris/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) ((maskp)->__sigbits[0]=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=((mask).__sigbits[0]>>24)&0xff), \ - (*(lop)=((mask).__sigbits[0]&0xffffff))) diff --git a/scsh/solaris/stdio_dep.c b/scsh/solaris/stdio_dep.c deleted file mode 100644 index 4913d14..0000000 --- a/scsh/solaris/stdio_dep.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/solaris/stdio_dep.h b/scsh/solaris/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/solaris/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/solaris/sysdep.h b/scsh/solaris/sysdep.h deleted file mode 100644 index a7644ba..0000000 --- a/scsh/solaris/sysdep.h +++ /dev/null @@ -1 +0,0 @@ -#undef HAVE_DLOPEN diff --git a/scsh/solaris/time_dep.scm b/scsh/solaris/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/solaris/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/solaris/time_dep1.c b/scsh/solaris/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/solaris/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/solaris/tty-consts.scm b/scsh/solaris/tty-consts.scm deleted file mode 100644 index 8bf6dc1..0000000 --- a/scsh/solaris/tty-consts.scm +++ /dev/null @@ -1,215 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for Solaris 2.x, -;;; and are taken from /usr/include/sys/termio.h -;;; and /usr/include/sys/termios.h. - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 5) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 10) ; ^z isig -(define ttychar/start 8) ; ^q ixon, ixoff -(define ttychar/stop 9) ; ^s ixon, ixoff -(define ttychar/min 4) ; !icanon ; Not exported -(define ttychar/time 5) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 14) ; ^w icanon -(define ttychar/reprint 12) ; ^r icanon -(define ttychar/literal-next 15) ; ^v iexten -(define ttychar/discard 13) ; ^o iexten -(define ttychar/delayed-suspend 11) ; ^y isig -(define ttychar/eol2 6) ; icanon - -;;; 4.3+BSD -(define ttychar/status #f) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 19) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #x00)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #o00001) ; ignbrk -(define ttyin/interrupt-on-break #o00002) ; brkint -(define ttyin/ignore-bad-parity-chars #o00004) ; ignpar -(define ttyin/mark-parity-errors #o00010) ; parmrk -(define ttyin/check-parity #o00020) ; inpck -(define ttyin/7bits #o00040) ; istrip -(define ttyin/nl->cr #o00100) ; inlcr -(define ttyin/ignore-cr #o00200) ; igncr -(define ttyin/cr->nl #o00400) ; icrnl -(define ttyin/output-flow-ctl #o02000) ; ixon -(define ttyin/input-flow-ctl #o10000) ; ixoff - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #o4000) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #o20000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #o1000) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #o000010) ; ocrnl -(define ttyout/fill-w/del #o000200) ; ofdel -(define ttyout/delay-w/fill-char #o000100) ; ofill -(define ttyout/uppercase #o000002) ; olcuc -(define ttyout/nl-does-cr #o000040) ; onlret -(define ttyout/no-col0-cr #o000020) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #o000400) ; mask (nldly) -(define ttyout/nl-delay0 #o000000) -(define ttyout/nl-delay1 #o000400) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #o014000) ; mask (tabdly) -(define ttyout/tab-delay0 #o000000) -(define ttyout/tab-delay1 #o004000) ; tty 37 -(define ttyout/tab-delay2 #o010000) -(define ttyout/tab-delayx #o014000) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #o003000) ; mask (crdly) -(define ttyout/cr-delay0 #o000000) -(define ttyout/cr-delay1 #o001000) ; tn 300 -(define ttyout/cr-delay2 #o002000) ; tty 37 -(define ttyout/cr-delay3 #o003000) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #o040000) ; mask (vtdly) -(define ttyout/vtab-delay0 #o000000) -(define ttyout/vtab-delay1 #o040000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #o020000) ; mask (bsdly) -(define ttyout/bs-delay0 #o000000) -(define ttyout/bs-delay1 #o020000) - -;;; Form-feed delay -(define ttyout/ff-delay #o100000) ; mask (ffdly) -(define ttyout/ff-delay0 #o000000) -(define ttyout/ff-delay1 #o100000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #o00060) ; csize: character size mask -(define ttyc/char-size5 #o00000) ; 5 bits (cs5) -(define ttyc/char-size6 #o00020) ; 6 bits (cs6) -(define ttyc/char-size7 #o00040) ; 7 bits (cs7) -(define ttyc/char-size8 #o00060) ; 8 bits (cs8) -(define ttyc/2-stop-bits #o00100) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #o00200) ; cread: Enable receiver. -(define ttyc/enable-parity #o00400) ; parenb -(define ttyc/odd-parity #o01000) ; parodd -(define ttyc/hup-on-close #o02000) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #o04000) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #o020) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #o040) ; echok: Echo nl after line kill -(define ttyl/echo #o010) ; echo: Enable echoing -(define ttyl/echo-nl #o100) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #o002) ; icanon: Canonicalize input -(define ttyl/enable-signals #o001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #o100000) ; iexten: Enable extensions -(define ttyl/ttou-signal #o400) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #o200) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #o04000); echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #o02000); echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #o01000); echoctl: echo control chars as "^X" -(define ttyl/flush-output #o20000); flusho: output is being flushed -(define ttyl/reprint-unread-chars #o40000); pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #o4) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 21518) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 21519) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 21520) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/solaris/waitcodes.scm b/scsh/solaris/waitcodes.scm deleted file mode 100644 index 09c832c..0000000 --- a/scsh/solaris/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for NeXTSTEP. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (zero? (bitwise-and #xFF status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (not (zero? (bitwise-and status #x40))) - (bitwise-and #x7F (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (and (not (zero? (bitwise-and status #xFF))) ; Didn't exit. - (zero? (bitwise-and status #x40)) ; Not suspended. - (bitwise-and status #x7F))) - - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/startup.scm b/scsh/startup.scm deleted file mode 100644 index ac8b2d7..0000000 --- a/scsh/startup.scm +++ /dev/null @@ -1,64 +0,0 @@ -;;; Scsh start-up code. -;;; Copyright (c) 1995 by Olin Shivers. - -;;; A scsh starter takes the command line args, parses them, -;;; initialises the scsh system, and either starts up a repl loop -;;; or executes the -s script. - -(define (make-scsh-starter) - (let ((context (user-context))) - (lambda (args) - (parse-switches-and-execute args context)))) - - -;;; Had to define these as the ones in s48's build.scm do not properly -;;; initialise ERROR-OUTPUT-PORT to stderr -- this is a bug in the vm's -;;; handoff to the very first Scheme form (it passes two ports -- not three). -;;; Until Kelsey fixes these, we hack it with these replacements, which -;;; invoke INIT-SCSH-HINDBRAIN, which re-initialises the I/O system to be -;;; what you wanted. - -;;; WRITE-IMAGE calls the starter after installing a fatal top-level -;;; error handler. MAKE-SCSH-STARTER shadows it in the interactive case. - -(define (really-dump-scsh-program start filename) - (let ((filename (translate filename))) - (display (string-append "Writing " filename) (command-output)) - (newline (command-output)) - (flush-the-symbol-table!) ;Gets restored at next use of string->symbol - (write-image filename - (scsh-stand-alone-resumer start) - "") - #t)) - - -;;; This one relies on the scsh top-level command-line switch parser -;;; to decide whether to do the scsh-var inits quietly or with warnings. - -(define (dump-scsh fname) - (really-dump-scsh-program (make-scsh-starter) fname)) - -;;; Init the scsh run-time's vars quietly before running the program. -;;; This is what we export to the user for his programs. - -(define (dump-scsh-program start filename) - (really-dump-scsh-program (lambda (args) - (init-scsh-vars #t) ; Do it quietly. - (start args)) - filename)) - - -(define (scsh-stand-alone-resumer start) - (usual-resumer ;sets up exceptions, interrupts, and current input & output - (lambda (args) ; VM gives us our args, but not our program. - (init-scsh-hindbrain #t) ; Whatever. Relink & install scsh's I/O system. - (call-with-current-continuation - (lambda (halt) - (set! %vm-prog-args (cons "scsh" args)) ; WRONG -- use image. - (set-command-line-args! %vm-prog-args) - (with-handler (simple-condition-handler halt (error-output-port)) - (lambda () - (let ((exit-val (start (command-line)))) - (if (integer? exit-val) exit-val 0))))))))) ; work around bug. - -(define %vm-prog-args #f) diff --git a/scsh/static.scm.in b/scsh/static.scm.in deleted file mode 100644 index af71e7b..0000000 --- a/scsh/static.scm.in +++ /dev/null @@ -1,899 +0,0 @@ -#!@prefix@/lib/scsh/scshvm \ --o @prefix@/lib/scsh/scshvm -h 8000000 -i @prefix@/lib/scsh/scsh.image -lm @prefix@/lib/scsh/vm/ps-interface.scm -lm @prefix@/lib/scsh/vm/interfaces.scm -lm @prefix@/lib/scsh/vm/package-defs.scm -lm @prefix@/lib/scsh/vm/s48-package-defs.scm -dm -m static-heaps -e static-heap-linker -s -!# - -#! -For testing load this at a scsh prompt -,config ,load ../vm/ps-interface.scm -,config ,load ../vm/interfaces.scm -,config ,load ../vm/package-defs.scm -,config ,load ../vm/s48-package-defs.scm -,config ,load static.scm -,load-package static-heaps -,in static-heaps -!# - -;;; Static heap package for the Scheme Shell -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1995-1996 by Brian D. Carlstrom. -;;; -;;; based on Scheme48 implementation. -;;; Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees. -;;; -;;; The business of this package is converting a Scheme 48 bytecode -;;; image as embodied in a .image file to a C representation. This C -;;; code is then compiled and linked in with a virtual machine. One -;;; pleasant side effect of this is reduced startup times. Another -;;; good thing is that immutable parts of the image can be shared -;;; between processes. - -(define-structure static-heaps - (export static-heap-linker) - (open scheme heap memory data stob struct - heap-extra - vm-architecture - formats - enumerated - signals - tables - defrec-package - scsh) - (begin - -;;; static-heap-linker -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; the external entry point -;;; real work in static-heap-linker1 -;;; argl is a list of the command line arguments - (define (static-heap-linker argl) - (static-heap-linker1 (parse-options argl)) - (exit 0)) - -;;; parse-options -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; parses the command line options -;;; returns them in an options structure - (define (parse-options argl) - (let ((options (make-options))) - (let loop ((args (cdr argl))) - (cond ((null? args) - (cond ((not (options:output-executible options)) - (display "error: -o is a required argument") - (newline) - (usage (car argl))) - ((not (options:input-image options)) - (display "error: -i is a required argument") - (newline) - (usage (car argl))))) - ((equal? (car args) "-o") - (cond ((not (null? (cdr args))) - (set-options:output-executible options (cadr args)) - (loop (cddr args))) - (else - (display "error: -o requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "-i") - (cond ((not (null? (cdr args))) - (set-options:input-image options (cadr args)) - (loop (cddr args))) - (else - (display "error: -i requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "--temp") - (cond ((not (null? (cdr args))) - (set-options:temp-dir options (cadr args)) - (loop (cddr args))) - (else - (display "error: --temp requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "--cc") - (cond ((not (null? (cdr args))) - (set-options:cc-command options (cadr args)) - (loop (cddr args))) - (else - (display "error: --cc requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "--ld") - (cond ((not (null? (cdr args))) - (set-options:ld-command options (cadr args)) - (loop (cddr args))) - (else - (display "error: --ld requires argument") (newline) - (usage (car argl))))) - ((equal? (car args) "--libs") - (cond ((not (null? (cdr args))) - (set-options:libraries options (cadr args)) - (loop (cddr args))) - (else - (display "error: --libs requires argument") (newline) - (usage (car argl))))) - (else - (format #t "error: unknown argument ~a" (car args)) - (newline) - (usage (car argl))))) - (set-options:temp-dir - options - (or (options:temp-dir options) - (getenv "TMPDIR") - "@TMPDIR@")) - (set-options:cc-command - options - (or (options:cc-command options) - (getenv "CC") - "@CC@ @CFLAGS@")) - (set-options:ld-flags - options - (or (options:ld-flags options) - (getenv "LDFLAGS") - "@LDFLAGS@")) - (set-options:libraries - options - (or (options:libraries options) - (getenv "LIBS") - "@LIBS@")) - options)) - -;;; usage reporting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define (usage program-name) - (format #t - (string-append - "usage: ~a -i image -o executible~%" - " [--temp directory]~%" - " [--cc command]~%" - " [--ld command]~%" - " [--libs libraries]~%") - program-name) - (exit 1)) - -;;; options structure -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-record options - (input-image #f) ; the input scheme image file - (temp-dir #f) ; place for intermediate .c .o files - (output-executible #f) ; the output executible file - (cc-command #f) ; command to compile a .c file - (ld-flags #f) ; flags needed to link executible - (libraries #f) ; linbraries need to link executible - ) - -;;; heap structure -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-record heap - (length 0) - (objects '()) - ) - -;;; static-heap-linker1 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define (static-heap-linker1 options) - - ;;; munge some options into a more usable form - (set-options:temp-dir - options - (format #f "~a/scsh~s" (options:temp-dir options) (pid))) - (set-options:output-executible - options - (string-append (cwd) "/" (options:output-executible options))) - - ;;; Read the image - (let ((start ; entry point of image - (read-heap-image (options:input-image options)))) - - ;;; Process the image - (receive (pure impure reloc externs) - (create-heaps-and-tables) - - ;;; Prepare for output - ;;; if directory exists blow it away - ;;; useful for repeated runs from within same scsh process - (if (file-exists? (options:temp-dir options)) - (if (file-directory? (options:temp-dir otions)) - (with-cwd (options:temp-dir options) - (map delete-file (directory-files - (options:temp-dir options) #t))) - (delete-file (options:temp-dir options)))) - (create-directory (options:temp-dir options) #o755 #t) - - ;;; Process the info we gather to make it the output file - (with-cwd (options:temp-dir options) - (write-c-header-file pure impure externs) - (compile-main-c-file start reloc options) - (compile-c-image pure impure reloc externs options) - (link-files options) - (map delete-file (directory-files - (options:temp-dir options) #t))) - (delete-directory (options:temp-dir options))))) - -;;; read-heap-image -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; reads the scheme48 bytecode image into memory. -;;; returns entry point. - (define (read-heap-image infile) - (let ((bytes (file-info:size (file-info infile)))) - (init (inexact->exact (floor (* 1.1 bytes))) infile))) - ;; XXX the 1.1 is because we need a little extra space for find-all-xs - -;;; create-heaps-and-tables -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Walks over the in memory scheme 48 heap image. -;;; Returns -;;; 1.) vector of heaps describing pure heap objects -;;; 2.) vector of heaps describing impure heap objects -;;; 3.) vector of tables descibing relocations -;;; 4.) table of external references - (define (create-heaps-and-tables) - (let* ((n (nchunks)) ; number of chunks we have in image - ( pure (make-vector n)) ; immutable bits of each chunk - (impure (make-vector n)) ; mutable bits of each chunk - (reloc (make-vector n)) ; relocation information - (externs (make-table))) ; external references - ;; create empty heaps for each chunk - (let loop ((i 0)) - (cond ((not (= i n)) - (vector-set! pure i (make-heap)) - (vector-set! impure i (make-heap)) - (vector-set! reloc i (make-table)) - (loop (+ i 1))))) - ;; here is where we iterate through all the bits - ;; we construct our own data structures describing the layout - (scsh-for-each-stored-object - (lambda (chunk) - (display ".")) - (lambda (chunk x len) - (let* ((heap ; choose the appropriate heap - (vector-ref (if (mutable? x) impure pure) chunk))) - ;; add the relocation information - (table-set! (vector-ref reloc chunk) x (heap:length heap)) - ;; add object reference to heap chunk - (set-heap:objects heap (cons x (heap:objects heap))) - ;; update current heap chunk length - (set-heap:length heap (+ len (heap:length heap))) - ;; if we have an external reference handle add it to the list - (if (= (header-type (stob-header x)) (enum stob external)) - (table-set! externs - (external-value x) - (vm-string->string (external-name x)))))) - (lambda (chunk) 'foo)) - (newline) - ;; put all the heaps in the correct order - (let loop ((i 0)) - (cond ((not (= i n)) - (let ((p (vector-ref pure i)) - (i (vector-ref impure i))) - (set-heap:objects p (reverse (heap:objects p))) - (set-heap:objects i (reverse (heap:objects i)))) - (loop (+ i 1))))) - (values pure impure reloc externs))) - -;;; vm-string->string -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; converts a vm-string to a scheme one that we can handle - (define (vm-string->string x) - (cond ((vm-string? x) - (let ((len (vm-string-length x))) - (let loop ((i 0) - (l '())) - (cond ((= i len) - (list->string (reverse l))) - (else - (loop (+ i 1) (cons (vm-string-ref x i) l))))))) - (else - (message x " is not a vm-string")))) - -;;; write-c-header-file -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; declares the c long arrays for each heap chunk -;;; declares the extern references to other c functions - (define (write-c-header-file pure impure externs) - (call-with-output-file "static.h" - (lambda (port) - (format port "/* Static Heap File Automatically Generated~%") - (format port " * by scsh/static.scm */~%") - ;; declare the long arrays for each heap chunk - (let ((n (nchunks))) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "extern const long p~s[~s];~%" i - (quotient (heap:length (vector-ref pure i)) 4))) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "extern long i~s[~s];~%" i - (quotient (heap:length (vector-ref impure i)) 4)))) - ;; declare the external references - (table-walk - (lambda (address name) - (format port "const extern ~a();~%" name)) - externs) - ))) - -;;; compile-main-c-file -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; creates the top level interfaces that scheme48 wants to see -;;; p_count i_count -;;; number of chunks -;;; p_areas i_areas -;;; pointers to each chunk -;;; p_sizes i_sizes -;;; sizes of each chunk -;;; entry -;;; the starting entry point - (define (compile-main-c-file start reloc options) - (let ((n (nchunks)) - (cc (append (line->list (options:cc-command options)) '(-c)))) - (call-with-output-file "static.c" - (lambda (port) - (format port "#include \"static.h\"~%") - (format port "const long p_count = ~s;~%" n) - (format port "const long i_count = ~s;~%" n) - - (format port "const long * const p_areas[~s] = {" n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "(const long *) &p~s, " i)) - (format port "};~%") - (format port "long * const i_areas[~s] = {" n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "(long *) &i~s, " i)) - (format port "};~%") - - (format port "const long p_sizes[~s] = {" n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "sizeof(p~s), " i)) - (format port "};~%") - (format port "const long i_sizes[~s] = {" n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "sizeof(i~s), " i)) - (format port "};~%") - - (display "const long entry = " port) - (scsh-emit-descriptor start reloc port) - (write-char #\; port) - (newline port))) - (message (append cc '("static.c"))) - (run (,@(append cc '("static.c")))))) - -;;; compile-c-image -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; responsible for writing and compiling the pure and impure heaps - (define (compile-c-image pure impure reloc externs options) - (compile-c-image1 pure "p" "const " reloc externs options) - (compile-c-image1 impure "i" "" reloc externs options)) - -;;; compile-c-image1 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; writes and compiles the c long array - (define (compile-c-image1 heap name const reloc externs options) - (let* ((n (nchunks)) - (process #f) - (cc (append (line->list (options:cc-command options)) '(-c)))) - ;; iterate over all the chunks for this part of heap - (let chunk-loop ((c 0)) - (cond ((not (= c n)) - (let ((filename (format #f "static-~a~s.c" name c))) - (call-with-output-file filename - (lambda (port) - (format port "#include \"static.h\"~%") - (format port "~a long ~a~s[]={~%" const name c) - (let ((heap (vector-ref heap c))) - ;; iterate over each object - (let heap-loop ((l (heap:objects heap))) - (cond ((not (null? l)) - (scsh-emit-initializer - (car l) reloc externs port) - (heap-loop (cdr l)))))) - (display "};" port) - (newline port))) - ;; wait for last compile before starting new one - (if process - (wait process)) - (message (append cc (list filename))) - (set! process (& (,@(append cc (list filename))))) - (chunk-loop (+ 1 c)))) - (else - (wait process)))))) - -;;; link-files -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; links the .o's from compile-c-files -;;; uses the provided flags and libraries -;;; produces outfile as executible - (define (link-files options) - (let ((n (nchunks)) - (ld (append (line->list (options:cc-command options)) - (line->list (options:ld-flags options)) - `(-o ,(options:output-executible options)))) - (libs (line->list (options:libraries options)))) - (message (append ld - (let loop ((i 0) - (l '())) - (cond ((not (= i n)) - (loop (+ i 1) - (cons - (format #f "static-i~s.o" i) - (cons - (format #f "static-p~s.o" i) - l)))) - (else - (reverse - (cons "static.o" - l))))) - '("@prefix@/lib/scsh/libscshvm.a") - libs)) - (run (,@(append - ld - (let loop ((i 0) - (l '())) - (cond ((not (= i n)) - (loop (+ i 1) - (cons - (format #f "static-i~s.o" i) - (cons - (format #f "static-p~s.o" i) - l)))) - (else - (reverse - (cons "static.o" - l))))) - '("@prefix@/lib/scsh/libscshvm.a") - libs))))) - -;;; scsh-emit-initializer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; see scheme48 emit-initialize below - (define (scsh-emit-initializer x reloc externs port) - ;; emit the header - (write-hex port (stob-header x)) - ;; handle descriptor vectors and vm-strings. - ;; everything else is a byte vector - (cond ((d-vector? x) - (scsh-emit-d-vector-initializer x reloc port)) - ((vm-string? x) - (scsh-emit-vm-string-initializer x port)) - (else - (scsh-emit-b-vector-initializer x externs port))) - (if *comments?* - (begin (display " /* " port) - (writex x port) - (display " */" port))) - (newline port)) - -;;; scsh-emit-d-vector -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; descriptor vectors are pretty easy given scsh-emit-descriptor - (define (scsh-emit-d-vector-initializer x reloc port) - (let ((len (d-vector-length x))) - (do ((i 0 (+ i 1))) - ((= i len)) - (scsh-emit-descriptor (d-vector-ref x i) reloc port) - (write-char #\, port)))) - -;;; scsh-emit-descriptor -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; for descrriptors we consult the relocation table - (define (scsh-emit-descriptor x reloc port) - (if (stob? x) - (let ((n (chunk-number x))) - (display "(long)(&" port) - (if (immutable? x) - (display "p" port) - (display "i" port)) - (display n port) - (display "[" port) - (display (quotient (table-ref (vector-ref reloc n) x) 4) port) - (display "])+7" port)) - (format port - (if (negative? x) "-0x~a" "0x~a") - (number->string (abs x) 16)))) - -;;; scsh-emit-vm-string-initializer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; vm-strings are converted to numbers and byte order adjusted - (define (scsh-emit-vm-string-initializer x port) - (let* ((len (vm-string-length x)) ; end is jawilson style hack - (end (- (cells->bytes (bytes->cells (+ len 1))) 4))) - (do ((i 0 (+ i 4))) - ((= i end) - (case (- len end) - ((0) - (write-hex port 0)) - ((1) - (write-hex - port - (net-to-host-32 (arithmetic-shift - (char->ascii (vm-string-ref x i)) 24)))) - ((2) - (write-hex - port - (net-to-host-32 - (bitwise-ior - (arithmetic-shift - (char->ascii (vm-string-ref x i)) 24) - (arithmetic-shift - (char->ascii (vm-string-ref x (+ i 1))) 16))))) - ((3) - (write-hex - port - (net-to-host-32 - (bitwise-ior - (bitwise-ior - (arithmetic-shift - (char->ascii (vm-string-ref x i)) 24) - (arithmetic-shift - (char->ascii (vm-string-ref x (+ i 1))) 16)) - (arithmetic-shift - (char->ascii (vm-string-ref x (+ i 2))) 8))))))) - (write-hex port - (net-to-host-32 (bitwise-ior - (bitwise-ior - (arithmetic-shift - (char->ascii - (vm-string-ref x i)) 24) - (arithmetic-shift - (char->ascii - (vm-string-ref x (+ i 1))) 16)) - (bitwise-ior - (arithmetic-shift - (char->ascii - (vm-string-ref x (+ i 2))) 8) - (char->ascii - (vm-string-ref x (+ i 3)))))) - )))) - -;;; scsh-emit-b-vector-initializer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; byte vectors are byte order adjusted too - (define (scsh-emit-b-vector-initializer x externs port) - (cond ((and (code-vector? x) - (table-ref externs x)) => - (lambda (name) - (format port "(long) *~a," name))) - (else - (let* ((len (b-vector-length x)) ;end is jawilson style hack - (end (- (cells->bytes (bytes->cells (+ len 1))) 4))) - (do ((i 0 (+ i 4))) - ((= i end) - (case (- len end) - ((1) - (write-hex - port - (net-to-host-32 - (arithmetic-shift (b-vector-ref x i) 24)))) - ((2) - (write-hex - port - (net-to-host-32 - (bitwise-ior - (arithmetic-shift (b-vector-ref x i) 24) - (arithmetic-shift (b-vector-ref x (+ i 1)) 16))))) - ((3) - (write-hex - port - (net-to-host-32 - (bitwise-ior - (bitwise-ior - (arithmetic-shift (b-vector-ref x i) 24) - (arithmetic-shift (b-vector-ref x (+ i 1)) 16)) - (arithmetic-shift (b-vector-ref x (+ i 2)) 8))) - )))) - (write-hex - port - (net-to-host-32 (bitwise-ior - (bitwise-ior - (arithmetic-shift - (b-vector-ref x i) 24) - (arithmetic-shift - (b-vector-ref x (+ i 1)) 16)) - (bitwise-ior - (arithmetic-shift - (b-vector-ref x (+ i 2)) 8) - (b-vector-ref x (+ i 3)))))))) - ))) - -;;; scsh-for-each-stored-object -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; see scheme48 for-each-stored-object -;;; Image traversal utility - - (define (scsh-for-each-stored-object chunk-start proc chunk-end) - (let ((limit (heap-pointer))) - (let chunk-loop ((addr (newspace-begin)) - (i 0) - (chunk (+ (newspace-begin) *chunk-size*))) - (if (addr< addr limit) - (begin (chunk-start i) - (let loop ((addr addr)) - (if (and (addr< addr limit) - (addr< addr chunk)) - (let* ((d (fetch addr)) - (len (addr1+ (header-a-units d)))) - (if (not (header? d)) - (warn "heap is in an inconsistent state" d)) - (proc i - (address->stob-descriptor (addr1+ addr)) - len) - (loop (addr+ addr len))) - (begin (chunk-end i) - (chunk-loop addr - (+ i 1) - (+ chunk *chunk-size*)))))))))) -;;; write-hex -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; utility routine to print a scheme number as a c hex number - (define (write-hex port x) - (format port - (if (negative? x) "-0x~a," "0x~a,") - (number->string (abs x) 16))) - -;;; line->list -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; utility that takes a string and break it into a list at whitespace -;;; rewrite using scsh stuff? - (define (line->list line) - (let ((len (string-length line))) - (let loop ((start 0) - (end 0) - (l '())) - (cond ((>= end len) - (if (= start end) - l - (append l (list (substring line start end))))) - ((and (= start end) - (or (char=? (string-ref line start) (ascii->char 32)) - (char=? (string-ref line start) (ascii->char 9)))) - (loop (+ 1 start) - (+ 1 end) - l)) - ((or (char=? (string-ref line end) (ascii->char 32)) - (char=? (string-ref line end) (ascii->char 9))) - (loop (+ 1 end) - (+ 1 end) - (append l (list (substring line start end))))) - ((< end len) - (loop start - (+ 1 end) - l)) - (else (error "unexpected case in line->list")))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Debugging -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (bin n) - (number->string n 2)) - - (define (oct n) - (number->string n 8)) - - (define (dec n) - (number->string n 10)) - - (define (hex n) - (number->string n 16)) - - ;;; Static Heap Code From Scheme48 - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; The Scheme 48 version produced monolithic C files that even - ;;; the GNU C Compiler couldn't handle, let alone standard vendor - ;;; compilers... - ;;; It also relied upon the C compiler to fill in some pointer - ;;; information. Because I needed to break up the files, I had to - ;;; calculate this information myself. - - ; For example: - ; (do-it 100000 "~/s48/debug/little.image" "little-heap.c") - ; - ; The first argument to do-it should be somewhat larger than the size, - ; in bytes, of the image file to be converted (which you can obtain with - ; "ls -l"). - ; - ; If the image contains 0-length stored objects, then the .c file will - ; have to be compiled by gcc, since 0-length arrays aren't allowed in - ; ANSI C. This wouldn't be difficult to work around. - - (define *comments?* #f) - - ; 800,000 bytes => 200,000 words => at least 100,000 objects - ; 50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk - (define *chunk-size* 10000) - - (define (do-it bytes infile outfile) - (let ((start (init bytes infile))) - (call-with-output-file outfile - (lambda (port) - (format port "#define D(x) (long)(&x)+7~%") - (format port "#define H unsigned long~%") - (emit-area-declarations "p" immutable? "const " port) - (emit-area-declarations "i" mutable? "" port) - (emit-area-initializers "p" immutable? "const " port) - (emit-area-initializers "i" mutable? "" port) - (display "const long entry = " port) - (emit-descriptor start port) - (write-char #\; port) - (newline port))))) - - (define (init bytes infile) - (create-memory (quotient bytes 2) quiescent) ;Output of ls -l - (initialize-heap (memory-begin) (memory-size)) - (let ((start (read-image infile 0))) - (message (nchunks) - " chunks") - start)) - - (define (nchunks) (+ (chunk-number (heap-pointer)) 1)) - - ; emit struct declarations for areas - - (define (emit-area-declarations name in-area? const port) - (for-each-stored-object - (lambda (chunk) - (message name chunk " declaration") - (display "struct " port) (display name port) (display chunk port) - (display " {" port) (newline port)) - (lambda (x) - (if (in-area? x) - (emit-declaration x port))) - (lambda (chunk) - (display "};" port) - (newline port) - (display const port) - (display "extern struct " port) (display name port) (display chunk port) - (write-char #\space port) (display name port) (display chunk port) - (write-char #\; port) (newline port) - chunk))) - - (define (emit-declaration x port) - (display " H x" port) - (writex x port) - (cond ((d-vector? x) - (display "; long d" port) - (writex x port) - (write-char #\[ port) - (write (d-vector-length x) port)) - ((vm-string? x) - (display "; char d" port) - (writex x port) - (write-char #\[ port) - ;; Ensure alignment (thanks Ian) - (write (cells->bytes (bytes->cells (b-vector-length x))) - port)) - (else - (display "; unsigned char d" port) - (writex x port) - (write-char #\[ port) - ;; Ensure alignment - (write (cells->bytes (bytes->cells (b-vector-length x))) - port))) - (display "];" port) - (if *comments?* - (begin (display " /* " port) - (display (enumerand->name (stob-type x) stob) port) - (display " */" port))) - (newline port)) - - ; Emit initializers for areas - - (define (emit-area-initializers name in-area? const port) - (for-each-stored-object - (lambda (chunk) - (message name chunk " initializer") - - (display const port) - (display "struct " port) (display name port) (write chunk port) - (write-char #\space port) (display name port) (write chunk port) - (display " =" port) (newline port) - - (write-char #\{ port) (newline port)) - (lambda (x) - (if (in-area? x) - (emit-initializer x port))) - (lambda (chunk) - (display "};" port) (newline port))) - - (let ((n (nchunks))) - (format port "const long ~a_count = ~s;~%" name n) - (format port "~a long * const ~a_areas[~s] = {" const name n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "(~a long *)&~a~s, " const name i)) - (format port "};~%const long ~a_sizes[~s] = {" name n) - (do ((i 0 (+ i 1))) - ((= i n)) - (format port "sizeof(~a~s), " name i)) - (format port "};~%"))) - - - (define (message . stuff) - (for-each display stuff) (newline)) - - (define (emit-initializer x port) - (display " " port) - (write (stob-header x) port) - (write-char #\, port) - (cond ((d-vector? x) - (emit-d-vector-initializer x port)) - ((vm-string? x) - (write-char #\" port) - (let ((len (vm-string-length x))) - (do ((i 0 (+ i 1))) - ((= i len) (write-char #\" port)) - (let ((c (vm-string-ref x i))) - (cond ((or (char=? c #\") (char=? c #\\)) - (write-char #\\ port)) - ((char=? c #\newline) - (display "\\n\\" port))) - (write-char c port))))) - (else - (write-char #\{ port) - (let ((len (b-vector-length x))) - (do ((i 0 (+ i 1))) - ((= i len) (write-char #\} port)) - (write (b-vector-ref x i) port) - (write-char #\, port))))) - (write-char #\, port) - (if *comments?* - (begin (display " /* " port) - (writex x port) - (display " */" port))) - (newline port)) - - (define (emit-d-vector-initializer x port) - (write-char #\{ port) - (let ((len (d-vector-length x))) - (do ((i 0 (+ i 1))) - ((= i len) (write-char #\} port)) - (emit-descriptor (d-vector-ref x i) port) - (write-char #\, port)))) - - (define (emit-descriptor x port) - (if (stob? x) - (begin (if (immutable? x) - (display "D(p" port) - (display "D(i" port)) - (display (chunk-number x) port) - (display ".x" port) - (writex x port) - (write-char #\) port)) - (write x port))) - - - ; Foo - - (define (writex x port) - (write (quotient (- (- x (memory-begin)) 7) 4) port)) - - (define (chunk-number x) - (quotient (- (- x (memory-begin)) 7) *chunk-size*)) - - - ; Image traversal utility - - (define (for-each-stored-object chunk-start proc chunk-end) - (let ((limit (heap-pointer))) - (let chunk-loop ((addr (newspace-begin)) - (i 0) - (chunk (+ (newspace-begin) *chunk-size*))) - (if (addr< addr limit) - (begin (chunk-start i) - (let loop ((addr addr)) - (if (and (addr< addr limit) - (addr< addr chunk)) - (let ((d (fetch addr))) - (if (not (header? d)) - (warn "heap is in an inconsistent state" d)) - (proc (address->stob-descriptor (addr1+ addr))) - (loop (addr1+ (addr+ addr (header-a-units d))))) - (begin (chunk-end i) - (chunk-loop addr - (+ i 1) - (+ chunk *chunk-size*)))))))))) - - (define (mutable? x) (not (immutable? x))) - - ;; End begin - )) diff --git a/scsh/stringcoll.scm b/scsh/stringcoll.scm deleted file mode 100644 index d1d9184..0000000 --- a/scsh/stringcoll.scm +++ /dev/null @@ -1,166 +0,0 @@ -;;; Copyright (c) 1994 by Olin Shivers - -;;; String collectors -;;; =========================================================================== -;;; string-colllector -;;; (make-string-collector) -;;; (collect-string! SC S) -;;; (clear-string-collector! SC) -;;; (string-collector->string SC) -;;; -;;; A string collector is a data structure that reduces the overhead of -;;; accumulating a large string in bits and pieces. It is basically a -;;; "chunk list," where a chunk is a string of at least 128 chars. In this -;;; way, the list overhead is kept under 2% of the whole data structure. -;;; When a new string is added to the collection, it is added to the current -;;; chunk. When the chunk reaches 128 chars, it is added to the chunk list, -;;; and a new chunk is started. If a large string is added to the collection, -;;; it is added as a chunk itself, so large strings are not split into small -;;; pieces. (Actually, a *copy* of the original large string is saved as a -;;; single chunk, so the collector's chunks are not shared with client data.) -;;; -;;; MAKE-STRING-COLLECTOR allocates a new string collector data structure. -;;; COLLECT-STRING! appends a string to the current collection. -;;; CLEAR-STRING-COLLECTOR! clears out accumulated strings from a collector. -;;; STRING-COLLECTOR->STRING converts a collector into a contiguous string. -;;; -;;; This facility makes it reasonably efficient to accumulate strings -;;; of any size in increments of any size. - -(define-record string-collector - (len 0) ; How many chars have we accumulated? - (chunks '()) ; The chunk list. - (chunk #f) ; The current chunk being filled, if any. - (chunk-left 0)) ; How many chars left to fill in the current chunk. - -(define (clear-string-collector! sc) - (set-string-collector:len sc 0) - (set-string-collector:chunks sc '()) - (set-string-collector:chunk sc #f) - sc) - -;;; (COLLECT-STRING! sc s) -;;; ---------------------- -;;; S is a string. Append it to the string being collected in the -;;; string-collector SC. -;;; -;;; The algorithm: -;;; First, do nothing if S is the empty string. Otherwise: -;;; If there is a current chunk: -;;; Copy characters from S into it. -;;; If we filled up the chunk -;;; Put the chunk on the chunk list. -;;; Look at the remaining chars from S we haven't copied yet. -;;; If there a lot of characters left (>= 128) -;;; Save them as a single chunk on the chunk list. -;;; No current chunk. -;;; Else if there a just a few characters left (> 0, < 128) -;;; Start a new current chunk, copy the chars left into it. -;;; Else if there aren't any characters left -;;; No current chunk. -;;; -;;; If there is no current chunk: -;;; If there are a lot of characters in S (>= 128) -;;; Save a copy of S as a single chunk on the chunk list. -;;; Still no current chunk. -;;; Else if there are a few characters in S (> 0, < 128) -;;; Start a new current chunk, copy the S into it. - -(define (collect-string! sc s) - (let ((slen (string-length s)) - (chunk (string-collector:chunk sc)) - (chunk-left (string-collector:chunk-left sc)) - - ;; Add the chunk C to the collector's chunk list. - (push-chunk! (lambda (c) - (set-string-collector:chunks sc - (cons c (string-collector:chunks sc))))) - - ;; Copy nchars characters from src[j] to dest[i] - ;; *Way* too much bounds checking going on in this loop. - (copy-substring! (lambda (dest i src j nchars) - (do ((i i (+ i 1)) - (j j (+ j 1)) - (nchars nchars (- nchars 1))) - ((zero? nchars)) - (string-set! dest i (string-ref src j)))))) - - (cond ((zero? slen)) ; Empty string, do nothing. - (chunk - (let ((ncopy (min slen chunk-left))) - (copy-substring! chunk (- 128 chunk-left) s 0 ncopy) - (if (> chunk-left slen) - (set-string-collector:chunk-left sc (- chunk-left slen)) - ;; Current chunk is full. - (let ((s-left (- slen chunk-left))) - (push-chunk! chunk) ; Push the current chunk. - ;; Handle remaining chars from S that weren't copied into - ;; the current chunk we just pushed: - (cond ((>= s-left 128) - ;; A lot more chars left. Push them as one chunk. - (push-chunk! (substring s chunk-left slen)) - (set-string-collector:chunk sc #f)) - ((> s-left 0) - ;; A few more chars left. Start a new chunk. - (let ((new-chunk (make-string 128))) - (copy-substring! new-chunk 0 s chunk-left s-left) - (set-string-collector:chunk sc new-chunk) - (set-string-collector:chunk-left sc - (- 128 s-left)))) - ;; No more chars left. No current chunk. - (else (set-string-collector:chunk sc #f))))))) - - (else ; No current chunk. - (if (>= slen 128) ; How many chars is S? - (push-chunk! (string-copy s)) ; A lot. Push as one chunk. - (let ((chunk (make-string 128))) ; Not many. Start a new chunk. - (set-string-collector:chunk sc chunk) - (copy-substring! chunk 0 s 0 slen) - (set-string-collector:chunk-left sc (- 128 slen)))))) - - ;; We don't actually do anything with this, but we keep it updated anyway. - (set-string-collector:len sc (+ (string-collector:len sc) slen)) - sc)) - - -;;; A bummed version for collecting a single character. - -(define (collect-char! sc c) - (let ((chunk (string-collector:chunk sc)) - (chunk-left (string-collector:chunk-left sc))) - - (cond (chunk - (string-set! chunk (- 128 chunk-left) c) - (cond ((> chunk-left 1) - (set-string-collector:chunk-left (- chunk-left 1))) - (else - (set-string-collector:chunks sc - (cons chunk (string-collector:chunks sc))) - (set-string-collector:chunk sc #f)))) - (else - (let ((new-chunk (make-string 128 c))) - (set-string-collector:chunk-left 127) - (set-string-collector:chunk sc new-chunk))))) - - ;; We don't actually do anything with this, but we keep it updated anyway. - (set-string-collector:len sc (+ (string-collector:len sc) 1)) - sc) - - -;;; Convert the data in the string-collector SC to a single contiguous -;;; string and return it. - -(define (string-collector->string sc) - (let ((chunk (string-collector:chunk sc)) - (chunks (string-collector:chunks sc))) - (apply string-append - (reverse (if chunk - (cons (substring chunk 0 - (- 128 - (string-collector:chunk-left sc))) - chunks) - chunks))))) - -;;; It's too bad we can't side-effect the string-collector's chunk list -;;; to be a single chunk after this coalescing operation, but we don't -;;; want to share the string we return -- the user might side-effect it. diff --git a/scsh/sunos/Makefile.inc b/scsh/sunos/Makefile.inc deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/sunos/bufpol.scm b/scsh/sunos/bufpol.scm deleted file mode 100644 index 09e5ad9..0000000 --- a/scsh/sunos/bufpol.scm +++ /dev/null @@ -1,12 +0,0 @@ -;;; Flags that control buffering policy. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are for the SET-PORT-BUFFERING procedure, essentially a Scheme -;;; analog of the setbuf(3S) stdio call. We use the actual stdio values. -;;; These constants are not likely to change from stdio lib to stdio lib, -;;; but you need to check when you do a port. - -(define-enum-constants bufpol - (block 0) ; _IOFBF - (line #o200) ; _IOLBF - (none 4)) ; _IONBF diff --git a/scsh/sunos/errno.scm b/scsh/sunos/errno.scm deleted file mode 100644 index 5b72ee4..0000000 --- a/scsh/sunos/errno.scm +++ /dev/null @@ -1,153 +0,0 @@ -;;; Errno constant definitions. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; These are the correct values for my SparcStation. - -(define errno/2big 7) ; 2big is not a legit Scheme symbol. Lose, lose. - -(define-enum-constants errno - ;; POSIX: - (perm 1) ; Operation not permitted - (noent 2) ; No such file or directory - (srch 3) ; No such process - (intr 4) ; Interrupted function call - (io 5) ; Input/output error - (nxio 6) ; No such device or address -; (2big 7) ; Arg list too long - (noexec 8) ; Exec format error - (badf 9) ; Bad file descriptor - (child 10) ; No child processes - (again 11) ; Resource temporarily unavailable - (nomem 12) ; Not enough space - (acces 13) ; Permission denied - (fault 14) ; Bad address - (notblk 15) ; Block device required - (busy 16) ; Resource busy - (exist 17) ; File exists - (xdev 18) ; Improper link - (nodev 19) ; No such device - (notdir 20) ; Not a directory - (isdir 21) ; Is a directory - (inval 22) ; Invalid argument - (nfile 23) ; Too many open files in system - (mfile 24) ; Too many open files - (notty 25) ; Inappropriate I/O control operation - (xtbsy 26) ; Text file busy - (fbig 27) ; File too large - (nospc 28) ; No space left on device - (spipe 29) ; Invalid seek - (rofs 30) ; Read-only file system - (mlink 31) ; Too many links - (pipe 32) ; Broken pipe - - ;; POSIX: - ;; math software - (dom 33) ; Domain error - (range 34) ; Result too large - - ;; non-blocking and interrupt i/o - (wouldblock 35) ; Operation would block - (inprogress 36) ; Operation now in progress - (already 37) ; Operation already in progress - - ;; ipc/network software - - ;; argument errors - (notsock 38) ; Socket operation on non-socket - (destaddrreq 39) ; Destination address required - (msgsize 40) ; Message too long - (prototype 41) ; Protocol wrong type for socket - (noprotoopt 42) ; Protocol not available - (protonosupport 43) ; Protocol not supported - (socktnosupport 44) ; Socket type not supported - (opnotsupp 45) ; Operation not supported on socket - (pfnosupport 46) ; Protocol family not supported - (afnosupport 47) ; Address family not supported by protocol family - (addrinuse 48) ; Address already in use - (addrnotavail 49) ; Can't assign requested address - - ;; operational errors - (netdown 50) ; Network is down - (netunreach 51) ; Network is unreachable - (netreset 52) ; Network dropped connection on reset - (connaborted 53) ; Software caused connection abort - (connreset 54) ; Connection reset by peer - (nobufs 55) ; No buffer space available - (isconn 56) ; Socket is already connected - (notconn 57) ; Socket is not connected - (shutdown 58) ; Can't send after socket shutdown - (toomanyrefs 59) ; Too many references: can't splice - (timedout 60) ; Connection timed out - (connrefused 61) ; Connection refused - - (loop 62) ; Too many levels of symbolic links - - ;; POSIX: - (nametoolong 63) ; File name too long - - ;; should be rearranged - (hostdown 64) ; Host is down - (hostunreach 65) ; No route to host - - ;; POSIX: - (notempty 66) ; Directory not empty - - ;; quotas & mush - (proclim 67) ; Too many processes - (users 68) ; Too many users - (dquot 69) ; Disc quota exceeded - - ;; Network File System - (stale 70) ; Stale NFS file handle - (remote 71) ; Too many levels of remote in path - - ;; streams - (nostr 72) ; Device is not a stream - (time 73) ; Timer expired - (nosr 74) ; Out of streams resources - (nomsg 75) ; No message of desired type - (badmsg 76) ; Trying to read unreadable message - - ;; SystemV IPC - (idrm 77) ; Identifier removed - - ;; POSIX - ;; SystemV Record Locking - (deadlk 78) ; Resource deadlock avoided - (nolck 79) ; No locks available - - ;; RFS - (nonet 80) ; Machine is not on the network - (rremote 81) ; Object is remote - (nolink 82) ; the link has been severed - (adv 83) ; advertise error - (srmnt 84) ; srmount error - (comm 85) ; Communication error on send - (proto 86) ; Protocol error - (multihop 87) ; multihop attempted - (dotdot 88) ; Cross mount point (not an error) - (remchg 89) ; Remote address changed - - ;; POSIX - (nosys 90)) ; function not implemented - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Non-POSIX messages -; Some of these SunOS messages are better. Some are stupid. -; -; Error SunOS POSIX -; perm Not owner Operation not permitted -; intr Interrupted system call Interrupted function call -; io I/O error Input/output error -; badf Bad file number Bad file descriptor -; child No children No child processes -; again No more processes Resource temporarily unavailable -; nomem Not enough core Not enough space -; busy Mount device busy Resource busy -; xdev Cross-device link Improper link -; nfile File table overflow Too many open files in system -; notty Not a typewriter Inappropriate I/O control operation -; spipe Illegal seek Invalid seek -; dom Argument too large Domain error -; deadlk Deadlock condition Resource deadlock avoided -; nolck No record locks available No locks available diff --git a/scsh/sunos/fdflags.scm b/scsh/sunos/fdflags.scm deleted file mode 100644 index 9855e3b..0000000 --- a/scsh/sunos/fdflags.scm +++ /dev/null @@ -1,49 +0,0 @@ -;;; Flags for open(2) and fcntl(2). -;;; Copyright (c) 1993 by Olin Shivers. - -(define-enum-constants open - (read 0) - (write 1) - (read+write 2) - (append 8) - (create #x0200) - (exclusive #x0800) - (no-control-tty #x8000) - (nonblocking #x4000) - (truncate #x0400) - -;;; Not POSIX. - (no-delay 4) - (sync #x2000)) - -(define open/access-mask - (bitwise-ior open/read - (bitwise-ior open/write open/read+write))) - -;;; fcntl() commands -(define-enum-constants fcntl - (dup-fdes 0) ; F_DUPFD - (get-fdes-flags 1) ; F_GETFD - (set-fdes-flags 2) ; F_SETFD - (get-status-flags 3) ; F_GETFL - (set-status-flags 4) ; F_SETFL - (get-owner 5) ; F_GETOWN (Not Posix) - (set-owner 6) ; F_SETOWN (Not Posix) - (get-record-lock 7) ; F_GETLK - (set-record-lock-noblock 8) ; F_SETLK - (set-record-lock 9)) ; F_SETLKW - -;;; fcntl fdes-flags (F_GETFD) - -(define fdflags/close-on-exec 1) - -;;; fcntl status-flags (F_GETFL) -;;; Mostly, these are OPEN/... flags, like OPEN/APPEND. -;;; (define fdstatus/... ...) - -;;; fcntl lock values. - -(define-enum-constants lock - (read 1) ; F_RDLCK - (write 2) ; F_WRLCK - (release 3)) ; F_UNLCK diff --git a/scsh/sunos/libansi.c b/scsh/sunos/libansi.c deleted file mode 100644 index 04370cd..0000000 --- a/scsh/sunos/libansi.c +++ /dev/null @@ -1,139 +0,0 @@ -/* OS-dependent support for what is supposed to be the standard ANSI C Library. -** Copyright (c) 1996 by Brian D. Carlstrom. -** -** For SunOS we provide raise and memmove from the BSD distribution. -** -*/ - - - -/*- - * Copyright (c) 1990, 1993 - * The Regents of the University of California. All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. All advertising materials mentioning features or use of this software - * must display the following acknowledgement: - * This product includes software developed by the University of - * California, Berkeley and its contributors. - * 4. Neither the name of the University nor the names of its contributors - * may be used to endorse or promote products derived from this software - * without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - * SUCH DAMAGE. - */ - -#if defined(LIBC_SCCS) && !defined(lint) -#if 0 -static char sccsid[] = "@(#)raise.c 8.1 (Berkeley) 6/4/93"; -#else -static char rcsid[] = "$NetBSD: raise.c,v 1.5 1995/02/27 04:35:54 cgd Exp $"; -#endif -#endif /* LIBC_SCCS and not lint */ - -#include -#include - -int -raise(s) - int s; -{ - return(kill(getpid(), s)); -} - -#include - -/* - * sizeof(word) MUST BE A POWER OF TWO - * SO THAT wmask BELOW IS ALL ONES - */ -typedef long word; /* "word" used for optimal copy speed */ - -#define wsize sizeof(word) -#define wmask (wsize - 1) - -void * -memmove(dst0, src0, length) - void *dst0; - const void *src0; - register size_t length; -{ - register char *dst = dst0; - register const char *src = src0; - register size_t t; - - if (length == 0 || dst == src) /* nothing to do */ - goto done; - - /* - * Macros: loop-t-times; and loop-t-times, t>0 - */ -#define TLOOP(s) if (t) TLOOP1(s) -#define TLOOP1(s) do { s; } while (--t) - - if ((unsigned long)dst < (unsigned long)src) { - /* - * Copy forward. - */ - t = (long)src; /* only need low bits */ - if ((t | (long)dst) & wmask) { - /* - * Try to align operands. This cannot be done - * unless the low bits match. - */ - if ((t ^ (long)dst) & wmask || length < wsize) - t = length; - else - t = wsize - (t & wmask); - length -= t; - TLOOP1(*dst++ = *src++); - } - /* - * Copy whole words, then mop up any trailing bytes. - */ - t = length / wsize; - TLOOP(*(word *)dst = *(word *)src; src += wsize; dst += wsize); - t = length & wmask; - TLOOP(*dst++ = *src++); - } else { - /* - * Copy backwards. Otherwise essentially the same. - * Alignment works as before, except that it takes - * (t&wmask) bytes to align, not wsize-(t&wmask). - */ - src += length; - dst += length; - t = (long)src; - if ((t | (long)dst) & wmask) { - if ((t ^ (long)dst) & wmask || length <= wsize) - t = length; - else - t &= wmask; - length -= t; - TLOOP1(*--dst = *--src); - } - t = length / wsize; - TLOOP(src -= wsize; dst -= wsize; *(word *)dst = *(word *)src); - t = length & wmask; - TLOOP(*--dst = *--src); - } -done: - return (dst0); -} diff --git a/scsh/sunos/netconst.scm b/scsh/sunos/netconst.scm deleted file mode 100644 index 548bb49..0000000 --- a/scsh/sunos/netconst.scm +++ /dev/null @@ -1,121 +0,0 @@ -;;; Magic Numbers for Networking -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; magic numbers not from header file -;;; but from man page -;;; why can't unix make up its mind -(define shutdown/receives 0) -(define shutdown/sends 1) -(define shutdown/sends+receives 2) - -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; BELOW THIS POINT ARE BITS FROM: -;;; -;;; -;;; -;;; -;;; -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -;;; ADDRESS FAMILIES -- -(define address-family/unspecified 0) ; unspecified -(define address-family/unix 1) ; local to host (pipes, portals) -(define address-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; SOCKET TYPES -- -(define socket-type/stream 1) ; stream socket -(define socket-type/datagram 2) ; datagram socket -(define socket-type/raw 3) ; raw-protocol interface -;;(define socket-type/rdm 4) ; reliably-delivered message -;;(define socket-type/seqpacket 5) ; sequenced packet stream - -;;; PROTOCOL FAMILIES -- -(define protocol-family/unspecified 0) ; unspecified -(define protocol-family/unix 1) ; local to host (pipes, portals) -(define protocol-family/internet 2) ; internetwork: UDP, TCP, etc. - -;;; Well know addresses -- -(define internet-address/any #x00000000) -(define internet-address/loopback #x7f000001) -(define internet-address/broadcast #xffffffff) ; must be masked - -;;; errors from host lookup -- -(define herror/host-not-found 1) ;Authoritative Answer Host not found -(define herror/try-again 2) ;Non-Authoritive Host not found, or SERVERFAIL -(define herror/no-recovery 3) ;Non recoverable errors, FORMERR, REFUSED, NOTIMP -(define herror/no-data 4) ;Valid name, no data record of requested type -(define herror/no-address herror/no-data) ;no address, look for MX record - -;;; flags for send/recv -- -(define message/out-of-band 1) ; process out-of-band data -(define message/peek 2) ; peek at incoming message -(define message/dont-route 4) ; send without using routing tables - -;;; protocol level for socket options -- -(define level/socket #xffff) ; SOL_SOCKET: options for socket level - -;;; socket options -- -(define socket/debug #x0001) ; turn on debugging info recording -(define socket/accept-connect #x0002) ; socket has had listen() -(define socket/reuse-address #x0004) ; allow local address reuse -(define socket/keep-alive #x0008) ; keep connections alive -(define socket/dont-route #x0010) ; just use interface addresses -(define socket/broadcast #x0020) ; permit sending of broadcast msgs -(define socket/use-loop-back #x0040) ; bypass hardware when possible -(define socket/linger #x0080) ; linger on close if data present -(define socket/oob-inline #x0100) ; leave received OOB data in line -;(define socket/use-privileged #x4000) ; allocate from privileged port area -;(define socket/cant-signal #x8000) ; prevent SIGPIPE on SS_CANTSENDMORE -(define socket/send-buffer #x1001) ; send buffer size -(define socket/receive-buffer #x1002) ; receive buffer size -(define socket/send-low-water #x1003) ; send low-water mark -(define socket/receive-low-water #x1004) ; receive low-water mark -(define socket/send-timeout #x1005) ; send timeout -(define socket/receive-timeout #x1006) ; receive timeout -(define socket/error #x1007) ; get error status and clear -(define socket/type #x1008) ; get socket type - -;;; ip options -- -(define ip/options 1) ; set/get IP per-packet options -;(define ip/time-to-live 2) ; set/get IP time-to-live value - -;;; tcp options -- -(define tcp/no-delay #x01) ; don't delay send to coalesce packets -(define tcp/max-segment #x02) ; set maximum segment size - -;;; -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; OPTION SETS FOR SOCKET-OPTION AND SET-SOCKET-OPTION - -;;; Boolean Options -(define options/boolean - (list socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - tcp/no-delay)) - -;;; Integer Options -(define options/value - (list socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/error - socket/type -; ip/time-to-live - tcp/max-segment)) - -;;; #f or Positive Integer -(define options/linger - (list socket/linger)) - -;;; Real Number -(define options/timeout - (list socket/send-timeout - socket/receive-timeout)) diff --git a/scsh/sunos/packages.scm b/scsh/sunos/packages.scm deleted file mode 100644 index 0151fc6..0000000 --- a/scsh/sunos/packages.scm +++ /dev/null @@ -1,112 +0,0 @@ -;;; Interfaces and packages for the Sun specific parts of scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -(define-interface sunos-fdflags-extras-interface - (export open/no-delay - open/sync - )) - -(define-interface sunos-errno-extras-interface - (export errno/addrinuse - errno/addrnotavail - errno/adv - errno/afnosupport - errno/already - errno/badmsg - errno/comm - errno/connaborted - errno/connrefused - errno/connreset - errno/destaddrreq - errno/dotdot - errno/dquot - errno/hostdown - errno/hostunreach - errno/idrm - errno/inprogress - errno/isconn - errno/loop - errno/msgsize - errno/multihop - errno/netdown - errno/netreset - errno/netunreach - errno/nobufs - errno/nolink - errno/nomsg - errno/nonet - errno/noprotoopt - errno/nosr - errno/nostr - errno/notblk - errno/notconn - errno/notsock - errno/opnotsupp - errno/pfnosupport - errno/proclim - errno/proto - errno/protonosupport - errno/prototype - errno/remchg - errno/remote - errno/rremote - errno/shutdown - errno/socktnosupport - errno/srmnt - errno/stale - errno/time - errno/timedout - errno/toomanyrefs - errno/users - errno/wouldblock - errno/xtbsy)) - -(define-interface sunos-signals-extras-interface - (export signal/cld - signal/iot)) - -(define-interface sunos-network-extras-interface - (export socket/debug - socket/accept-connect - socket/reuse-address - socket/keep-alive - socket/dont-route - socket/broadcast - socket/use-loop-back - socket/linger - socket/oob-inline -; socket/use-privileged -; socket/cant-signal - socket/send-buffer - socket/receive-buffer - socket/send-low-water - socket/receive-low-water - socket/send-timeout - socket/receive-timeout - socket/error - socket/type - ip/options -; ip/time-to-live - tcp/no-delay - tcp/max-segment)) - -(define-interface sunos-extras-interface - (compound-interface sunos-errno-extras-interface - sunos-fdflags-extras-interface - sunos-network-extras-interface - sunos-signals-extras-interface)) - -(define-interface sunos-defs-interface - (compound-interface sunos-extras-interface - sockets-network-interface - posix-errno-interface - posix-fdflags-interface - posix-signals-interface - signals-internals-interface)) - -(define-structure sunos-defs sunos-defs-interface - (open scheme bitwise defenum-package) - (files fdflags errno signals netconst)) - -(define-interface os-extras-interface sunos-extras-interface) -(define os-dependent sunos-defs) diff --git a/scsh/sunos/signals.scm b/scsh/sunos/signals.scm deleted file mode 100644 index d1b961d..0000000 --- a/scsh/sunos/signals.scm +++ /dev/null @@ -1,57 +0,0 @@ -;;; Signal constant definitions for Sun4 -;;; Copyright (c) 1994, 1996 by Olin Shivers and Brian D. Carlstrom - -(define-enum-constants signal - ;; POSIX - (hup 1) ; hangup - (int 2) ; interrupt - (quit 3) ; quit - (ill 4) ; illegal instruction (not reset when caught) - ;; SunOS - (trap 5) ; trace trap (not reset when caught) */ - ;; POSIX - (iot 6) ; IOT instruction - (abrt 6) ; used by abort, replace SIGIOT in the future - ;; SunOS - (emt 7) ; EMT instruction - ;; POSIX - (fpe 8) ; floating point exception - (kill 9) ; kill (cannot be caught or ignored) - ;; SunOS - (bus 10) ; bus error - ;; POSIX - (segv 11) ; segmentation violation - ;; SunOS - (sys 12) ; bad argument to system call - ;; POSIX - (pipe 13) ; write on a pipe with no one to read it - (alrm 14) ; alarm clock - (term 15) ; software termination signal from kill - ;; SunOS - (urg 16) ; urgent condition on IO channel - ;; POSIX - (stop 17) ; sendable stop signal not from tty - (tstp 18) ; stop signal from tty - (cont 19) ; continue a stopped process - (chld 20) ; to parent on child stop or exit - (cld 20) ; System V name for SIGCHLD - (ttin 21) ; to readers pgrp upon background tty read - (ttou 22) ; like TTIN for output if (tp->t_local<OSTOP) - ;; SunOS - (io 23) ; input/output possible signal - (poll 23) ; System V name for SIGIO - (xcpu 24) ; exceeded CPU time limit - (xfsz 25) ; exceeded file size limit - (vtalrm 26) ; virtual time alarm - (prof 27) ; profiling time alarm - (winch 28) ; window changed - (lost 29) ; resource lost (eg, record-lock lost) - ;; POSIX - ;; User defined - (usr1 30) ; user defined signal 1 - (usr2 31) ; user defined signal 2 - ) - -(define signals-ignored-by-default - (list signal/chld signal/cont ; These are Posix. - signal/urg signal/io signal/winch)) ; These are SunOS. diff --git a/scsh/sunos/sigset.h b/scsh/sunos/sigset.h deleted file mode 100644 index f30fa8c..0000000 --- a/scsh/sunos/sigset.h +++ /dev/null @@ -1,10 +0,0 @@ -/* Convert between a lo24/hi integer-pair bitset and a sigset_t value. -** These macros are OS-dependent, and must be defined per-OS. -*/ - -#define make_sigset(maskp, hi, lo) (*maskp=((hi)<<24)|(lo)) - -/* Not a procedure: */ -#define split_sigset(mask, hip, lop) \ - ((*(hip)=(mask>>24)&0xff), \ - (*(lop)=(mask&0xffffff))) diff --git a/scsh/sunos/stdio_dep.c b/scsh/sunos/stdio_dep.c deleted file mode 100644 index 4913d14..0000000 --- a/scsh/sunos/stdio_dep.c +++ /dev/null @@ -1,83 +0,0 @@ -/* Copyright (c) 1994 by Olin Shivers. -** Copyright (c) 1994-1995 by Brian D. Carlstrom. -** -** This file implements the char-ready? procedure for file descriptors -** and Scsh's fdports. It is not Posix, so it must be implemented for -** each OS to which scsh is ported. -** -** This version assumes two things: -** - the existence of select to tell if there is data -** available for the file descriptor. -** - the existence of the _cnt field in the stdio FILE struct, telling -** if there is any buffered input in the struct. -** -** Most Unixes have these things, so this file should work for them. -** However, Your Mileage May Vary. -** -** You could also replace the select() with a iotctl(FIONREAD) call, if you -** had one but not the other. -** -Olin&Brian -*/ - -#include -#include -#include -#include -#include "libcig.h" -#include - -#include "stdio_dep.h" /* Make sure the .h interface agrees with the code. */ - -/* These two procs return #t if data ready, #f data not ready, -** and errno if error. -*/ - -scheme_value char_ready_fdes(int fd) -{ - fd_set readfds; - struct timeval timeout; - int result; - - FD_ZERO(&readfds); - FD_SET(fd,&readfds); - - timeout.tv_sec=0; - timeout.tv_usec=0; - - result=select(fd+1, &readfds, NULL, NULL, &timeout); - - if(result == -1 ) - return(ENTER_FIXNUM(errno)); - if(result) - return(SCHTRUE); - return(SCHFALSE); -} - -scheme_value stream_char_readyp(FILE *f) -{ - int fd = fileno(f); - return f->_cnt > 0 ? SCHTRUE : char_ready_fdes(fd); -} - -void setfileno(FILE *fs, int fd) -{ - fileno(fs) = fd; -} - -int fbufcount(FILE* fs) -{ - return(fs->_cnt); -} - -/* Returns true if there is no buffered data in stream FS -** (or there is no buffering, period.) -*/ - -int ibuf_empty(FILE *fs) {return fs->_cnt <= 0;} - - -/* Returns true if the buffer in stream FS is full -** (or there is no buffering, period). -*/ - -int obuf_full(FILE *fs) {return fs->_cnt <= 0;} diff --git a/scsh/sunos/stdio_dep.h b/scsh/sunos/stdio_dep.h deleted file mode 100644 index 6c6eaca..0000000 --- a/scsh/sunos/stdio_dep.h +++ /dev/null @@ -1,13 +0,0 @@ -/* Exports from stdio_dep.h. */ - -scheme_value char_ready_fdes(int fd); - -scheme_value stream_char_readyp(FILE *f); - -void setfileno(FILE *fs, int fd); - -int fbufcount(FILE* fs); - -int ibuf_empty(FILE *fs); - -int obuf_full(FILE *fs); diff --git a/scsh/sunos/sysdep.h b/scsh/sunos/sysdep.h deleted file mode 100644 index e69de29..0000000 diff --git a/scsh/sunos/time_dep.scm b/scsh/sunos/time_dep.scm deleted file mode 100644 index 7f8adf4..0000000 --- a/scsh/sunos/time_dep.scm +++ /dev/null @@ -1,8 +0,0 @@ -;;; OS-dependent time stuff -;;; Copyright (c) 1995 by Olin Shivers. - -;;; This suffices for BSD systems with the gettimeofday() -;;; microsecond-resolution timer. - -(define (ticks/sec) 1000000) ; usec - diff --git a/scsh/sunos/time_dep1.c b/scsh/sunos/time_dep1.c deleted file mode 100644 index 1d81150..0000000 --- a/scsh/sunos/time_dep1.c +++ /dev/null @@ -1,38 +0,0 @@ -/* OS-dependent support for fine-grained timer. -** Copyright (c) 1995 by Olin Shivers. -** -** We return the current time in seconds and sub-second "ticks" where the -** number of ticks/second is OS dependent (and is defined in time_dep.scm). -** This definition works on any BSD Unix with the gettimeofday() -** microsecond-resolution timer. -*/ - -#include -#include -#include "scheme48.h" -#include "../time1.h" - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks) -{ - struct timeval t; - struct timezone tz; - - if( gettimeofday(&t, &tz) ) return ENTER_FIXNUM(errno); - - { long int secs = t.tv_sec; - long int ticks = t.tv_usec; - - *hi_secs = hi8(secs); - *lo_secs = lo24(secs); - *hi_ticks = hi8(ticks); - *lo_ticks = lo24(ticks); - } - - return SCHFALSE; - } diff --git a/scsh/sunos/tty-consts.scm b/scsh/sunos/tty-consts.scm deleted file mode 100644 index 16ada56..0000000 --- a/scsh/sunos/tty-consts.scm +++ /dev/null @@ -1,217 +0,0 @@ -;;; Constant definitions for tty control code (POSIX termios). -;;; Copyright (c) 1995 by Brian Carlstrom. -;;; Largely rehacked by Olin. - -;;; These constants are for SunOS 4.x.x, -;;; and are taken from /usr/include/sys/termio.h -;;; and /usr/include/sys/termios.h -;;; and /usr/include/sys/ttydev.h - -;;; Non-standard (POSIX, SVR4, 4.3+BSD) things: -;;; - Some of the baud rates. - - -;;; Special Control Characters -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indices into the c_cc[] character array. - -;;; Name Subscript Enabled by -;;; ---- --------- ---------- -;;; POSIX -(define ttychar/eof 4) ; ^d icanon -(define ttychar/eol 5) ; icanon -(define ttychar/delete-char 2) ; ^? icanon -(define ttychar/delete-line 3) ; ^u icanon -(define ttychar/interrupt 0) ; ^c isig -(define ttychar/quit 1) ; ^\ isig -(define ttychar/suspend 10) ; ^z isig -(define ttychar/start 8) ; ^q ixon, ixoff -(define ttychar/stop 9) ; ^s ixon, ixoff -(define ttychar/min 4) ; !icanon ; Not exported -(define ttychar/time 5) ; !icanon ; Not exported - -;;; SVR4 & 4.3+BSD -(define ttychar/delete-word 14) ; ^w icanon -(define ttychar/reprint 12) ; ^r icanon -(define ttychar/literal-next 15) ; ^v iexten -(define ttychar/discard 13) ; ^o iexten -(define ttychar/delayed-suspend 11) ; ^y isig -(define ttychar/eol2 6) ; icanon - -;;; 4.3+BSD -(define ttychar/status 16) ; ^t icanon - -;;; Length of control-char string -- *Not Exported* -(define num-ttychars 17) - -;;; Magic "disable feature" tty character -(define disable-tty-char (ascii->char #x00)) ; _POSIX_VDISABLE - -;;; Flags controllling input processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyin/ignore-break #x00001) ; ignbrk -(define ttyin/interrupt-on-break #x00002) ; brkint -(define ttyin/ignore-bad-parity-chars #x00004) ; ignpar -(define ttyin/mark-parity-errors #x00008) ; parmrk -(define ttyin/check-parity #x00010) ; inpck -(define ttyin/7bits #x00020) ; istrip -(define ttyin/nl->cr #x00040) ; inlcr -(define ttyin/ignore-cr #x00080) ; igncr -(define ttyin/cr->nl #x00100) ; icrnl -(define ttyin/output-flow-ctl #x00400) ; ixon -(define ttyin/input-flow-ctl #x01000) ; ixoff - - -;;; SVR4 & 4.3+BSD -(define ttyin/xon-any #x800) ; ixany: Any char restarts after stop -(define ttyin/beep-on-overflow #x2000) ; imaxbel: queue full => ring bell - -;;; SVR4 -(define ttyin/lowercase #x200) ; iuclc: Map upper-case to lower case - - -;;; Flags controlling output processing -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyout/enable #o000001) ; opost: enable output processing - -;;; SVR4 & 4.3+BSD -(define ttyout/nl->crnl #o000004) ; onlcr: map nl to cr-nl - -;;; 4.3+BSD -(define ttyout/discard-eot #f) ; onoeot -(define ttyout/expand-tabs #f) ; oxtabs (NOT xtabs) - -;;; SVR4 -(define ttyout/cr->nl #x000008) ; ocrnl -(define ttyout/fill-w/del #x000080) ; ofdel -(define ttyout/delay-w/fill-char #x000040) ; ofill -(define ttyout/uppercase #x000002) ; olcuc -(define ttyout/nl-does-cr #x000020) ; onlret -(define ttyout/no-col0-cr #x000010) ; onocr - -;;; Newline delay -(define ttyout/nl-delay #x000100) ; mask (nldly) -(define ttyout/nl-delay0 #x000000) -(define ttyout/nl-delay1 #x000100) ; tty 37 - -;;; Horizontal-tab delay -(define ttyout/tab-delay #x001800) ; mask (tabdly) -(define ttyout/tab-delay0 #x000000) -(define ttyout/tab-delay1 #x000800) ; tty 37 -(define ttyout/tab-delay2 #x001000) -(define ttyout/tab-delayx #x001800) ; Expand tabs (xtabs, tab3) - -;;; Carriage-return delay -(define ttyout/cr-delay #x000600) ; mask (crdly) -(define ttyout/cr-delay0 #x000000) -(define ttyout/cr-delay1 #x000200) ; tn 300 -(define ttyout/cr-delay2 #x000400) ; tty 37 -(define ttyout/cr-delay3 #x000600) ; concept 100 - -;;; Vertical tab delay -(define ttyout/vtab-delay #x004000) ; mask (vtdly) -(define ttyout/vtab-delay0 #x000000) -(define ttyout/vtab-delay1 #x004000) ; tty 37 - -;;; Backspace delay -(define ttyout/bs-delay #x002000) ; mask (bsdly) -(define ttyout/bs-delay0 #x000000) -(define ttyout/bs-delay1 #x002000) - -;;; Form-feed delay -(define ttyout/ff-delay #x008000) ; mask (ffdly) -(define ttyout/ff-delay0 #x000000) -(define ttyout/ff-delay1 #x008000) - -(define ttyout/all-delay - (bitwise-ior (bitwise-ior (bitwise-ior ttyout/nl-delay ttyout/tab-delay) - (bitwise-ior ttyout/cr-delay ttyout/vtab-delay)) - (bitwise-ior ttyout/bs-delay ttyout/ff-delay))) - - -;;; Control flags - hacking the serial-line. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyc/char-size #x00030) ; csize: character size mask -(define ttyc/char-size5 #x00000) ; 5 bits (cs5) -(define ttyc/char-size6 #x00010) ; 6 bits (cs6) -(define ttyc/char-size7 #x00020) ; 7 bits (cs7) -(define ttyc/char-size8 #x00030) ; 8 bits (cs8) -(define ttyc/2-stop-bits #x00040) ; cstopb: Send 2 stop bits. -(define ttyc/enable-read #x00080) ; cread: Enable receiver. -(define ttyc/enable-parity #x00100) ; parenb -(define ttyc/odd-parity #x00200) ; parodd -(define ttyc/hup-on-close #x00400) ; hupcl: Hang up on last close. -(define ttyc/no-modem-sync #x00800) ; clocal: Ignore modem lines. - -;;; 4.3+BSD -(define ttyc/ignore-flags #f) ; cignore: ignore control flags -(define ttyc/CTS-output-flow-ctl #f) ; ccts_oflow: CTS flow control of output -(define ttyc/RTS-input-flow-ctl #f) ; crts_iflow: RTS flow control of input -(define ttyc/carrier-flow-ctl #f) ; mdmbuf - -;;; Local flags -- hacking the tty driver / user interface. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; POSIX -(define ttyl/visual-delete #x010) ; echoe: Visually erase chars -(define ttyl/echo-delete-line #x020) ; echok: Echo nl after line kill -(define ttyl/echo #x008) ; echo: Enable echoing -(define ttyl/echo-nl #x040) ; echonl: Echo nl even if echo is off -(define ttyl/canonical #x002) ; icanon: Canonicalize input -(define ttyl/enable-signals #x001) ; isig: Enable ^c, ^z signalling -(define ttyl/extended #x8000) ; iexten: Enable extensions -(define ttyl/ttou-signal #x100) ; tostop: SIGTTOU on background output -(define ttyl/no-flush-on-interrupt #x80) ; noflsh - -;;; SVR4 & 4.3+BSD -(define ttyl/visual-delete-line #x0800); echoke: visually erase a line-kill -(define ttyl/hardcopy-delete #x0400); echoprt: visual erase for hardcopy -(define ttyl/echo-ctl #x0200); echoctl: echo control chars as "^X" -(define ttyl/flush-output #x2000); flusho: output is being flushed -(define ttyl/reprint-unread-chars #x4000); pendin: retype pending input - -;;; 4.3+BSD -(define ttyl/alt-delete-word #f) ; altwerase -(define ttyl/no-kernel-status #f) ; nokerninfo: no kernel status on ^T - -;;; SVR4 -(define ttyl/case-map #x4) ; xcase: canonical upper/lower presentation - -;;; Vector of (speed . code) pairs. - -(define baud-rates '#((0 . 0) (1 . 50) (2 . 75) - (3 . 110) (4 . 134) (5 . 150) - (6 . 200) (7 . 300) (8 . 600) - (9 . 1200) (10 . 1800) (11 . 2400) - (12 . 4800) (13 . 9600) (14 . 19200) - (15 . 38400) (14 . exta) (15 . extb))) - -;;; tcflush() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %flush-tty/input 0) ; TCIFLUSH -(define %flush-tty/output 1) ; TCOFLUSH -(define %flush-tty/both 2) ; TCIOFLUSH - - -;;; tcflow() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %tcflow/start-out 1) ; TCOON -(define %tcflow/stop-out 0) ; TCOOFF -(define %tcflow/start-in 3) ; TCION -(define %tcflow/stop-in 2) ; TCIOFF - - -;;; tcsetattr() constants -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define %set-tty-info/now 0) ; TCSANOW Make change immediately. -(define %set-tty-info/drain 1) ; TCSADRAIN Drain output, then change. -(define %set-tty-info/flush 2) ; TCSAFLUSH Drain output, flush input. diff --git a/scsh/sunos/waitcodes.scm b/scsh/sunos/waitcodes.scm deleted file mode 100644 index 2dedbdc..0000000 --- a/scsh/sunos/waitcodes.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Scsh routines for analysing exit codes returned by WAIT. -;;; Copyright (c) 1994 by Olin Shivers. -;;; -;;; To port these to a new OS, consult /usr/include/sys/wait.h, -;;; and check the WIFEXITED, WEXITSTATUS, WIFSTOPPED, WSTOPSIG, -;;; WIFSIGNALED, and WTERMSIG macros for the magic fields they use. -;;; These definitions are for SunOS. -;;; -;;; I could have done a portable version by making C calls for this, -;;; but it's such overkill. - - -;;; If process terminated normally, return the exit code, otw #f. - -(define (status:exit-val status) - (and (not (= (bitwise-and #xFF status) #x7F)) - (zero? (bitwise-and #x7F status)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process was suspended, return the suspending signal, otw #f. - -(define (status:stop-sig status) - (and (= #x7F (bitwise-and status #xFF)) - (bitwise-and #xFF (arithmetic-shift status -8)))) - - -;;; If the process terminated abnormally, -;;; return the terminating signal, otw #f. - -(define (status:term-sig status) - (let ((termsig (bitwise-and status #x7F))) - (and (not (zero? termsig)) ; Didn't exit. - (not (= #x7F (bitwise-and status #xFF))) ; Not suspended. - termsig))) - - -;;; Flags. -(define wait/poll 1) ; Don't hang if nothing to wait for. -(define wait/stopped-children 2) ; Report on suspended subprocs, too. diff --git a/scsh/syntax-helpers.scm b/scsh/syntax-helpers.scm deleted file mode 100644 index 71efd6a..0000000 --- a/scsh/syntax-helpers.scm +++ /dev/null @@ -1,209 +0,0 @@ -;;; Macro expanding procs for scsh. -;;; Written for Clinger/Rees explicit renaming macros. -;;; Needs name-export and receive-syntax S48 packages. -;;; Also needs scsh's utilities package (for CHECK-ARG). -;;; Must be loaded into for-syntax package. -;;; Copyright (c) 1993 by Olin Shivers. - -(define-syntax define-simple-syntax - (syntax-rules () - ((define-simple-syntax (name . pattern) result) - (define-syntax name (syntax-rules () ((name . pattern) result)))))) - -(define (name? thing) - (or (symbol? thing) - (generated? thing))) - -;;; Debugging macro: -(define-simple-syntax (assert exp) - (if (not exp) (error "Assertion failed" (quote exp)))) - -;;; Some process forms and redirections are implicitly backquoted. - -(define (backq form rename) - (list (rename 'quasiquote) form)) ; form -> `form -(define (unq form rename) - (list (rename 'unquote) form)) ; form -> ,form - -(define (make-backquoter rename) - (lambda (form) (list (rename 'quasiquote) form))) -(define (make-unquoter rename) - (lambda (form) (list (rename 'unquote) form))) - -;; DEBLOCK maps an expression to a list of expressions, flattening BEGINS. -;; (deblock '(begin (begin 3 4) 5 6 (begin 7 8))) => (3 4 5 6 7 8) - -(define (deblock exp rename compare) - (let ((%block (rename 'begin))) - (let deblock1 ((exp exp)) - (if (and (pair? exp) - (name? (car exp)) - (compare %block (car exp))) - (apply append (map deblock1 (cdr exp))) - (list exp))))) - -;; BLOCKIFY maps an expression list to a BEGIN form, flattening nested BEGINS. -;; (blockify '( (begin 3 4) 5 (begin 6) )) => (begin 3 4 5 6) - -(define (blockify exps rename compare) - (let ((new-exps (apply append - (map (lambda (exp) (deblock exp rename compare)) - exps)))) - (cond ((null? new-exps) - (error "Empty BEGIN" exps)) - ((null? (cdr new-exps)) ; (begin exp) => exp - (car new-exps)) - (else `(,(rename 'begin) . ,new-exps))))) - -(define (thunkate code rename compare) - (let ((%lambda (rename 'lambda))) - `(,%lambda () ,@(deblock code rename compare)))) - -;;; Process forms are rewritten into code that causes them to execute -;;; in the current process. -;;; (BEGIN . scheme-code) => (STDIO->STDPORTS (LAMBDA () . scheme-code)) -;;; (| pf1 pf2) => (BEGIN (FORK/PIPE (LAMBDA () pf1-code)) -;;; pf2-code) -;;; (|+ conns pf1 pf2) => (BEGIN -;;; (FORK/PIPE+ `conns (LAMBDA () pf1-code)) -;;; pf2-code) -;;; (epf . epf) => epf-code -;;; (prog arg1 ... argn) => (APPLY EXEC-PATH `(prog arg1 ... argn)) -;;; [note the implicit backquoting of PROG, ARG1, ...] - -;;; NOTE: | and |+ won't read into many Scheme's as a symbol. If your -;;; Scheme doesn't handle it, kill them, and just use the PIPE, PIPE+ -;;; aliases. - -(define (transcribe-process-form pf rename compare) - (if (and (list? pf) (pair? pf)) - (case (car pf) - ((begin) (transcribe-begin-process-form (cdr pf) rename compare)) - - ((epf) (transcribe-extended-process-form (cdr pf) rename compare)) - - ((pipe) (transcribe-simple-pipeline (cdr pf) rename compare)) - ((|) (transcribe-simple-pipeline (cdr pf) rename compare)) - - ((|+) (let ((conns (backq (cadr pf) rename)) - (pfs (cddr pf))) - (transcribe-complex-pipeline conns pfs rename compare))) - ((pipe+)(let ((conns (backq (cadr pf) rename)) - (pfs (cddr pf))) - (transcribe-complex-pipeline conns pfs rename compare))) - - (else (let ((%apply (rename 'apply)) - (%exec-path (rename 'exec-path)) - (pf (backq pf rename))) - `(,%apply ,%exec-path ,pf)))) - (error "Illegal process form" pf))) - - -(define (transcribe-begin-process-form body rename compare) - (let ((%with-stdio-ports* (rename 'with-stdio-ports*)) - (%lambda (rename 'lambda))) - `(,%with-stdio-ports* (,%lambda () . ,body)))) - - -(define (transcribe-simple-pipeline pfs rename compare) - (if (null? pfs) (error "Empty pipeline") - (let* ((%fork/pipe (rename 'fork/pipe)) - (trans-pf (lambda (pf) - (transcribe-process-form pf rename compare))) - (chunks (reverse (map trans-pf pfs))) - (last-chunk (car chunks)) - (first-chunks (reverse (cdr chunks))) - (forkers (map (lambda (chunk) - `(,%fork/pipe ,(thunkate chunk rename compare))) - first-chunks))) - (blockify `(,@forkers ,last-chunk) rename compare)))) - - -;;; Should let-bind CONNS in case it's a computed form. - -(define (transcribe-complex-pipeline conns pfs rename compare) - (if (null? pfs) (error "Empty pipeline") - (let* ((%fork/pipe+ (rename 'fork/pipe+)) - (trans-pf (lambda (pf) - (transcribe-process-form pf rename compare))) - (chunks (reverse (map trans-pf pfs))) - (last-chunk (car chunks)) - (first-chunks (reverse (cdr chunks))) - (forkers (map (lambda (chunk) - `(,%fork/pipe+ ,conns - ,(thunkate chunk rename compare))) - first-chunks))) - (blockify `(,@forkers ,last-chunk) rename compare)))) - - -(define (transcribe-extended-process-form epf rename compare) - (let* ((pf (car epf)) ; First form is the process form. - (redirs (cdr epf)) ; Others are redirection forms. - (trans-redir (lambda (r) (transcribe-redirection r rename compare))) - (redir-chunks (map trans-redir redirs)) - (pf-chunk (transcribe-process-form pf rename compare))) - (blockify `(,@redir-chunks ,pf-chunk) rename compare))) - - -(define (transcribe-redirection redir rename compare) - (let* ((backq (make-backquoter rename)) - (parse-spec (lambda (x default-fdes) ; Parse an ([fdes] arg) form. - ;; X must be a list of 1 or 2 elts. - (check-arg (lambda (x) (and (list? x) - (< 0 (length x) 3))) - x transcribe-redirection) - (let ((a (car x)) - (b (cdr x))) - (if (null? b) (values default-fdes (backq a)) - (values (backq a) (backq (car b))))))) - (oops (lambda () (error "unknown i/o redirection" redir))) - (%open (rename 'shell-open)) -; (%dup-port (rename 'dup-port)) - (%dup->fdes (rename 'dup->fdes)) -; (%run/port (rename 'run/port)) - (%open-string-source (rename 'open-string-source)) - (%open/create+trunc (rename 'open/create+trunc)) - (%open/write+append+create (rename 'open/write+append+create)) - (%q (lambda (x) (list (rename 'quote) x))) - (%close (rename 'close)) - (%move->fdes (rename 'move->fdes)) - (%stdports->stdio (rename 'stdports->stdio))) - (cond ((pair? redir) - (let ((args (cdr redir))) - (case (car redir) - ((<) - (receive (fdes fname) (parse-spec args 0) - `(,%open ,fname 0 ,fdes))) - - ((>) - (receive (fdes fname) (parse-spec args 1) - `(,%open ,fname ,%open/create+trunc ,fdes))) - - ;;; BUG BUG -- EPF is backquoted by parse-spec. -; ((<<<) ; Just a RUN/PORT with a specific target fdes. -; (receive (fdes epf) (parse-spec args 0) -; `(,%dup-port (,%run/port . ,epf) ,fdes))) ; Add a WITH-PORT. - - ((<<) - (receive (fdes exp) (parse-spec args 0) - `(,%move->fdes (,%open-string-source ,exp) ,fdes))) - - ((>>) - (receive (fdes fname) (parse-spec args 1) - `(,%open ,fname ,%open/write+append+create ,fdes))) - - ((=) - (assert (= 2 (length args))) ; Syntax check. - `(,%dup->fdes ,(backq (cadr args)) ,(backq (car args)))) - - ((-) ; (- fdes) => close the fdes. - (assert (= 1 (length args))) ; Syntax check. - `(,%close ,(backq (car args)))) - - (else (oops))))) - - ((eq? redir 'stdports) - `(,%stdports->stdio)) - (else (oops))))) - -;;; <<< should be { diff --git a/scsh/syntax.scm b/scsh/syntax.scm deleted file mode 100644 index 8d2e0c5..0000000 --- a/scsh/syntax.scm +++ /dev/null @@ -1,71 +0,0 @@ -;;; Syntax definitions for scsh. -;;; Translating process forms into Scheme code. -;;; Copyright (c) 1993 by Olin Shivers. - -(define-syntax define-simple-syntax - (syntax-rules () - ((define-simple-syntax (name . pattern) result) - (define-syntax name (syntax-rules () ((name . pattern) result)))))) - -;;; The three basic forms for running an extended process form: -;;; EXEC-EPF, &, and RUN. EXEC-EPF is the foundation. - -(define-syntax exec-epf - (lambda (form rename compare) - (transcribe-extended-process-form (cdr form) rename compare))) - -(define-simple-syntax (& . epf) - (fork (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run . epf) - (wait (& . epf))) - -;;; Sequencing operators: -;;; -;;; (|| pf1 ... pfn) -;;; Run each proc until one completes successfully (i.e., exit status 0). -;;; Return true if some proc completes successfully; otherwise #f. -;;; -;;; (&& pf1 ... pfn) -;;; Run each proc until one fails (i.e., exit status non-0). -;;; Return true if all procs complete successfully; otherwise #f. - -;;; WARNING: || is not a readable symbol in R4RS. - -(define-simple-syntax (|| pf ...) (or (zero? (run pf)) ...)) -(define-simple-syntax (:or: pf ...) (or (zero? (run pf)) ...)) -(define-simple-syntax (&& pf ...) (and (zero? (run pf)) ...)) - -(define-simple-syntax (run/collecting fds . epf) - (run/collecting* `fds (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/port+proc . epf) - (run/port+proc* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/port . epf) - (run/port* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/strings . epf) - (run/strings* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/file . epf) - (run/file* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/string . epf) - (run/string* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/sexp . epf) - (run/sexp* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/sexps . epf) - (run/sexps* (lambda () (exec-epf . epf)))) - -(define-simple-syntax (run/pty . epf) - (run/pty* (lambda () (exec-epf . epf)))) - -;(define (expand-mac transformer form) -; (transformer form (lambda (x) x) eq?)) - -;(define-simple-syntax (test-mac trans . form) -; (pp (expand-mac trans (quote form)))) - diff --git a/scsh/syscalls.c b/scsh/syscalls.c deleted file mode 100644 index be4c11e..0000000 --- a/scsh/syscalls.c +++ /dev/null @@ -1,1179 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -#include -#include -#include -#include -#include /* for O_RDWR */ -#include -#include -#include -#include - -/* Make sure foreign-function stubs interface to the C funs correctly: */ -#include "dirstuff1.h" -#include "fdports1.h" -#include "select1.h" -#include "syscalls1.h" -#include "userinfo1.h" - -extern int errno; - -#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno)) -#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE) -#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE) - -scheme_value df_scheme_exec(long nargs, scheme_value *args) -{ - extern int scheme_exec(const char *, scheme_value , scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "scheme_exec"); - r1 = scheme_exec(cig_string_body(args[2]), args[1], args[0]); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_exit(long nargs, scheme_value *args) -{ - extern void exit(int ); - - cig_check_nargs(1, nargs, "exit"); - exit(EXTRACT_FIXNUM(args[0])); - return SCHFALSE; - } - -scheme_value df__exit(long nargs, scheme_value *args) -{ - extern void _exit(int ); - - cig_check_nargs(1, nargs, "_exit"); - _exit(EXTRACT_FIXNUM(args[0])); - return SCHFALSE; - } - -scheme_value df_fork(long nargs, scheme_value *args) -{ - extern pid_t fork(void); - scheme_value ret1; - pid_t r1; - - cig_check_nargs(1, nargs, "fork"); - r1 = fork(); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_wait_pid(long nargs, scheme_value *args) -{ - extern scheme_value wait_pid(int , int , int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - - cig_check_nargs(3, nargs, "wait_pid"); - r1 = wait_pid(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2, &r3); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_chdir(long nargs, scheme_value *args) -{ - extern int chdir(const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "chdir"); - r1 = chdir(cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_scheme_cwd(long nargs, scheme_value *args) -{ - extern int scheme_cwd(const char **); - scheme_value ret1; - int r1; - const char *r2; - - cig_check_nargs(1, nargs, "scheme_cwd"); - r1 = scheme_cwd(&r2); - ret1 = False_on_zero(r1); - {AlienVal(CAR(VECTOR_REF(*args,0))) = (long) r2; CDR(VECTOR_REF(*args,0)) = strlen_or_false(r2);} - return ret1; - } - -scheme_value df_getgid(long nargs, scheme_value *args) -{ - extern gid_t getgid(void); - scheme_value ret1; - gid_t r1; - - cig_check_nargs(0, nargs, "getgid"); - r1 = getgid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_getegid(long nargs, scheme_value *args) -{ - extern gid_t getegid(void); - scheme_value ret1; - gid_t r1; - - cig_check_nargs(0, nargs, "getegid"); - r1 = getegid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_setgid(long nargs, scheme_value *args) -{ - extern int setgid(gid_t ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "setgid"); - r1 = setgid(EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_num_supp_groups(long nargs, scheme_value *args) -{ - extern int num_supp_groups(void); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "num_supp_groups"); - r1 = num_supp_groups(); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_get_groups(long nargs, scheme_value *args) -{ - extern int get_groups(scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "get_groups"); - r1 = get_groups(args[1]); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_getuid(long nargs, scheme_value *args) -{ - extern uid_t getuid(void); - scheme_value ret1; - uid_t r1; - - cig_check_nargs(0, nargs, "getuid"); - r1 = getuid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_geteuid(long nargs, scheme_value *args) -{ - extern uid_t geteuid(void); - scheme_value ret1; - uid_t r1; - - cig_check_nargs(0, nargs, "geteuid"); - r1 = geteuid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_setuid(long nargs, scheme_value *args) -{ - extern int setuid(uid_t ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "setuid"); - r1 = setuid(EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_my_username(long nargs, scheme_value *args) -{ - extern char *my_username(void); - scheme_value ret1; - char *r1; - - cig_check_nargs(1, nargs, "my_username"); - r1 = my_username(); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - return ret1; - } - -scheme_value df_getpid(long nargs, scheme_value *args) -{ - extern pid_t getpid(void); - scheme_value ret1; - pid_t r1; - - cig_check_nargs(0, nargs, "getpid"); - r1 = getpid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_getppid(long nargs, scheme_value *args) -{ - extern pid_t getppid(void); - scheme_value ret1; - pid_t r1; - - cig_check_nargs(0, nargs, "getppid"); - r1 = getppid(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_getpgrp(long nargs, scheme_value *args) -{ - extern pid_t getpgrp(void); - scheme_value ret1; - pid_t r1; - - cig_check_nargs(0, nargs, "getpgrp"); - r1 = getpgrp(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_setpgid(long nargs, scheme_value *args) -{ - extern int setpgid(pid_t , pid_t ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "setpgid"); - r1 = setpgid(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_setsid(long nargs, scheme_value *args) -{ - extern pid_t setsid(void); - scheme_value ret1; - pid_t r1; - - cig_check_nargs(1, nargs, "setsid"); - r1 = setsid(); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_umask(long nargs, scheme_value *args) -{ - - scheme_value ret1; - mode_t r1; - - cig_check_nargs(1, nargs, "umask"); - r1 = umask(EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_process_times(long nargs, scheme_value *args) -{ - extern int process_times(int *, int *, int *, int *); - scheme_value ret1; - int r1; - int r2; - int r3; - int r4; - int r5; - - cig_check_nargs(1, nargs, "process_times"); - r1 = process_times(&r2, &r3, &r4, &r5); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - VECTOR_REF(*args,3) = ENTER_FIXNUM(r5); - return ret1; - } - -scheme_value df_cpu_clock_ticks_per_sec(long nargs, scheme_value *args) -{ - extern int cpu_clock_ticks_per_sec(void); - scheme_value ret1; - int r1; - - cig_check_nargs(0, nargs, "cpu_clock_ticks_per_sec"); - r1 = cpu_clock_ticks_per_sec(); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_chmod(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "chmod"); - r1 = chmod(cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_fchmod(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "fchmod"); - r1 = fchmod(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_chown(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "chown"); - r1 = chown(cig_string_body(args[2]), EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_fchown(long nargs, scheme_value *args) -{ - extern int fchown(int , uid_t , gid_t ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "fchown"); - r1 = fchown(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_access(long nargs, scheme_value *args) -{ - extern int access(const char *, int ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "access"); - r1 = access(cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_BOOLEAN(r1); - return ret1; - } - -scheme_value df_link(long nargs, scheme_value *args) -{ - extern int link(const char *, const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "link"); - r1 = link(cig_string_body(args[1]), cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_mkfifo(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "mkfifo"); - r1 = mkfifo(cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_mkdir(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "mkdir"); - r1 = mkdir(cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_scm_readlink(long nargs, scheme_value *args) -{ - extern const char *scm_readlink(const char *); - scheme_value ret1; - const char *r1; - - cig_check_nargs(2, nargs, "scm_readlink"); - r1 = scm_readlink(cig_string_body(args[1])); - ret1 = errno_on_zero_or_false(r1); - {AlienVal(CAR(VECTOR_REF(*args,0))) = (long) r1; CDR(VECTOR_REF(*args,0)) = strlen_or_false(r1);} - return ret1; - } - -scheme_value df_rename(long nargs, scheme_value *args) -{ - extern int rename(const char *, const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "rename"); - r1 = rename(cig_string_body(args[1]), cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_rmdir(long nargs, scheme_value *args) -{ - extern int rmdir(const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "rmdir"); - r1 = rmdir(cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_scm_utime(long nargs, scheme_value *args) -{ - extern int scm_utime(const char *, int , int , int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(5, nargs, "scm_utime"); - r1 = scm_utime(cig_string_body(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_scm_utime_now(long nargs, scheme_value *args) -{ - extern int scm_utime_now(const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "scm_utime_now"); - r1 = scm_utime_now(cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_scheme_stat(long nargs, scheme_value *args) -{ - extern int scheme_stat(const char *, scheme_value , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "scheme_stat"); - r1 = scheme_stat(cig_string_body(args[2]), args[1], EXTRACT_BOOLEAN(args[0])); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_scheme_fstat(long nargs, scheme_value *args) -{ - extern int scheme_fstat(int , scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "scheme_fstat"); - r1 = scheme_fstat(EXTRACT_FIXNUM(args[1]), args[0]); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_symlink(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "symlink"); - r1 = symlink(cig_string_body(args[1]), cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_truncate(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "truncate"); - r1 = truncate(cig_string_body(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_ftruncate(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "ftruncate"); - r1 = ftruncate(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_unlink(long nargs, scheme_value *args) -{ - extern int unlink(const char *); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "unlink"); - r1 = unlink(cig_string_body(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_fsync(long nargs, scheme_value *args) -{ - extern int fsync(int ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "fsync"); - r1 = fsync(EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_sync(long nargs, scheme_value *args) -{ - - - cig_check_nargs(0, nargs, "sync"); - sync(); - return SCHFALSE; - } - -scheme_value df_close(long nargs, scheme_value *args) -{ - extern int close(int ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "close"); - r1 = close(EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_dup(long nargs, scheme_value *args) -{ - extern int dup(int ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "dup"); - r1 = dup(EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_dup2(long nargs, scheme_value *args) -{ - extern int dup2(int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "dup2"); - r1 = dup2(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_lseek(long nargs, scheme_value *args) -{ - extern off_t lseek(int , off_t , int ); - scheme_value ret1; - off_t r1; - - cig_check_nargs(4, nargs, "lseek"); - r1 = lseek(EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_char_ready_fdes(long nargs, scheme_value *args) -{ - extern scheme_value char_ready_fdes(int ); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(1, nargs, "char_ready_fdes"); - r1 = char_ready_fdes(EXTRACT_FIXNUM(args[0])); - ret1 = r1; - return ret1; - } - -scheme_value df_open(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(4, nargs, "open"); - r1 = open(cig_string_body(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_scheme_pipe(long nargs, scheme_value *args) -{ - extern int scheme_pipe(int *, int *); - scheme_value ret1; - int r1; - int r2; - int r3; - - cig_check_nargs(1, nargs, "scheme_pipe"); - r1 = scheme_pipe(&r2, &r3); - ret1 = False_on_zero(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_read_fdes_char(long nargs, scheme_value *args) -{ - extern scheme_value read_fdes_char(int ); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(1, nargs, "read_fdes_char"); - r1 = read_fdes_char(EXTRACT_FIXNUM(args[0])); - ret1 = r1; - return ret1; - } - -scheme_value df_write_fdes_char(long nargs, scheme_value *args) -{ - extern int write_fdes_char(char , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "write_fdes_char"); - r1 = write_fdes_char(EXTRACT_CHAR(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_read_fdes_substring(long nargs, scheme_value *args) -{ - extern int read_fdes_substring(scheme_value , int , int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(5, nargs, "read_fdes_substring"); - r1 = read_fdes_substring(args[4], EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_write_fdes_substring(long nargs, scheme_value *args) -{ - extern int write_fdes_substring(scheme_value , int , int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(5, nargs, "write_fdes_substring"); - r1 = write_fdes_substring(args[4], EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_kill(long nargs, scheme_value *args) -{ - extern int kill(pid_t , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "kill"); - r1 = kill(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_pause(long nargs, scheme_value *args) -{ - - - cig_check_nargs(0, nargs, "pause"); - pause(); - return SCHFALSE; - } - -scheme_value df_alarm(long nargs, scheme_value *args) -{ - extern unsigned int alarm(unsigned int ); - scheme_value ret1; - unsigned int r1; - - cig_check_nargs(1, nargs, "alarm"); - r1 = alarm(EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_user_info_uid(long nargs, scheme_value *args) -{ - extern int user_info_uid(uid_t , char **, gid_t *, char **, char **); - scheme_value ret1; - int r1; - char *r2; - gid_t r3; - char *r4; - char *r5; - - cig_check_nargs(2, nargs, "user_info_uid"); - r1 = user_info_uid(EXTRACT_FIXNUM(args[1]), &r2, &r3, &r4, &r5); - ret1 = ENTER_BOOLEAN(r1); - {AlienVal(CAR(VECTOR_REF(*args,0))) = (long) r2; CDR(VECTOR_REF(*args,0)) = strlen_or_false(r2);} - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - {AlienVal(CAR(VECTOR_REF(*args,2))) = (long) r4; CDR(VECTOR_REF(*args,2)) = strlen_or_false(r4);} - {AlienVal(CAR(VECTOR_REF(*args,3))) = (long) r5; CDR(VECTOR_REF(*args,3)) = strlen_or_false(r5);} - return ret1; - } - -scheme_value df_user_info_name(long nargs, scheme_value *args) -{ - extern int user_info_name(const char *, uid_t *, gid_t *, char **, char **); - scheme_value ret1; - int r1; - uid_t r2; - gid_t r3; - char *r4; - char *r5; - - cig_check_nargs(2, nargs, "user_info_name"); - r1 = user_info_name(cig_string_body(args[1]), &r2, &r3, &r4, &r5); - ret1 = ENTER_BOOLEAN(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - {AlienVal(CAR(VECTOR_REF(*args,2))) = (long) r4; CDR(VECTOR_REF(*args,2)) = strlen_or_false(r4);} - {AlienVal(CAR(VECTOR_REF(*args,3))) = (long) r5; CDR(VECTOR_REF(*args,3)) = strlen_or_false(r5);} - return ret1; - } - -scheme_value df_group_info_gid(long nargs, scheme_value *args) -{ - extern int group_info_gid(int , char **, char** *, int *); - scheme_value ret1; - int r1; - char *r2; - char** r3; - int r4; - - cig_check_nargs(2, nargs, "group_info_gid"); - r1 = group_info_gid(EXTRACT_FIXNUM(args[1]), &r2, &r3, &r4); - ret1 = ENTER_BOOLEAN(r1); - {AlienVal(CAR(VECTOR_REF(*args,0))) = (long) r2; CDR(VECTOR_REF(*args,0)) = strlen_or_false(r2);} - AlienVal(VECTOR_REF(*args,1)) = (long) r3; - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - return ret1; - } - -scheme_value df_group_info_name(long nargs, scheme_value *args) -{ - extern int group_info_name(const char *, int *, char** *, int *); - scheme_value ret1; - int r1; - int r2; - char** r3; - int r4; - - cig_check_nargs(2, nargs, "group_info_name"); - r1 = group_info_name(cig_string_body(args[1]), &r2, &r3, &r4); - ret1 = ENTER_BOOLEAN(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - AlienVal(VECTOR_REF(*args,1)) = (long) r3; - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - return ret1; - } - -scheme_value df_open_dir(long nargs, scheme_value *args) -{ - extern int open_dir(const char *, char** *, int *); - scheme_value ret1; - int r1; - char** r2; - int r3; - - cig_check_nargs(2, nargs, "open_dir"); - r1 = open_dir(cig_string_body(args[1]), &r2, &r3); - ret1 = False_on_zero(r1); - AlienVal(VECTOR_REF(*args,0)) = (long) r2; - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_scm_sort_filevec(long nargs, scheme_value *args) -{ - extern void scm_sort_filevec(const char** , int ); - - cig_check_nargs(2, nargs, "scm_sort_filevec"); - scm_sort_filevec((const char** )AlienVal(args[1]), EXTRACT_FIXNUM(args[0])); - return SCHFALSE; - } - -scheme_value df_scm_envvec(long nargs, scheme_value *args) -{ - extern char** scm_envvec(int *); - scheme_value ret1; - char** r1; - int r2; - - cig_check_nargs(1, nargs, "scm_envvec"); - r1 = scm_envvec(&r2); - ret1 = VECTOR_REF(*args,0); - AlienVal(ret1) = (long) r1; - VECTOR_REF(*args,1) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_install_env(long nargs, scheme_value *args) -{ - extern int install_env(scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "install_env"); - r1 = install_env(args[0]); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_getenv(long nargs, scheme_value *args) -{ - extern char *getenv(const char *); - scheme_value ret1; - char *r1; - - cig_check_nargs(2, nargs, "getenv"); - r1 = getenv(cig_string_body(args[1])); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - return ret1; - } - -#define errno_on_nonzero_or_false(x) ((x) ? ENTER_FIXNUM(errno) : SCHFALSE) - -scheme_value df_putenv(long nargs, scheme_value *args) -{ - - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "putenv"); - r1 = putenv(scheme2c_strcpy(args[0])); - ret1 = errno_on_nonzero_or_false(r1); - return ret1; - } - -scheme_value df_delete_env(long nargs, scheme_value *args) -{ - extern void delete_env(const char *); - - cig_check_nargs(1, nargs, "delete_env"); - delete_env(cig_string_body(args[0])); - return SCHFALSE; - } - -scheme_value df_close_fdport(long nargs, scheme_value *args) -{ - extern int close_fdport(scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "close_fdport"); - r1 = close_fdport(args[0]); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_fdport_getchar(long nargs, scheme_value *args) -{ - extern scheme_value fdport_getchar(scheme_value ); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(1, nargs, "fdport_getchar"); - r1 = fdport_getchar(args[0]); - ret1 = r1; - return ret1; - } - -scheme_value df_fdport_char_readyp(long nargs, scheme_value *args) -{ - extern scheme_value fdport_char_readyp(scheme_value ); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(1, nargs, "fdport_char_readyp"); - r1 = fdport_char_readyp(args[0]); - ret1 = r1; - return ret1; - } - -scheme_value df_fdport_putchar(long nargs, scheme_value *args) -{ - extern int fdport_putchar(scheme_value , char ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "fdport_putchar"); - r1 = fdport_putchar(args[1], EXTRACT_CHAR(args[0])); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_flush_fdport(long nargs, scheme_value *args) -{ - extern int flush_fdport(scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(1, nargs, "flush_fdport"); - r1 = flush_fdport(args[0]); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_flush_all_ports(long nargs, scheme_value *args) -{ - extern int flush_all_ports(void); - scheme_value ret1; - int r1; - - cig_check_nargs(0, nargs, "flush_all_ports"); - r1 = flush_all_ports(); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_seek_fdport(long nargs, scheme_value *args) -{ - extern int seek_fdport(scheme_value , off_t , int , int *); - scheme_value ret1; - int r1; - int r2; - - cig_check_nargs(4, nargs, "seek_fdport"); - r1 = seek_fdport(args[3], EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); - ret1 = False_on_zero(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_tell_fdport(long nargs, scheme_value *args) -{ - extern int tell_fdport(scheme_value , int *); - scheme_value ret1; - int r1; - int r2; - - cig_check_nargs(2, nargs, "tell_fdport"); - r1 = tell_fdport(args[1], &r2); - ret1 = False_on_zero(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - return ret1; - } - -scheme_value df_set_fdbuf(long nargs, scheme_value *args) -{ - extern int set_fdbuf(scheme_value , int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "set_fdbuf"); - r1 = set_fdbuf(args[2], EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_set_cloexec(long nargs, scheme_value *args) -{ - extern int set_cloexec(int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(2, nargs, "set_cloexec"); - r1 = set_cloexec(EXTRACT_FIXNUM(args[1]), EXTRACT_BOOLEAN(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_init_fdports(long nargs, scheme_value *args) -{ - extern void init_fdports(void); - - cig_check_nargs(0, nargs, "init_fdports"); - init_fdports(); - return SCHFALSE; - } - -scheme_value df_install_port(long nargs, scheme_value *args) -{ - extern int install_port(int , scheme_value , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "install_port"); - r1 = install_port(EXTRACT_FIXNUM(args[2]), args[1], EXTRACT_FIXNUM(args[0])); - ret1 = False_on_zero(r1); - return ret1; - } - -scheme_value df_maybe_fdes2port(long nargs, scheme_value *args) -{ - extern scheme_value maybe_fdes2port(int ); - scheme_value ret1; - scheme_value r1; - - cig_check_nargs(1, nargs, "maybe_fdes2port"); - r1 = maybe_fdes2port(EXTRACT_FIXNUM(args[0])); - ret1 = r1; - return ret1; - } - -scheme_value df_move_fdport(long nargs, scheme_value *args) -{ - extern int move_fdport(int , scheme_value , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "move_fdport"); - r1 = move_fdport(EXTRACT_FIXNUM(args[2]), args[1], EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_BOOLEAN(r1); - return ret1; - } - -scheme_value df_read_fdport_substring(long nargs, scheme_value *args) -{ - extern int read_fdport_substring(scheme_value , int , int , scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(5, nargs, "read_fdport_substring"); - r1 = read_fdport_substring(args[4], EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), args[1]); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_write_fdport_substring(long nargs, scheme_value *args) -{ - extern int write_fdport_substring(scheme_value , int , int , scheme_value ); - scheme_value ret1; - int r1; - - cig_check_nargs(5, nargs, "write_fdport_substring"); - r1 = write_fdport_substring(args[4], EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), args[1]); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_fcntl_read(long nargs, scheme_value *args) -{ - extern int fcntl_read(int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "fcntl_read"); - r1 = fcntl_read(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1])); - ret1 = errno_or_false(r1); - VECTOR_REF(*args,0) = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_fcntl_write(long nargs, scheme_value *args) -{ - extern int fcntl_write(int , int , int ); - scheme_value ret1; - int r1; - - cig_check_nargs(3, nargs, "fcntl_write"); - r1 = fcntl_write(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0])); - ret1 = errno_or_false(r1); - return ret1; - } - -scheme_value df_sleep(long nargs, scheme_value *args) -{ - extern unsigned int sleep(unsigned int ); - scheme_value ret1; - unsigned int r1; - - cig_check_nargs(1, nargs, "sleep"); - r1 = sleep(EXTRACT_FIXNUM(args[0])); - ret1 = ENTER_FIXNUM(r1); - return ret1; - } - -scheme_value df_scm_gethostname(long nargs, scheme_value *args) -{ - extern char *scm_gethostname(void); - scheme_value ret1; - char *r1; - - cig_check_nargs(1, nargs, "scm_gethostname"); - r1 = scm_gethostname(); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - return ret1; - } - -scheme_value df_errno_msg(long nargs, scheme_value *args) -{ - extern char *errno_msg(int ); - scheme_value ret1; - char *r1; - - cig_check_nargs(2, nargs, "errno_msg"); - r1 = errno_msg(EXTRACT_FIXNUM(args[1])); - ret1 = VECTOR_REF(*args,0); - {AlienVal(CAR(ret1)) = (long) r1; CDR(ret1) = strlen_or_false(r1);} - return ret1; - } - diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm deleted file mode 100644 index c664e05..0000000 --- a/scsh/syscalls.scm +++ /dev/null @@ -1,1118 +0,0 @@ -;;; POSIX system-call Scheme binding. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; Scheme48 implementation. - -;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme? - -(foreign-source - "#include " - "#include " - "#include " - "#include " - "#include /* for O_RDWR */" ; ??? - "#include " - "#include " - "#include " - "#include " - "" - "/* Make sure foreign-function stubs interface to the C funs correctly: */" - "#include \"dirstuff1.h\"" - "#include \"fdports1.h\"" - "#include \"select1.h\"" - "#include \"syscalls1.h\"" - "#include \"userinfo1.h\"" - "" - "extern int errno;" - "" - "#define errno_on_zero_or_false(x) ((x) ? SCHFALSE : ENTER_FIXNUM(errno))" - "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)" - "#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)" ; Not a function. - "" "") - -;;; Macro for converting syscalls that return error codes to ones that -;;; raise exceptions on errors. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from -;;; one that returns an error code as its first return value -- #f for win, -;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall), -;;; we try again. -;;; -;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==> -;;; -;;; (define (SYSCALL . ARGS) -;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS) -;;; (cond ((not err) (values . RET-VALS)) ; Win -;;; ((= err errno/intr) (SYSCALL . ARGS)) ; Retry -;;; (else (errno-error err SYSCALL . ARGS))))); Lose - -(define-syntax define-errno-syscall - (syntax-rules () - ((define-errno-syscall (syscall arg ...) syscall/errno - ret-val ...) - (define (syscall arg ...) - (receive (err ret-val ...) (syscall/errno arg ...) - (cond ((not err) (values ret-val ...)) ; Win - ((= err errno/intr) (syscall arg ...)) ; Retry - (else (errno-error err syscall arg ...)))))) ; Lose - - ;;; This case handles rest args - ((define-errno-syscall (syscall . args) syscall/errno - ret-val ...) - (define (syscall . args) - (receive (err ret-val ...) (apply syscall/errno args) - (cond ((not err) (values ret-val ...)) ; Win - ((= err errno/intr) (apply syscall args)) ; Retry - (else (apply errno-error err syscall args)))))))); Lose - -;;; By the way, it would be better to insert a (LET LP () ...) for the -;;; the errno/intr retries, instead of calling the top-level definition -;;; (because in Scheme you have to allow for the fact that top-level -;;; defns can be re-defined, so the compiler can't just turn it into a -;;; jump), but the brain-dead S48 byte-compiler will cons a closure for -;;; the LP loop, which means that little syscalls like read-char can cons -;;; like crazy. So I'm doing it this way. Ech. - - -;;; Process -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign %%exec/errno - (scheme_exec (string prog) - (vector-desc argv) - (desc env)) ; string vector or #t. - integer) - -(define (%%exec prog argv env) - (errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute. - -(define (%exec prog arg-list env) - (let ((argv (mapv! stringify (list->vector arg-list))) - (prog (stringify prog)) - (env (if (eq? env #t) #t (alist->env-vec env)))) - (%%exec prog argv env))) - - -(define-foreign exit/errno ; errno -- misnomer. - (exit (integer status)) - ignore) - -(define-foreign %exit/errno ; errno -- misnomer - (_exit (integer status)) - ignore) - -(define (%exit . maybe-status) - (%exit/errno (:optional maybe-status 0)) - (error "Yikes! %exit returned.")) - - -(define-foreign %%fork/errno (fork) - (multi-rep (to-scheme pid_t errno_or_false) - pid_t)) - -;;; If the fork fails, and we are doing early zombie reaping, then reap -;;; some zombies to try and free up a some space in the process table, -;;; and try again. -;;; -;;; This ugly little hack will have to stay in until I do early -;;; zombie reaping with SIGCHLD interrupts. - -(define (%%fork-with-retry/errno) - (receive (err pid) (%%fork/errno) - (cond ((and err (eq? 'early (autoreap-policy))) - (reap-zombies) - (%%fork/errno)) - (else (values err pid))))) - -(define-errno-syscall (%%fork) %%fork-with-retry/errno - pid) - -;;; Posix waitpid(2) call. -(define-foreign %wait-pid/errno (wait_pid (integer pid) (integer options)) - desc ; errno or #f - integer ; process' id - integer) ; process' status - - -;;; Miscellaneous process state -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Working directory - -(define-foreign %chdir/errno - (chdir (string directory)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%chdir dir) %chdir/errno) - -(define (chdir . maybe-dir) - (let ((dir (:optional maybe-dir (home-dir)))) - (%chdir (ensure-file-name-is-nondirectory dir)))) - - -(define-foreign cwd/errno (scheme_cwd) - (to-scheme integer "False_on_zero") ; errno or #f - string) ; directory (or #f on error) - -(define-errno-syscall (cwd) cwd/errno - dir) - - -;;; GID - -(define-foreign user-gid (getgid) gid_t) -(define-foreign user-effective-gid (getegid) gid_t) - -(define-foreign set-gid/errno (setgid (gid_t id)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (set-gid gid) set-gid/errno) - -(define-foreign %num-supplementary-gids/errno (num_supp_groups) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-foreign load-groups/errno (get_groups (vector-desc group-vec)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define (user-supplementary-gids) - (receive (err numgroups) (%num-supplementary-gids/errno) - (if err (errno-error err user-supplementary-gids) - (let ((vec (make-vector numgroups))) - (receive (err numgroups2) (load-groups/errno vec) - (if err (errno-error err user-supplementary-gids) - (vector->list vec))))))) - - -;;; UID - -(define-foreign user-uid (getuid) uid_t) -(define-foreign user-effective-uid (geteuid) uid_t) - -(define-foreign set-uid/errno (setuid (uid_t id)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (set-uid uid_t) set-uid/errno) - -(define-foreign %user-login-name (my_username) - static-string) - -(define (user-login-name) - (or (%user-login-name) - (error "Cannot get your name"))) - -;;; PID - -(define-foreign pid (getpid) pid_t) -(define-foreign parent-pid (getppid) pid_t) - - -;;; Process groups and session ids -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign process-group (getpgrp) pid_t) -(define-foreign %set-process-group/errno - (setpgid (pid_t pid) (pid_t groupid)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%set-process-group pid pgrp) - %set-process-group/errno) - - -(define (set-process-group arg1 . maybe-arg2) - (receive (pid pgrp) (if (null? maybe-arg2) - (values (pid) arg1) - (values arg1 (car maybe-arg2))) - (%set-process-group pid pgrp))) - - -(define-foreign become-session-leader/errno (setsid) - (multi-rep (to-scheme pid_t errno_or_false) - pid_t)) - -(define-errno-syscall (become-session-leader) become-session-leader/errno - sid) - - -;;; UMASK - -(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS - mode_t) - -(define (umask) - (let ((m (set-umask 0))) - (set-umask m) - m)) - - -;;; PROCESS TIMES - -;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away. -;;; OOPS: The ret values should be clock_t, not int, but cig can't handle it. - -(define-foreign process-times/errno (process_times) - (to-scheme integer errno_or_false) - integer ; user cpu time - integer ; system cpu time - integer ; user cpu time for me and all my descendants. - integer) ; system cpu time for me and all my descendants. - -(define-errno-syscall (process-times) process-times/errno - utime stime cutime cstime) - -(define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer) - -;;; File system -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Useful little utility for generic ops that work on filenames, fd's or -;;; ports. - -(define (generic-file-op thing fd-op fname-op) - (if (string? thing) (fname-op thing) - (call/fdes thing fd-op))) - - -(define-foreign set-file-mode/errno - (chmod (string path) (mode_t mode)) no-declare ; integer on SunOS - (to-scheme integer errno_or_false)) - -; IBM's AIX include files declare fchmod(char*, mode_t). -; Amazing, but true. So we must prevent this def-foreign from issuing -; the conflicting, correct declaration. Hence the NO-DECLARE. - -(define-foreign set-fdes-mode/errno - (fchmod (integer fd) (mode_t mode)) ; integer on SunOS - no-declare ; Workaround for AIX bug. - (to-scheme integer errno_or_false)) - -(define-errno-syscall (set-file-mode thing mode) - (lambda (thing mode) - (generic-file-op thing - (lambda (fd) (set-fdes-mode/errno fd mode)) - (lambda (fname) (set-file-mode/errno fname mode))))) - - -;;; NO-DECLARE: gcc unistd.h bogusness. -(define-foreign set-file-uid&gid/errno - (chown (string path) (uid_t uid) (gid_t gid)) no-declare - (to-scheme integer errno_or_false)) - -(define-foreign set-fdes-uid&gid/errno - (fchown (integer fd) (uid_t uid) (gid_t gid)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (set-file-owner thing uid) - (lambda (thing uid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid/errno fd uid -1)) - (lambda (fname) (set-file-uid&gid/errno fname uid -1))))) - -(define-errno-syscall (set-file-group thing gid) - (lambda (thing gid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid/errno fd gid -1)) - (lambda (fname) (set-file-uid&gid/errno fname gid -1))))) - - -;;; Uses real uid and gid, not effective. I don't use this anywhere. - -(define-foreign %file-ruid-access-not? - (access (string path) - (integer perms)) - bool) - -;(define (file-access? path perms) -; (not (%file-access-not? path perms))) -; -;(define (file-executable? fname) -; (file-access? fname 1)) -; -;(define (file-writable? fname) -; (file-access? fname 2)) -; -;(define (file-readable? fname) -; (file-access? fname 4)) - - -(define-foreign create-hard-link/errno - (link (string original-name) (string new-name)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (create-hard-link original-name new-name) - create-hard-link/errno) - - -(define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode)) - no-declare ; integer on SunOS - (to-scheme integer errno_or_false)) - -(define-errno-syscall (create-fifo path mode) create-fifo/errno) - - -(define-foreign create-directory/errno - (mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS. - (to-scheme integer errno_or_false)) - -(define (create-directory path . maybe-mode) - (let ((mode (:optional maybe-mode #o777)) - (fname (ensure-file-name-is-nondirectory path))) - (cond ((create-directory/errno fname mode) => - (lambda (err) - (if err (errno-error err create-directory path mode))))))) - - -(define-foreign read-symlink/errno (scm_readlink (string path)) - (multi-rep (to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f - static-string)) - -(define-errno-syscall (read-symlink path) read-symlink/errno - new-path) - - -(define-foreign %rename-file/errno - (rename (string old-name) (string new-name)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%rename-file old-name new-name) - %rename-file/errno) - - -(define-foreign delete-directory/errno - (rmdir (string path)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (delete-directory path) delete-directory/errno) - - -(define-foreign %utime/errno (scm_utime (string path) - (integer ac_hi) (integer ac_lo) - (integer m_hi) (integer m_lo)) - (to-scheme integer errno_or_false)) - -(define-foreign %utime-now/errno (scm_utime_now (string path)) - (to-scheme integer errno_or_false)) - - -;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time]) - -(define (set-file-times/errno path . maybe-times) - (if (pair? maybe-times) - (let* ((access-time (real->exact-integer (car maybe-times))) - (mod-time (if (pair? (cddr maybe-times)) - (error "Too many arguments to set-file-times/errno" - (cons path maybe-times)) - (real->exact-integer (cadr maybe-times))))) - (%utime/errno path (hi8 access-time) (lo24 access-time) - (hi8 mod-time) (lo24 mod-time))) - (%utime-now/errno path))) - -(define-errno-syscall (set-file-times . args) set-file-times/errno) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; STAT - -(define-foreign stat-file/errno - (scheme_stat (string path) (vector-desc data) (bool chase?)) - (to-scheme integer "False_on_zero")) ; errno or #f - -;(define-errno-syscall (stat-file fd data chase?) stat-file/errno) - -(define-foreign stat-fdes/errno - (scheme_fstat (integer fd) (vector-desc data)) - (to-scheme integer "False_on_zero")) ; errno or #f - -;(define-errno-syscall (stat-fdes fd data) stat-fdes/errno) - -(define-record file-info - type - device - inode - mode - nlinks - uid - gid - size - atime - mtime - ctime - ) - - -;;; Should be redone to return multiple-values. -(define (file-info/errno fd/port/fname chase?) - (let ((ans-vec (make-vector 14)) - (time-hack (lambda (lo-24 hi-8) - (let ((val (+ (arithmetic-shift hi-8 24) lo-24))) - (if (zero? (bitwise-and hi-8 #x80)) val - ;; Oops -- it's a negative 32-bit value. - ;; Or in all the sign bits. - (bitwise-ior (bitwise-not #xffffffff) - val))))) - (file-type (lambda (type-code) - (vector-ref '#(block-special char-special directory fifo - regular socket symlink) - type-code)))) - - (cond ((generic-file-op fd/port/fname - (lambda (fd) - (stat-fdes/errno fd ans-vec)) - (lambda (fname) - (stat-file/errno fname ans-vec chase?))) - => (lambda (err) (values err #f))) - - (else (values #f (make-file-info (file-type (vector-ref ans-vec 0)) - (vector-ref ans-vec 1) - (vector-ref ans-vec 2) - (vector-ref ans-vec 3) - (vector-ref ans-vec 4) - (vector-ref ans-vec 5) - (vector-ref ans-vec 6) - (vector-ref ans-vec 7) - (time-hack (vector-ref ans-vec 8) - (vector-ref ans-vec 9)) - (time-hack (vector-ref ans-vec 10) - (vector-ref ans-vec 11)) - (time-hack (vector-ref ans-vec 12) - (vector-ref ans-vec 13)))))))) - -(define (file-info fd/port/fname . maybe-chase?) - (let ((chase? (:optional maybe-chase? #t))) - (receive (err info) (file-info/errno fd/port/fname chase?) - (if err (errno-error err file-info fd/port/fname chase?) - info)))) - - -(define file-attributes - (deprecated-proc file-info "file-attributes" "Use file-info instead.")) - - -;;; "no-declare" as there is no agreement among the OS's as to whether or not -;;; the OLD-NAME arg is "const". It *should* be const. - -(define-foreign create-symlink/errno - (symlink (string old-name) (string new-name)) no-declare - (to-scheme integer errno_or_false)) - -;(define-errno-syscall (create-symlink old-name new-name) -; create-symlink/errno) - - -;;; "no-declare" as there is no agreement among the OS's as to whether or not -;;; the PATH arg is "const". It *should* be const. - -(define-foreign truncate-file/errno - (truncate (string path) (off_t length)) no-declare - (to-scheme integer errno_or_false)) - -(define-foreign truncate-fdes/errno - (ftruncate (integer fd) (off_t length)) no-declare ; Indigo bogosity. - (to-scheme integer errno_or_false)) - -(define-errno-syscall (truncate-file path length) - (lambda (thing length) - (generic-file-op thing - (lambda (fd) (truncate-fdes/errno fd length)) - (lambda (fname) (truncate-file/errno fname length))))) - - -(define-foreign delete-file/errno - (unlink (string path)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (delete-file path) delete-file/errno) - - -(define-foreign sync-file/errno (fsync (integer fd)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (sync-file fd/port) - (lambda (fd/port) - (if (output-port? fd/port) (force-output fd/port)) - (sleazy-call/fdes fd/port sync-file/errno))) - - -;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys. -(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int - ignore) - - -;;; I/O -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign %close-fdes/errno (close (integer fd)) - (to-scheme integer "errno_or_false")) - -(define (%close-fdes fd) - (let lp () - (let ((errno (%close-fdes/errno fd))) - (cond ((not errno) #t) ; Successful close. - ((= errno errno/badf) #f) ; File descriptor already closed. - ((= errno errno/intr) (lp)) ; Retry. - (else - (errno-error errno %close-fdes fd)))))) ; You lose. - -(define-foreign %dup/errno - (dup (integer fd)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-errno-syscall (%dup fd) %dup/errno - new-fd) - -(define-foreign %dup2/errno - (dup2 (integer fd-from) (integer fd-to)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno - new-fd) - - -(define-foreign %fd-seek/errno - (lseek (integer fd) (off_t offset) (integer whence)) - (multi-rep (to-scheme off_t errno_or_false) - off_t)) - - - -(define seek/set 0) ;Unix codes for "whence" -(define seek/delta 1) -(define seek/end 2) - -(define (seek fd/port offset . maybe-whence) - (let ((whence (:optional maybe-whence seek/set))) - (receive (err cursor) - ((if (integer? fd/port) %fd-seek/errno %fdport-seek/errno) - fd/port - offset - whence) - (if err (errno-error err seek fd/port offset whence) cursor)))) - -(define (tell fd/port) - (receive (err offset) (if (integer? fd/port) - (%fd-seek/errno fd/port 0 seek/delta) ; seek(fd) - (%fdport-tell/errno fd/port)) ; ftell(f) - (if err (errno-error err tell fd/port) offset))) - - -(define-foreign %char-ready-fdes?/errno - (char_ready_fdes (integer fd)) - desc) ; errno, #t, or #f - -(define (%char-ready-fdes? fd) - (let ((retval (%char-ready-fdes?/errno fd))) - (if (integer? retval) (errno-error retval %char-ready-fdes? fd) - retval))) - - -(define-foreign %open/errno - (open (string path) - (integer flags) - (mode_t mode)) ; integer on SunOS - no-declare ; NOTE - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-errno-syscall (%open path flags mode) %open/errno - fd) - -(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666 - (%open path flags (:optional maybe-mode #o666))) - - -(define-foreign pipe-fdes/errno (scheme_pipe) - (to-scheme integer "False_on_zero") ; Win: #f, lose: errno - integer ; r - integer) ; w - -(define-errno-syscall (pipe-fdes) pipe-fdes/errno - r w) - -(define (pipe) - (receive (r-fd w-fd) (pipe-fdes) - (let ((r (fdes->inport r-fd)) - (w (fdes->outport w-fd))) - (release-port-handle r) - (release-port-handle w) - (values r w)))) - -(define-foreign %read-fdes-char - (read_fdes_char (integer fd)) - desc) ; Char or errno or #f (eof). - -(define (read-fdes-char fd) - (let ((c (%read-fdes-char fd))) - (if (integer? c) (errno-error c read-fdes-char fd) c))) - - -(define-foreign write-fdes-char/errno (write_fdes_char (char char) (integer fd)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read and write - -(define-foreign read-fdes-substring!/errno - (read_fdes_substring (string-desc buf) - (integer start) - (integer end) - (integer fd)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-foreign write-fdes-substring/errno - (write_fdes_substring (string-desc buf) - (integer start) - (integer end) - (integer fd)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - - -;;; Signals (rather incomplete) -;;; --------------------------- - -(define-foreign signal-pid/errno - (kill (pid_t pid) (integer signal)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (signal-pid pid signal) signal-pid/errno) - -(define (signal-process proc signal) - (signal-pid (cond ((proc? proc) (proc:pid proc)) - ((integer? proc) proc) - (else (error "Illegal proc passed to signal-process" proc))) - signal)) - -(define (signal-process-group proc-group signal) - (signal-pid (- (cond ((proc? proc-group) (proc:pid proc-group)) - ((integer? proc-group) proc-group) - (else (error "Illegal proc passed to signal-process-group" - proc-group)))) - signal)) - -;;; SunOS, not POSIX: -;;; (define-foreign signal-process-group/errno -;;; (killpg (integer proc-group) (integer signal)) -;;; (to-scheme integer errno_or_false)) -;;; -;;; (define-errno-syscall (signal-process-group proc-group signal) -;;; signal-process-group/errno) - -(define-foreign pause-until-interrupt (pause) no-declare ignore) - -(define-foreign itimer (alarm (uint_t secs)) uint_t) - -;;; User info -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-record user-info - name uid gid home-dir shell - - ;; Make user-info records print like #{user-info shivers}. - ((disclose ui) - (list "user-info" (user-info:name ui)))) - -(define-foreign %uid->user-info (user_info_uid (uid_t uid)) - bool ; win? - static-string ; name - gid_t ; gid - static-string ; home-dir - static-string); shell - -(define-foreign %name->user-info (user_info_name (string name)) - bool ; win? - uid_t ; uid - gid_t ; gid - static-string ; home-dir - static-string); shell - -(define (uid->user-info uid) - (receive (win? name gid home-dir shell) - (%uid->user-info uid) - (if win? (make-user-info name uid gid home-dir shell) - (error "Cannot get user's information" uid->user-info uid)))) - -(define (name->user-info name) - (receive (win? uid gid home-dir shell) - (%name->user-info name) - (if win? (make-user-info name uid gid home-dir shell) - (error "Cannot get user's information" name->user-info name)))) - -(define (user-info uid/name) - ((cond ((string? uid/name) name->user-info) - ((integer? uid/name) uid->user-info) - (else (error "user-info arg must be string or integer" uid/name))) - uid/name)) - -;;; Derived functions - -(define (->uid uid/name) - (user-info:uid (user-info uid/name))) - -(define (->username uid/name) - (user-info:name (user-info uid/name))) - -(define (%homedir uid/name) - (user-info:home-dir (user-info uid/name))) - - -;;; Group info -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-record group-info - name gid members - - ;; Make group-info records print like #{group-info wheel}. - ((disclose gi) (list "group-info" (group-info:name gi)))) - -;;; These guys return static structs, so they aren't reentrant. -;;; Must be fixed for threaded version. - -(define-foreign %gid->group-info - (group_info_gid (integer gid)) - bool ; win? - static-string ; name - (C char**) ; members - integer) ; num members - -(define-foreign %name->group-info - (group_info_name (string name)) - bool ; win? - integer ; gid - (C char**) ; members - integer) ; num members - -(define (gid->group-info gid) - (receive (win? name members nmembers) - (%gid->group-info gid) - (if win? - (make-group-info name gid - (vector->list (C-string-vec->Scheme members nmembers))) - (error "Cannot get group's information for gid" gid)))) - -(define (name->group-info name) - (receive (win? gid members nmembers) - (%name->group-info name) - (if win? - (make-group-info name gid - (vector->list (C-string-vec->Scheme members nmembers))) - (error "Cannot get group's information for name" name)))) - -(define (group-info gid/name) - ((cond ((string? gid/name) name->group-info) - ((integer? gid/name) gid->group-info) - (else (error "group-info arg must be string or integer" gid/name))) - gid/name)) - -;;; Derived functions - -(define (->gid name) - (group-info:gid (group-info name))) - -(define (->groupname gid) - (group-info:name (group-info gid))) - -;;; Directory stuff -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign %open-dir (open_dir (string dir-name)) - (to-scheme integer "False_on_zero") ; Win: #f, lose: errno - (C char**) ; Vector of strings - integer) ; Length of strings - -;;; Takes a null-terminated C vector of strings -- filenames. -;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others. - -(define-foreign %sort-file-vector - (scm_sort_filevec ((C "const char** ~a") cvec) - (integer veclen)) - ignore) - -(define (directory-files . args) - (let-optionals args ((dir ".") - (dotfiles? #f)) - (check-arg string? dir directory-files) - (receive (err cvec numfiles) - (%open-dir (ensure-file-name-is-nondirectory dir)) - (if err (errno-error err directory-files dir dotfiles?)) - (%sort-file-vector cvec numfiles) - (let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles)))) - (if dotfiles? files - (filter (lambda (f) (not (char=? (string-ref f 0) #\.))) - files)))))) - -(define (match-files regexp . maybe-dir) - (let ((dir (:optional maybe-dir "."))) - (check-arg string? dir match-files) - (receive (err cvec numfiles) - (%open-dir (ensure-file-name-is-nondirectory dir)) - (if err (errno-error err match-files regexp dir)) - (receive (err numfiles) (%filter-C-strings! regexp cvec) - (if err (error err match-files)) - (%sort-file-vector cvec numfiles) - (let ((files (C-string-vec->Scheme&free cvec numfiles))) - (vector->list files)))))) - - -;;; Environment manipulation -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; (var . val) / "var=val" rep conversion: - -(define (split-env-string var=val) - (let ((i (index var=val #\=))) - (if i (values (substring var=val 0 i) - (substring var=val (+ i 1) (string-length var=val))) - (error "No \"=\" in environment string" var=val)))) - -(define (env-list->alist env-list) - (map (lambda (var=val) - (call-with-values (lambda () (split-env-string var=val)) - cons)) - env-list)) - -(define (alist->env-vec alist) - (list->vector (map (lambda (var.val) - (string-append (car var.val) "=" (cdr var.val))) - alist))) - -;;; ENV->ALIST - -(define-foreign %load-env (scm_envvec) - (C char**) ; char **environ - fixnum) ; & its length. - -(define (env->list) - (receive (C-env nelts) (%load-env) - (vector->list (C-string-vec->Scheme C-env nelts)))) - -(define (env->alist) (env-list->alist (env->list))) - -;;; ALIST->ENV - -(define-foreign %install-env/errno - (install_env (vector-desc env-vec)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%install-env env-vec) %install-env/errno) - -(define (alist->env alist) - (%install-env (alist->env-vec alist))) - -;;; GETENV, PUTENV, SETENV - -(define-foreign getenv (getenv (string var)) - static-string) - -(foreign-source - "#define errno_on_nonzero_or_false(x) ((x) ? ENTER_FIXNUM(errno) : SCHFALSE)" - "" "") - -;(define-foreign putenv/errno -; (put_env (string var=val)) -; desc) ; #f or errno - - -;;; putenv takes a constant: const char *, cig can't figure that out.. -(define-foreign putenv/errno - (putenv (string-copy var=val)) no-declare - (to-scheme integer errno_on_nonzero_or_false)) ; #f or errno - -(define-foreign delete-env (delete_env (string var)) - ignore) - -(define (putenv var=val) - (if (putenv/errno var=val) - (error "malloc failure in putenv" var=val))) - -(define (setenv var val) - (if val - (putenv (string-append var "=" val)) - (delete-env var))) - - -;;; Fd-ports -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-foreign close-fdport*/errno (close_fdport (desc data)) - (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno - -(define (close-fdport* data) - (let lp () - (let ((errno (close-fdport*/errno data))) - (cond ((not errno) #t) ; Successful close. - ((= errno errno/badf) #f) ; File descriptor already closed. - ((= errno errno/intr) (lp)) ; Retry. - (else - (errno-error errno close-fdport* data)))))) ; You lose. - - - -(define-foreign %fdport*-read-char/errno (fdport_getchar (desc data)) - desc) ; char, errno, or #f for end-of-file. - -(define (%fdport*-read-char data) - (let ((c (%fdport*-read-char/errno data))) - (if (integer? c) - (if (= c errno/intr) - (%fdport*-read-char data) ; Retry - (errno-error c %fdport*-read-char data)) ; Lose - (or c eof-object)))) ; Win - - -(define-foreign %fdport*-char-ready?/errno - (fdport_char_readyp (desc data)) - desc) - -(define (%fdport*-char-ready? data) - (let ((val (%fdport*-char-ready?/errno data))) - (if (integer? val) (errno-error val %fdport*-char-ready? data) - val))) - -(define-foreign %fdport*-write-char/errno - (fdport_putchar (desc data) (char c)) - (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno - -(define-errno-syscall (%fdport*-write-char desc c) - %fdport*-write-char/errno) - -(define-foreign flush-fdport*/errno (flush_fdport (desc data)) - (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno - -;;; FLUSH-FDPORT* isn't defined with DEFINE-ERRNO-SYSCALL because that would -;;; return 0 values, which blows up S48's extended-port machinery. This -;;; version returns #f. -;;; ??? - -(define (flush-fdport* data) - (cond ((flush-fdport*/errno data) => - (lambda (err) (if (= err errno/intr) - (flush-fdport* data) - (errno-error err flush-fdport* data)))) - (else #f))) - -(define-foreign flush-all-ports/errno (flush_all_ports) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (flush-all-ports) - flush-all-ports/errno) - -(define-foreign %fdport*-seek/errno - (seek_fdport (desc data) (off_t offset) (integer whence)) - (to-scheme integer "False_on_zero") ; errno - integer) ; new position - -(define-foreign %fdport*-tell/errno - (tell_fdport (desc data)) - (to-scheme integer "False_on_zero") ; errno - integer) - -(define-foreign %fdport*-set-buffering/errno - (set_fdbuf (desc data) (integer policy) (integer size)) - (to-scheme integer "False_on_zero")) ; errno - -(define-foreign %set-cloexec (set_cloexec (integer fd) (bool val)) - (to-scheme integer "errno_or_false")) - -(define-foreign %init-fdports! (init_fdports) ignore) - -(define-foreign %install-port/errno - (install_port (integer fd) (desc port) (integer revealed)) - (to-scheme integer "False_on_zero")) ; Win: #f, lose: errno - -(define-errno-syscall (%install-port fd port revealed) %install-port/errno) - - -(define-foreign %maybe-fdes->port (maybe_fdes2port (integer fd)) - desc) ; fd or #f - - -;;; Doesn't signal on error. Clients must check return value. - -(define-foreign %move-fdport - (move_fdport (integer fd) (desc port) (integer new-revealed-count)) - bool) ; Win: #f, lose: #t - - -(define-foreign read-fdport*-substring!/errno - (read_fdport_substring (string-desc buf) - (integer start) - (integer end) - (desc data)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-foreign write-fdport*-substring/errno - (write_fdport_substring (string-desc buf) - (integer start) - (integer end) - (desc fdport)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - - -;;; Some of fcntl() -;;;;;;;;;;;;;;;;;;; - -(define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command)) - (multi-rep (to-scheme integer errno_or_false) - integer)) - -(define-foreign %fcntl-write/errno - (fcntl_write (fixnum fd) (fixnum command) (fixnum val)) - (to-scheme integer errno_or_false)) - -(define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value) -(define-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno) - -;;; fcntl()'s F_GETFD and F_SETFD. Note that the SLEAZY- prefix on the -;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour -;;; of these procedures. Straight CALL/FDES modifies unrevealed file -;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it -;;; would interfere with the reading and writing of that bit! - -(define (fdes-flags fd/port) - (sleazy-call/fdes fd/port - (lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags)))) - -(define (set-fdes-flags fd/port flags) - (sleazy-call/fdes fd/port - (lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags)))) - -;;; fcntl()'s F_GETFL and F_SETFL. -;;; Get: Returns open flags + get-status flags (below) -;;; Set: append, sync, async, nbio, nonblocking, no-delay - -(define (fdes-status fd/port) - (sleazy-call/fdes fd/port - (lambda (fd) (%fcntl-read fd fcntl/get-status-flags)))) - -(define (set-fdes-status fd/port flags) - (sleazy-call/fdes fd/port - (lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags)))) - -;;; Miscellaneous -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; usleep(3): Try to sleep for USECS microseconds. -;;; sleep(3): Try to sleep for SECS seconds. - -; De-released -- not POSIX and not on SGI systems. -; (define-foreign usleep (usleep (integer usecs)) integer) - -(define-foreign sleep (sleep (uint_t secs)) uint_t) - -(define-foreign %gethostname (scm_gethostname) - static-string) - -(define system-name %gethostname) - -(define-foreign errno-msg (errno_msg (integer i)) - static-string) diff --git a/scsh/syscalls1.c b/scsh/syscalls1.c deleted file mode 100644 index c171bef..0000000 --- a/scsh/syscalls1.c +++ /dev/null @@ -1,520 +0,0 @@ -/* Scheme48/scsh Unix system interface. -** Routines that require custom C support. -** Copyright (c) 1993,1994 by Olin Shivers. -*/ - -#include "sysdep.h" -#include -#include -#include -#include -#include -#include -#include /* for O_RDWR */ -#include - -#include -/* This losage brought to you by Solaris and BIND */ -/* We thank Solaris for forcing users to get a new BIND */ -/* We thank BIND for blowing away the Solaris includea for MAXHOSTNAMELEN */ -#ifndef MAXHOSTNAMELEN -#include -#ifndef MAXHOSTNAMELEN -#define MAXHOSTNAMELEN MAXDNAME -#endif -#endif - -#include -#include /* For gethostname() */ -#include -#include -#include -#include -#include - -#include "cstuff.h" -#include "machine/stdio_dep.h" - -/* Make sure our exports match up w/the implementation: */ -#include "syscalls1.h" - -extern int errno; -extern char **environ; - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - - -/* Process stuff -******************************************************************************* -** wait, exec -*/ - -/* Args: pid, flags; returns [retval, status] */ - -scheme_value wait_pid(int pid, int flags, int *result_pid, int *status) -{ - *result_pid = waitpid(pid, status, flags); - return (*result_pid == -1) ? ENTER_FIXNUM(errno) : SCHFALSE; - } - - -/* env: Scheme vector of Scheme strings, e.g., #("TERM=vt100" ...) or #T. -** argv: Scheme vector of Scheme strings. -** prog: String. -** -** We don't typecheck the args. You must do the typechecking -** on the Scheme side. -*/ - -int scheme_exec(const char *prog, scheme_value argv, scheme_value env) -{ - int i, j, e; - int argc = VECTOR_LENGTH(argv); - - char **unix_argv = Malloc(char*, argc+1); - char **unix_env; - - if( unix_argv == NULL ) return errno; - - /* Scheme->Unix convert the argv parameter. */ - for(i=0; iUnix convert the env parameter. */ - if( env == SCHTRUE ) unix_env = environ; - else { - int envlen = VECTOR_LENGTH(env); - unix_env = Malloc(char*, envlen+1); - - if( !unix_env ) goto lose; - - for(j=0; j 0 and 1 -> -1 */ - - /* If it's already what we want, just return. */ - if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return 0; - - flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC); - return fcntl(fd, F_SETFD, flags) ? errno : 0; - } - - -/* Two versions of CWD -******************************************************************************* -*/ - -/* Simple-minded POSIX version. */ -int scheme_cwd(const char **dirp) -{ - char *buf; - int size = 100; - - buf = Malloc(char,size); - if(!buf) goto lose; - - while( !getcwd(buf, size) ) - if( errno != ERANGE ) goto lose; - else { - /* Double the buf and retry. */ - char *nbuf = Realloc(char, buf, size += size); - if( !nbuf ) goto lose; - buf = nbuf; - } - - *dirp = (const char*) buf; /* win */ - return 0; - - lose: - {int e = errno; - Free(buf); - *dirp = NULL; - return e;} -} - - -#if 0 -/* Faster SUNOS version. */ -/* We have to use malloc, because the stub is going to free the string. */ - -int scheme_cwd(const char **dirp) -{ - char *buf = Malloc(char,MAXPATHLEN); - int e; - - if( buf && getwd(buf) ) { - *dirp = (const char*) buf; - return 0; - } - - /* lose */ - e = errno; - Free(buf); - *dirp = NULL; - return e; -} -#endif - - -/* Process times -******************************************************************************* -*/ - -/* Sleazing on the types here -- the ret values should be clock_t, not int, -** but cig can't handle it. -*/ - -int process_times(int *utime, int *stime, int *cutime, int *cstime) -{ - struct tms tms; - clock_t t = times(&tms); - if (t == -1) return -1; - *utime = tms.tms_utime; - *stime = tms.tms_stime; - *cutime = tms.tms_cutime; - *cstime = tms.tms_cstime; - return t; - } - -int cpu_clock_ticks_per_sec() -{ -#ifdef _SC_CLK_TCK - static long clock_tick = 0; - - if (clock_tick == 0) - clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */ - return clock_tick; -#else -#ifdef CLK_TCK - return CLK_TCK; -#else - return 60; -#endif -#endif -} - -/* Reading and writing -******************************************************************************* -*/ - -/* Return a char, #f (EOF), or errno. */ -scheme_value read_fdes_char(int fd) -{ - int i; char c; - if( (i=read(fd, &c, 1)) < 0 ) return ENTER_FIXNUM(errno); - if(i==0) return SCHFALSE; - return ENTER_CHAR(c); -} - -int write_fdes_char(char c, int fd) {return write(fd, &c, 1);} - - -int read_fdes_substring(scheme_value buf, int start, int end, int fd) -{ - return read(fd, StrByte(buf,start), end-start); -} - -int write_fdes_substring(scheme_value buf, int start, int end, int fd) -{ - return write(fd, StrByte(buf,start), end-start); -} - - -/* -** Stat hackery -******************************************************************************* -** DANGER, WILL ROBINSON: It's not necessarily true that all these -** stat fields will fit into a fixnum. -** In fact, S48's 30 bit fixnums are almost certainly good enough -** for everything but times. 30 signed bits ran out in 1987. -** So the time fields are split, low 24, high everything else. -** I haven't bothered w/anything else, since the only other real limit -** is size -- files can't be bigger than .5Gb. -*/ - -/* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */ -#ifndef S_ISSOCK -#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK) -#endif -#ifndef S_ISLNK -#define S_ISLNK(mode) (((mode) & S_IFMT) == S_IFLNK) -#endif - -#define low24(x) ((x) & 0xffffff) -#define hi_but24(x) (((x) >> 24) & 0xff) - -/* Note that hi_but24 assumes value is a *32 bit* signed value. We have to -** do this, because C's right-shift operator exposes word width. A suckful -** language. -*/ - -/* Internal aux function -- loads stat values into Scheme vector: */ -static int really_stat(int retval, struct stat *s, scheme_value vec) -{ - int modes, typecode = -1; - - if( 14 != VECTOR_LENGTH(vec) ) return -1; - if( retval < 0 ) return errno; - - modes = s->st_mode; - if( S_ISBLK(modes) ) typecode = 0; - else if( S_ISCHR(modes) ) typecode = 1; - else if( S_ISDIR(modes) ) typecode = 2; - else if( S_ISFIFO(modes) ) typecode = 3; - else if( S_ISREG(modes) ) typecode = 4; - else if( S_ISSOCK(modes) ) typecode = 5; - else if( S_ISLNK(modes) ) typecode = 6; - - VECTOR_REF(vec,0) = ENTER_FIXNUM(typecode); - VECTOR_REF(vec,1) = ENTER_FIXNUM(s->st_dev); - VECTOR_REF(vec,2) = ENTER_FIXNUM(s->st_ino); - VECTOR_REF(vec,3) = ENTER_FIXNUM(s->st_mode); - VECTOR_REF(vec,4) = ENTER_FIXNUM(s->st_nlink); - VECTOR_REF(vec,5) = ENTER_FIXNUM(s->st_uid); - VECTOR_REF(vec,6) = ENTER_FIXNUM(s->st_gid); - VECTOR_REF(vec,7) = ENTER_FIXNUM(s->st_size); - - VECTOR_REF(vec,8) = ENTER_FIXNUM( low24(s->st_atime)); - VECTOR_REF(vec,9) = ENTER_FIXNUM(hi_but24(s->st_atime)); - - VECTOR_REF(vec,10) = ENTER_FIXNUM( low24(s->st_mtime)); - VECTOR_REF(vec,11) = ENTER_FIXNUM(hi_but24(s->st_mtime)); - - VECTOR_REF(vec,12) = ENTER_FIXNUM( low24(s->st_ctime)); - VECTOR_REF(vec,13) = ENTER_FIXNUM(hi_but24(s->st_ctime)); - - /* We also used to do st_rdev, st_blksize, and st_blocks. - These aren't POSIX, and, e.g., are not around on SGI machines. - Too bad -- blksize is useful. Unix sux. */ - - return 0; -} - -int scheme_stat(const char *path, scheme_value vec, int chase_p) -{ - struct stat s; - return really_stat(chase_p ? stat(path, &s) : lstat(path, &s), &s, vec); -} - -int scheme_fstat(int fd, scheme_value vec) -{ - struct stat s; - return really_stat(fstat(fd,&s), &s, vec); -} - - -/* Supplementary groups access -******************************************************************************* -*/ - -int num_supp_groups(void) -{ - return getgroups(0,NULL); -} - -/* Load the supplementary groups into GVEC. */ - -int get_groups(scheme_value gvec) -{ - int veclen = VECTOR_LENGTH(gvec), i, retval; - gid_t gvec0[20], *gp = gvec0; - - if( veclen > 20 ) - if( NULL == (gp=Malloc(gid_t,veclen)) ) return -1; - - retval = getgroups(veclen, gp); - - if( retval != -1 ) - for( i=veclen; i--; ) - VECTOR_REF(gvec,i) = ENTER_FIXNUM(gp[i]); - - if( veclen > 20 ) Free(gp); - - return retval; -} - - -/* Environment hackery -******************************************************************************* -*/ - -int put_env(const char *s) -{ - char *s1 = Malloc(char, strlen(s)+1); - if( !s1 ) return ENTER_FIXNUM(errno); - - strcpy(s1, s); - - return putenv(s1) ? ENTER_FIXNUM(errno) : SCHFALSE; -} - -char** scm_envvec(int *len) /* Returns environ c-vector & its length. */ -{ - char **ptr=environ; - while( *ptr ) ptr++; - *len = ptr-environ; - - return(environ); -} - -/* Load the (Scheme) strings in the (Scheme) vector VEC into environ. -** Somewhat wasteful of memory: we do not free any of the memory -** in the old environ -- don't know if it is being shared elsewhere. -*/ - -int install_env(scheme_value vec) -{ - int i, envsize; - char **newenv; - - envsize = VECTOR_LENGTH(vec); - newenv = Malloc(char*, envsize+1); - if( !newenv ) return errno; - - for( i=0; i - -char *errno_msg(int i) -{ -#ifdef HAVE_STRERROR - return(strerror(i)); -#else - /* temp hack until we figure out what to do about losing sys_errlist's */ - extern -#ifdef HAVE_CONST_SYS_ERRLIST - const -#endif - char *sys_errlist[]; - extern int sys_nerr; - return ( i < 0 || i > sys_nerr ) ? NULL /* i.e., #f */ - : (char*) sys_errlist[i]; -#endif /* !HAVE_STRERROR */ -} - -/* Some of fcntl() -****************** -*/ - -int fcntl_read(int fd, int command) -{ return fcntl(fd, command); } - - -int fcntl_write(int fd, int command, int value) -{ return fcntl(fd, command, value); } diff --git a/scsh/syscalls1.h b/scsh/syscalls1.h deleted file mode 100644 index e23221c..0000000 --- a/scsh/syscalls1.h +++ /dev/null @@ -1,55 +0,0 @@ -/* Exports from syscalls1.c. */ - -scheme_value wait_pid(int pid, int flags, int *result_pid, int *status); - -int scheme_exec(const char *prog, scheme_value argv, scheme_value env); - -int scheme_pipe(int *r, int *w); - -char const *scm_readlink(const char *path); - -int scm_utime(char const *path, int ac_hi, int ac_lo, int mod_hi, int mod_lo); - -int scm_utime_now(char const *path); - -int scheme_cwd(const char **dirp); - -int process_times(int *utime, int *stime, int *cutime, int *cstime); - -int cpu_clock_ticks_per_sec(); - -scheme_value read_fdes_char(int fd); - -int write_fdes_char(char c, int fd); - -int read_fdes_substring(scheme_value buf, int start, int end, int fd); - -int read_stream_substring(scheme_value buf, int start, int end, FILE *f); - -int write_fdes_substring(scheme_value buf, int start, int end, int fd); - -int write_stream_substring(scheme_value buf, int start, int end, FILE *f); - -int scheme_stat(const char *path, scheme_value vec, int chase_p); - -int scheme_fstat(int fd, scheme_value vec); - -int num_supp_groups(void); - -int get_groups(scheme_value gvec); - -int put_env(const char *s); - -char** scm_envvec(int *len); - -int install_env(scheme_value vec); - -void delete_env(const char *var); - -char *scm_gethostname(void); - -char *errno_msg(int i); - -int fcntl_read(int fd, int command); - -int fcntl_write(int fd, int command, int value); diff --git a/scsh/time.c b/scsh/time.c deleted file mode 100644 index 37b6074..0000000 --- a/scsh/time.c +++ /dev/null @@ -1,109 +0,0 @@ -/* This is an Scheme48/C interface file, -** automatically generated by cig. -*/ - -#include -#include /* For malloc. */ -#include "libcig.h" - -#include "time1.h" -scheme_value df_time_plus_ticks(long nargs, scheme_value *args) -{ - extern scheme_value time_plus_ticks(int *, int *, int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - int r4; - int r5; - - cig_check_nargs(1, nargs, "time_plus_ticks"); - r1 = time_plus_ticks(&r2, &r3, &r4, &r5); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - VECTOR_REF(*args,3) = ENTER_FIXNUM(r5); - return ret1; - } - -scheme_value df_scheme_time(long nargs, scheme_value *args) -{ - extern scheme_value scheme_time(int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - - cig_check_nargs(1, nargs, "scheme_time"); - r1 = scheme_time(&r2, &r3); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_date2time(long nargs, scheme_value *args) -{ - extern scheme_value date2time(int , int , int , int , int , int , scheme_value , scheme_value , int , int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - - cig_check_nargs(10, nargs, "date2time"); - r1 = date2time(EXTRACT_FIXNUM(args[9]), EXTRACT_FIXNUM(args[8]), EXTRACT_FIXNUM(args[7]), EXTRACT_FIXNUM(args[6]), EXTRACT_FIXNUM(args[5]), EXTRACT_FIXNUM(args[4]), args[3], args[2], EXTRACT_BOOLEAN(args[1]), &r2, &r3); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - return ret1; - } - -scheme_value df_time2date(long nargs, scheme_value *args) -{ - extern scheme_value time2date(int , int , scheme_value , int *, int *, int *, int *, int *, int *, const char **, int *, int *, int *, int *); - scheme_value ret1; - scheme_value r1; - int r2; - int r3; - int r4; - int r5; - int r6; - int r7; - const char *r8; - int r9; - int r10; - int r11; - int r12; - - cig_check_nargs(4, nargs, "time2date"); - r1 = time2date(EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), args[1], &r2, &r3, &r4, &r5, &r6, &r7, &r8, &r9, &r10, &r11, &r12); - ret1 = r1; - VECTOR_REF(*args,0) = ENTER_FIXNUM(r2); - VECTOR_REF(*args,1) = ENTER_FIXNUM(r3); - VECTOR_REF(*args,2) = ENTER_FIXNUM(r4); - VECTOR_REF(*args,3) = ENTER_FIXNUM(r5); - VECTOR_REF(*args,4) = ENTER_FIXNUM(r6); - VECTOR_REF(*args,5) = ENTER_FIXNUM(r7); - {AlienVal(CAR(VECTOR_REF(*args,6))) = (long) r8; CDR(VECTOR_REF(*args,6)) = strlen_or_false(r8);} - VECTOR_REF(*args,7) = ENTER_FIXNUM(r9); - VECTOR_REF(*args,8) = ENTER_BOOLEAN(r10); - VECTOR_REF(*args,9) = ENTER_FIXNUM(r11); - VECTOR_REF(*args,10) = ENTER_FIXNUM(r12); - return ret1; - } - -scheme_value df_format_date(long nargs, scheme_value *args) -{ - extern scheme_value format_date(const char *, int , int , int , int , int , int , scheme_value , int , int , int , const char **); - scheme_value ret1; - scheme_value r1; - const char *r2; - - cig_check_nargs(12, nargs, "format_date"); - r1 = format_date(cig_string_body(args[11]), EXTRACT_FIXNUM(args[10]), EXTRACT_FIXNUM(args[9]), EXTRACT_FIXNUM(args[8]), EXTRACT_FIXNUM(args[7]), EXTRACT_FIXNUM(args[6]), EXTRACT_FIXNUM(args[5]), args[4], EXTRACT_BOOLEAN(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2); - ret1 = r1; - {AlienVal(CAR(VECTOR_REF(*args,0))) = (long) r2; CDR(VECTOR_REF(*args,0)) = strlen_or_false(r2);} - return ret1; - } - diff --git a/scsh/time.scm b/scsh/time.scm deleted file mode 100644 index e6579b2..0000000 --- a/scsh/time.scm +++ /dev/null @@ -1,305 +0,0 @@ -;;; Time interface for scsh. -;;; Copyright (c) 1994 by Olin Shivers. - -;;; Should I have a (FILL-IN-DATE! date) procedure that fills in -;;; the redundant info in a date record? -;;; - month-day & month defined -> week-day & year-day filled in. -;;; - month-day and year-day filled in from week-day and year-day -;;; (not provided by mktime(), but can be synthesized) -;;; - If tz-secs and tz-name not defined, filled in from current time zone. -;;; - If tz-name not defined, fabbed from tz-secs. -;;; - If tz-secs not defined, filled in from tz-name. - -(foreign-source "#include \"time1.h\"" ; Import the time1.h interface. - "") - -;;; A TIME is an instant in the history of the universe; it is location -;;; independent, barring relativistic effects. It is measured as the -;;; number of seconds elapsed since "epoch" -- January 1, 1970 UTC. - -;;; A DATE is a *local* name for an instant in time -- which instant -;;; it names depends on your time zone (February 23, 1994 4:37 pm happens -;;; at different moments in Boston and Hong Kong). - -;;; DATE definition -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; We hack this so the date maker can take take the last three slots -;;; as optional arguments. - -(define-record %date ; A Posix tm struct - seconds ; Seconds after the minute (0-59) - minute ; Minutes after the hour (0-59) - hour ; Hours since midnight (0-23) - month-day ; Day of the month (1-31) - month ; Months since January (0-11) - year ; Years since 1900 - tz-name ; Time zone as a string. - tz-secs ; Time zone as an integer: seconds west of UTC. - summer? ; Summer time (Daylight savings) in effect? - week-day ; Days since Sunday (0-6) ; Redundant - year-day) ; Days since Jan. 1 (0-365) ; Redundant - -(define date? %date?) - -(define date:seconds %date:seconds) -(define date:minute %date:minute) -(define date:hour %date:hour) -(define date:month-day %date:month-day) -(define date:month %date:month) -(define date:year %date:year) -(define date:tz-name %date:tz-name) -(define date:tz-secs %date:tz-secs) -(define date:summer? %date:summer?) -(define date:week-day %date:week-day) -(define date:year-day %date:year-day) - -(define set-date:seconds set-%date:seconds) -(define set-date:minute set-%date:minute) -(define set-date:hour set-%date:hour) -(define set-date:month-day set-%date:month-day) -(define set-date:month set-%date:month) -(define set-date:year set-%date:year) -(define set-date:tz-name set-%date:tz-name) -(define set-date:tz-secs set-%date:tz-secs) -(define set-date:summer? set-%date:summer?) -(define set-date:week-day set-%date:week-day) -(define set-date:year-day set-%date:year-day) - -(define (make-date s mi h md mo y . args) - (let-optionals args ((tzn #f) (tzs #f) (s? #f) (wd 0) (yd 0)) - (make-%date s mi h md mo y tzn tzs s? wd yd))) - - -;;; Not exported to interface. -(define (time-zone? x) - (or (integer? x) ; Seconds offset from UTC. - (string? x) ; Time zone name, e.g. "EDT" - (not x))) ; Local time - - -;;; Time -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; TICKS/SEC is defined in OS-dependent code. - -(define-foreign %time+ticks/errno (time_plus_ticks) ; C fun is OS-dependent - desc ; errno or #f - fixnum ; hi secs - fixnum ; lo secs - fixnum ; hi ticks - fixnum) ; lo ticks - -(define (time+ticks) - (receive (err hi-secs lo-secs hi-ticks lo-ticks) (%time+ticks/errno) - (if err (errno-error err time+ticks) - (values (compose-8/24 hi-secs lo-secs) - (compose-8/24 hi-ticks lo-ticks))))) - -(define (time+ticks->time secs ticks) - (+ secs (/ ticks (ticks/sec)))) - -(define-foreign %time/errno (scheme_time) - desc ; errno or #f - fixnum ; hi secs - fixnum) ; lo secs - - -(define-foreign %date->time/errno (date2time (fixnum sec) - (fixnum min) - (fixnum hour) - (fixnum month-day) - (fixnum month) - (fixnum year) - (desc tz-name) ; #f or string - (desc tz-secs) ; #f or int - (bool summer?)) - desc ; errno or #f - fixnum ; hi secs - fixnum) ; lo secs - -(define (time . args) ; optional arg [date] - (let lp () - (receive (err hi-secs lo-secs) - (if (null? args) - (%time/errno) ; Fast path for (time). - (let ((date (check-arg date? (car args) time))) - (%date->time/errno (date:seconds date) - (date:minute date) - (date:hour date) - (date:month-day date) - (date:month date) - (date:year date) - (date:tz-name date) ; #f or string - (date:tz-secs date) ; #f or int - (date:summer? date)))) - - (cond ((not err) (compose-8/24 hi-secs lo-secs)) ; Win. - ((= errno/intr err) (lp)) ; Retry. - (else (apply errno-error err time args)))))); Lose. - - -;;; Date -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-foreign %time->date (time2date (fixnum time-hi) - (fixnum time-lo) - (desc zone)) - desc ; errno or #f - fixnum ; seconds - fixnum ; minute - fixnum ; hour - fixnum ; month-day - fixnum ; month - fixnum ; year - string ; tz-name (#f if we need to make it from tz-secs) - fixnum ; tz-secs - bool ; summer? - fixnum ; week-day - fixnum) ; year-day - - -(define (date . args) ; Optional args [time zone] - (let ((time (if (pair? args) - (real->exact-integer (check-arg real? (car args) date)) - (time))) - (zone (check-arg time-zone? - (and (pair? args) (:optional (cdr args) #f)) - date))) - (let lp () - (receive (err seconds minute hour month-day month - year tz-name tz-secs summer? week-day year-day) - (%time->date (hi8 time) (lo24 time) zone) - (cond ((not err) - (make-%date seconds minute hour month-day month - year - (format-time-zone (or tz-name "UTC") tz-secs) - tz-secs summer? week-day year-day)) - ((= errno/intr err) (lp)) - (errno-error err date time zone)))))) - - -;;; Formatting date strings -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (date->string date) ; Sun Sep 16 01:03:52 1973 - (format-date "~a ~b ~d ~H:~M:~S ~Y" date)) - -(define (format-date fmt date) - (check-arg date? date format-date) - (receive (err result) - (%format-date/errno fmt - (date:seconds date) - (date:minute date) - (date:hour date) - (date:month-day date) - (date:month date) - (date:year date) - (if (string? (date:tz-name date)) - (date:tz-name date) - (deintegerize-time-zone (date:tz-secs date))) - (date:summer? date) - (date:week-day date) - (date:year-day date)) - (cond ((not err) result) - ((= errno/intr err) (format-date fmt date)) - (else (errno-error err format-date fmt date))))) - -(define-foreign %format-date/errno (format_date (string fmt) - (fixnum seconds) - (fixnum minute) - (fixnum hour) - (fixnum month-day) - (fixnum month) - (fixnum year) - (desc tz-name) - (bool summer?) - (fixnum week-day) - (fixnum year-day)) - desc ; false or errno - string) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Obsoleted, since DATE records now include time zone info. -;;; If you want the UTC offset, just do (date:tz-secs (date [time tz])). -;;; -;(define (utc-offset . args) ; Optional args [time tz] -; (let ((tim (if (pair? args) -; (real->exact-integer (check-arg real? (car args) utc-offset)) -; (time))) -; (tz (and (pair? args) -; (check-arg time-zone? (:optional (cdr args) #f) utc-offset)))) -; (if (integer? tz) tz -; (- (time (date tim tz) 0) tim)))) - - -;(define (time-zone . args) ; Optional args [summer? tz] -; (let ((tz (and (pair? args) -; (check-arg time-zone? (:optional (cdr args) #f) time-zone)))) -; (if (integer? tz) -; (deintegerize-time-zone tz) -; (let* ((summer? (if (pair? args) (car args) (time))) -; (summer? (if (real? summer?) (real->exact-integer summer?) summer?))) -; (receive (err zone) (%time-zone/errno summer? tz) -; (if err (errno-error err time-zone summer? tz) -; zone)))))) - -;;; 8/24 bit signed integer splitting and recombination. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (hi8 n) (bitwise-and (arithmetic-shift n -24) #xff)) -(define (lo24 n) (bitwise-and n #xffffff)) - -(define (compose-8/24 hi-8 lo-24) - (let ((val (+ (arithmetic-shift hi-8 24) lo-24))) - (if (zero? (bitwise-and hi-8 #x80)) val - ;; Oops -- it's a negative 32-bit value. - ;; Or in all the sign bits. - (bitwise-ior (bitwise-not #xffffffff) - val)))) - -;;; Render a number as a two-digit base ten numeral. -;;; Pathetic. FORMAT should do this for me. -(define (two-digits n) - (let ((s (number->string n))) - (if (= (string-length s) 1) - (string-append "0" s) - s))) - -;;; If time-zone is an integer, convert to a Posix-format string of the form: -;;; UTC+hh:mm:ss -(define (deintegerize-time-zone tz) - (if (integer? tz) - (format-time-zone "UTC" tz) - tz)) - - -;;; NAME is a simple time-zone name such as "EST" or "UTC". You get them -;;; back from the Unix time functions as the values of the char *tzname[2] -;;; standard/dst vector. The problem is that these time are ambiguous. -;;; This function makes them unambiguous by tacking on the UTC offset -;;; in Posix format, such as "EST+5". You need to do this for two reasons: -;;; 1. Simple time-zone strings are not recognised at all sites. -;;; For example, HP-UX doesn't understand "EST", but does understand "EST+5" -;;; 2. Time zones represented as UTC offsets (e.g., "UTC+5") are returned -;;; back from the Unix time software as just "UTC", which in the example -;;; just given is 5 hours off. Try setting TZ=UTC+5 and running the date(1) -;;; program. It will give you EST time, but print the time zone as "UTC". -;;; Oops. - -(define (format-time-zone name offset) - (if (zero? offset) name - (receive (sign offset) - (if (< offset 0) - (values #\+ (- offset)) ; Notice the flipped sign - (values #\- offset)) ; of SIGN. - (let* ((offset (modulo offset 86400)) - (h (quotient offset 3600)) - (m (quotient (modulo offset 3600) 60)) - (s (modulo offset 60))) - (if (zero? s) - (if (zero? m) - (format #f "~a~a~d" name sign h) ; name+h - (format #f "~a~a~a:~a" ; name+hh:mm - sign (two-digits h) (two-digits m))) - (format #f "~a~a~a:~a:~a" ; name+hh:mm:ss - sign (two-digits h) (two-digits m) (two-digits s))))))) diff --git a/scsh/time1.c b/scsh/time1.c deleted file mode 100644 index cb99ddc..0000000 --- a/scsh/time1.c +++ /dev/null @@ -1,408 +0,0 @@ -/* Posix time support for scsh. -** Copyright (c) 1994 by Olin Shivers. -*/ - -/* WARNING: THIS FILE HAS CODE THAT DEPENDS ON 32-BIT ARCHITECTURES. -** This code is so marked. -** -** The source code is also conditionalised by three #ifdef feature macros: -** HAVE_TZNAME -** The char *tzname[2] global variable is POSIX. Everyone provides -** it...except some "classic" versions of SunOS that we still care about -** running (People in LCS/AI refuse to switch to Solaris). So, we kluge -** around not having it. -** -** HAVE_GMTOFF -** Some systems (NetBSD, NeXTSTEP, Solaris) have a non-standard field in the -** tm struct, the tm_gmtoff field. localtime() sets it to the offset from -** UTC for the current time. If you have this field, it is trivial to -** compute the the UTC time zone offset. If you have a strict POSIX system, -** and don't have it, then the offset can be computed with a slower -** technique. -** -** NeXT -** The presence of this feature macro means that, basically, you are -** screwed, and should go download yourself a real Unix system off the -** Net. For free. -** -** More specifically, it means that (1) the presence of the strftime() -** function will cause the whole system build to die at link time, -** when compiled with the -posix flag. (NeXT bug #59098) There is no fix -** for this as of November 1994. Thanks, guys. -** -** We handle this problem by abandoning ship. When compiled under NeXT, -** your time zone is always computed to be the empty string. -** -** The other problem is that (2) NeXT's mktime() procedure pays attention -** to the gmt_offset field of the tm struct you give it, instead of -** the $TZ environment variable. So there is no way to convert a date -** to a time without knowing in advance what the UTC offset is in seconds. -** This screws up scsh's DATE->TIME procedure. -*/ - -#include -#include -#include -#include - -#include "sysdep.h" -#include "cstuff.h" -#include "time1.h" /* Make sure the .h interface agrees with the code. */ - -extern char **environ; - -/* To work in the UTC time zone, do "environ = utc_env;". */ -static char *utc_env[] = {"TZ=UCT0", 0}; - -#ifdef HAVE_TZNAME -extern char *tzname[]; /* Why isn't this defined in time.h? */ -#endif - -/* These two functions allow you to temporarily override -** the current time zone with one of your choice. make_newenv() -** takes a time zone string as an argument, and constructs a Unix environ -** vector with a single entry: "TZ=". You pass the new environ vector -** as an argument. It installs the new environment, and returns the old -** one. You can later pass the old environment back to revert_env() -** to reinstall the old environment and free up malloc'd storage. -** -** On error, make_newenv returns NULL. -*/ - -static char **make_newenv(scheme_value zone, char *newenv[2]) -{ - int zonelen = STRING_LENGTH(zone); - char **oldenv = environ, - *tz = Malloc(char, 4+zonelen); - if( !tz ) return NULL; - strcpy(tz, "TZ="); - strncpy(tz+3, &STRING_REF(zone,0), zonelen); - tz[zonelen+3] = '\0'; - newenv[0] = tz; - newenv[1] = NULL; - - environ = newenv; /* Install it. */ - return oldenv; - } - -static void revert_env(char **old_env) -{ - char *tz = *environ; - environ = old_env; - Free(tz); - } - - -/*****************************************************************************/ - -/* Sux because it's dependent on 32-bitness. */ -#define hi8(i) (((i)>>24) & 0xff) -#define lo24(i) ((i) & 0xffffff) -#define comp8_24(hi, lo) (((hi)<<24) + (lo)) - -scheme_value scheme_time(int *hi_secs, int *lo_secs) -{ - time_t t; - errno = 0; - t = time(NULL); - if( t == -1 && errno ) return ENTER_FIXNUM(errno); - *hi_secs = hi8(t); - *lo_secs = lo24(t); - return SCHFALSE; - } - -/* Zone: -** #f Local time -** int Offset from GMT in seconds. -** string Time zone understood by OS. -*/ -scheme_value time2date(int hi_secs, int lo_secs, scheme_value zone, - int *sec, int *min, int *hour, - int *mday, int *month, int *year, - const char **tz_name, int *tz_secs, - int *summer, - int *wday, int *yday) -{ - time_t t = comp8_24(hi_secs, lo_secs); - struct tm d; - - if( FIXNUMP(zone) ) { /* Offset from GMT in secs. */ - int offset = EXTRACT_FIXNUM(zone); - t += EXTRACT_FIXNUM(zone); - d = *gmtime(&t); - *tz_name = NULL; - *tz_secs = offset; - } - else { - char *newenv[2], **oldenv = NULL; - - if( STRINGP(zone) ) { /* Time zone */ - oldenv = make_newenv(zone, newenv); /* Install new TZ. */ - if( !oldenv ) return ENTER_FIXNUM(errno); /* Error installing. */ - d = *localtime(&t); /* Do it. */ - } - else /* Local time */ - d = *localtime(&t); - - /* This little chunk of code copies the calculated time zone into - ** a malloc'd buffer and assigns it to *tz_name. It's a little - ** complicated because we have to clean up after detecting an - ** error w/o walking on errno. - ** - ** The time zone has to be stashed into a malloc'd buffer because - ** when revert_env resets to the original time zone, it will - ** overwrite the static buffer tzname. We have to copy it out before - ** that happens. - */ - { int error = 0; -#ifndef HAVE_TZNAME - char *zone = d.tm_zone; /* Hack it for SunOS. */ -#else - char *zone = tzname[d.tm_isdst]; -#endif - char *newzone = Malloc(char, 1+strlen(zone)); - *tz_name = newzone; - if( newzone ) strcpy(newzone, zone); - else error = errno; - - if( oldenv ) revert_env(oldenv); /* Revert TZ & env. */ - - if( !newzone ) return ENTER_FIXNUM(error); - } - - /* Calculate the time-zone offset in seconds from UTC. */ -#ifdef HAVE_GMTOFF - *tz_secs = d.tm_gmtoff; -#else - { char **oldenv = environ; /* Set TZ to UTC */ - environ=utc_env; /* time temporarily. */ - tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ - *tz_secs = mktime(&d) - t; - environ=oldenv; - } -#endif - } - - *sec = d.tm_sec; *min = d.tm_min; *hour = d.tm_hour; - *mday = d.tm_mday; *month = d.tm_mon; *year = d.tm_year; - *wday = d.tm_wday; *yday = d.tm_yday; *summer = d.tm_isdst; - return SCHFALSE; -} - - -scheme_value date2time(int sec, int min, int hour, - int mday, int month, int year, - scheme_value tz_name, scheme_value tz_secs, - int summer, - int *hi_secs, int *lo_secs) -{ - time_t t; - struct tm d; - int error = 0; - - d.tm_sec = sec; d.tm_min = min; d.tm_hour = hour; - d.tm_mday = mday; d.tm_mon = month; d.tm_year = year; - d.tm_wday = 0; d.tm_yday = 0; d.tm_isdst = summer; - - if( FIXNUMP(tz_secs) ) { /* Offset from GMT in seconds. */ - char **oldenv = environ; /* Set TZ to UTC */ - environ = utc_env; /* time temporarily. */ - tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ - errno = 0; /* A -1 ret value from mktime() might be legal; */ - t = mktime(&d); /* hack errno to disambiguate. Ugh. */ - if( t == -1 && errno ) error = errno; - t -= EXTRACT_FIXNUM(tz_secs); - environ = oldenv; - } - - else if( STRINGP(tz_name) ) { /* Time zone */ - char *newenv[2]; - char **oldenv = make_newenv(tz_name, newenv); - if( !oldenv ) return ENTER_FIXNUM(errno); - tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ - errno = 0; /* A -1 ret value from mktime() might be legal; */ - t = mktime(&d); /* hack errno to disambiguate. Ugh. */ - if( t == -1 && errno ) error = errno; - revert_env(oldenv); - } - - else { /* Local time */ - tzset(); /* NetBSD, SunOS POSIX-noncompliance requires this. */ - t = mktime(&d); - if( t == -1 && errno ) error = errno; - } - - if( error ) return ENTER_FIXNUM(error); - - *hi_secs = hi8(t); - *lo_secs = lo24(t); - return SCHFALSE; - } - - -/* WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING -** -** This code doesn't work under NeXTSTEP. I have cleverly #included the -** critical call to strftime() out for NeXT. This is because the compiler -** blows up on Posix compiles involving strftime(). Go figure. -*/ - - -/* It's disgusting how long and tortuous this function is, just -** to interface to the strftime() function. -Olin -** -** There's a weird screw case this code is careful to handle. Exhibiting -** classic Unix design (we use the term loosely), strftime()'s error -** return (0) is also a legal return value for some boundary cases. -** For example, if the format string is empty, or it is "%Z" and -** the time-zone is not available, then the result string is 0 chars long. -** We distinguish this case by suffixing an "x" to the format string, -** and flushing the last char in the formatted result. -** -** Don't consider *prefixing* an "x" instead, because then you'd -** probably pass back &result[1] to skip the x, and that would lose -- -** the guy we are handing the string to will later pass it to free(), -** so we can't pass back a pointer to anything other than the very front -** of the block. -** -** Professional programmers sacrifice their pride that others may live. -** Why me? Why Unix? -*/ -scheme_value format_date(const char *fmt, int sec, int min, int hour, - int mday, int month, int year, - scheme_value tz, int summer, - int week_day, int year_day, - const char **ans) -{ - struct tm d; - int fmt_len = strlen(fmt); - char *fmt2 = Malloc(char, 2+2*fmt_len); /* 1 extra for prefixed "x" char.*/ - int target_len = 1; /* 1 for the prefixed "x" char. Ugh. */ - int zone = 0; /* Are we using the time-zone? */ - char *q, *target; - const char *p; - char *newenv[2], **oldenv = NULL; - int result_len; - - *ans = NULL; /* In case we error out. */ - if( !fmt2 ) return ENTER_FIXNUM(errno); - - d.tm_sec = sec; d.tm_min = min; d.tm_hour = hour; - d.tm_mday = mday; d.tm_mon = month; d.tm_year = year; - d.tm_wday = week_day; d.tm_yday = year_day; d.tm_isdst = summer; - - /* Copy fmt -> fmt2, converting ~ escape codes to % escape codes. - ** Set zone=1 if fmt has a ~Z. - ** Build up an estimate of how large the target buffer needs to be. - ** The length calculation is not required to be accurate. - */ - for(q=fmt2, p=fmt; *p; p++) { - if( *p != '~' ) { - target_len++; - *q++ = *p; - if( *p == '%' ) *q++ = '%'; /* Percents get doubled. */ - } - else { - char c = *++p; - if( ! c ) { - Free(fmt2); - return SCHTRUE; /* % has to be followed by something. */ - } - else if( c == '~' ) { - *q++ = '~'; - target_len++; - } - else { - *q++ = '%'; - *q++ = c; - switch (c) { - case 'a': target_len += 3; break; - case 'A': target_len += 9; break; - case 'b': target_len += 3; break; - case 'B': target_len += 9; break; - case 'c': target_len += 10; break; /* wtf */ - case 'd': target_len += 2; break; - case 'H': target_len += 2; break; - case 'I': target_len += 2; break; - case 'j': target_len += 3; break; - case 'm': target_len += 2; break; - case 'M': target_len += 2; break; - case 'p': target_len += 2; break; - case 'S': target_len += 2; break; - case 'U': target_len += 2; break; - case 'w': target_len += 1; break; - case 'W': target_len += 2; break; - case 'x': target_len += 10; break; /* wtf */ - case 'X': target_len += 10; break; /* wtf */ - case 'y': target_len += 2; break; - case 'Y': target_len += 4; break; - case 'Z': target_len += 6; zone++; break; - default: - target_len += 5; break; /* wtf */ - } - } - } - } - *q++ = 'x'; *q = '\0'; /* Append the guard "x" suffix and nul-terminate. */ - - /* Fix up the time-zone if it is being used and the user passed one in. */ - if( zone && STRINGP(tz) ) { - oldenv = make_newenv(tz, newenv); - if( !oldenv ) { - int err = errno; - Free(fmt); - return ENTER_FIXNUM(err); - } - } - - /* Call strftime with increasingly larger buffers until the result fits. */ - target = Malloc(char, target_len); - if( !target ) goto lose; /* Alloc lost. */ - -#ifndef NeXT - while( !(result_len=strftime(target, target_len, fmt2, &d)) ) { - target_len *= 2; - target = Realloc(char, target, target_len); - if( !target ) goto lose; - } - target[result_len-1] = '\0'; /* Flush the trailing "x". */ -#endif - *ans = target; - Free(fmt2); - if( oldenv ) revert_env(oldenv); - return SCHFALSE; - -lose: - /* We lost trying to allocate space for the strftime() target buffer. */ - {int err = errno; - if( oldenv ) revert_env(oldenv); /* Clean up */ - Free(fmt2); - return ENTER_FIXNUM(err); - } -} - -#if 0 -/* This is a kludge one can use should the tzname variable -** not be present on the system. Only SunOS is broken this way, -** and it has a non-standard alternative we can use for this application. -** So this code is commented out. -** -** tzname_loser(int dst) returns a string containing the current time zone -** for loser OS's. The string is statically allocated. If the time zone -** is longer than some hidden, arbitrary length, the function simply -** returns the empty string. It is a workaround for tzname[dp->tm_isdst]. -** -*/ -char *tzname_loser(struct tm *dp) -{ - static char buf[1024]; - return strftime(buf, 1024, "x%Z", dp) ? buf+1 : ""; - } -#endif - -/* clear errno before mktime() and time(), if -1 ret, return errno. -** This is defined to work under HP-UX at least; -** other man pages are silent. -** gettimeofday() returns -1/errno -** localtime() & gmtime() don't error. -*/ diff --git a/scsh/time1.h b/scsh/time1.h deleted file mode 100644 index f7706a1..0000000 --- a/scsh/time1.h +++ /dev/null @@ -1,23 +0,0 @@ -extern scheme_value scheme_time(int *hi_secs, int *lo_secs); - -extern scheme_value time_plus_ticks(int *hi_secs, int *lo_secs, - int *hi_ticks, int *lo_ticks); - -extern scheme_value time2date(int hi_secs, int lo_secs, scheme_value zone, - int *sec, int *min, int *hour, - int *mday, int *month, int *year, - const char **tz_name, int *tz_secs, - int *summer, - int *wday, int *yday); - -extern scheme_value date2time(int sec, int min, int hour, - int mday, int month, int year, - scheme_value tz_name, scheme_value tz_secs, - int summer, - int *hi_secs, int *lo_secs); - -extern scheme_value format_date(const char *fmt, int sec, int min, int hour, - int mday, int month, int year, - scheme_value tz, int summer, - int week_day, int year_day, - const char **ans); diff --git a/scsh/top.scm b/scsh/top.scm deleted file mode 100644 index cfc235b..0000000 --- a/scsh/top.scm +++ /dev/null @@ -1,312 +0,0 @@ -;;; The scsh argv switch parser. -;;; Copyright (c) 1995 by Olin Shivers. - -;;; Imports: -;;; COMMAND-PROCESSOR: set-batch-mode?! command-loop -;;; ENSURES-LOADED: really-ensure-loaded -;;; ENVIRONMENTS: set-interaction-environment! environment-ref -;;; environment-define! -;;; ERROR-PACKAGE: error -;;; EVALUATION: eval -;;; EXTENDED-PORTS: make-string-input-port -;;; INTERFACES: make-simple-interface -;;; INTERRUPTS: interrupt-before-heap-overflow! -;;; PACKAGE-COMMANDS-INTERNAL: user-environment config-package -;;; get-reflective-tower -;;; PACKAGE-MUTATION: package-open! -;;; PACKAGES: structure-package structure? make-structure -;;; make-simple-package -;;; RECEIVING: mv return stuff -;;; SCSH-LEVEL-0-INTERNALS: set-command-line-args! -;;; SCSH-VERSION: scsh-version-string -;;; - -;;; This should be defined by the package code, but it isn't. - -(define (get-struct config-pack struct-name) - (let ((s (environment-ref config-pack struct-name))) - (cond ((structure? s) s) - (else (error "not a structure" s struct-name))))) - -;;; The switches: -;;; -o Open the structure in current package. -;;; -n Create new package, make it current package. -;;; -m 's package becomes current package. -;;; -;;; -l Load into current package. -;;; -lm Load into config package. -;;; -;;; These two require terminating -s