Greetings! This stuff is quite interesting and ingenious! Just thought I'd mention a few things -- select in libc does something similar, and as I've mentioned in the previous post we have a beginning hook now into lisp. CMUCL uses this for job multiplexing to my limited understanding -- I believe all within one process. select likely uses some signalling mechanism internal to its definition, though I have no knowledge of the particulars. The older way to do i/o multiplexing was by sending SIGIO. In this case, one must take care that certain system calls remain restartable across a signal. On an earlier project, I found out that one such call which could permanently fail across signals regardless of file descriptor settings was read! Finally, gcl-tk uses SIGUSR1 to communicate with gcltksrv, and the windows port kills itself with sigalrm (apparently). I like signals in general, but there are certain portability problems, as well as code protection issues. You will see BEGIN_NO_INTERRUPT etc. throughout the C code -- this blocks interfering signals during the critical moments. I've avoided building atop this structure, as I have not verified for myself precisely what the minimal set of calls needing protection is. This aspect of GCL could use an overhaul.
Take care, Robert Boyer <[EMAIL PROTECTED]> writes: > ; Here is a sketch of an implementation of with-timeout. It would be > ; better if GCL had a function like get-universal-time that worked in > ; microseconds and Linux had a sleep command that worked in > ; microseconds. > > ; We steal signal 2 so that it is no longer useful for GCL user > ; interrupts to the console. We should use some other signal number > ; but don't know how. > > ; The *waiting-stack* is a list of (i . time) pairs, where the i is an > ; integer catch tag and time is a universal time. In a good > ; implementation, the tags would somehow have to be eq different from > ; any tags the user might create, but we use simple integers here. > (defvar *waiting-stack* nil) > > ; *setting-up-timeout* is just a hack to indicate where a critical > ; section is needed, but we'll never understand these things. > (defvar *setting-up-timeout* nil) > > (defmacro with-timeout (seconds &rest forms) > ;; If seconds pass before the evaluation of forms is complete, nil is > returned. > ;; Otherwise, the value of the last of forms is returned. > (let ((v (gensym))) > `(let* ((,v ,seconds) > (n (cond ((null *waiting-stack*) 0) > (t (+ 1 (caar *waiting-stack*))))) > (w (cons (cons n (+ (get-universal-time) ,v)) > *waiting-stack*))) > (cond ((or *trying-to-stop* *setting-up-timeout*) > (error "Think harder!"))) > (let* ((*setting-up-timeout* t) > (*waiting-stack* w)) > ;; For an instant, *waiting-stack* has an entry on it that we better > not go to. > (catch n > (let ((*setting-up-timeout* nil)) > ;; but now, the catch stack and *waiting-stack* are resynchronized. > (si::system (format nil "interrupt ~a ~a &" ,v (si::getpid))) > ,@forms)))))) > > ; *trying-to-stop* is just a hack to indicate where a critical section > ; is needed, but we'll never understand these things. > (defvar *trying-to-stop* nil) > > (defun si::terminal-interrupt (correctablep) > (declare (ignore correctablep)) > (cond ((or *trying-to-stop* *setting-up-timeout*) > (error "Think harder!"))) > (let ((*trying-to-stop* t)) > (let ((time (get-universal-time)) > (destination nil)) > (loop for x in *waiting-stack* > when (>= time (cdr x)) > do (setq destination (car x))) > (cond (destination > (throw destination 'nil)))))) > > #| Here is the file /u/boyer/bin/interrupt > > sleep $1 > /bin/kill -2 $2 > > |# > > ; Under this design, the user might create timer interrupts that may > ; stay around for a long time after they are relevant to any body. So > ; perhaps a list of the process id's of timer interrupt processes > ; created should be kept and occasionally cleansed by the top-level > ; loop. > > ------------------------------------------------------------------------------- > > > % g > GCL (GNU Common Lisp) 2.7.0 ANSI Oct 29 2005 16:46:15 > Source License: LGPL(gcl,gmp), GPL(unexec,bfd) > Binary License: GPL due to GPL'ed components: (BFD UNEXEC) > Modifications of this banner must retain notice of a compatible license > Dedicated to the memory of W. Schelter > > Use (help) to get some basic information on how to use GCL. > > >(load "foo.lisp") > > Loading foo.lisp > Finished loading foo.lisp > T > > >(time (with-timeout 1 (with-timeout 4 (with-timeout 300 (loop))))) > > real time : 1.040 secs > run-gbc time : 0.810 secs > child run time : 0.010 secs > gbc time : 0.200 secs > NIL > > >(time (with-timeout 8 (with-timeout 4 (with-timeout 300 (loop))))) > > real time : 4.030 secs > run-gbc time : 3.560 secs > child run time : 0.000 secs > gbc time : 0.440 secs > NIL > > >(time (with-timeout 8 (with-timeout 4 (with-timeout 1 'win)))) > > real time : 0.010 secs > run-gbc time : 0.000 secs > child run time : 0.010 secs > gbc time : 0.000 secs > WIN > > > > > > -- Camm Maguire [EMAIL PROTECTED] ========================================================================== "The earth is but one country, and mankind its citizens." -- Baha'u'llah _______________________________________________ Gcl-devel mailing list Gcl-devel@gnu.org http://lists.gnu.org/mailman/listinfo/gcl-devel
