srfi42?

srfi42.lisp

;;;; SRFI-42 Eager Comprehensions ( 先行評価的内包表記 ) in Common Lisp
(defpackage srfi-42
  (:use :cl)
  (:export ))

(in-package :srfi-42)


;;; Qualifiers

(defparameter *control-qualifiers*
  `( (if <test>)
     (not <test> &rest <tests>)
     (and <test> &rest <tests>)
     (or <test> &rest <tests>)
     (begin &rest <commands>)
     (nested &rest <qualifiers>)) )

;; <vars> -> <variable1> [ (index <variable2> ]
;; command = an expression begin evaluated for its side-effects
;; ob = outer binding
;; oc = outer command
;; ne1? = not-end1?
;; ne2? = not-end2?
;; lb = loop binding
;; ib = inner binding
;; ic = inner command
;; ls = loop step

(defparameter *generator-qualifiers*
  `( (:any <vars> <arg1> &rest <args>) ;; (: <vars> <arg1> &rest <args>)
     (:list <vars> <arg1> &rest <args>)
     (:string <vars> <arg1> &rest <args>)
     (:vector <vars> <arg1> &rest <args>)
     (:integers &rest <vars>)
     (:range <vars> <stop>)
     (:range <vars> <start> <stop>)
     (:range <vars> <start> <stop> <step>)
     (:real-range <vars> <stop>)
     (:real-range <vars> <start> <stop>)
     (:real-range <vars> <start> <stop> <step>)
     (:char-range <vars> <min> <max)
     (:port <vars> <port>)
     (:port <vars> <port> <read-proc>)
     (:dispatched <vars> <dispatch> <arg1> &rest <args>)
     (:do (&rest <lbs>) <ne1?> (&rest <lss>))
     (:do (let (&rest <obs>) &rest <ocs>)
	  (&rest <lbs>) <ne1?>
       (let (&rest <ibs>) &rest <ics>) <ne2?> (&rest <lss>))
     (:let <vars> <expression>)
     (:parallel &rest <generator-qualifiers>)
     (:while <generator-qualifier> <expression>)
     (:until <generator-qualifier> <expression>) ))


(defmacro do-ec (&rest args)
  (cond
    ((null args) args)
    ((null (cdr args)) (car args))
    (T
     (labels
	((lp (rest)
	   (if (null (cdr rest))
	       ;; body
	       (car rest)
	       ;; qualifier
	       (let ((q (car rest)))
		 `(loop
		   ,@(expand-qualifier (car q) (cdr q))
		   :do
		   ,(lp (cdr rest)))))))
      (lp args)))))

(defmacro fn-ec (fn base &rest args)
  (if (null args) nil
      (let ((result (gensym))
	    (f (gensym)))
	`(let ((,result ,base)
	       (,f ,fn))
	   (do-ec
	       ,@(append
		  (butlast args)
		  `((setf ,result (funcall ,f ,result ,(car (last args)))))))
	   ,result))))

(defmacro list-ec (&rest args)
  `(nreverse
    (fn-ec #'(lambda (b a) (cons a b))
	   nil
	   ,@args)))

(defmacro string-ec (&rest args)
  `(coerce (list-ec ,@args) 'string))

(defmacro vector-ec (&rest args)
  `(coerce (list-ec ,@args) 'vector))

(defmacro string-append-ec (&rest args)
  `(apply #'concatenate 'string (list-ec ,@args)))

(defmacro append-ec (&rest args)
  `(fn-ec #'append nil ,@args))

(defmacro sum-ec (&rest args)
  `(fn-ec #'+ 0 ,@args))

(defmacro product-ec (&rest args)
  `(fn-ec #'* 0 ,@args))

(defmacro min-ec (&rest args)
  `(apply #'min (list-ec ,@args)))

(defmacro max-ec (&rest args)
  `(apply #'max (list-ec ,@args)))

(defmacro any?-ec (&rest args)
  (let ((s (gensym)))
  `(block ,s
     (fn-ec #'(lambda (b a)
		(declare (ignore b))
		(and a (return-from ,s T)))
	    T
	    ,@args)
     nil)))

(defmacro every?-ec (&rest args)
  (let ((s (gensym)))
    `(block ,s
       (fn-ec #'(lambda (b a)
		  (declare (ignore b))
		  (or a (return-from ,s nil)))
	      T
	      ,@args)
       T)))

(defmacro first-ec (default &rest args)
  (let ((s (gensym))
	(d (gensym)))
    `(block ,s
       (let ((,d ,default))
	 (fn-ec #'(lambda (b a)
		    (declare (ignore b))
		    (return-from ,s a))
		T
		,@args)
	 ,d))))
       

(defmacro last-ec (default &rest args)
  (let ((d (gensym)))
    `(let ((,d ,default))
       (fn-ec #'(lambda (b a)
		  (declare (ignore b))
		  a)
	      ,d
	      ,@args))))

(defmacro fold-ec (x0 &rest rest)
  (case (length rest)
    ((0 1 2) (error "Invalid fold-ec clause"))
    (T
     (let ((fn (car (last rest)))
	   (body (car (last rest 2)))
	   (q (butlast rest 2)))
       `(fn-ec (lambda (b a)
		 (funcall ,fn a b))
	       ,x0 ,@q ,body)))))

(defmacro fold3-ec (x0 &rest rest)
  (case (length rest)
    ((0 1 2) (error "Invalid-fold-ec clause"))
    ((3) `(funcall ,(second rest) ,(first rest)))
    (T `(fold-ec ,x0 ,@(butlast rest 2) ,(car (last rest))))))


;; expander

(defmacro vars-bind ((var index rest) qualifier &body body)
  (let ((sym (gensym)))
    `(let ((,sym ,qualifier))
       (let ((,var (first ,sym))
	     (,index (if
		      (and (listp (second ,sym))
			   (eq (intern "INDEX") (car (second ,sym))))
			   (cadr (second ,sym))
			   nil)))
     (let ((,rest (if (and (listp (second ,sym))
			   (eq (intern "INDEX") (car (second ,sym))))
		      (nthcdr 2 ,sym)
		      (nthcdr 1 ,sym))))
       ,@body)))))


(defgeneric expand-qualifier (qualifier args))

(defmethod expand-qualifier ((qualifier (eql :list)) args)
  (vars-bind (var index rest) args
    (destructuring-bind (arg1 &rest args) rest
      `(:for ,var :in (append ,arg1 ,@args)
	     ,@(when index `(:for ,index :from 0))))))

(defmethod expand-qualifier ((qualifier (eql :range)) args)
  (vars-bind (var index rest) args
    `(,@
      (case (length rest)
	((1) `(:for ,var :from 0 :below ,(first rest)))
	((2) `(:for ,var :from ,(first rest) :below ,(second rest)))
	((3) `(:for ,var :from ,(first rest) :below ,(second rest)
		    :by ,(third rest)))
	(T (error "invalid number of :range qualifier argument")))
      ,@(when index `(:for ,index :from 0)))))

(defmethod expand-qualifier ((qualifier (eql :integers)) args)
  (vars-bind (var index rest) args
    `(:for ,var :from 0
	   ,@(when index `(:for ,index :from 0)))))
    

(defmethod expand-qualifier ((qualifier (eql :char-range)) args)
  (vars-bind (var index rest) args
    (destructuring-bind (min max) rest
      (let ((s1 (gensym))
	    (s2 (gensym)))
	`(:with ,s2 := (char-code ,max)
		:for ,s1 :from (char-code ,min) :to ,s2
		:for ,var := (code-char ,s1)
		,@(when index `(:for ,index :from 0)))))))

;; <read-proc> => (lambda (port eof-object) ...)
(defmethod expand-qualifier ((qualifier (eql :port)) args)
  (vars-bind (var index rest) args
    (let ((p (gensym))
	  (f (gensym))
	  (eof (gensym)))
      (case (length args)
	((2) `(:with ,p := ,(second args)
		     :for ,var = (read ,p nil ',eof)
		     ,@(when index `(:for ,index :from 0))
		     :until (eq ,var ',eof)))
	((3) `(:with ,p := ,(second args)
		     :with ,f := ,(third args)
		     :for ,var = (funcall ,f ,p ',eof)
		     ,@(when index `(:for ,index :from 0))
		     :until (eq ,var ',eof))))
      (T (error "Invalid :port qualifier")))))

(defmethod expand-qualifier ((qualifier (eql :parallel)) args)
  (loop :for arg in args
     :append (expand-qualifier (car arg) (cdr arg))))

;; examples

(do-ec (:list x (index i) (list 1 2 3))
  (:list y (index j) (list 10 11 12))
  (format t "(~A, ~A) (~A, ~A)~%" i x j y))

(list-ec
 (:range i 0 10 2) (:list x '(100 200))
 (list i x))

(list-ec
 (:parallel (:list x '(1 2 3)) (:list y '(11 12 13)))
 (:list j '(a b))
 (list x y j))