;;;; none, once, and all that stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a n-ary nor (defmacro none (&body exprs) `(not (or ,@exprs))) ;;; exactly one among any number (defmacro once (&body exprs) (cond ((null exprs) 'nil) (T `(if ,(car exprs) (none ,@(cdr exprs)) (once ,@(cdr exprs)))))) ;;; exactly : first version ;;; works only if the numeric argument is a constant !!! (defmacro exactly-1 (n &body exprs) (cond ((null exprs) (<= n 0)) ((<= n 0) `(none ,@ exprs)) (T `(if ,(car exprs) (exactly-1 ,(- n 1) ,@(cdr exprs)) (exactly-1 ,n ,@(cdr exprs)))))) ;(macroexpand-1 ; '(exactly-1 2 (p x) (q x) (r x))) ; ; (IF (P X) (EXACTLY-1 1 (Q X) (R X)) (EXACTLY-1 2 (Q X) (R X))) ; (macroexpand-1 '(exactly-1 8 (p x) (q x))) ; (IF (P X) (EXACTLY-1 7 (Q X)) (EXACTLY-1 8 (Q X))) ; (macroexpand-1 '(exactly-1 (+ 4 4) (p x) (q x))) ; *** error **** ;;; 2nd version : allows numerical EXPRESSIONS as first argument (defmacro exactly-2 (n &body exprs) (let ((g (gensym))) (if (null exprs) `(<= ,n 0) `(let ((,g ,n)) (cond ((<= ,g 0) (none ,@ exprs)) (,(car exprs) (exactly-2 (- ,g 1) ,@(cdr exprs))) (T (exactly-2 ,g ,@(cdr exprs)))))))) ;;; (macroexpand '(exactly-2 (* 2 2) a b c d e)) ;(LET ((#:G829 (* 2 2))) ; (COND ((<= #:G829 0) (NONE A B C D E)) ; (A (EXACTLY-2 (- #:G829 1) B C D E)) ; (T (EXACTLY-2 #:G829 B C D E)))) ; T ;;; 3d version failure is detected as soon as possible (defmacro exactly-3 (n &body exprs) (let ((g (gensym)) (l (length exprs))) (if (null exprs) `(<= ,n 0) `(let ((,g ,n)) (cond ((<= ,g 0) (none ,@ exprs)) ((> ,g ,l) nil) (,(car exprs) (exactly-3 (- ,g 1) ,@(cdr exprs))) (T (exactly-3 ,g ,@(cdr exprs)))))))) ; (macroexpand-1 '(exactly-3 5 a b c)) ;(LET ((#:G778 5)) ; (COND ((<= #:G778 0) (NONE A B C)) ; ((> #:G778 3) NIL) ; (A (EXACTLY-3 (- #:G778 1) B C)) ; (T (EXACTLY-3 #:G778 B C)))) ;;; 4th version ;;; merge of first and third version (defmacro exactly-4 (n &body exprs) (let ((l (length exprs))) (if (numberp n) ; :-) (cond ((null exprs) (<= n 0)) ((<= n 0) `(none ,@exprs)) ((> n l) nil) (T `(if ,(car exprs) (exactly ,(- n 1) ,@(cdr exprs)) (exactly ,n ,@(cdr exprs))))) (let ((g (gensym))) (if (null exprs) `(<= ,n 0) `(let ((,g ,n)) (cond ((<= ,g 0) (none ,@ exprs)) ((> ,g ,l) nil) (,(car exprs) (exactly (- ,g 1) ,@(cdr exprs))) (T (exactly ,g ,@(cdr exprs)))))))))) ; (macroexpand-1 '(exactly 4 a b c)) ; nil ;;; last version : avoids code duplication ;;; uses some counters (defmacro exactly-5 (n &body exprs) (let ((frozens (mapcar #'(lambda (e) `(function (lambda () , e))) exprs)) (todo (gensym)) (done (gensym)) (nb-todo (gensym))) `(let ((,nb-todo ,n)) (do ((,todo (list ,@frozens) (cdr ,todo)) (,done 0)) ((endp ,todo) (= ,done ,nb-todo)) (cond ((> ,done ,nb-todo) (return nil)) ((funcall (car ,todo)) (incf ,done))))))) ;(macroexpand-1 '(exactly-4 2 (p x) (q x) (r x))) ;(LET ((#:G864 2)) ; (DO ((#:G862 (LIST #'(LAMBDA () (P X)) ; #'(LAMBDA () (Q X)) ; #'(LAMBDA () (R X))) ; (CDR #:G862)) ; (#:G863 0)) ; ((ENDP #:G862) (= #:G863 #:G864)) ; (COND ((> #:G863 #:G864) (RETURN NIL)) ; ((FUNCALL (CAR #:G862)) (INCF #:G863))))) ;;; last version ;;; merge of all preceeding ones (defmacro exactly-6 (n &body exprs) (let* ((delays (mapcar #'(lambda (e) (list (gensym) `(function (lambda () ,e)))) exprs)) (names (mapcar #'car delays)) (calls (mapcar #'(lambda (name) `(funcall ,name)) names))) `(let ,delays (exactly-3 ,n ,@calls)))) (defmacro exactly-7 (n &body exprs) (let* ((delays (mapcar #'(lambda (e) (list (gensym) '() e)) exprs)) (calls (mapcar #'(lambda (d) (list (car d))) delays))) `(flet ,delays (exactly-3 ,n ,@calls)))) ; (macroexpand-1 '(exactly-6 2 (p x) (q x) (r x))) ;(LET ((#:G868 #'(LAMBDA () (P X))) ; (#:G869 #'(LAMBDA () (Q X))) ; (#:G870 #'(LAMBDA () (R X)))) ; (EXACTLY-3 2 (FUNCALL #:G868) (FUNCALL #:G869) (FUNCALL #:G870))) ;;; how to chose ? (defmacro exactly (&body exprs) `(exactly-5 ,@exprs)) ;;;; Pascal' repeat ... until (defmacro repeat-until (test return-exp &body body) (let ((label (gensym))) `(prog () ,label ,@body (if ,test (return ,return-exp) (go ,label))))) (defun essai (n) (repeat-until (<= n 0) "ok" (format T "n=~d~%" n) (setf n (- n 1)))) (essai 6) ;n=6 ;n=5 ;n=4 ;n=3 ;n=2 ;n=1 ;"ok"