scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Port to new FFI.

This commit is contained in:
mainzelm 2001-01-01 17:34:08 +00:00
parent c7be5ed2b1
commit 07f9cbc6c9
3 changed files with 129 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

166
scsh/network.scm
View File

@ -407,26 +407,18 @@
(define (create-socket-pair type) (define (create-socket-pair type)
(if (not (integer? type)) (if (not (integer? type))
(error "create-socket-pair: integer argument expected ~s" type) (error "create-socket-pair: integer argument expected ~s" type)
(receive (s1 s2) (apply
(%socket-pair type) (lambda (s1 s2)
(let* ((in1 (make-input-fdport s1 0)) (let* ((in1 (make-input-fdport s1 0))
(out1 (dup->outport in1)) (out1 (dup->outport in1))
(in2 (make-input-fdport s2 0)) (in2 (make-input-fdport s2 0))
(out2 (dup->outport in2))) (out2 (dup->outport in2)))
(values (make-socket protocol-family/unix in1 out1) (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-stubless-foreign %socket-pair (type) "scheme_socket_pair")
(define-foreign %socket-pair/errno
(scheme_socket_pair (fixnum type))
(to-scheme fixnum errno_or_false)
fixnum
fixnum)
(define-errno-syscall
(%socket-pair type) %socket-pair/errno
sockfd1
sockfd2)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; recv syscall ;;; recv syscall
@ -632,64 +624,31 @@
(error "socket-option: integer expected ~s ~s" level option)) (error "socket-option: integer expected ~s ~s" level option))
((boolean-option? option) ((boolean-option? option)
(let ((result (%getsockopt (socket->fdes sock) level option))) (let ((result (%getsockopt (socket->fdes sock) level option)))
(cond ((= result -1) (not (= result 0))))
(error "socket-option ~s ~s ~s" sock level option))
(else (not (= result 0))))))
((value-option? option) ((value-option? option)
(let ((result (%getsockopt (socket->fdes sock) level option))) (%getsockopt (socket->fdes sock) level option))
(cond ((= result -1)
(error "socket-option ~s ~s ~s" sock level option))
(else result))))
((linger-option? option) ((linger-option? option)
(receive (result/on-off time) (apply (%getsockopt-linger (socket->fdes sock) level option)
(%getsockopt-linger (socket->fdes sock) level option) (lambda (result/on-off time)
(cond ((= result/on-off -1) (if (= result/on-off 0) #f time))))
(error "socket-option ~s ~s ~s" sock level option))
(else (if (= result/on-off 0) #f time)))))
((timeout-option? option) ((timeout-option? option)
(receive (result/secs usecs) (apply (%getsockopt-timeout (socket->fdes sock) level option)
(%getsockopt-linger (socket->fdes sock) level option) (lambda (result/secs usecs)
(cond ((= result/secs -1) (cond ((= result/secs -1)
(error "socket-option ~s ~s ~s" sock level option)) (error "socket-option ~s ~s ~s" sock level option))
(else (+ result/secs (/ usecs 1000)))))) (else (+ result/secs (/ usecs 1000)))))))
(else (else
"socket-option: unknown option type ~s" option))) "socket-option: unknown option type ~s" option)))
(define-foreign %getsockopt/errno (define-stubless-foreign %getsockopt (sock level option) "scheme_getsockopt")
(scheme_getsockopt (fixnum sockfd)
(fixnum level)
(fixnum optname))
(multi-rep (to-scheme fixnum errno_or_false)
fixnum))
(define-errno-syscall (%getsockopt sock level option) %getsockopt/errno ;;; returns (list on-off linger)
value) (define-stubless-foreign %getsockopt-linger (sockfd level optname)
"scheme_getsockopt_linger")
(define-foreign %getsockopt-linger/errno ;;; returns (list secs usecs)
(scheme_getsockopt_linger (fixnum sockfd) (define-stubless-foreign %getsockopt-timeout (sockfd level optname)
(fixnum level) "scheme_getsockopt_timeout")
(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)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; setsockopt syscall ;;; setsockopt syscall
@ -717,38 +676,14 @@
(else (else
"set-socket-option: unknown option type"))) "set-socket-option: unknown option type")))
(define-foreign %setsockopt/errno (define-stubless-foreign %setsockopt (sockfd level optname optval)
(scheme_setsockopt (fixnum sockfd) "scheme_setsockopt")
(fixnum level)
(fixnum optname)
(fixnum optval))
(to-scheme fixnum errno_or_false))
(define-errno-syscall (define-stubless-foreign %setsockopt-linger
(%setsockopt sock level option value) %setsockopt/errno) (sockfd level optname on-off time) "scheme_setsockopt_linger")
(define-stubless-foreign %setsockopt-timeout
(define-foreign %setsockopt-linger/errno (sockfd level optname secs usecs) "scheme_setsockopt_timeout")
(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)
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
;;; socket-option routines ;;; socket-option routines
@ -916,52 +851,3 @@
(define-stubless-foreign %protocol-name->protocol-info (name) (define-stubless-foreign %protocol-name->protocol-info (name)
"scheme_proto_name2proto_info") "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))))))

127
scsh/network1.c
View File

@ -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]; int sv[2];
if( socketpair(PF_UNIX,type,0,sv) ) { if( socketpair(PF_UNIX,s48_extract_integer (type),0,sv) )
*s1 = 0; *s2 = 0; s48_raise_os_error_1(errno, type);
return errno;
} return s48_cons (s48_enter_fixnum (sv[0]),
*s1 = sv[0]; *s2 = sv[1]; s48_cons (s48_enter_fixnum (sv[1]), S48_NULL));
return 0;
} }
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
@ -390,84 +389,108 @@ s48_value send_substring(s48_value scm_sockfd,
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
int scheme_getsockopt (int s, s48_value scheme_getsockopt (s48_value s,
int level, s48_value level,
int optname) s48_value optname)
{ {
int optval; int optval;
int optlen=sizeof(optval); int optlen=sizeof(optval);
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) if (getsockopt(s48_extract_fixnum (s),
return(-1); s48_extract_fixnum (level),
return(optval); 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, s48_value scheme_getsockopt_linger (s48_value s,
int level, s48_value level,
int optname, s48_value optname)
int *out_time)
{ {
struct linger optval; struct linger optval;
int optlen=sizeof(optval); int optlen=sizeof(optval);
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { if (getsockopt(s48_extract_fixnum (s),
out_time = 0; s48_extract_fixnum (level),
return(-1); s48_extract_fixnum (optname),
(char *)&optval,
&optlen) == -1) {
s48_raise_os_error_3 (errno, s, level, optname);
} }
*out_time=optval.l_linger; return s48_cons (s48_enter_fixnum (optval.l_onoff),
return(optval.l_onoff); s48_cons (s48_enter_fixnum (optval.l_linger), S48_NULL));
} }
int scheme_getsockopt_timeout (int s, s48_value scheme_getsockopt_timeout (s48_value s,
int level, s48_value level,
int optname, s48_value optname)
int *out_usec)
{ {
struct timeval optval; struct timeval optval;
size_t optlen=sizeof(optval); size_t optlen=sizeof(optval);
if (getsockopt(s,level,optname,(char *)&optval,&optlen) == -1) { if (getsockopt(s48_extract_fixnum (s),
out_usec = 0; s48_extract_fixnum (level),
return(-1); s48_extract_fixnum (optname),
(char *)&optval,
&optlen) == -1) {
s48_raise_os_error_3 (errno, s, level, optname);
} }
*out_usec=optval.tv_usec; return(s48_cons (s48_enter_fixnum (optval.tv_sec),
return(optval.tv_sec); s48_cons (s48_enter_fixnum (optval.tv_usec), S48_NULL)));
} }
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/
int scheme_setsockopt (int s, s48_value scheme_setsockopt (s48_value s,
int level, s48_value level,
int optname, s48_value optname,
int optval) 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, s48_value scheme_setsockopt_linger (s48_value s,
int level, s48_value level,
int optname, s48_value optname,
int onoff, s48_value onoff,
int linger) s48_value linger)
{ {
struct linger optval; struct linger optval;
optval.l_onoff=onoff; optval.l_onoff = s48_extract_fixnum (onoff);
optval.l_linger=linger; 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, s48_value scheme_setsockopt_timeout (s48_value s,
int level, s48_value level,
int optname, s48_value optname,
int sec, s48_value sec,
int usec) s48_value usec)
{ {
struct timeval optval; struct timeval optval;
optval.tv_sec=sec; optval.tv_sec = s48_extract_fixnum (sec);
optval.tv_usec=usec; 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;
} }
/*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/ /*-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-*/

48
scsh/network1.h
View File

@ -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); 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 recv_substring(s48_value s, s48_value flags, s48_value buf,
s48_value start, s48_value end); 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 start, s48_value end, s48_value family,
s48_value scheme_name); 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, s48_value scheme_getsockopt_linger (s48_value s,
int level, s48_value level,
int optname, s48_value optname);
int *out_time);
int scheme_getsockopt_timeout (int s,
int level,
int optname,
int *out_usec);
int scheme_setsockopt (int s, s48_value scheme_getsockopt_timeout (s48_value s,
int level, s48_value level,
int optname, s48_value optname);
int optval);
int scheme_setsockopt_linger (int s,
int level,
int optname,
int onoff,
int linger);
int scheme_setsockopt_timeout (int s, s48_value scheme_setsockopt (s48_value s,
int level, s48_value level,
int optname, s48_value optname,
int sec, s48_value optval);
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); s48_value scheme_host_address2host_info(s48_value scheme_byte_vector);