;*=====================================================================*/
;*    serrano/prgm/project/bigloo/fthread/src2.6b/Llib/async.scm       */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Sat Oct 19 16:47:03 2002                          */
;*    Last change :  Wed Jul  2 17:09:51 2003 (serrano)                */
;*    Copyright   :  2002-03 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    Fair thread asyncrent fake signals.                              */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __ft_async

   (import __ft_types
	   __ft_%types
	   __ft_%thread
	   __ft_scheduler
	   __ft_%scheduler
	   __ft_env
	   __ft_%env
	   __ft_signal
	   __ft_reader
	   __ft_exception
	   __ft_%exception
	   __ft_%mutex
	   __ft_thread)

   (export (make-input-signal ::input-port ::obj . opt)
	   (make-output-signal ::output-port ::bstring . opt)
	   (make-connect-signal ::socket . opt)
	   (make-accept-signal ::socket . opt)
	   (make-process-signal ::process . opt)
	   (make-sleep-signal ::long . opt)
	   (make-send-chars-signal ::input-port ::output-port . opt)

	   (fair-read/rp ::procedure ::input-port))

   (extern ($rgc-fill-buffer::bool ::input-port "rgc_fill_buffer")))

;*---------------------------------------------------------------------*/
;*    object-equal? ::%sigasync ...                                    */
;*---------------------------------------------------------------------*/
(define-method (object-equal? o1::%sigasync o2)
   (eq? o1 o2))

;*---------------------------------------------------------------------*/
;*    make-input-len-signal ...                                        */
;*---------------------------------------------------------------------*/
(define (make-input-len-signal p::input-port s::int opt)
   (let* ((scdl (%get-optional-scheduler 'make-input-signal opt))
	  (thunk (make-fair-reader p s))
	  (sig (instantiate::%sigasync
		  (id 'make-input-signal:len)
		  (thunk thunk))))
      (if (input-procedure-port? p)
	  (%scheduler-add-broadcast! (current-scheduler) sig (thunk))
	  (%scheduler-add-async! (current-scheduler) sig))
      sig))

;*---------------------------------------------------------------------*/
;*    make-input-pattern-signal ...                                    */
;*---------------------------------------------------------------------*/
(define (make-input-pattern-signal p::input-port s::bstring opt)
   (let* ((scdl (%get-optional-scheduler 'make-input-signal opt))
	  (thunk (make-fair-match p (list s)))
	  (sig (instantiate::%sigasync
		  (id 'make-input-signal:pattern)
		  (thunk thunk))))
      (if (input-procedure-port? p)
	  (%scheduler-add-broadcast! (current-scheduler) sig (thunk))
	  (%scheduler-add-async! (current-scheduler) sig))
      sig))

;*---------------------------------------------------------------------*/
;*    make-input-pattern*-signal ...                                   */
;*---------------------------------------------------------------------*/
(define (make-input-pattern*-signal p::input-port s::pair opt)
   (let* ((scdl (%get-optional-scheduler 'make-input-signal opt))
	  (thunk (make-fair-match p s))
	  (sig (instantiate::%sigasync
		  (id 'make-input-signal:pattern)
		  (thunk thunk))))
      (if (input-procedure-port? p)
	  (%scheduler-add-broadcast! (current-scheduler) sig (thunk))
	  (%scheduler-add-async! (current-scheduler) sig))
      sig))

;*---------------------------------------------------------------------*/
;*    make-input-charset-signal ...                                    */
;*---------------------------------------------------------------------*/
(define (make-input-charset-signal p::input-port s::pair opt)
   (if (pair? (filter (lambda (x) (not (char? x))) s))
       (error "thread-await" "Illegal :input await" opt)
       (let* ((scdl (%get-optional-scheduler 'make-output-signal opt))
	      (thunk (make-fair-memq p s))
	      (sig (instantiate::%sigasync
		      (id 'make-input-signal:charset)
		      (thunk thunk))))
	  (if (input-procedure-port? p)
	      (%scheduler-add-broadcast! (current-scheduler) sig (thunk))
	      (%scheduler-add-async! (current-scheduler) sig))
	  sig)))

;*---------------------------------------------------------------------*/
;*    make-input-signal ...                                            */
;*---------------------------------------------------------------------*/
(define (make-input-signal p s . opt)
   (define (err)
      (error "make-input-signal" "Illegal argument" s))
   (cond
      ((integer? s)
       (make-input-len-signal p s opt))
      ((string? s)
       (make-input-pattern-signal p s opt))
      ((list? s)
       (cond
	  ((every? char? s)
	   (make-input-charset-signal p s opt))
	  ((every? string? s)
	   (make-input-pattern*-signal p s opt))
	  (else
	   (err))))
      (else
       (err))))

;*---------------------------------------------------------------------*/
;*    make-output-signal ...                                           */
;*---------------------------------------------------------------------*/
(define (make-output-signal p s . opt)
   (let* ((scdl (%get-optional-scheduler 'make-output-signal opt))
	  (sig (instantiate::%sigasync
		  (id 'make-output-signal)
		  (thunk (lambda ()
			    (display-string s p)
			    (flush-output-port p))))))
      (%scheduler-add-async! (current-scheduler) sig)
      sig))

;*---------------------------------------------------------------------*/
;*    make-connect-signal ...                                          */
;*---------------------------------------------------------------------*/
(define (make-connect-signal s . opt)
   (let* ((scdl (%get-optional-scheduler 'make-connect-signal opt))
	  (sig (instantiate::%sigasync
		  (id 'make-connect-signal)
		  (thunk (lambda ()
			    (socket-accept-connection s #f))))))
      (%scheduler-add-async! (current-scheduler) sig)
      sig))

;*---------------------------------------------------------------------*/
;*    make-accept-signal ...                                           */
;*---------------------------------------------------------------------*/
(define (make-accept-signal s . opt)
   (let* ((scdl (%get-optional-scheduler 'make-accept-signal opt))
	  (sig (instantiate::%sigasync
		  (id 'make-accept-signal)
		  (thunk (lambda ()
			    (let ((c (socket-accept s #f #f)))
			       (cond-expand
				  (bigloo-c
				   ($rgc-fill-buffer (socket-input c)))
				  (else
				   #f))
			       c))))))
      (%scheduler-add-async! (current-scheduler) sig)
      sig))

;*---------------------------------------------------------------------*/
;*    make-process-signal ...                                          */
;*---------------------------------------------------------------------*/
(define (make-process-signal s::process . opt)
   (let* ((scdl (%get-optional-scheduler 'make-process-signal opt))
	  (sig (instantiate::%sigasync
		  (id 'make-process-signal)
		  (thunk (lambda ()
			    (process-wait s)
			    (process-exit-status s))))))
      (%scheduler-add-async! (current-scheduler) sig)
      sig))

;*---------------------------------------------------------------------*/
;*    make-sleep-signal ...                                            */
;*---------------------------------------------------------------------*/
(define (make-sleep-signal ms::long . opt)
   (let* ((scdl (%get-optional-scheduler 'make-sleep-signal opt))
	  (sig (instantiate::%sigasync
		  (id 'make-sleep-signal)
		  (thunk (lambda () (sleep ms) #t)))))
      (%scheduler-add-async! (current-scheduler) sig)
      sig))
		       
;*---------------------------------------------------------------------*/
;*    make-send-chars-signal ...                                       */
;*---------------------------------------------------------------------*/
(define (make-send-chars-signal ip::input-port op::output-port . opt)
   (let* ((len (if (and (pair? opt) (integer? (car opt)))
		   (car opt)
		   -1))
	  (opt (if (and (pair? opt) (integer? (car opt)))
		   (cdr opt)
		   opt))
	  (scdl (%get-optional-scheduler 'make-send-chars-signal opt))
	  (bd (lambda ()
		 (send-chars ip op len)
		 #t))
	  (sig (instantiate::%sigasync
		  (id 'make-send-chars-signal)
		  (thunk bd))))
      (if (input-procedure-port? ip)
	  (begin
	     (%scheduler-add-broadcast! (current-scheduler) sig (bd))
	     (%scheduler-add-async! (current-scheduler) sig)))
      sig))
		       
;*---------------------------------------------------------------------*/
;*    make-rgc-signal ...                                              */
;*---------------------------------------------------------------------*/
(define (make-rgc-signal state iport def ct)
   (let ((scdl (%get-optional-scheduler 'make-rgc-signal '()))
	 (sig (instantiate::%sigasync
	       (id 'make-rgc-signal)
	       (thunk (lambda () (state iport def ct))))))
      (%scheduler-add-async! scdl sig)
      sig))

;*---------------------------------------------------------------------*/
;*    fair-read/rp ...                                                 */
;*---------------------------------------------------------------------*/
(define (fair-read/rp grammar port)
   (grammar port
	    (lambda (state iport def context)
	       (thread-await! (make-rgc-signal state iport def context)))))

