/[gcl]/gcl/lsp/gcl_evalmacros.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_evalmacros.lsp

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

revision 1.10 by camm, Wed Oct 5 15:24:41 2005 UTC revision 1.11 by camm, Tue Nov 1 12:14:04 2005 UTC
# Line 346  Line 346 
346  (defmacro lambda ( &rest l) `(function (lambda ,@l)))  (defmacro lambda ( &rest l) `(function (lambda ,@l)))
347    
348  (defmacro memq (a b) `(member ,a ,b :test 'eq))  (defmacro memq (a b) `(member ,a ,b :test 'eq))
349    
350    ;;FIXME should come from DEFUNO_NEW
351    (proclaim '(ftype (function (t fixnum) fixnum) si::select-read))
352    (proclaim '(ftype (function () t) si::fork))
353    (proclaim '(ftype (function (t) t) fib si::kill))
354    
355    (defmacro background (form)
356      (let ((x (gensym)))
357        `(let ((,x (si::fork)))
358           (if (eql 0 (car ,x))
359               (progn (prin1 ,form (cdr ,x))(bye))
360             ,x))))
361    
362    (defmacro with-read-values ((i r b) (forms timeout) &body body)
363      (let* ((m (gensym))
364             (j (gensym))
365             (k (gensym))
366             (p (gensym))
367             (pbl (length forms))
368             (pbm (1- (ash 1 pbl))))
369      `(let* ((,m ,pbm)
370              (,b (list ,@(mapcar (lambda (x) `(background ,x)) forms))))
371         (declare ((integer 0 ,pbm) ,m))
372         (do nil ((= ,m 0))
373             (let ((,p (si::select-read ,b ,timeout)));;FAILURE code here on 0 return
374               (declare ((integer 0 ,pbm) ,p))
375               (do ((,i 0 (1+ ,i))(,j 1 (ash ,j 1)) (,k ,b (cdr ,k)))
376                   ((= ,i ,pbl) (setq ,m (logandc2 ,m ,p)))
377                   (declare ((integer 0 ,pbl) ,i) ((integer 1 ,(1+ pbm)) ,j))
378                   (when (/= 0 (logand ,j ,p))
379                     (let ((,r (read (cdar ,k))))
380                       (close (cdar ,k))
381                       ,@body))))))))
382      
383    (defmacro p-let (bindings &body body)
384      (let* ((i (gensym)) (r (gensym)) (c (gensym))
385             (pb (remove-if 'atom bindings)))
386      `(let* (,@(mapcar 'car pb) ,@(remove-if 'consp bindings))
387         (with-read-values
388          (,i ,r ,c) (,(mapcar 'cadr pb) -1)
389          (case ,i
390                ,@(let ((g -1))
391                    (mapcar (lambda (x) `(,(incf g) (setq ,(car x) ,r))) pb))))
392         ,@body)))
393    
394    (defmacro p-and (&rest forms)
395      (let* ((i (gensym)) (r (gensym)) (c (gensym)) (top (gensym)))
396        `(block ,top
397           (with-read-values
398            (,i ,r ,c) (,forms -1)
399            (unless ,r
400              (dolist (,c ,c) (si::kill ,c))
401              (return-from ,top nil)))
402           t)))
403    
404    (defmacro p-or (&rest forms)
405      (let* ((i (gensym)) (r (gensym)) (c (gensym)) (top (gensym)))
406        `(block ,top
407           (with-read-values
408            (,i ,r ,c) (,forms -1)
409            (when ,r
410              (dolist (,c ,c) (si::kill ,c))
411              (return-from ,top t)))
412           nil)))

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26