Accepting and returning multiple values in 'cl

[Dave Goel]

Is devel the correct upstream place to make/discess changes to 'cl?

It seems to me that CL can easily handle multiple values correctly.
Currently, it uses lists instead of multiple values, which is far less
than satisfactory.  Just to cite one example, a user should be able to
use both these simultaneously:

(setq a (floor* 1 2))

as well as 

(multiple-value-setq (a b) (floor* 1 2))

----

I am including below a file that I think implements every single
multiple value facility in the common lisp spec.  No codewalking hacks
or anything.  Just macros. Not only that, I believe every facility's
detailed spec is implemented to the dot.  For example, everything is
evalled in the proper order it should be and only if it should be,
multiple-value-setq carefully does the right thing when the number
asked and supplied differ.  Zero values (values) are handled
correctly, etc.

At the end follow 4 tests.

After some doc. cleanup, we can make it a part of emacs' cl.  Please
let me know of any feedback.

Dave
-- 




;;; cl-multiple.el ---  Framework to handle multiple values in emacs.
;; Time-stamp: <2009-03-11 23:21:33 deego>
;; Copyright (C) 2009 Dave Goel
;; Emacs Lisp Archive entry
;; Filename: cl-multiple.el
;; Package: cl-multiple
;; Author: Dave Goel <address@hidden>
;; Keywords:  
;; Version:  dev
 
;; This file is NOT (yet) part of GNU Emacs.
 
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
 
;; This is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.


(require 'cl)

(defconst multiple-values-limit most-positive-fixnum
  "Our implementation has no internal limit.")

;; This variable should never be used by anything except values.
(defvar cl-internal-multiple nil
  "Internal variable.  Every multiple-value-acceptor binds this
variable to to nil before calling each of its arguments. 

When a call to values returns one value, it leaves this variable
as nil.

When a call to values returns > 1 value, it sets this variable equal
to the cdr of the list of its returned values.

When a call to values returns 0 values, it sets this varible to nil.")



;; These functions are not defined in regular emacs anyway. So, if
;; someone calls them, we can afford to autoload these. Regular cl
;; seems to autoload them too. todo: double-check.

;;;###autoload
(defun values-list (ls)
  (let ((a1 (car ls)))
    (setq cl-internal-multiple 
          (if ls (cdr ls) 0))
    a1))





;;;###autoload
(defun values (&rest args)
  (values-list args))




;; The rest of the functions simply need to accept things properly.
;; They can employ this one function for help!

(defmacro cl-internal-multiple-values-obtain (&rest args)
  "As a test case, try to call this on three args, each providing values."
  (let* ((max (- (length args) 1))
         (temp (gensym "--cl-var--")))
    (cons 'list 
          (loop for ii from 0 to max
                collect
                `(let ((cl-internal-multiple nil)
                       ,temp)
                   (setq ,temp ,(nth ii args))
                   (if 
                       (listp cl-internal-multiple)
                       (cons ,temp cl-internal-multiple)
                     nil))))))



;;;====================================================
;; Now, we can code everything else. 




;;;###autoload
(defmacro multiple-value-bind (vars form &rest body)
  ;; This itself needs to only return one value.
  ;; We do need to eval ALL forms, but set only as many as supplied in
  ;; vars.
  (let ((temp (gensym "--cl-var--"))
        ;;(temp2 (make-symbol "--cl-var--"))
        (l1 (length vars)))
    `(let ((,temp (first (cl-internal-multiple-values-obtain ,form))))
       (let
           ,(loop for ii from  0 to (- l1 1) 
                  collect
                  `( ,(nth ii vars) (nth ,ii ,temp)))
         ,@body))))






;;;###autoload
(defmacro multiple-value-call (fn &rest forms)
  (let ((temp (gensym "--cl-var--")))
    `(let ((,temp (cl-internal-multiple-values-obtain ,@forms)))
       (apply ,fn 
              (apply #'append ,temp)))))




;;;###autoload
(defmacro multiple-value-list (form)
  `(car (cl-internal-multiple-values-obtain ,form)))

;;;###autoload
(defmacro multiple-value-prog1 (form &rest others)
  (let ((temp (gensym "--cl-var--")))
    `(let  
         ((,temp (cl-internal-multiple-values-obtain ,form)))
       ,@others
       ;;(values-list (car ,temp)))))
       (values-list (car ,temp)))))
;;;(values-list (car ,temp)))))



        

;;;###autoload
(defmacro multiple-value-setq (vars form)
  ;; We do need to eval ALL forms, but set only as many as supplied in
  ;; vars.
  (let ((temp (gensym "--cl-var--"))
        (l1 (length vars)))
    `(let ((,temp (first (cl-internal-multiple-values-obtain ,form))))
       ,(cons 'prog1 
              (loop for ii from  0 to (- l1 1) 
                    collect
                    `(setf ,(nth ii vars) (nth ,ii ,temp)))))))



;;;====================================================
;; These functions in cl-extra should now be tweaked to return
;; (values) instead of (list). Until now, values was == list, so it
;; was ok for them to use (list):
;; floor*, ceiling*, truncate*, round*, mod*. 


;; tests. 

(defun cl-internal-test-1-values-values-list-and-setq ()
  (interactive)
  (let ( a b c d e f)
    (multiple-value-setq 
        (a b c)
      (values-list '(1 2 3)))
    (multiple-value-setq 
        (d e f)
      (values 4 5 6))
    (message "1 2 3 4 5: %s %s %s %s %s %s" a b c d e f)))



(defun cl-internal-test-2-bind ()
  (interactive)
  (let ((a 0) b c d)
    (multiple-value-bind
        (a b c d)
        (values 1 2 3 4)
      (setq b c)
      (setq d a)
      (message "1 3 3 1: %s %s %s %s .. sleeping for 2" a b c d))
    (sit-for 2)
    (message "0 nil nil nil nil: %s %s %s %s" a b c d)))



(defun cl-internal-test-3-call ()
  (interactive)
  (let ((sum 
         (multiple-value-call
          #'+
          (values 1 2 3)
          ;;(values)
          2 
          (values 5 6 7))))
    (message "26: %s" sum)))

(defun cl-internal-test-4-list ()
  (interactive)
  (let ((a (multiple-value-list (values)))
        (b (multiple-value-list (values 1 2 3)))
        (c (multiple-value-list 4))
        (d (multiple-value-list 5)))
    (message "nil (1 2 3) (4) (5): %s %s %s %s" a b c d)))





(defun cl-internal-test-5-prog1 ()
  (interactive)
  (let (a b c d e f)
    (multiple-value-setq 
        (a b c d)
      (multiple-value-prog1
       (values 1 2 3 4)
       nil 
       (setq e 5)
       (values 5 6 7 8)))
    (message "1 2 3 4 5: %s %s %s %s %s" a b c d e)))







(provide 'cl-multiple)
(run-hooks 'cl-multiple-after-load-hook)



;;; cl-multiple.el ends here