diff --git a/scsh/network.scm b/scsh/network.scm index 33ec5f8..0bf4809 100644 --- a/scsh/network.scm +++ b/scsh/network.scm @@ -407,26 +407,18 @@ (define (create-socket-pair type) (if (not (integer? type)) (error "create-socket-pair: integer argument expected ~s" type) - (receive (s1 s2) - (%socket-pair type) + (apply + (lambda (s1 s2) (let* ((in1 (make-input-fdport s1 0)) (out1 (dup->outport in1)) (in2 (make-input-fdport s2 0)) (out2 (dup->outport in2))) (values (make-socket protocol-family/unix in1 out1) - (make-socket protocol-family/unix in2 out2)))))) + (make-socket protocol-family/unix in2 out2)))) + (%socket-pair type)))) -;; based on pipe in syscalls.scm -(define-foreign %socket-pair/errno - (scheme_socket_pair (fixnum type)) - (to-scheme fixnum errno_or_false) - fixnum - fixnum) +(define-stubless-foreign %socket-pair (type) "scheme_socket_pair") -(define-errno-syscall - (%socket-pair type) %socket-pair/errno - sockfd1 - sockfd2) ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;; recv syscall @@ -632,64 +624,31 @@ (error "socket-option: integer expected ~s ~s" level option)) ((boolean-option? option) (let ((result (%getsockopt (socket->fdes sock) level option))) - (cond ((= result -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else (not (= result 0)))))) + (not (= result 0)))) ((value-option? option) - (let ((result (%getsockopt (socket->fdes sock) level option))) - (cond ((= result -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else result)))) + (%getsockopt (socket->fdes sock) level option)) ((linger-option? option) - (receive (result/on-off time) - (%getsockopt-linger (socket->fdes sock) level option) - (cond ((= result/on-off -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else (if (= result/on-off 0) #f time))))) + (apply (%getsockopt-linger (socket->fdes sock) level option) + (lambda (result/on-off time) + (if (= result/on-off 0) #f time)))) ((timeout-option? option) - (receive (result/secs usecs) - (%getsockopt-linger (socket->fdes sock) level option) - (cond ((= result/secs -1) - (error "socket-option ~s ~s ~s" sock level option)) - (else (+ result/secs (/ usecs 1000)))))) + (apply (%getsockopt-timeout (socket->fdes sock) level option) + (lambda (result/secs usecs) + (cond ((= result/secs -1) + (error "socket-option ~s ~s ~s" sock level option)) + (else (+ result/secs (/ usecs 1000))))))) (else "socket-option: unknown option type ~s" option))) -(define-foreign %getsockopt/errno - (scheme_getsockopt (fixnum sockfd) - (fixnum level) - (fixnum optname)) - (multi-rep (to-scheme fixnum errno_or_false) - fixnum)) +(define-stubless-foreign %getsockopt (sock level option) "scheme_getsockopt") -(define-errno-syscall (%getsockopt sock level option) %getsockopt/errno - value) +;;; returns (list on-off linger) +(define-stubless-foreign %getsockopt-linger (sockfd level optname) + "scheme_getsockopt_linger") -(define-foreign %getsockopt-linger/errno - (scheme_getsockopt_linger (fixnum sockfd) - (fixnum level) - (fixnum optname)) - (multi-rep (to-scheme fixnum errno_or_false) - fixnum) ; error/on-off - fixnum) ; linger time - -(define-errno-syscall - (%getsockopt-linger sock level option) %getsockopt-linger/errno - on-off - linger) - -(define-foreign %getsockopt-timeout/errno - (scheme_getsockopt_timeout (fixnum sockfd) - (fixnum level) - (fixnum optname)) - (multi-rep (to-scheme fixnum errno_or_false) - fixnum) ; error/secs - fixnum) ; usecs - -(define-errno-syscall - (%getsockopt-timeout sock level option) %getsockopt-timeout/errno - secs - usecs) +;;; returns (list secs usecs) +(define-stubless-foreign %getsockopt-timeout (sockfd level optname) + "scheme_getsockopt_timeout") ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;; setsockopt syscall @@ -717,38 +676,14 @@ (else "set-socket-option: unknown option type"))) -(define-foreign %setsockopt/errno - (scheme_setsockopt (fixnum sockfd) - (fixnum level) - (fixnum optname) - (fixnum optval)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign %setsockopt (sockfd level optname optval) + "scheme_setsockopt") -(define-errno-syscall - (%setsockopt sock level option value) %setsockopt/errno) +(define-stubless-foreign %setsockopt-linger + (sockfd level optname on-off time) "scheme_setsockopt_linger") - -(define-foreign %setsockopt-linger/errno - (scheme_setsockopt_linger (fixnum sockfd) - (fixnum level) - (fixnum optname) - (fixnum on-off) - (fixnum time)) - (to-scheme fixnum errno_or_false)) - -(define-errno-syscall - (%setsockopt-linger sock level option on-off time) %setsockopt-linger/errno) - -(define-foreign %setsockopt-timeout/errno - (scheme_setsockopt_timeout (fixnum sockfd) - (fixnum level) - (fixnum optname) - (fixnum secs) - (fixnum usecs)) - (to-scheme fixnum errno_or_false)) - -(define-errno-syscall - (%setsockopt-timeout sock level option secs usecs) %setsockopt-timeout/errno) +(define-stubless-foreign %setsockopt-timeout + (sockfd level optname secs usecs) "scheme_setsockopt_timeout") ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;; socket-option routines @@ -916,52 +851,3 @@ (define-stubless-foreign %protocol-name->protocol-info (name) "scheme_proto_name2proto_info") -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;;; Lowlevel junk -;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- -;; Used to pull address list back -;; based on C-string-vec->Scheme from cig/libcig.scm -(define (C-long-vec->Scheme cvec veclen) ; No free. - (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0)))) - (mapv! (lambda (ignore) (make-string 4)) vec) - (%set-long-vector-carriers! vec cvec) - (mapv! string->integer vec))) - -(define (integer->string num32) - (let* ((str (make-string 4)) - (num24 (arithmetic-shift num32 -8)) - (num16 (arithmetic-shift num24 -8)) - (num08 (arithmetic-shift num16 -8)) - (byte0 (bitwise-and #b11111111 num08)) - (byte1 (bitwise-and #b11111111 num16)) - (byte2 (bitwise-and #b11111111 num24)) - (byte3 (bitwise-and #b11111111 num32))) - (string-set! str 0 (ascii->char byte0)) - (string-set! str 1 (ascii->char byte1)) - (string-set! str 2 (ascii->char byte2)) - (string-set! str 3 (ascii->char byte3)) - str)) - -(define (string->integer str) - (+ (arithmetic-shift(char->ascii(string-ref str 0))24) - (arithmetic-shift(char->ascii(string-ref str 1))16) - (arithmetic-shift(char->ascii(string-ref str 2)) 8) - (char->ascii(string-ref str 3)))) - -;; also from cig/libcig.scm -(define-foreign %c-veclen-or-false - (veclen ((C "const long * ~a") c-vec)); redefining can we open cig-aux? - desc) ; integer or #f if arg is NULL. - -;; also from cig/libcig.scm -(define-foreign %set-long-vector-carriers! - (set_longvec_carriers (vector-desc svec) - ((C "long const * const * ~a") cvec)) - ignore) - -;; also from cig/libcig.scm -(define (mapv! f v) - (let ((len (vector-length v))) - (do ((i 0 (+ i 1))) - ((= i len) v) - (vector-set! v i (f (vector-ref v i)))))) diff --git a/scsh/network1.c b/scsh/network1.c index 1f683ef..4616f71 100644 --- a/scsh/network1.c +++ b/scsh/network1.c @@ -174,7 +174,7 @@ s48_value scheme_accept(s48_value sockfd_tagged, s48_value family) s48_raise_out_of_memory_error(); return S48_FALSE; } - + return(s48_enter_fixnum (newsockfd)); break; } @@ -271,15 +271,14 @@ s48_value scheme_socket_name(s48_value sock, s48_value family) } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ -int scheme_socket_pair(int type, int *s1, int *s2) +s48_value scheme_socket_pair(s48_value type) { int sv[2]; - if( socketpair(PF_UNIX,type,0,sv) ) { - *s1 = 0; *s2 = 0; - return errno; - } - *s1 = sv[0]; *s2 = sv[1]; - return 0; + if( socketpair(PF_UNIX,s48_extract_integer (type),0,sv) ) + s48_raise_os_error_1(errno, type); + + return s48_cons (s48_enter_fixnum (sv[0]), + s48_cons (s48_enter_fixnum (sv[1]), S48_NULL)); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ @@ -390,84 +389,108 @@ s48_value send_substring(s48_value scm_sockfd, /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ -int scheme_getsockopt (int s, - int level, - int optname) +s48_value scheme_getsockopt (s48_value s, + s48_value level, + s48_value optname) { int optval; int optlen=sizeof(optval); - if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) - return(-1); - return(optval); + if (getsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname) + ,(char *)&optval, + &optlen) == -1) + s48_raise_os_error_3 (errno, s, level, optname); + return(s48_enter_fixnum (optval)); } -int scheme_getsockopt_linger (int s, - int level, - int optname, - int *out_time) +s48_value scheme_getsockopt_linger (s48_value s, + s48_value level, + s48_value optname) { struct linger optval; int optlen=sizeof(optval); - if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { - out_time = 0; - return(-1); - } - *out_time=optval.l_linger; - return(optval.l_onoff); + if (getsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname), + (char *)&optval, + &optlen) == -1) { + s48_raise_os_error_3 (errno, s, level, optname); + } + return s48_cons (s48_enter_fixnum (optval.l_onoff), + s48_cons (s48_enter_fixnum (optval.l_linger), S48_NULL)); } -int scheme_getsockopt_timeout (int s, - int level, - int optname, - int *out_usec) +s48_value scheme_getsockopt_timeout (s48_value s, + s48_value level, + s48_value optname) { struct timeval optval; size_t optlen=sizeof(optval); - if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { - out_usec = 0; - return(-1); + if (getsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname), + (char *)&optval, + &optlen) == -1) { + s48_raise_os_error_3 (errno, s, level, optname); } - *out_usec=optval.tv_usec; - return(optval.tv_sec); + return(s48_cons (s48_enter_fixnum (optval.tv_sec), + s48_cons (s48_enter_fixnum (optval.tv_usec), S48_NULL))); } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ -int scheme_setsockopt (int s, - int level, - int optname, - int optval) +s48_value scheme_setsockopt (s48_value s, + s48_value level, + s48_value optname, + s48_value _optval) { - return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); + int optval = s48_extract_fixnum (_optval); + if ((setsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname), + (char *)&optval,sizeof(optval))) == -1) + s48_raise_os_error_4 (errno, s, level, optname, _optval); + return S48_UNSPECIFIC; } -int scheme_setsockopt_linger (int s, - int level, - int optname, - int onoff, - int linger) +s48_value scheme_setsockopt_linger (s48_value s, + s48_value level, + s48_value optname, + s48_value onoff, + s48_value linger) { struct linger optval; - optval.l_onoff=onoff; - optval.l_linger=linger; + optval.l_onoff = s48_extract_fixnum (onoff); + optval.l_linger = s48_extract_fixnum (linger); - return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); + if ((setsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname), + (char *)&optval,sizeof(optval))) == -1) + s48_raise_os_error_5 (errno, s, level, optname, onoff, linger); + return S48_UNSPECIFIC; } -int scheme_setsockopt_timeout (int s, - int level, - int optname, - int sec, - int usec) +s48_value scheme_setsockopt_timeout (s48_value s, + s48_value level, + s48_value optname, + s48_value sec, + s48_value usec) { struct timeval optval; - optval.tv_sec=sec; - optval.tv_usec=usec; + optval.tv_sec = s48_extract_fixnum (sec); + optval.tv_usec = s48_extract_fixnum (usec); - return(setsockopt(s,level,optname,(char *)&optval,sizeof(optval))); + if ((setsockopt(s48_extract_fixnum (s), + s48_extract_fixnum (level), + s48_extract_fixnum (optname), + (char *)&optval,sizeof(optval))) == -1) + s48_raise_os_error_5 (errno, s, level, optname, sec, usec); + return S48_UNSPECIFIC; } /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ diff --git a/scsh/network1.h b/scsh/network1.h index fc9ce7e..55884ef 100644 --- a/scsh/network1.h +++ b/scsh/network1.h @@ -11,7 +11,7 @@ s48_value scheme_peer_name(s48_value sockfd, s48_value family); s48_value scheme_socket_name(s48_value sockfd, s48_value family); -int scheme_socket_pair(int type, int *s1, int *s2); +s48_value scheme_socket_pair(s48_value type); s48_value recv_substring(s48_value s, s48_value flags, s48_value buf, s48_value start, s48_value end); @@ -20,34 +20,34 @@ s48_value send_substring(s48_value s, s48_value flags, s48_value buf, s48_value start, s48_value end, s48_value family, s48_value scheme_name); -int scheme_getsockopt (int s, int level, int optname); +s48_value scheme_getsockopt (s48_value s, s48_value level, s48_value optname); -int scheme_getsockopt_linger (int s, - int level, - int optname, - int *out_time); +s48_value scheme_getsockopt_linger (s48_value s, + s48_value level, + s48_value optname); + -int scheme_getsockopt_timeout (int s, - int level, - int optname, - int *out_usec); +s48_value scheme_getsockopt_timeout (s48_value s, + s48_value level, + s48_value optname); -int scheme_setsockopt (int s, - int level, - int optname, - int optval); -int scheme_setsockopt_linger (int s, - int level, - int optname, - int onoff, - int linger); +s48_value scheme_setsockopt (s48_value s, + s48_value level, + s48_value optname, + s48_value optval); -int scheme_setsockopt_timeout (int s, - int level, - int optname, - int sec, - int usec); +s48_value scheme_setsockopt_linger (s48_value s, + s48_value level, + s48_value optname, + s48_value onoff, + s48_value linger); + +s48_value scheme_setsockopt_timeout (s48_value s, + s48_value level, + s48_value optname, + s48_value sec, + s48_value usec); s48_value scheme_host_address2host_info(s48_value scheme_byte_vector);