From: <cli...@li...> - 2004-11-02 11:58:20
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src defstruct.lisp,1.53,1.54 ChangeLog,1.3761,1.3762 (Bruno Haible) 2. clisp/src defstruct.lisp,1.54,1.55 ChangeLog,1.3762,1.3763 (Bruno Haible) 3. clisp/src gray.lisp,1.9,1.10 constsym.d,1.277,1.278 genclisph.d,1.151,1.152 NEWS,1.195,1.196 lispbibl.d,1.560,1.561 sequence.d,1.88,1.89 stream.d,1.454,1.455 subr.d,1.189,1.190 subrkw.d,1.49,1.50 unix.d,1.63,1.64 unixaux.d,1.43,1.44 win32.d,1.44,1.45 win32aux.d,1.38,1.39 ChangeLog,1.3763,1.3764 (Bruno Haible) --__--__-- Message: 1 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src defstruct.lisp,1.53,1.54 ChangeLog,1.3761,1.3762 Date: Tue, 02 Nov 2004 11:32:48 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12557/src Modified Files: defstruct.lisp ChangeLog Log Message: New function ds-initfunction-fetcher. Index: defstruct.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defstruct.lisp,v retrieving revision 1.53 retrieving revision 1.54 diff -u -d -r1.53 -r1.54 --- defstruct.lisp 2 Nov 2004 11:30:44 -0000 1.53 +++ defstruct.lisp 2 Nov 2004 11:32:45 -0000 1.54 @@ -522,6 +522,11 @@ name slotname)) (clos:slot-definition-initfunction slot)))) +(defun ds-initfunction-fetcher (name type slotname) + (if (eq type 'T) + `(FIND-STRUCTURE-CLASS-SLOT-INITFUNCTION ',name ',slotname) + `(FIND-STRUCTURE-SLOT-INITFUNCTION ',name ',slotname))) + ;; A hook for CLOS (defun clos::defstruct-remove-print-object-method (name) ; preliminary (declare (ignore name)) @@ -759,12 +764,8 @@ ;; by the substructure, the "size" of the substructure. (dolist (slot slotlist) (setf (clos::structure-effective-slot-definition-initff slot) - (if incl-class - `(FIND-STRUCTURE-CLASS-SLOT-INITFUNCTION ',subname - ',(clos:slot-definition-name slot)) - `(FIND-STRUCTURE-SLOT-INITFUNCTION ',subname - ',(clos:slot-definition-name slot))))) - ;; process further arguments of the :INCLUDE-option: + (ds-initfunction-fetcher subname type-option (clos:slot-definition-name slot)))) + ;; Process further arguments of the :INCLUDE-option: (dolist (slotarg (rest option)) (let* ((slotname (if (atom slotarg) slotarg (first slotarg))) (slot (find slotname slotlist :key #'clos:slot-definition-name @@ -999,11 +1000,7 @@ ;; constructor-forms = list of forms, that define the constructors. (mapc #'(lambda (slot directslot) (let ((initfunctionform - (if (eq type-option 'T) - `(FIND-STRUCTURE-CLASS-SLOT-INITFUNCTION - ',name ',(clos:slot-definition-name slot)) - `(FIND-STRUCTURE-SLOT-INITFUNCTION - ',name ',(clos:slot-definition-name slot))))) + (ds-initfunction-fetcher name type-option (clos:slot-definition-name slot)))) (setf (clos::structure-effective-slot-definition-initff slot) initfunctionform) (when directslot Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3761 retrieving revision 1.3762 diff -u -d -r1.3761 -r1.3762 --- ChangeLog 2 Nov 2004 11:30:47 -0000 1.3761 +++ ChangeLog 2 Nov 2004 11:32:46 -0000 1.3762 @@ -1,5 +1,10 @@ 2004-10-17 Bruno Haible <br...@cl...> + * defstruct.lisp (ds-initfunction-fetcher): New function. + (defstruct): Use it. + +2004-10-17 Bruno Haible <br...@cl...> + Remove redundant data from a defstruct-description. * io.d (structure_reader): Expect a vector of size = 4. * defstruct.lisp (find-structure-slot-initfunction): New function. --__--__-- Message: 2 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src defstruct.lisp,1.54,1.55 ChangeLog,1.3762,1.3763 Date: Tue, 02 Nov 2004 11:33:55 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12794/src Modified Files: defstruct.lisp ChangeLog Log Message: Simplify directslotlist iteration. There are no NILs in this list. Index: defstruct.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/defstruct.lisp,v retrieving revision 1.54 retrieving revision 1.55 diff -u -d -r1.54 -r1.55 --- defstruct.lisp 2 Nov 2004 11:32:45 -0000 1.54 +++ defstruct.lisp 2 Nov 2004 11:33:52 -0000 1.55 @@ -1035,14 +1035,11 @@ (if i (nth i slotdefaultvars) nil)))) slotlist)) (LIST - ,@(mapcan #'(lambda (directslot) - (if directslot - (list - (clos::make-load-form-<structure-direct-slot-definition> - directslot - (let ((i (position directslot slotdefaultdirectslots))) - (if i (nth i slotdefaultvars) nil)))) - '())) + ,@(mapcar #'(lambda (directslot) + (clos::make-load-form-<structure-direct-slot-definition> + directslot + (let ((i (position directslot slotdefaultdirectslots))) + (if i (nth i slotdefaultvars) nil)))) directslotlist))) `(CLOS::UNDEFINE-STRUCTURE-CLASS ',name))) ,@(if (and named-option predicate-option) Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3762 retrieving revision 1.3763 diff -u -d -r1.3762 -r1.3763 --- ChangeLog 2 Nov 2004 11:32:46 -0000 1.3762 +++ ChangeLog 2 Nov 2004 11:33:52 -0000 1.3763 @@ -1,5 +1,9 @@ 2004-10-17 Bruno Haible <br...@cl...> + * defstruct.lisp (defstruct): Simplify directslotlist iteration. + +2004-10-17 Bruno Haible <br...@cl...> + * defstruct.lisp (ds-initfunction-fetcher): New function. (defstruct): Use it. --__--__-- Message: 3 From: Bruno Haible <ha...@us...> To: cli...@li... Subject: clisp/src gray.lisp,1.9,1.10 constsym.d,1.277,1.278 genclisph.d,1.151,1.152 NEWS,1.195,1.196 lispbibl.d,1.560,1.561 sequence.d,1.88,1.89 stream.d,1.454,1.455 subr.d,1.189,1.190 subrkw.d,1.49,1.50 unix.d,1.63,1.64 unixaux.d,1.43,1.44 win32.d,1.44,1.45 win32aux.d,1.38,1.39 ChangeLog,1.3763,1.3764 Date: Tue, 02 Nov 2004 11:39:59 +0000 Reply-To: cli...@li... Update of /cvsroot/clisp/clisp/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13581/src Modified Files: gray.lisp constsym.d genclisph.d NEWS lispbibl.d sequence.d stream.d subr.d subrkw.d unix.d unixaux.d win32.d win32aux.d ChangeLog Log Message: A third way of doing I/O. Generalize 'bool no_hang' to 'perseverance_t persev'. Index: gray.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/gray.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- gray.lisp 24 Jun 2004 10:50:40 -0000 1.9 +++ gray.lisp 2 Nov 2004 11:39:51 -0000 1.10 @@ -319,17 +319,18 @@ ) ) ) -(clos:defgeneric stream-read-byte-sequence - (stream sequence &optional start end no-hang) +(clos:defgeneric stream-read-byte-sequence (stream sequence + &optional start end no-hang interactive) (:method ((stream fundamental-input-stream) (sequence vector) - &optional (start 0) (end nil) (no-hang nil)) + &optional (start 0) (end nil) (no-hang nil) (interactive nil)) ;; sequence is a (simple-array (unsigned-byte 8) (*)), ;; and start and end are suitable integers. (unless end (setq end (length sequence))) (do ((index start (1+ index))) ((eql index end) index) - (let ((x (if no-hang (stream-read-byte-no-hang stream) - (stream-read-byte stream)))) + (let ((x (if (or no-hang (and interactive (> index start))) + (stream-read-byte-no-hang stream) + (stream-read-byte stream)))) (when (or (null x) (eq x ':EOF)) (return index)) (setf (aref sequence index) x))))) @@ -338,9 +339,9 @@ (clos:defgeneric stream-write-byte (stream integer)) (clos:defgeneric stream-write-byte-sequence (stream sequence - &optional start end no-hang) + &optional start end no-hang interactive) (:method ((stream fundamental-output-stream) (sequence vector) - &optional (start 0) (end nil) (no-hang nil)) + &optional (start 0) (end nil) (no-hang nil) (interactive nil)) ;; sequence is a (simple-array (unsigned-byte 8) (*)), ;; and start and end are suitable integers. ;; if no-hang and you write less than end-start bytes then you should @@ -349,6 +350,9 @@ (when no-hang (error "~S: ~S is not supported by the default method" 'stream-write-byte-sequence :NO-HANG)) + (when interactive + (error "~S: ~S is not supported by the default method" + 'stream-write-byte-sequence :INTERACTIVE)) (unless end (setq end (length sequence))) (do ((index start (1+ index))) ((eql index end) nil) Index: unix.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/unix.d,v retrieving revision 1.63 retrieving revision 1.64 diff -u -d -r1.63 -r1.64 --- unix.d 1 Nov 2004 11:21:18 -0000 1.63 +++ unix.d 2 Nov 2004 11:39:55 -0000 1.64 @@ -510,12 +510,12 @@ #define CLOSE close #endif /* wrapper around the system call, get partial results and handle EINTR: */ -extern ssize_t read_helper (int fd, void* buf, size_t nbyte, bool no_hang); -extern ssize_t write_helper (int fd, const void* buf, size_t nbyte, bool no_hang); -#define safe_read(f,b,n) read_helper(f,b,n,true) -#define full_read(f,b,n) read_helper(f,b,n,false) -#define safe_write(f,b,n) write_helper(f,b,n,true) -#define full_write(f,b,n) write_helper(f,b,n,false) +extern ssize_t read_helper (int fd, void* buf, size_t nbyte, perseverance_t persev); +extern ssize_t write_helper (int fd, const void* buf, size_t nbyte, perseverance_t persev); +#define safe_read(fd,buf,nbyte) read_helper(fd,buf,nbyte,persev_partial) +#define full_read(fd,buf,nbyte) read_helper(fd,buf,nbyte,persev_full) +#define safe_write(fd,buf,nbyte) write_helper(fd,buf,nbyte,persev_partial) +#define full_write(fd,buf,nbyte) write_helper(fd,buf,nbyte,persev_full) /* used by STREAM, PATHNAME, SPVW, MISC, UNIXAUX */ /* inquire the terminal, window size: */ @@ -786,14 +786,14 @@ #ifdef UNIX_BEOS /* BeOS 5 sockets cannot be used like file descriptors. Reading and writing from a socket */ - extern ssize_t sock_read (int socket, void* buf, size_t size); - extern ssize_t sock_write (int socket, const void* buf, size_t size, bool no_hang); + extern ssize_t sock_read (int socket, void* buf, size_t size, perseverance_t persev); + extern ssize_t sock_write (int socket, const void* buf, size_t size, perseverance_t persev); /* Closing a socket */ /* extern int closesocket (int socket); */ #else /* Reading and writing from a socket */ - #define sock_read(s,b,n) read_helper(s,b,n,true) - #define sock_write(s,b,n,no_hang) write_helper(s,b,n,no_hang) + #define sock_read(socket,buf,nbyte,persev) read_helper(socket,buf,nbyte,persev) + #define sock_write(socket,buf,nbyte,persev) write_helper(socket,buf,nbyte,persev) /* Closing a socket */ #define closesocket close #endif Index: stream.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/stream.d,v retrieving revision 1.454 retrieving revision 1.455 diff -u -d -r1.454 -r1.455 --- stream.d 1 Nov 2004 11:31:12 -0000 1.454 +++ stream.d 2 Nov 2004 11:39:52 -0000 1.455 @@ -126,15 +126,15 @@ typedef object (* rd_by_Pseudofun) (object stream); /* Specification for READ-BYTE-ARRAY - Pseudo-Function: - fun(&stream,&bytearray,start,len,no_hang) + fun(&stream,&bytearray,start,len,persev) > stream: stream > object bytearray: simple-8bit-vector > uintL start: start index of byte sequence to be filled > uintL len: length of byte sequence to be filled, >0 - > bool no_hang: do not block + > perseverance_t persev: how to react on incomplete I/O [...1166 lines suppressed...] bitbuffer = STACK_0; if (BIG_ENDIAN_P ? !endianness : endianness) /* byte swap */ @@ -16507,7 +16552,7 @@ if (endianness) /* byte swap */ elt_nreverse(bitbuffer,0,bytesize); # Write the data. - write_byte_array(&STACK_3,&STACK_0,0,bytesize,false); + write_byte_array(&STACK_3,&STACK_0,0,bytesize,persev_full); FREE_DYNAMIC_8BIT_VECTOR(STACK_0); VALUES1(STACK_4); /* return obj */ skipSTACK(5); @@ -16578,7 +16623,7 @@ if (BIG_ENDIAN_P ? !endianness : endianness) /* byte swap */ elt_nreverse(bitbuffer,0,bytesize); # Write the data. - write_byte_array(&STACK_3,&STACK_0,0,bytesize,false); + write_byte_array(&STACK_3,&STACK_0,0,bytesize,persev_full); FREE_DYNAMIC_8BIT_VECTOR(STACK_0); VALUES1(STACK_4); /* return obj */ skipSTACK(5); Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.3763 retrieving revision 1.3764 diff -u -d -r1.3763 -r1.3764 --- ChangeLog 2 Nov 2004 11:33:52 -0000 1.3763 +++ ChangeLog 2 Nov 2004 11:39:55 -0000 1.3764 @@ -1,3 +1,126 @@ +2004-10-30 Bruno Haible <br...@cl...> + + A third way of reading input. + * lispbibl.d (perseverance_t): New type. + (read_byte_array, write_byte_array): Take a perseverance argument + instead of a no_hang argument. + * unix.d (read_helper, write_helper): Take a perseverance argument + instead of a no_hang argument. + (full_read, full_write): Update. + (safe_read, safe_write): Pass persev_partial, not no_hang=true. + (sock_read): Add a perseverance argument. + (sock_write): Take a perseverance argument instead of a no_hang + argument. + * win32.d (read_helper, write_helper): Take a perseverance argument + instead of a no_hang argument. Change type of nbyte argument. + (full_read, full_write): Update. + (safe_read, safe_write): Pass persev_partial, not no_hang=true. + (sock_read): Add a perseverance argument. + (sock_write): Take a perseverance argument instead of a no_hang + argument. + * unixaux.d (read_helper): Take a perseverance argument instead of a + no_hang argument. Bug fixes: Handle EWOULDBLOCK like EAGAIN. Don't + forget to call END_NO_BLOCK in case of an error. + (write_helper): Take a perseverance argument instead of a no_hang + argument. Bug fixes: Handle EWOULDBLOCK like EAGAIN. Don't cast a + negative int to a size_t. + (sock_read): Add a perseverance argument. + (sock_write): Take a perseverance argument instead of a no_hang + argument. + * win32aux.d (read_helper_low): Take a perseverance argument instead of + a no_hang argument. Change type of nbyte argument. When no blocking + is required, call GetOverlappedResult with wait=false. Continue the + loop when limited_nbyte == MAX_IO. + (full_read_params): Replace no_hang with perseverance. Change type of + nbyte field. + (do_read_helper): Update. + (read_helper): Take a perseverance argument instead of a no_hang + argument. Change type of nbyte argument. + (write_helper): Take a perseverance argument instead of a no_hang + argument. Change type of nbyte argument. When no blocking is required, + call GetOverlappedResult with wait=false, instead of skipping it. + Continue the loop when limited_nbyte == MAX_IO. + (lowlevel_sock_read): Add a perseverance argument. Change type of nbyte + argument. Continue the loop when limited_nbyte == MAX_IO. + (sock_read_params): Add perseverance. Change type of nbyte field. + (do_sock_read): Update. + (sock_read): Add a perseverance argument. Change type of nbyte + argument. + (lowlevel_sock_write): Take a perseverance argument instead of a + no_hang argument. Change type of nbyte argument. Continue the loop when + limited_nbyte == MAX_IO. + (sock_write_params): Replace no_hang with perseverance. Change type of + nbyte field. + (do_sock_write): Update. + (sock_write): Take a perseverance argument instead of a no_hang + argument. Change type of nbyte argument. + * stream.d (rd_by_array_Pseudofun, wr_by_array_Pseudofun): Take a + perseverance argument instead of a no_hang argument. + (rd_by_array_error): Update. + (rd_by_array_dummy): Update. Implement persev_partial too. + (wr_by_array_error): Update. + (wr_by_array_dummy): Update. + (read_byte_array): Update. Pass a 6th argument to + GRAY:STREAM-READ-BYTE-SEQUENCE. + (write_byte_array): Update. Pass a 6th argument to + GRAY:STREAM-WRITE-BYTE-SEQUENCE. + (rd_by_array_synonym, wr_by_array_synonym): Update. + (wr_by_array_broad): Update. + (rd_by_array_concat): Update. + (wr_by_array_twoway): Update. + (rd_by_array_twoway): Update. + (rd_by_array_echo): Update. + (struct strm_unbuffered_extrafields_t): Change low_read_array, + low_write_array methods to take a perseverance argument instead of a + no_hang argument. + (low_read_array_unbuffered_handle): Update. + (rd_by_aux_iax_unbuffered, rd_by_array_iau8_unbuffered): Update. + (rd_ch_array_unbuffered): Update. + (low_write_array_unbuffered_handle): Update. + (wr_by_aux_ia_unbuffered, wr_by_array_iau8_unbuffered): Update. + (wr_ch_unbuffered_unix, wr_ch_array_unbuffered_unix): Update. + (wr_ch_unbuffered_mac, wr_ch_array_unbuffered_mac): Update. + (wr_ch_unbuffered_dos, wr_ch_array_unbuffered_dos): Update. + (oconv_unshift_output_unbuffered_): Update. + (struct strm_buffered_extrafields_t): Change low_fill method to take + a perseverance argument instead of a no_hang argument. + (low_fill_buffered_handle): Update. When a byte has already been read, + use persev_immediate also if no_hang=false. + (buffered_nextbyte): Take a restricted perseverance argument instead of + a no_hang argument. + (buffered_writebyte, position_file_buffered): Update. + (read_byte_array_buffered, write_byte_array_buffered): Take a + perseverance argument instead of a no_hang argument. + (rd_ch_buffered, listen_char_buffered, rd_ch_array_buffered): Update. + (wr_ch_buffered_unix, wr_ch_array_buffered_unix): Update. + (wr_ch_buffered_mac, wr_ch_array_buffered_mac): Update. + (wr_ch_buffered_dos, wr_ch_array_buffered_dos): Update. + (oconv_unshift_output_buffered_): Update. + (position_file_i_buffered, rd_by_aux_iax_buffered, + rd_by_aux_ibx_buffered, rd_by_aux_icx_buffered, rd_by_iau8_buffered, + rd_by_array_iau8_buffered, listen_byte_ia8_buffered): Update. + (wr_by_aux_ia_buffered, WRITE_LAST_BYTE, wr_by_aux_ib_buffered, + wr_by_aux_ic_buffered, wr_by_array_iau8_buffered): Update. + (logical_position_file_end): Update. + (make_file_stream): Update. + (low_write_array_unbuffered_pipe): Update. + (low_read_unbuffered_socket, low_listen_unbuffered_socket): Update. + (low_read_array_unbuffered_socket): Update. + (low_write_unbuffered_socket): Update. + (low_write_array_unbuffered_socket): Update. Fix the safety check. + (SYS::READ-N-BYTES, SYS::WRITE-N-BYTES): Update. + (low_fill_buffered_socket): Take a perseverance argument instead of a + no_hang argument. + (low_flush_buffered_socket): Update. + (READ-INTEGER, READ-FLOAT, WRITE-INTEGER, WRITE-FLOAT): Update. + * sequence.d (READ-BYTE-SEQUENCE, WRITE-BYTE-SEQUENCE): Add + :interactive argument. + * genclisph.d (main): Emit perseverance_t. Emit include of sys/types.h. + Fix declations of read_helper, write_helper to be consistent with those + in unix.d. Update declarations of read_byte_array, write_byte_array. + * gray.lisp (stream-read-byte-sequence): Add interactive argument. + (stream-write-byte-sequence): Likewise. + 2004-10-17 Bruno Haible <br...@cl...> * defstruct.lisp (defstruct): Simplify directslotlist iteration. Index: subr.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subr.d,v retrieving revision 1.189 retrieving revision 1.190 diff -u -d -r1.189 -r1.190 --- subr.d 23 Oct 2004 19:52:03 -0000 1.189 +++ subr.d 2 Nov 2004 11:39:55 -0000 1.190 @@ -1050,10 +1050,10 @@ (kw(start),kw(end)) ) LISPFUN(write_char_sequence,seclass_default,2,0,norest,key,2, (kw(start),kw(end)) ) -LISPFUN(read_byte_sequence,seclass_default,2,0,norest,key,3, - (kw(start),kw(end),kw(no_hang)) ) -LISPFUN(write_byte_sequence,seclass_default,2,0,norest,key,3, - (kw(start),kw(end),kw(no_hang)) ) +LISPFUN(read_byte_sequence,seclass_default,2,0,norest,key,4, + (kw(start),kw(end),kw(no_hang),kw(interactive)) ) +LISPFUN(write_byte_sequence,seclass_default,2,0,norest,key,4, + (kw(start),kw(end),kw(no_hang),kw(interactive)) ) /* ---------- STREAM ---------- */ LISPFUN(symbol_stream,seclass_read,1,1,norest,nokey,0,NIL) LISPFUNNR(make_synonym_stream,1) Index: constsym.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/constsym.d,v retrieving revision 1.277 retrieving revision 1.278 diff -u -d -r1.277 -r1.278 --- constsym.d 1 Nov 2004 11:24:46 -0000 1.277 +++ constsym.d 2 Nov 2004 11:39:51 -0000 1.278 @@ -1190,6 +1190,7 @@ LISPSYM(Kstart,"START",keyword) LISPSYM(Kend,"END",keyword) LISPSYM(Kno_hang,"NO-HANG",keyword) +LISPSYM(Kinteractive,"INTERACTIVE",keyword) LISPSYM(Kpreserve_whitespace,"PRESERVE-WHITESPACE",keyword) LISPSYM(Kradix,"RADIX",keyword) LISPSYM(Kjunk_allowed,"JUNK-ALLOWED",keyword) Index: sequence.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/sequence.d,v retrieving revision 1.88 retrieving revision 1.89 diff -u -d -r1.88 -r1.89 --- sequence.d 8 Oct 2004 10:40:54 -0000 1.88 +++ sequence.d 2 Nov 2004 11:39:52 -0000 1.89 @@ -4996,12 +4996,14 @@ VALUES1(popSTACK()); /* return sequence */ } -LISPFUN(read_byte_sequence,seclass_default,2,0,norest,key,3, - (kw(start),kw(end),kw(no_hang)) ) -{ /* (READ-BYTE-SEQUENCE sequence stream [:start] [:end] [:no-hang]), +LISPFUN(read_byte_sequence,seclass_default,2,0,norest,key,4, + (kw(start),kw(end),kw(no_hang),kw(interactive)) ) +{ /* (READ-BYTE-SEQUENCE sequence stream [:start] [:end] [:no-hang] [:interactive]), cf. dpANS p. 21-26 */ - /* stack layout: sequence, stream, start, end, no-hang. */ - var bool no_hang = !missingp(STACK_0); skipSTACK(1); + /* stack layout: sequence, stream, start, end, no-hang, interactive. */ + var bool interactive = !missingp(STACK_0); + var bool no_hang = !missingp(STACK_1); + skipSTACK(2); pushSTACK(get_valid_seq_type(STACK_3)); /* check sequence */ /* stack layout: sequence, stream, start, end, typdescr. */ STACK_3 = check_stream(STACK_3); @@ -5015,7 +5017,8 @@ var uintL index = 0; STACK_0 = array_displace_check(STACK_4,end,&index); var uintL result = - read_byte_array(&STACK_3,&STACK_0,index+start,end-start,no_hang); + read_byte_array(&STACK_3,&STACK_0,index+start,end-start, + no_hang ? persev_immediate : interactive ? persev_partial : persev_full); VALUES1(fixnum(start+result)); skipSTACK(5); } else { @@ -5025,9 +5028,9 @@ pushSTACK(value1); /* =: pointer */ /* stack layout: sequence, stream, index, end, typdescr, pointer. */ while (!eql(STACK_3,STACK_2)) { /* index = end (both integers) -> done */ - var object item = /* get an element */ - (no_hang && !ls_avail_p(listen_byte(STACK_4)) - ? eof_value : read_byte(STACK_4)); + if (no_hang && !ls_avail_p(listen_byte(STACK_4))) + break; + var object item = read_byte(STACK_4); /* get an element */ if (eq(item,eof_value)) /* EOF -> done */ break; /* (SEQ-ACCESS-SET sequence pointer item): */ @@ -5036,21 +5039,25 @@ /* pointer := (SEQ-UPD sequence pointer) : */ pointer_update(STACK_0,STACK_5,STACK_1); increment(STACK_3); /* index := (1+ index) */ + if (interactive) + no_hang = true; } VALUES1(STACK_3); /* return index */ skipSTACK(6); } } -LISPFUN(write_byte_sequence,seclass_default,2,0,norest,key,3, - (kw(start),kw(end),kw(no_hang)) ) -{ /* (WRITE-BYTE-SEQUENCE sequence stream [:start] [:end] [:no-hang]), +LISPFUN(write_byte_sequence,seclass_default,2,0,norest,key,4, + (kw(start),kw(end),kw(no_hang),kw(interactive)) ) +{ /* (WRITE-BYTE-SEQUENCE sequence stream [:start] [:end] [:no-hang] [:interactive]), 2 values: sequence as first value (backward compatible) - second value is the position of first unwritten byte (sequence length if everything was written, including :no-hang nil) cf. dpANS p. 21-27 */ - /* stack layout: sequence, stream, start, end, no-hang. */ - var bool no_hang = !missingp(STACK_0); skipSTACK(1); + /* stack layout: sequence, stream, start, end, no-hang, interactive. */ + var bool interactive = !missingp(STACK_0); + var bool no_hang = !missingp(STACK_1); + skipSTACK(2); pushSTACK(get_valid_seq_type(STACK_3)); /* sequence check */ /* stack layout: sequence, stream, start, end, typdescr. */ STACK_3 = check_stream(STACK_3); @@ -5064,7 +5071,8 @@ var uintL index = 0; STACK_0 = array_displace_check(STACK_4,end,&index); var uintL result = - write_byte_array(&STACK_3,&STACK_0,index+start,end-start,no_hang); + write_byte_array(&STACK_3,&STACK_0,index+start,end-start, + no_hang ? persev_immediate : interactive ? persev_partial : persev_full); skipSTACK(4); VALUES2(popSTACK(),fixnum(start+result)); } else { @@ -5077,10 +5085,11 @@ funcall(seq_init_start(STACK_(0+2)),2); /*(SEQ-INIT-START sequence start)*/ STACK_2 = value1; /* =: pointer */ /* stack layout: sequence, stream, pointer, count, typdescr. */ + if (no_hang || interactive) /* FIXME: need write_byte_will_hang_p() */ + fehler_illegal_streamop(S(write_byte_sequence),STACK_3); while (!eq(STACK_1,Fixnum_0)) { /* count (an integer) = 0 -> done */ pushSTACK(STACK_4); pushSTACK(STACK_(2+1)); funcall(seq_access(STACK_(0+2)),2); /* (SEQ-ACCESS sequence pointer) */ - /* FIXME: if (!no_hang || !write_byte_will_hang_p(STACK_3)) ... */ write_byte(STACK_3,value1); /* output an element */ /* pointer := (SEQ-UPD sequence pointer) : */ pointer_update(STACK_2,STACK_4,STACK_0); Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.560 retrieving revision 1.561 diff -u -d -r1.560 -r1.561 --- lispbibl.d 23 Oct 2004 19:52:08 -0000 1.560 +++ lispbibl.d 2 Nov 2004 11:39:51 -0000 1.561 @@ -1694,6 +1694,22 @@ #define CR 13 # #\Return carriage return #define PG 12 # #\Page form feed, new page +# Desired reaction when an I/O operation cannot be completed immediately. +typedef enum { + persev_full, /* Continue the I/O operation until the whole buffer is + handled or EOF or an error occurred. May hang. */ + persev_partial, /* Continue the I/O operation until some (non-empty) part + of the buffer is handled or EOF or an error occurred. + May hang. */ + persev_immediate, /* Act immediately. Perform I/O only if we know in advance + that it will not block. In case of doubt, perform it + anway. May return with 0 bytes handled. Does usually + not hang. */ + persev_bonus /* Act immediately. Perform I/O only if we know in advance + that it will not block. In case of doubt, don't perform + it. May return with 0 bytes handled. Does not hang. */ +} perseverance_t; + #if defined(UNIX) || defined(WIN32) #ifdef UNIX @@ -13738,15 +13754,15 @@ /* used by STREAM */ /* Function: Reads several bytes from a stream. - read_byte_array(&stream,&bytearray,start,len,no_hang) + read_byte_array(&stream,&bytearray,start,len,persev) > stream: stream (on the STACK) > object bytearray: simple-8bit-vector (on the STACK) > uintL start: start index of byte sequence to be filled > uintL len: length of byte sequence to be filled - > bool no_hang: don't block, return already after partial read + > perseverance_t persev: how to react on incomplete I/O < uintL result: number of bytes that have been filled can trigger GC */ -extern uintL read_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, bool no_hang); +extern uintL read_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev); /* used by SEQUENCE, PATHNAME */ # Function: Writes several bytes to a stream. @@ -13755,9 +13771,9 @@ # > object bytearray: simple-8bit-vector (on the STACK) # > uintL start: start index of byte sequence to be written # > uintL len: length of byte sequence to be written -# > bool no_hang: don't block, return already after partial write +# > perseverance_t persev: how to react on incomplete I/O # < uintL result: number of bytes that have been written -extern uintL write_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, bool no_hang); +extern uintL write_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev); # is used by SEQUENCE # Function: Reads several characters from a stream. Index: win32.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/win32.d,v retrieving revision 1.44 retrieving revision 1.45 diff -u -d -r1.44 -r1.45 --- win32.d 8 Sep 2004 09:25:56 -0000 1.44 +++ win32.d 2 Nov 2004 11:39:55 -0000 1.45 @@ -210,13 +210,12 @@ /* Like ReadConsoleInput with Length==1, but is interruptible by Ctrl-C. */ extern BOOL ReadConsoleInput1 (HANDLE ConsoleInput, PINPUT_RECORD Buffer, LPDWORD NumberOfEventsRead); /* The following functions deal with all kinds of file/pipe/console handles */ -extern int read_helper (HANDLE fd, void* buf, int nbyte, bool no_hang); -#define safe_read(f,b,n) read_helper(f,b,n,true) -#define full_read(f,b,n) read_helper(f,b,n,false) -extern int write_helper (HANDLE fd, const void* buf, int nbyte, bool no_hang); -#define full_write(f,b,n) write_helper(f,b,n,false) -#define read full_read -#define write full_write +extern ssize_t read_helper (HANDLE fd, void* buf, size_t nbyte, perseverance_t persev); +extern ssize_t write_helper (HANDLE fd, const void* buf, size_t nbyte, perseverance_t persev); +#define safe_read(fd,buf,nbyte) read_helper(fd,buf,nbyte,persev_partial) +#define full_read(fd,buf,nbyte) read_helper(fd,buf,nbyte,persev_full) +#define safe_write(fd,buf,nbyte) write_helper(fd,buf,nbyte,persev_partial) +#define full_write(fd,buf,nbyte) write_helper(fd,buf,nbyte,persev_full) /* Changing the position within a file. */ #define lseek(handle,offset,mode) ((int)SetFilePointer(handle,offset,NULL,mode)) #undef SEEK_SET @@ -278,8 +277,8 @@ /* Signalling a socket related error extern void SOCK_error (void); Reading and writing from a socket */ -extern int sock_read (SOCKET fd, void* buf, int nbyte); -extern int sock_write (SOCKET fd, const void* buf, int nbyte, bool no_hang); +extern int sock_read (SOCKET fd, void* buf, size_t nbyte, perseverance_t persev); +extern int sock_write (SOCKET fd, const void* buf, size_t nbyte, perseverance_t persev); /* Interruptible wait for something on socket */ typedef enum { socket_wait_read, socket_wait_write, socket_wait_except } socket_wait_event; extern int interruptible_socket_wait (SOCKET socket_handle, socket_wait_event waitwhat, struct timeval * timeout_ptr); Index: subrkw.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/subrkw.d,v retrieving revision 1.49 retrieving revision 1.50 diff -u -d -r1.49 -r1.50 --- subrkw.d 5 Oct 2004 15:54:30 -0000 1.49 +++ subrkw.d 2 Nov 2004 11:39:55 -0000 1.50 @@ -48,7 +48,7 @@ s(write_char_sequence) s(convert_string_from_bytes) s(convert_string_to_bytes) -v(3, (kw(start),kw(end),kw(no_hang)) ) +v(4, (kw(start),kw(end),kw(no_hang),kw(interactive)) ) s(read_byte_sequence) s(write_byte_sequence) v(5, (kw(charset),kw(line_terminator),kw(input_error_action), Index: unixaux.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/unixaux.d,v retrieving revision 1.43 retrieving revision 1.44 diff -u -d -r1.43 -r1.44 --- unixaux.d 1 Nov 2004 11:18:53 -0000 1.43 +++ unixaux.d 2 Nov 2004 11:39:55 -0000 1.44 @@ -220,11 +220,11 @@ #endif /* a wrapper for read(). */ -global ssize_t read_helper (int fd, void* bufarea, size_t nbyte, bool no_hang) +global ssize_t read_helper (int fd, void* bufarea, size_t nbyte, perseverance_t persev) { var char* buf = (char*) bufarea; var ssize_t retval; - var size_t done = 0; + var ssize_t done = 0; #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) /* Must adjust the memory permissions before calling read(). - On SunOS4 a missing write permission causes the read() call to hang @@ -239,57 +239,53 @@ #endif { NO_BLOCK_DECL(fd); - if (no_hang) START_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) START_NO_BLOCK(fd); while (nbyte!=0) { retval = read(fd,buf,nbyte); if (retval == 0) break; else if (retval < 0) { - /* FIXME: Why only EAGAIN and not also EWOULDBLOCK? */ - if (no_hang && (errno == EAGAIN)) { - /* FIXME: signal blocking state reached -- just use errno? - never executes - printf("read_helper - read blocked\n"); */ + if ((persev == persev_immediate || persev == persev_bonus) + && (errno == EAGAIN || errno == EWOULDBLOCK)) break; - } #ifdef EINTR if (errno != EINTR) #endif - return retval; + { + done = retval; /* -1 */ + break; + } } else { buf += retval; done += (size_t)retval; nbyte -= (size_t)retval; - if (no_hang) + if (persev != persev_full) break; } } - if (no_hang) END_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) END_NO_BLOCK(fd); } - /* never executes - if (errno == EAGAIN) printf("returning with block from read_helper\n");*/ return done; } /* a wrapper for write(). */ -global ssize_t write_helper (int fd, const void* bufarea, size_t nbyte, - bool no_hang) +global ssize_t write_helper (int fd, const void* bufarea, size_t nbyte, perseverance_t persev) { var const char* buf = (const char*) bufarea; var ssize_t retval; - var size_t done = 0; + var ssize_t done = 0; #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) /* Must adjust the memory permissions before calling write(). */ handle_fault_range(PROT_READ,(aint)buf,(aint)buf+nbyte); #endif { NO_BLOCK_DECL(fd); - if (no_hang) START_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) START_NO_BLOCK(fd); while (nbyte!=0) { retval = write(fd,buf,nbyte); if (retval < 0) { - /* FIXME: Why only EAGAIN and not also EWOULDBLOCK? */ - if (no_hang && (errno == EAGAIN)) + if ((persev == persev_immediate || persev == persev_bonus) + && (errno == EAGAIN || errno == EWOULDBLOCK)) break; #ifdef EINTR - /* FIXME: no way to interrupt a large write? *** */ if (errno != EINTR) #endif { @@ -298,9 +294,11 @@ } } else { buf += retval; done += (size_t)retval; nbyte -= (size_t)retval; + if (persev != persev_full) + break; } } - if (no_hang) END_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) END_NO_BLOCK(fd); } return done; } @@ -310,64 +308,78 @@ /* BeOS 5 sockets cannot be used like file descriptors. */ /* A wrapper around the recv() function. */ -/* FIXME: Why no no_hang argument here? */ -global ssize_t sock_read (int fd, void* bufarea, size_t nbyte) { +/* FIXME: persev_immediate case totally untested ! */ +global ssize_t sock_read (int fd, void* bufarea, size_t nbyte, perseverance_t persev) { var char* buf = (char*) bufarea; var ssize_t retval; - var size_t done = 0; + var ssize_t done = 0; #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) /* Must adjust the memory permissions before calling recv(). */ handle_fault_range(PROT_READ_WRITE,(aint)buf,(aint)buf+nbyte); #endif - while (nbyte!=0) { - retval = recv(fd,buf,nbyte,0); - if (retval == 0) - break; - else if (retval < 0) { - #ifdef EINTR - if (!(errno == EINTR)) - #endif - return retval; - } else { - buf += retval; done += retval; nbyte -= retval; - break; /* return partial read */ + { + NO_BLOCK_DECL(fd); + if (persev == persev_immediate || persev == persev_bonus) START_NO_BLOCK(fd); + while (nbyte!=0) { + retval = recv(fd,buf,nbyte,0); + if (retval == 0) + break; + else if (retval < 0) { + if ((persev == persev_immediate || persev == persev_bonus) + && (errno == EAGAIN || errno == EWOULDBLOCK)) + break; + #ifdef EINTR + if (errno != EINTR) + #endif + { + done = retval; /* -1 */ + break; + } + } else { + buf += retval; done += (size_t)retval; nbyte -= (size_t)retval; + if (persev != persev_full) + break; + } } + if (persev == persev_immediate || persev == persev_bonus) END_NO_BLOCK(fd); } return done; } -/* A wrapper around the send() function. - FIXME: no_hang case totally untested ! */ -global ssize_t sock_write (int fd, const void* bufarea, size_t nbyte, - bool no_hang) +/* A wrapper around the send() function. */ +/* FIXME: persev_immediate case totally untested ! */ +global ssize_t sock_write (int fd, const void* bufarea, size_t nbyte, perseverance_t persev) { var const char* buf = (const char*) bufarea; var ssize_t retval; - var size_t done = 0; + var ssize_t done = 0; #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) /* Must adjust the memory permissions before calling send(). */ handle_fault_range(PROT_READ,(aint)buf,(aint)buf+nbyte); #endif { NO_BLOCK_DECL(fd); - if (no_hang) START_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) START_NO_BLOCK(fd); while (nbyte!=0) { retval = send(fd,buf,nbyte,0); if (retval < 0) { - if (no_hang && (errno == EAGAIN || errno == EWOULDBLOCK)) + if ((persev == persev_immediate || persev == persev_bonus) + && (errno == EAGAIN || errno == EWOULDBLOCK)) break; #ifdef EINTR if (errno != EINTR) #endif { - done = retval; + done = retval; /* -1 */ break; } } else { - buf += retval; done += retval; nbyte -= retval; + buf += retval; done += (size_t)retval; nbyte -= (size_t)retval; + if (persev != persev_full) + break; } } - if (no_hang) END_NO_BLOCK(fd); + if (persev == persev_immediate || persev == persev_bonus) END_NO_BLOCK(fd); } return done; } Index: NEWS =================================================================== RCS file: /cvsroot/clisp/clisp/src/NEWS,v retrieving revision 1.195 retrieving revision 1.196 diff -u -d -r1.195 -r1.196 --- NEWS 29 Oct 2004 15:49:33 -0000 1.195 +++ NEWS 2 Nov 2004 11:39:51 -0000 1.196 @@ -231,6 +231,12 @@ See <http://clisp.cons.org/impnotes.html#dffi-make-var> and <http://clisp.cons.org/impnotes.html#dffi-make-func> for details. +* Function READ-BYTE-SEQUENCE takes a new keyword argument :INTERACTIVE. + See <http://clisp.cons.org/impnotes.html#rd-by-seq> for details. + +* Methods on GRAY:STREAM-READ-BYTE-SEQUENCE and GRAY:STREAM-WRITE-BYTE-SEQUENCE + now need to accept a second optional argument. + * The :LIBRARY option argument to DEF-CALL-OUT and DEF-C-VAR is now evaluated (i.e., it can now be a variable) and may take a value of :DEFAULT and :NEXT in addition to being a string as before. Index: win32aux.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/win32aux.d,v retrieving revision 1.38 retrieving revision 1.39 diff -u -d -r1.38 -r1.39 --- win32aux.d 8 Sep 2004 09:25:57 -0000 1.38 +++ win32aux.d 2 Nov 2004 11:39:55 -0000 1.39 @@ -370,7 +370,7 @@ /* Reading from a file/pipe/console handle. This is the non-interruptible routine. */ -local int read_helper_low (HANDLE fd, void* bufarea, int nbyte, bool no_hang) { +local int read_helper_low (HANDLE fd, void* bufarea, size_t nbyte, perseverance_t persev) { #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) handle_fault_range(PROT_READ_WRITE,(aint)bufarea,(aint)bufarea+nbyte); #endif @@ -407,15 +407,20 @@ break; if (err != ERROR_IO_PENDING) return -1; - if (!GetOverlappedResult(fd, &overlap, &nchars, true)) { + if (!GetOverlappedResult(fd, &overlap, &nchars, + persev != persev_immediate && persev != persev_bonus)) { if (GetLastError() == ERROR_HANDLE_EOF) break; return -1; } ok: + if (nchars == 0) + break; buf += nchars; done += nchars; nbyte -= nchars; - if (nchars == 0 || no_hang) + if (persev != persev_full && nchars < MAX_IO) break; + if (persev == persev_partial) + persev = persev_bonus; } #ifndef UNICODE /* Possibly translate characters. */ @@ -443,26 +448,25 @@ } /* Then we make it interruptible. */ struct full_read_params { - HANDLE fd; void* buf; int nbyte; + HANDLE fd; void* buf; size_t nbyte; perseverance_t persev; int retval; DWORD errcode; - bool no_hang; }; local DWORD WINAPI do_read_helper (LPVOID arg) { var struct full_read_params * params = (struct full_read_params *)arg; params->retval = read_helper_low(params->fd,params->buf,params->nbyte, - params->no_hang); + params->persev); if (params->retval < 0) params->errcode = GetLastError(); return 0; } -global int read_helper (HANDLE fd, void* buf, int nbyte, bool no_hang) { +global int read_helper (HANDLE fd, void* buf, size_t nbyte, perseverance_t persev) { var struct full_read_params params; params.fd = fd; params.buf = buf; params.nbyte = nbyte; + params.persev = persev; params.retval = 0; params.errcode = 0; - params.no_hang = no_hang; if (DoInterruptible(&do_read_helper,(void*)¶ms,false)) { if (params.retval < 0) SetLastError(params.errcode); @@ -473,7 +477,7 @@ } /* Writing to a file/pipe/console handle. */ -global int write_helper (HANDLE fd, const void* b, int nbyte, bool no_hang) +global int write_helper (HANDLE fd, const void* b, size_t nbyte, perseverance_t persev) { #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) handle_fault_range(PROT_READ,(aint)b,(aint)b+nbyte); @@ -534,18 +538,24 @@ } if (err != ERROR_IO_PENDING) return -1; - if (no_hang) return done; /* do not wait! */ - if (!GetOverlappedResult(fd, &overlap, &nchars, true)) + if (!GetOverlappedResult(fd, &overlap, &nchars, + persev != persev_immediate && persev != persev_bonus)) return -1; ok: + if (nchars == 0) + break; buf += nchars; done += nchars; nbyte -= nchars; + if (persev != persev_full && nchars < MAX_IO) + break; + if (persev == persev_partial) + persev = persev_bonus; } return done; } /* Reading from a socket. This is the non-interruptible routine. */ -local int lowlevel_sock_read (SOCKET fd, void* b, int nbyte) +local int lowlevel_sock_read (SOCKET fd, void* b, size_t nbyte, perseverance_t persev) { #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) handle_fault_range(PROT_READ_WRITE,(aint)b,(aint)b+nbyte); @@ -561,30 +571,35 @@ return retval; else { buf += retval; done += retval; nbyte -= retval; - break; /* return partial read */ + if (persev != persev_full && retval < MAX_IO) + break; + if (persev == persev_partial) + persev = persev_bonus; } } return done; } /* Then we make it interruptible. */ struct sock_read_params { - SOCKET fd; void* buf; int nbyte; + SOCKET fd; void* buf; size_t nbyte; perseverance_t persev; int retval; int errcode; }; local DWORD WINAPI do_sock_read (LPVOID arg) { var struct sock_read_params * params = (struct sock_read_params *)arg; - params->retval = lowlevel_sock_read(params->fd,params->buf,params->nbyte); + params->retval = lowlevel_sock_read(params->fd,params->buf,params->nbyte, + params->persev); if (params->retval < 0) params->errcode = WSAGetLastError(); return 0; } -global int sock_read (SOCKET fd, void* buf, int nbyte) +global int sock_read (SOCKET fd, void* buf, size_t nbyte, perseverance_t persev) { var struct sock_read_params params; params.fd = fd; params.buf = buf; params.nbyte = nbyte; + params.persev = persev; params.retval = 0; params.errcode = 0; if (DoInterruptible(&do_sock_read,(void*)¶ms,true)) { @@ -598,8 +613,7 @@ /* Writing to a socket. This is the non-interruptible routine. */ -local int lowlevel_sock_write (SOCKET fd, const void* b, int nbyte, - bool no_hang) +local int lowlevel_sock_write (SOCKET fd, const void* b, size_t nbyte, perseverance_t persev) { #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED) handle_fault_range(PROT_READ,(aint)b,(aint)b+nbyte); @@ -615,35 +629,37 @@ return retval; else { buf += retval; done += retval; nbyte -= retval; - if (no_hang) break; + if (persev != persev_full && retval < MAX_IO) + break; + if (persev == persev_partial) + persev = persev_bonus; } } return done; } /* Then we make it interruptible. */ struct sock_write_params { - SOCKET fd; const void* buf; int nbyte; + SOCKET fd; const void* buf; size_t nbyte; perseverance_t persev; int retval; int errcode; - bool no_hang; }; local DWORD WINAPI do_sock_write (LPVOID arg) { var struct sock_write_params * params = (struct sock_write_params *)arg; params->retval = lowlevel_sock_write(params->fd,params->buf,params->nbyte, - params->no_hang); + params->persev); if (params->retval < 0) params->errcode = WSAGetLastError(); return 0; } -global int sock_write (SOCKET fd, const void* buf, int nbyte, bool no_hang) +global int sock_write (SOCKET fd, const void* buf, size_t nbyte, perseverance_t persev) { var struct sock_write_params params; params.fd = fd; params.buf = buf; params.nbyte = nbyte; + params.persev = persev; params.retval = 0; params.errcode = 0; - params.no_hang = no_hang; if (DoInterruptible(&do_sock_write,(void*)¶ms,true)) { if (params.retval < 0) WSASetLastError(params.errcode); Index: genclisph.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v retrieving revision 1.151 retrieving revision 1.152 diff -u -d -r1.151 -r1.152 --- genclisph.d 23 Oct 2004 19:52:13 -0000 1.151 +++ genclisph.d 2 Nov 2004 11:39:51 -0000 1.152 @@ -455,7 +455,18 @@ sprintf(buf,"sint%d",intDsize); emit_typedef(buf,"sintD"); #endif sprintf(buf,"uint%d",intDsize); emit_typedef(buf,"uintD"); + printf("typedef enum { persev_full, persev_partial, persev_immediate, persev_bonus } perseverance_t;\n"); printf("#include <stdlib.h>\n"); + printf("#include <sys/types.h>\n"); +#if defined(WIN32_NATIVE) + printf("#define Handle HANDLE\n"); +#elif defined(UNIX) + printf("#define Handle uintW\n"); +#else + printf("#error \"what is Handle on your platform?!\"\n"); +#endif + printf("extern ssize_t read_helper (Handle fd, void* buf, size_t nbyte, perseverance_t persev);\n"); + printf("extern ssize_t write_helper (Handle fd, const void* buf, size_t nbyte, perseverance_t persev);\n"); #if notused #ifdef WIDE_HARD printf("#define WIDE_HARD\n"); @@ -2084,22 +2095,13 @@ printf("extern object convert_time_to_universal (const FILETIME* time);\n"); #endif printf("#define UNIX_LISP_TIME_DIFF 2208988800UL\n"); -#if defined(WIN32_NATIVE) - printf("#define Handle HANDLE\n"); -#elif defined(UNIX) - printf("#define Handle uintW\n"); -#else - printf("#error \"what is Handle on your platform?!\"\n"); -#endif printf("extern Handle handle_dup (Handle old_handle, Handle new_handle);\n"); printf("extern Handle stream_lend_handle (object stream, bool inputp, int * handletype);\n"); - printf("extern uintL read_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, bool no_hang);\n"); - printf("extern uintL write_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, bool no_hang);\n"); + printf("extern uintL read_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);\n"); + printf("extern uintL write_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);\n"); printf("extern void builtin_stream_close (const gcv_object_t* stream_);\n"); printf("extern object file_stream_truename (object s);\n"); printf("extern object open_file_stream_handle (object stream, Handle *fd);\n"); - printf("extern int write_helper (Handle fd, const void* buf, int nbyte, bool no_hang);\n"); - printf("extern int read_helper (Handle fd, void* buf, int nbyte, bool no_hang);\n"); printf("extern object addr_to_string (short type, char *addr);\n"); printf("extern struct hostent* resolve_host (object arg);\n"); printf("#define strm_buffered_bufflen %d\n",strm_buffered_bufflen); --__--__-- _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest |