Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv9651/scsh
Modified Files:
newports.scm rw.scm sleep1.c syscalls.scm syscalls1.c
syscalls1.h
Removed Files:
syscalls.c
Log Message:
+ Decigged syscalls, sleep
+ Modified operations that work on file descriptors to allocate appropriate
buffered ports.
Index: newports.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/newports.scm,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -r1.12 -r1.13
*** newports.scm 2001/07/10 14:52:57 1.12
--- newports.scm 2001/09/07 16:05:31 1.13
***************
*** 396,403 ****
(else (port-maker fd 1))))
! (define (fdes->inport fd) (fdes->port fd make-input-fdport))
- (define (fdes->outport fd) (fdes->port fd make-output-fdport))
-
(define (port->fdes port)
(check-arg open-fdport? port port->fdes)
--- 396,411 ----
(else (port-maker fd 1))))
! (define (fdes->inport fd)
! (let ((port (fdes->port fd make-input-fdport)))
! (if (not (input-port? port))
! (error "fdes was already assigned to an outport" fd)
! port)))
!
! (define (fdes->outport fd)
! (let ((port (fdes->port fd make-output-fdport)))
! (if (not (output-port? port))
! (error "fdes was already assigned to an inport" fd)
! port)))
(define (port->fdes port)
(check-arg open-fdport? port port->fdes)
***************
*** 552,556 ****
(define-r4rs-input (read-char) input s48-read-char
! (read-fdes-char input))
;structure refs changed to get reference from scheme -dalbertz
--- 560,566 ----
(define-r4rs-input (read-char) input s48-read-char
! (let ((port (fdes->inport input)))
! (set-port-buffering port bufpol/none)
! (s48-read-char port)))
;structure refs changed to get reference from scheme -dalbertz
***************
*** 568,572 ****
(cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
! (else (error "Not a port or file descriptor" stream))))))
;;; This one depends upon S48's string ports.
--- 578,582 ----
(cond ((output-port? stream) (s48name arg ... stream))
((integer? stream) body ...)
! (else (error "Not a outport or file descriptor" stream))))))
;;; This one depends upon S48's string ports.
***************
*** 577,581 ****
(define-r4rs-output (newline) output s48-newline
! (write-fdes-char #\newline output))
(define-r4rs-output (write object) output s48-write
--- 587,593 ----
(define-r4rs-output (newline) output s48-newline
! (let ((port (fdes->outport output)))
! (set-port-buffering port bufpol/none)
! (s48-newline port)))
(define-r4rs-output (write object) output s48-write
***************
*** 585,589 ****
(define-r4rs-output (write-char char) output s48-write-char
! (write-fdes-char char output))
;;; S48's force-output doesn't default to forcing (current-output-port).
--- 597,603 ----
(define-r4rs-output (write-char char) output s48-write-char
! (let ((port (fdes->outport output)))
! (set-port-buffering port bufpol/none)
! (s48-write-char char port)))
;;; S48's force-output doesn't default to forcing (current-output-port).
Index: rw.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/rw.scm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -r1.2 -r1.3
*** rw.scm 2000/05/18 14:03:44 1.2
--- rw.scm 2001/09/07 16:05:31 1.3
***************
*** 13,30 ****
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (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))
--- 13,16 ----
***************
*** 32,37 ****
(end (string-length s)))
(cond ((integer? fd/port)
! (generic-read-string!/partial s start end
! read-fdes-substring!/errno fd/port))
(else ; no differnce between fd/ports and s48 ports
(let* ((buffer (make-string (- end start)))
--- 18,25 ----
(end (string-length s)))
(cond ((integer? fd/port)
! (let ((port (fdes->inport fd/port)))
! (set-port-buffering port bufpol/block (max (- end start) 0))
! (read-string!/partial port start end)))
!
(else ; no differnce between fd/ports and s48 ports
(let* ((buffer (make-string (- end start)))
***************
*** 60,81 ****
;;; Operation on ports is easy, since we can use read-block
- (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))
--- 48,51 ----
***************
*** 83,88 ****
(end (string-length s)))
(cond ((integer? fd/port)
! (generic-read-string! s start end
! read-fdes-substring!/errno fd/port))
(else ; no differnce between fd/port and s48 ports
--- 53,59 ----
(end (string-length s)))
(cond ((integer? fd/port)
! (let ((port (fdes->inport fd/port)))
! (set-port-buffering port bufpol/block (max (- end start) 0))
! (read-string! port start end)))
(else ; no differnce between fd/port and s48 ports
***************
*** 105,121 ****
;;; 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))
--- 76,79 ----
***************
*** 123,133 ****
(end (string-length s)))
(cond ((integer? fd/port)
! (generic-write-string/partial s start end
! write-fdes-substring/errno fd/port))
(else
;; the only way to implement this, would be to use
;; channel-maybe-write. But this is an VM-instruction which is not
;; exported. Since we now have threads this shouldn;t matter.
! (error "write-string/parital is no longer supported on ports")))))
--- 81,93 ----
(end (string-length s)))
(cond ((integer? fd/port)
! (let ((port (fdes->outport fd/port)))
! (set-port-buffering port bufpol/block (max (- end start) 0))
! (write-string/partial s port start end)))
(else
;; the only way to implement this, would be to use
;; channel-maybe-write. But this is an VM-instruction which is not
;; exported. Since we now have threads this shouldn;t matter.
! (error "write-string/parital is currently dereleased.
! See the RELEASE file for details")))))
***************
*** 135,150 ****
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (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))
--- 95,98 ----
***************
*** 152,156 ****
(end (string-length s)))
(cond ((integer? fd/port)
! (generic-write-string s start end
! write-fdes-substring/errno fd/port))
(else (write-block s start (- end start) fd/port)))))
--- 100,105 ----
(end (string-length s)))
(cond ((integer? fd/port)
! (let ((port (fdes->outport fd/port)))
! (set-port-buffering port bufpol/block (max (- end start) 0))
! (write-string s port start end)))
(else (write-block s start (- end start) fd/port)))))
Index: sleep1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/sleep1.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -r1.3 -r1.4
*** sleep1.c 1999/09/28 23:48:35 1.3
--- sleep1.c 2001/09/07 16:05:31 1.4
***************
*** 25,32 ****
*/
! s48_value sleep_until(time_t when)
{
time_t now = time(0);
! int delta = when - now;
if( delta > 0 ) {
fd_set r, w, e;
--- 25,32 ----
*/
! s48_value sleep_until(s48_value scm_when)
{
time_t now = time(0);
! int delta = s48_extract_integer(scm_when) - now;
if( delta > 0 ) {
fd_set r, w, e;
Index: syscalls.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls.scm,v
retrieving revision 1.26
retrieving revision 1.27
diff -C2 -r1.26 -r1.27
*** syscalls.scm 2001/09/06 16:34:48 1.26
--- syscalls.scm 2001/09/07 16:05:31 1.27
***************
*** 6,36 ****
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
- (foreign-init-name "syscalls")
-
- (foreign-source
- "#include <sys/signal.h>"
- "#include <sys/types.h>"
- "#include <sys/times.h>"
- "#include <sys/time.h>"
- "#include <fcntl.h> /* for O_RDWR */" ; ???
- "#include <sys/stat.h>"
- "#include <netdb.h>"
- "#include <pwd.h>"
- "#include <unistd.h>"
- ""
- "/* Make sure foreign-function stubs interface to the C funs correctly: */"
- "#include \"dirstuff1.h\""
- ; "#include \"fdports1.h\"" JMG
- "#include \"select1.h\""
- "#include \"syscalls1.h\""
- "#include \"userinfo1.h\""
- ""
- "extern int errno;"
- ""
- "#define errno_on_zero_or_false(x) ((x) ? S48_FALSE :
s48_enter_fixnum(errno))"
- "#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) :
S48_FALSE)"
- "#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)" ; Not a
function.
- "" "")
-
;;; Macro for converting syscalls that return error codes to ones that
;;; raise exceptions on errors.
--- 6,9 ----
***************
*** 89,93 ****
((errno/intr) (display "eintr")(loop)))
(apply syscall/eintr args)))))))
!
;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 62,66 ----
((errno/intr) (display "eintr")(loop)))
(apply syscall/eintr args)))))))
!
;;; Process
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
***************
*** 295,299 ****
(define-retrying-syscall %rename-file %rename-file/eintr)
-
(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir")
(define-retrying-syscall delete-directory delete-directory/eintr)
--- 268,271 ----
***************
*** 465,503 ****
(pipe-fdes)))
- (define-foreign %read-fdes-char
- (read_fdes_char (fixnum 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) (fixnum
fd))
- (to-scheme fixnum 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)
- (size_t start)
- (size_t end)
- (fixnum fd))
- (multi-rep (to-scheme ssize_t errno_or_false)
- ssize_t))
-
- (define-foreign write-fdes-substring/errno
- (write_fdes_substring (string-desc buf)
- (size_t start)
- (size_t end)
- (fixnum fd))
- (multi-rep (to-scheme ssize_t errno_or_false)
- ssize_t))
-
-
;;; Signals (rather incomplete)
;;; ---------------------------
--- 437,440 ----
***************
*** 792,798 ****
(or (%sleep-until when) (lp)))))
! ;;; JMG: I don't know whether time_t or long is correct...
! (define-foreign %sleep-until (sleep_until (time_t secs))
! desc)
(define-stubless-foreign %gethostname/eintr () "scm_gethostname")
--- 729,733 ----
(or (%sleep-until when) (lp)))))
! (define-stubless-foreign %sleep-until (secs) "sleep_until")
(define-stubless-foreign %gethostname/eintr () "scm_gethostname")
Index: syscalls1.c
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -r1.20 -r1.21
*** syscalls1.c 2001/09/06 16:34:48 1.20
--- syscalls1.c 2001/09/07 16:05:31 1.21
***************
*** 36,40 ****
#endif
#include "cstuff.h"
- #include "machine/stdio_dep.h"
/* Make sure our exports match up w/the implementation: */
--- 36,39 ----
***************
*** 408,441 ****
}
-
-
- /* Reading and writing
-
*******************************************************************************
- */
-
- /* Return a char, #f (EOF), or errno. */
- s48_value read_fdes_char(int fd)
- {
- int i; char c;
- if( (i=read(fd, &c, 1)) < 0 ) return s48_enter_fixnum(errno);
- if(i==0) return S48_FALSE;
- return s48_enter_char(c);
- }
-
- int write_fdes_char(char c, int fd) {return write(fd, &c, 1);}
-
-
- ssize_t read_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
- {
- return read(fd, StrByte(buf,start), end-start);
- }
-
- ssize_t write_fdes_substring(s48_value buf, size_t start, size_t end, int fd)
- {
- return write(fd, StrByte(buf,start), end-start);
- }
-
-
-
/* S_ISSOCK(mode) and S_ISLNK(mode) are not POSIX. You lose on a NeXT. Ugh. */
#ifndef S_ISSOCK
--- 407,410 ----
***************
*** 612,616 ****
struct timeval timeout;
int result;
! int fd = s48_extract_fixnum sch_fd;
FD_ZERO(&readfds);
FD_SET(fd, &readfds);
--- 581,585 ----
struct timeval timeout;
int result;
! int fd = s48_extract_fixnum (sch_fd);
FD_ZERO(&readfds);
FD_SET(fd, &readfds);
***************
*** 936,940 ****
}
! void s48_init_syscalls2(){
S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
--- 905,973 ----
}
! void s48_init_syscalls (){
! S48_EXPORT_FUNCTION(scheme_exec);
! S48_EXPORT_FUNCTION(scsh_exit);
! S48_EXPORT_FUNCTION(scsh__exit);
! S48_EXPORT_FUNCTION(scsh_fork);
! S48_EXPORT_FUNCTION(wait_pid);
! S48_EXPORT_FUNCTION(scsh_chdir);
! S48_EXPORT_FUNCTION(scheme_cwd);
! S48_EXPORT_FUNCTION(scsh_getgid);
! S48_EXPORT_FUNCTION(scsh_getegid);
! S48_EXPORT_FUNCTION(scsh_setgid);
! S48_EXPORT_FUNCTION(scsh_setegid);
! S48_EXPORT_FUNCTION(get_groups);
! S48_EXPORT_FUNCTION(scsh_getuid);
! S48_EXPORT_FUNCTION(scsh_geteuid);
! S48_EXPORT_FUNCTION(scsh_setuid);
! S48_EXPORT_FUNCTION(scsh_seteuid);
! S48_EXPORT_FUNCTION(scsh_getpid);
! S48_EXPORT_FUNCTION(scsh_getppid);
! S48_EXPORT_FUNCTION(scsh_getpgrp);
! S48_EXPORT_FUNCTION(setpgid);
! S48_EXPORT_FUNCTION(scsh_setsid);
! S48_EXPORT_FUNCTION(scsh_umask);
! S48_EXPORT_FUNCTION(process_times);
! S48_EXPORT_FUNCTION(cpu_clock_ticks_per_sec);
! S48_EXPORT_FUNCTION(scsh_chmod);
! S48_EXPORT_FUNCTION(scsh_fchmod);
! S48_EXPORT_FUNCTION(scsh_chown);
! S48_EXPORT_FUNCTION(scsh_fchown);
! S48_EXPORT_FUNCTION(scsh_access);
! S48_EXPORT_FUNCTION(scsh_link);
! S48_EXPORT_FUNCTION(scsh_mkfifo);
! S48_EXPORT_FUNCTION(scsh_mkdir);
! S48_EXPORT_FUNCTION(scsh_readlink);
! S48_EXPORT_FUNCTION(scsh_rename);
! S48_EXPORT_FUNCTION(scsh_rmdir);
! S48_EXPORT_FUNCTION(scm_utime);
! S48_EXPORT_FUNCTION(scm_utime_now);
! S48_EXPORT_FUNCTION(scheme_stat);
! S48_EXPORT_FUNCTION(scheme_fstat);
! S48_EXPORT_FUNCTION(scsh_symlink);
! S48_EXPORT_FUNCTION(scsh_truncate);
! S48_EXPORT_FUNCTION(scsh_ftruncate);
! S48_EXPORT_FUNCTION(scsh_unlink);
! S48_EXPORT_FUNCTION(scsh_fsync);
! S48_EXPORT_FUNCTION(scsh_sync);
! S48_EXPORT_FUNCTION(scsh_close);
! S48_EXPORT_FUNCTION(scsh_dup);
! S48_EXPORT_FUNCTION(scsh_dup2);
! S48_EXPORT_FUNCTION(scsh_lseek);
! S48_EXPORT_FUNCTION(char_ready_fdes);
! S48_EXPORT_FUNCTION(scsh_open);
! S48_EXPORT_FUNCTION(scheme_pipe);
! S48_EXPORT_FUNCTION(scsh_kill);
! S48_EXPORT_FUNCTION(scm_envvec);
! S48_EXPORT_FUNCTION(create_env);
! S48_EXPORT_FUNCTION(align_env);
! S48_EXPORT_FUNCTION(free_envvec);
! S48_EXPORT_FUNCTION(set_cloexec);
! S48_EXPORT_FUNCTION(fcntl_read);
! S48_EXPORT_FUNCTION(fcntl_write);
! S48_EXPORT_FUNCTION(sleep_until);
! S48_EXPORT_FUNCTION(scm_gethostname);
! S48_EXPORT_FUNCTION(errno_msg);
! S48_EXPORT_FUNCTION(scm_crypt);
S48_GC_PROTECT_GLOBAL(envvec_record_type_binding);
S48_GC_PROTECT_GLOBAL(add_envvec_finalizerB_binding);
Index: syscalls1.h
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/syscalls1.h,v
retrieving revision 1.15
retrieving revision 1.16
diff -C2 -r1.15 -r1.16
*** syscalls1.h 2001/08/08 09:21:20 1.15
--- syscalls1.h 2001/09/07 16:05:31 1.16
***************
*** 74,77 ****
--- 74,79 ----
s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode);
+ s48_value char_ready_fdes(s48_value sch_fd);
+
s48_value read_fdes_char(int fd);
***************
*** 144,145 ****
--- 146,148 ----
s48_value scm_closelog();
+ s48_value sleep_until();
--- syscalls.c DELETED ---
|