Nothing Can Stop The Progressive Revolution

Added:
 * XOR
 * WHICHEVER
 * SWITCH, ESWITCH, CSWItCH
 * UNIONF, NUNIONF
 * ALIST-PLIST, PLIST-ALIST
 * ENSURE-CONS
 * NAMED-LAMDBA
 * DEFINE-CONSTANT
 * STRING-DESIGNATOR

Note:
 Documentation strings of many new operators are sorely lacking, particularly
 NAMED-LAMBDA and *SWITCH.

alexandria.asd

@@ -5,14 +5,17 @@
   ((:static-file "LICENCE")
    (:static-file "tests.lisp")
    (:file "package")
+   (:file "definitions" :depends-on ("package"))
+   (:file "strings" :depends-on ("package"))
    (:file "errors" :depends-on ("package"))
    (:file "hash-tables" :depends-on ("package"))
-   (:file "macros" :depends-on ("package"))
+   (:file "macros" :depends-on ("package" "strings"))
+   (:file "control-flow" :depends-on ("package" "macros"))
    (:file "symbols" :depends-on ("package"))
    (:file "arrays" :depends-on ("package"))
    (:file "types" :depends-on ("package"))
    (:file "binding" :depends-on ("package"))
-   (:file "functions" :depends-on ("package" "symbols"))
+   (:file "functions" :depends-on ("package" "symbols" "macros"))
    (:file "lists" :depends-on ("package" "functions"))
    (:file "sequences" :depends-on ("package" "lists"))
    (:file "numbers" :depends-on ("package" "sequences"))))

control-flow.lisp

@@ -0,0 +1,70 @@
+(in-package :alexandria)
+
+(defmacro switch ((object &key (test 'eql) (key 'identity) (default nil))
+                  &body clauses)
+  "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of DEFAULT if no keys match."
+  (with-gensyms (value)
+    `(let ((,value (,key ,object)))
+       (cond ,@(mapcar (lambda (clause)
+                         (destructuring-bind (key-form &body forms) clause
+                           `((,test ,value ,key-form)
+                             ,@forms)))
+                       clauses)
+             (t ,default)))))
+
+(defmacro eswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
+  "Like SWITCH, but signals an error if no key matches."
+  (with-gensyms (value)
+    `(let ((,value (,key ,object)))
+       (cond ,@(mapcar (lambda (clause)
+                         (destructuring-bind (key-form &body forms) clause
+                           `((,test ,value ,key-form)
+                             ,@forms)))
+                       clauses)
+             (t
+              (error "No keys match in ESWITCH. Testing against ~S with ~S."
+                     ,value ',test))))))
+
+(defmacro eswitch ((object &key (test 'eql) (key 'identity)) &body clauses)
+  "Like SWITCH, but signals a continuable error if no key matches."
+  (with-gensyms (value)
+    `(let ((,value (,key ,object)))
+       (cond ,@(mapcar (lambda (clause)
+                         (destructuring-bind (key-form &body forms) clause
+                           `((,test ,value ,key-form)
+                             ,@forms)))
+                       clauses)
+             (t
+              (cerror "Return NIL from CSWITCH."
+               "No keys match in CSWITCH. Testing against ~S with ~S."
+               ,value ',test))))))
+
+(defmacro whichever (&rest possibilities)
+  "Evaluates exactly one of POSSIBILITIES, chosen at random."
+  `(funcall (the function
+              (svref (load-time-value
+                      (vector ,@(mapcar (lambda (possibility)
+                                          `(lambda () ,possibility))
+                                        possibilities))
+                      t)
+                     (random ,(length possibilities))))))
+
+(defmacro xor (&rest datums)
+  "Evaluates its argument one at a time, from left to right. If more then one
+argument evaluates to a true value no further DATUMS are evaluated, and NIL is
+returned as both primary and secondary value. If exactly one argument
+evaluates to true, its value is returned as the primary value after all the
+arguments have been evaluated, and T is returned as the secondary value. If no
+arguments evaluate to true NIL is retuned as primary, and T as secondary
+value."
+  (with-gensyms (xor tmp true)
+    `(let (,tmp ,true)
+       (block ,xor
+         ,@(mapcar (lambda (datum)
+                     `(if (setf ,tmp ,datum)
+                          (if ,true
+                              (return-from ,xor (values nil nil))
+                              (setf ,true ,tmp))))
+                   datums)
+         (return-from ,xor (values ,true t))))))

definitions.lisp

@@ -0,0 +1,34 @@
+(in-package :alexandria)
+
+(defmacro define-constant (name initial-value &key (test 'eql) documentation)
+  "Ensures that the global variable named by NAME is a constant with a value
+that is equal under TEST to the result of evaluating INITIAL-VALUE. TEST
+defaults to EQL, and if given it must be a symbol naming a function. If
+DOCUMENTATION is given, it becomes the documentation string of the constant.
+
+Signals an error if NAME is already a bound non-constant variable.
+
+Signals an error if NAME is already a constant variable whose value is not
+equal under TEST to result of evaluating INITIAL-VALUE."
+  `(defconstant ,name
+     (let ((new ,initial-value))
+       (if (boundp ',name)
+           (let ((old (symbol-value ',name)))
+             (cond
+               ((constantp ',name)
+                (cond
+                  ((,test old new)
+                   old)
+                  (t
+                   (cerror "Try to redefine the constant."
+                           "~@<~S is an already defined constant whose value ~
+                            ~S is not equal to the provided initial value ~S ~
+                            under ~S.~:@>" ',name old new ',test)
+                   new)))
+               (t
+                (cerror "Try to redefine the variable as a constant."
+                        "~@<~S is an already bound non-constant variable ~
+                         whose value is ~S.~:@>" ',name old)
+                new)))
+           new))
+     ,@(when documentation `(,documentation))))

functions.lisp

@@ -99,3 +99,21 @@ with and ARGUMENTS to FUNCTION."
   (lambda (&rest more)
     (declare (dynamic-extent more))                 
     (multiple-value-call function (values-list more) (values-list arguments))))
+
+(defmacro named-lambda (name lambda-list &body body)
+  "Expands into a lambda-expression within whose BODY NAME denotes the
+function corresponding function."
+  (let* ((simplep (union lambda-list-keywords lambda-list))
+         (restp (and (not simplep) (find '&rest lambda-list))))
+    (if simplep
+        ;; Required arguments only, no need for APPLY
+        `(lambda ,lambda-list
+           (labels ((,name ,lambda-list ,@body))
+             (,name ,@lambda-list)))
+        ;; Lambda-list keywords present, need to APPLY to
+        ;; get &KEY and &REST handled correctly.
+        (with-gensyms (arguments)
+          `(lambda (&rest ,arguments)
+             ,@(unless restp `((declare (dynamic-extent ,arguments))))
+             (labels ((,name ,lambda-list ,@body))
+               (apply #',name ,arguments)))))))

lists.lisp

@@ -1,9 +1,35 @@
 (in-package :alexandria)
 
+(defun alist-plist (alist)
+  "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+  (let (plist)
+    (dolist (pair alist)
+      (push (car pair) plist)
+      (push (cdr pair) plist))
+    (nreverse plist)))
+
+(defun plist-alist (plist)
+  "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+  (let (alist)
+    (do ((tail plist (cddr tail)))
+        ((endp tail) (nreverse alist))
+      (push (cons (car tail) (cadr tail)) alist))))
+
 (define-modify-macro appendf (&rest lists) append
   "Modify-macro for APPEND. Appends LISTS to the place designated by the first
 argument.")
 
+(define-modify-macro unionf (list) union
+  "Modify-macro for UNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place.")
+
+(define-modify-macro nunionf (list) nunion
+  "Modify-macro for NUNION. Saves the union of LIST and the contents of the
+place designated by the first argument to the designated place. May modify
+either argument.")
+
 (defun circular-list (&rest elements)
   "Creates a circular list of ELEMENTS."
   (let ((cycle (copy-list elements)))
@@ -100,6 +126,13 @@ recommended for performance intensive use. Main usefullness as the
 expected-type designator of a TYPE-ERROR."
   `(satisfies circular-list-p))
 
+(defun ensure-cons (cons)
+  "If CONS is a cons, it is returned. Otherwise returns a fresh cons with CONS
+  in the car, and NIL in the cdr."
+  (if (consp cons)
+      cons
+      (cons cons nil)))
+
 (defun ensure-list (list)
   "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
   (if (listp list)

package.lisp

@@ -7,6 +7,14 @@
    #:if-let*
    #:when-let
    #:when-let*
+   ;; Definitions
+   #:define-constant
+   ;; Control flow
+   #:switch
+   #:eswitch
+   #:cswitch
+   #:whichever
+   #:xor
    ;; Hash tables
    #:copy-hash-table
    #:hash-table-keys
@@ -24,14 +32,19 @@
    #:rcurry
    #:compose
    #:multiple-value-compose
+   #:named-lambda
    ;; Lists
+   #:alist-plist
    #:appendf
    #:circular-list
    #:circular-list-p
    #:circular-tree-p
+   #:ensure-cons
    #:ensure-list
    #:lastcar
    #:make-circular-list
+   #:nunionf
+   #:plist-alist
    #:proper-list-p
    #:proper-list
    #:mappend
@@ -41,6 +54,7 @@
    #:remove-from-plist
    #:set-equal
    #:setp
+   #:unionf
    ;; Numbers
    #:clamp
    #:gaussian-random
@@ -79,6 +93,8 @@
    #:format-symbol
    #:make-keyword
    #:make-gensym-list
+   ;; Strings
+   #:string-designator
    ;; Types
    #:of-type
    #:type=

strings.lisp

@@ -0,0 +1,6 @@
+(in-package :alexandria)
+
+(deftype string-designator ()
+  "A string designator type. A string designator is either a string, a symbol,
+or a character."
+  `(or symbol string character))

symbols.lisp

@@ -1,14 +1,14 @@
 (in-package :alexandria)
 
+(declaim (inline ensure-symbol))
 (defun ensure-symbol (name &optional (package *package*))
   "Returns a symbol with name designated by NAME, accessible in package
 designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
-interned there.
+interned there. Returns a secondary value reflecting the status of the symbol
+in the package, which matches the secondary return value of INTERN.
 
-Example: (ENSURE-SYMBOL :CONS :CL) => CL:CONS"
-  (let ((name (string name)))
-    (values (or (find-symbol name package)
-                (intern name package)))))
+Example: (ENSURE-SYMBOL :CONS :CL) => CL:CONS, :EXTERNAL"
+  (intern (string name) package))
 
 (defun make-formatted-symbol (package name)
   (case package
@@ -26,7 +26,8 @@ then creates a symbol named by that string. If PACKAGE is NIL, returns an
 uninterned symbol, if package is T, returns a symbol interned in the current
 package, and otherwise returns a symbol interned in the package designated by
 PACKAGE."
-  (values (make-formatted-symbol package (apply #'format nil control arguments))))
+  (values
+   (make-formatted-symbol package (apply #'format nil control arguments))))
 
 (defun make-keyword (name)
   "Interns the string designated by NAME in the KEYWORD package."