git » jacl.git » master » tree

[master] / mv.lisp 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
(defconstant mv-limit 20)

(defparameter *mv-expected* 1)

(defparameter *mv* (make-array mv-limit))

(defun mv (&rest vals)
  (do ((i 0 (1+ i))
       (vs vals (cdr vs)))
      ((or (eql i *mv-expected*) (null vs))
       (setq *mv-expected* (min i mv-limit))
       (car vals))
    (setf (aref *mv* i) (car vs))))

(defmacro mv-list (form)
  (let ((val1# (gensym)))
    `(let* ((*mv-expected* mv-limit)
            (,val1# ,form))
       (if (eql *mv-expected* mv-limit)
           (list ,val1#)
           (coerce (subseq *mv* 0 *mv-expected*)
                   'list)))))

(defun make-mv-bindings (vars val1# &aux (i 0))
  (mapcar (lambda (var)
            (prog1
                (if (zerop i)
                    `(,var ,val1#)
                    `(,var (when (< ,i *mv-expected* mv-limit)
                             (aref *mv* ,i))))
              (incf i)))
          vars))

(defmacro mv-bind (vars expr &body body)
  (if (null vars)
      `(progn () (progn ,expr nil) ,@body)
      (let ((val1# (gensym)))
        `(let* ((*mv-expected* ,(length vars))
                (,val1# ,expr))
           (let ,(make-mv-bindings vars val1#)
             ,@body)))))

(mv-bind (x) nil
  (format t "x = ~A~%" x))

(mv-bind (x) 123
  (format t "x = ~A~%" x))

(mv-bind (x y) (mv 1 2 3)
  (format t "x = ~A, y = ~A~%" x y))

(mv-bind (x y) ((lambda () (mv 1 2 3)))
  (format t "x = ~A, y = ~A~%" x y))

(mv-list (foo))

;; ;; 

;; (defun values* (&rest values)
;;   (if (and (boundp '*values*)
;;            (> (length values) 1))
;;       (progn
;;         (setf (fill-pointer *values*) 20)
;;         (loop
;;            for v in values
;;            for i upfrom 0
;;            do (setf (elt *values* i) v)
;;            finally (progn (setf (fill-pointer *values*) (1+ i))
;;                           (return *values*))))
;;       (first values)))

;; (defmacro multiple-value-bind* (vars mv-form &body body)
;;   (let ((values# (gensym)))
;;     `(let (,@(mapcar #'list vars)
;;            (,values# (let ((*values* (if (boundp '*values*)
;;                                          *values*
;;                                          (make-array '(20) :fill-pointer 0))))
;;                        ,mv-form)))
;;        (if (eq ,values# *values*)
;;            (prog () ,@(loop
;;                          for v in vars
;;                          for i upfrom 0
;;                          collect `(when (> (length ,values#) ,i)
;;                                     (setq ,v (elt ,values# ,i)))))
;;            ,(when (> (length vars) 0)
;;               `(prog () (setq ,(first vars) ,values#))))
;;        ,@body)))

;; (format t "~A~%" (multiple-value-bind* () nil))

;; (multiple-value-bind* (x) nil
;;   (format t "x = ~A~%" x))

;; (multiple-value-bind* (x) 123
;;   (format t "x = ~A~%" x))

;; (multiple-value-bind* (x y) (values* 1 2 3)
;;   (format t "x = ~A, y = ~A~%" x y))

;; (multiple-value-bind* (x y) ((lambda () (values* 1 2 3)))
;;   (format t "x = ~A, y = ~A~%" x y))