/[cmucl]/src/clx/excldep.lisp
ViewVC logotype

Diff of /src/clx/excldep.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by pw, Tue Mar 16 23:37:42 1999 UTC revision 1.4 by fgilham, Tue Aug 21 15:49:28 2007 UTC
# Line 13  Line 13 
13  ;;; express or implied warranty.  ;;; express or implied warranty.
14  ;;;  ;;;
15    
16    #+cmu
17    (ext:file-comment "$Id$")
18    
19  (in-package :xlib)  (in-package :xlib)
20    
21  (eval-when (compile load eval)  (eval-when (compile load eval)
# Line 30  Line 33 
33  (eval-when (eval compile load)  (eval-when (eval compile load)
34    (let ((x '#(1)))    (let ((x '#(1)))
35      (if (not (eq 0 (sys::memref x      (if (not (eq 0 (sys::memref x
36                                  #.(comp::mdparam 'comp::md-svector-data0-adj)                                  #.(sys::mdparam 'comp::md-lvector-data0-norm)
37                                  0 :unsigned-byte)))                                  0 :unsigned-byte)))
38          (pushnew :little-endian *features*)          (pushnew :little-endian *features*)
39        (pushnew :big-endian *features*))))        (pushnew :big-endian *features*))))
# Line 184  Line 187 
187    
188  ;; Return t if there is a character available for reading or on error,  ;; Return t if there is a character available for reading or on error,
189  ;; otherwise return nil.  ;; otherwise return nil.
190    #-(version>= 6 0)
191    (progn
192    
193    #-(or (version>= 4 2) mswindows)
194  (defun fd-char-avail-p (fd)  (defun fd-char-avail-p (fd)
195    (multiple-value-bind (available-p errcode)    (multiple-value-bind (available-p errcode)
196        (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)        (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
# Line 191  Line 198 
198         then t         then t
199         else available-p)))         else available-p)))
200    
201    #+(and (version>= 4 2) (not mswindows))
202    (defun fd-char-avail-p (fd)
203      (excl::filesys-character-available-p fd))
204    
205    #+mswindows
206    (defun fd-char-avail-p (socket-stream)
207      (listen socket-stream))
208    )
209    
210    #+(version>= 6 0)
211    (defun fd-char-avail-p (socket-stream)
212      (excl::read-no-hang-p socket-stream))
213    
214  (defmacro with-interrupt-checking-on (&body body)  (defmacro with-interrupt-checking-on (&body body)
215    `(locally (declare (optimize (safety 1)))    `(locally (declare (optimize (safety 1)))
216       ,@body))       ,@body))
# Line 199  Line 219 
219  ;; Start storing at index 'start-index' and read exactly 'length' bytes.  ;; Start storing at index 'start-index' and read exactly 'length' bytes.
220  ;; Return t if an error or eof occurred, nil otherwise.  ;; Return t if an error or eof occurred, nil otherwise.
221  (defun fd-read-bytes (fd vector start-index length)  (defun fd-read-bytes (fd vector start-index length)
222    (declare (fixnum fd start-index length)    ;; Read from the given stream fd into 'vector', which has element type card8.
223             (type (simple-array (unsigned-byte 8) (*)) vector))    ;; Start storing at index 'start-index' and read exactly 'length' bytes.
224      ;; Return t if an error or eof occurred, nil otherwise.
225      (declare (fixnum next-index start-index length))
226    (with-interrupt-checking-on    (with-interrupt-checking-on
227     (do ((rest length))        (let ((end-index (+ start-index length)))
228         ((eq 0 rest) nil)          (loop
229       (declare (fixnum rest))            (let ((next-index (excl:read-vector vector fd
230       (multiple-value-bind (numread errcode)                                                :start start-index
231           (comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector                                                :end end-index)))
232                                  start-index rest)              (excl:if* (eq next-index start-index)
233         (declare (fixnum numread))                 then                     ; end of file before was all filled up
234         (excl:if* errcode                      (return t)
235            then (if (not (eq errcode               elseif (eq next-index end-index)
236                              excl::*error-code-interrupted-system-call*))                 then                     ; we're all done
237                     (return t))                      (return nil)
238          elseif (eq 0 numread)                 else (setq start-index next-index)))))))
           then (return t)  
           else (decf rest numread)  
                (incf start-index numread))))))  
   
   
 (when (plusp (ff:get-entry-points  
               (make-array 1 :initial-contents  
                           (list (ff:convert-to-lang "fd_wait_for_input")))  
               (make-array 1 :element-type '(unsigned-byte 32))))  
   (ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))  
   (load "excldep.o"))  
   
 (when (plusp (ff:get-entry-points  
               (make-array 1 :initial-contents  
                           (list (ff:convert-to-lang "connect_to_server")))  
               (make-array 1 :element-type '(unsigned-byte 32))))  
   (ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))  
   (load "socket.o"))  
   
 (ff:defforeign-list `((connect-to-server  
                        :entry-point  
                        ,(ff:convert-to-lang "connect_to_server")  
                        :return-type :fixnum  
                        :arg-checking nil  
                        :arguments (string fixnum))  
                       (fd-wait-for-input  
                        :entry-point ,(ff:convert-to-lang "fd_wait_for_input")  
                        :return-type :fixnum  
                        :arg-checking nil  
                        :call-direct t  
                        :callback nil  
                        :allow-other-keys t  
                        :arguments (fixnum fixnum))))  
239    
240    
241  ;; special patch for CLX (various process fixes)  ;; special patch for CLX (various process fixes)

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

  ViewVC Help
Powered by ViewVC 1.1.5