Initial commit.

.gitignore

@@ -0,0 +1,3 @@
+*.fasl
+*.*~
+#*

README

@@ -0,0 +1,9 @@
+Project's home: http://www.hexstreamsoft.com/projects/multiple-value-variants/
+
+
+multiple-value-variants gives access to multiple-value variants
+of operators through one macro: MULTIPLE-VALUE.
+
+
+This library is in the Public Domain.
+See the UNLICENSE file for details.

UNLICENSE

@@ -0,0 +1,22 @@
+This is free and unencumbered software released into the public domain.
+
+Anyone is free to copy, modify, publish, use, compile, sell, or
+distribute this software, either in source code form or as a compiled
+binary, for any purpose, commercial or non-commercial, and by any
+means.
+
+In jurisdictions that recognize copyright laws, the author or authors
+of this software dedicate any and all copyright interest in the
+software to the public domain. We make this dedication for the benefit
+of the public at large and to the detriment of our heirs and
+successors. We intend this dedication to be an overt act of
+relinquishment in perpetuity of all present and future rights to this
+software under copyright law.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.

definitions.lisp

@@ -0,0 +1,64 @@
+(in-package #:multiple-value-variants)
+
+(defun %recursively (forms last-transform function)
+  (if forms
+      (labels ((recurse (forms)
+                 (destructuring-bind (current . rest) forms
+                   (if rest
+                       (let ((values (gensym (string '#:values))))
+                         `(multiple-value-call
+                              (lambda (&rest ,values)
+                                ,(funcall function values (recurse rest)))
+                            ,current))
+                       (funcall last-transform current)))))
+        (recurse forms))
+      '(values)))
+
+(define and () (&rest forms)
+  (%recursively forms #'identity
+                (lambda (values rest)
+                  `(if (car ,values)
+                       ,rest
+                       (values-list ,values)))))
+
+(define or () (&rest forms)
+  (%recursively forms #'identity
+                (lambda (values rest)
+                  `(if (car ,values)
+                       (values-list ,values)
+                       ,rest))))
+
+#+nil(define cond () (&whole whole &rest clauses)
+       (if (every #'cdr clauses)
+           whole
+           (%recursively clauses ?
+                         (lambda (values rest)
+                           `(if (car ,values)
+                                (values-list ,values)
+                                ,else)))
+           (and clauses
+                (map-bind (reduce) (((clause else) clauses)
+                                    (() :from-end t :initial-value nil))
+                  (destructuring-bind (test &rest forms) clause
+                    (if forms
+                        `(cond (test ,@forms)
+                               (t else))
+                        (let ((values (gensym (string '#:values))))
+                          `(multiple-value-call (lambda (&rest ,values)
+                                                  (if (car ,values)
+                                                      (values-list ,values)
+                                                      ,else))
+                             ,test))))))))
+
+(define when () (test &body forms)
+  `(cond (,test ,@forms)
+         (t (values))))
+
+(define unless () (test &body forms)
+  `(cond ((not ,test) ,@forms)
+         (t (values))))
+
+(define prog1 () (result &body body)
+  `(multiple-value-prog1 ,result ,@body))
+
+;;; multiple-value-bind? aref? array-row-major-index? assoc? assoc-if? assoc-if-not? bit? sbit? butlast? nbutlast? car? cdr? cddr? rest? char? schar? count? count-if? count-if-not? delete delete-if delete-if-not remove remove-if remove-if-not destructuring-bind? dolist dotimes elt? every some notevery notany fill find find-if find-if-not first second third fourth fifth sixth seventh eighth ninth tenth gethash? map map-into? mapcan mapcar mapcon maplist member? member-if? member-if-not? mismatch? nth? nth-value? position? position-if? position-if-not? rassoc? rassoc-if? rassoc-if-not? reduce? replace? search?

info.lisp

@@ -0,0 +1,155 @@
+(in-package #:multiple-value-variants)
+
+(defvar *infos* (make-hash-table :test 'eq))
+
+(defgeneric multiple-value-variants:name (object))
+(defgeneric multiple-value-variants:form-lambda-list (object))
+(defgeneric multiple-value-variants:options-lambda-list (object))
+(defgeneric multiple-value-variants:expander (object))
+
+(defclass multiple-value-variants:info () ())
+
+(defclass multiple-value-variants:standard-info (info)
+  ((%name :initarg :name
+          :reader multiple-value-variants:name
+          :type symbol)
+   (%options-lambda-list :initarg :options-lambda-list
+                         :reader multiple-value-variants:options-lambda-list
+                         :type list)
+   (%form-lambda-list :initarg :form-lambda-list
+                      :reader multiple-value-variants:form-lambda-list
+                      :type list)
+   (%expander :initarg :expander
+              :reader multiple-value-variants:expander
+              :type (or function symbol))
+   (%atom-options-transformer :initarg :atom-options-transformer
+                              :reader multiple-value-variants:atom-options-transformer
+                              :type (or function symbol)
+                              :initform #'list)))
+
+(defun multiple-value-variants:locate (name &key (errorp t))
+  (check-type name symbol)
+  (or (gethash name *infos*)
+      (and errorp
+           (error "No multiple-value-variant with name ~S." name))))
+
+(defun (setf %locate) (new name &key (errorp t))
+  (declare (ignore errorp))
+  (check-type name symbol)
+  (check-type new info)
+  (setf (gethash name *infos*) new))
+
+(defun multiple-value-variants:expand (options form &optional env)
+  (check-type form cons)
+  (let* ((operator (first form))
+         (info (multiple-value-variants:locate operator))
+         (options
+          (if (listp options)
+              options
+              (let ((transformed
+                     (funcall (multiple-value-variants:atom-options-transformer info)
+                              options)))
+                (if (listp transformed)
+                    transformed
+                    (error "atom-options-transformer for ~S ~
+                            returned ~S, which is not a list."
+                           operator transformed))))))
+    (funcall (multiple-value-variants:expander info) options form env)))
+
+(defun %extract-&whole (lambda-list)
+  '(values whole-var lambda-list)
+  (if (eq (first lambda-list) '&whole)
+      (destructuring-bind (whole-var &rest lambda-list) (rest lambda-list)
+        (values whole-var lambda-list))
+      (values nil lambda-list)))
+
+;; Not robust in the face of misplaced &environment.
+;; Doesn't support dotted lambda-lists.
+(defun %extract-&environment (macro-lambda-list)
+  '(values env-var ordinary-lambda-list)
+  (let ((tail (member '&environment macro-lambda-list)))
+    (cond (tail
+           (when (member '&environment tail)
+             (error "More than one ~S parameter in ~S."
+                    '&environment macro-lambda-list))
+           (values (second tail)
+                   (append (ldiff macro-lambda-list tail)
+                           (cddr tail))))
+          (t (values nil macro-lambda-list)))))
+
+(defun %extract-&whole-&environment (macro-lambda-list)
+  '(values lambda-list whole-var environment-var)
+  (multiple-value-bind (whole-var lambda-list)
+      (%extract-&whole macro-lambda-list)
+    (multiple-value-bind (environment-var lambda-list)
+        (%extract-&environment lambda-list)
+      (values lambda-list whole-var environment-var))))
+
+(defun %check-expected-operator (actual expected)
+  (unless (eq actual expected)
+    (error "Wrong operator ~S, expected ~S." actual expected)))
+
+(defun %make-expander (name options-lambda-list form-lambda-list body)
+  (let ((options-var (gensym (string '#:options)))
+        (form-var (gensym (string '#:form)))
+        (operator-var (gensym (string '#:operator))))
+    (multiple-value-bind (options-env-var
+                          options-lambda-list
+                          form-lambda-list
+                          form-whole-var
+                          form-env-var)
+        (multiple-value-call #'values
+          (%extract-&environment options-lambda-list)
+          (%extract-&whole-&environment form-lambda-list))
+      (let* ((env-var (gensym (string '#:env)))
+             (options-env-template
+              (if options-env-var
+                  (lambda (fill-in)
+                    (list `(let ((,options-env-var ,env-var))
+                             ,@fill-in)))
+                  #'identity))
+             (form-env-template
+              (if form-env-var
+                  (lambda (fill-in)
+                    (list `(let ((,form-env-var ,env-var))
+                             ,@fill-in)))
+                  #'identity)))
+        `(lambda (,options-var ,form-var ,env-var)
+           ,@(unless (or options-env-var form-env-var)
+                     (list `(declare (ignore ,env-var))))
+           (destructuring-bind ,options-lambda-list ,options-var
+             ,@(funcall
+                options-env-template
+                `((destructuring-bind (,@(and form-whole-var
+                                              `(&whole ,form-whole-var))
+                                       ,operator-var ,@form-lambda-list)
+                      ,form-var
+                    (%check-expected-operator ,operator-var ',name)
+                    ,@(funcall form-env-template body))))))))))
+
+(defun %remove-keys (keys plist)
+  (let ((keys (if (listp keys) keys (list keys)))
+        (processp nil))
+    (map-bind (mapcan) ((key plist) (value (cdr plist)))
+      (when (setf processp (not processp))
+        (unless (member key keys)
+          (list key value))))))
+
+(defun multiple-value-variants:ensure
+    (name form-lambda-list options-lambda-list expander
+     &rest keys &key (class 'multiple-value-variants:standard-info) &allow-other-keys)
+  (setf (%locate name)
+        (apply #'make-instance class
+               :name name
+               :options-lambda-list options-lambda-list
+               :form-lambda-list form-lambda-list
+               :expander expander
+               (%remove-keys :class keys))))
+
+(defmacro multiple-value-variants:define
+    (name options-lambda-list form-lambda-list &body body)
+  `(multiple-value-variants:ensure
+    ',name
+    ',options-lambda-list
+    ',form-lambda-list
+    ,(%make-expander name options-lambda-list form-lambda-list body)))

main.lisp

@@ -0,0 +1,5 @@
+(in-package #:multiple-value-variants)
+
+(defmacro multiple-value (options &body form &environment env)
+  (check-type form (cons t null))
+  (multiple-value-variants:expand options (first form) env))

multiple-value-variants.asd

@@ -0,0 +1,17 @@
+(asdf:defsystem #:multiple-value-variants
+
+  :author "Jean-Philippe Paradis <hexstream@gmail.com>"
+
+  ;; See the UNLICENSE file for details.
+  :license "Public Domain"
+
+  :description "Gives access to multiple-value variants of operators through one macro: MULTIPLE-VALUE."
+
+  :depends-on (#:map-bind)
+
+  :version "0.1"
+  :serial cl:t
+  :components ((:file "package")
+               (:file "info")
+               (:file "definitions")
+               (:file "main")))

package.lisp

@@ -0,0 +1,17 @@
+(cl:defpackage #:multiple-value-variants
+  (:nicknames #:mv-variants #:mv-variant #:multiple-value-variant)
+  (:use #:cl)
+  (:import-from #:map-bind #:map-bind)
+  (:export #:multiple-value ; import this single symbol for normal usage.
+
+           #:info
+           #:standard-info
+           #:name
+           #:form-lambda-list
+           #:options-lambda-list
+           #:expander
+           #:atom-options-transformer
+           #:locate
+           #:expand
+           #:ensure
+           #:define))