Commit 02e674e1 authored by Nikodemus Siivola's avatar Nikodemus Siivola

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.
parent 735ea22b
...@@ -5,14 +5,17 @@ ...@@ -5,14 +5,17 @@
((:static-file "LICENCE") ((:static-file "LICENCE")
(:static-file "tests.lisp") (:static-file "tests.lisp")
(:file "package") (:file "package")
(:file "definitions" :depends-on ("package"))
(:file "strings" :depends-on ("package"))
(:file "errors" :depends-on ("package")) (:file "errors" :depends-on ("package"))
(:file "hash-tables" :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 "symbols" :depends-on ("package"))
(:file "arrays" :depends-on ("package")) (:file "arrays" :depends-on ("package"))
(:file "types" :depends-on ("package")) (:file "types" :depends-on ("package"))
(:file "binding" :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 "lists" :depends-on ("package" "functions"))
(:file "sequences" :depends-on ("package" "lists")) (:file "sequences" :depends-on ("package" "lists"))
(:file "numbers" :depends-on ("package" "sequences")))) (:file "numbers" :depends-on ("package" "sequences"))))
(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))))))
\ No newline at end of file
(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))))
...@@ -99,3 +99,21 @@ with and ARGUMENTS to FUNCTION." ...@@ -99,3 +99,21 @@ with and ARGUMENTS to FUNCTION."
(lambda (&rest more) (lambda (&rest more)
(declare (dynamic-extent more)) (declare (dynamic-extent more))
(multiple-value-call function (values-list more) (values-list arguments)))) (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)))))))
(in-package :alexandria) (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 (define-modify-macro appendf (&rest lists) append
"Modify-macro for APPEND. Appends LISTS to the place designated by the first "Modify-macro for APPEND. Appends LISTS to the place designated by the first
argument.") 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) (defun circular-list (&rest elements)
"Creates a circular list of ELEMENTS." "Creates a circular list of ELEMENTS."
(let ((cycle (copy-list elements))) (let ((cycle (copy-list elements)))
...@@ -100,6 +126,13 @@ recommended for performance intensive use. Main usefullness as the ...@@ -100,6 +126,13 @@ recommended for performance intensive use. Main usefullness as the
expected-type designator of a TYPE-ERROR." expected-type designator of a TYPE-ERROR."
`(satisfies circular-list-p)) `(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) (defun ensure-list (list)
"If LIST is a list, it is returned. Otherwise returns the list designated by LIST." "If LIST is a list, it is returned. Otherwise returns the list designated by LIST."
(if (listp list) (if (listp list)
......
...@@ -7,6 +7,14 @@ ...@@ -7,6 +7,14 @@
#:if-let* #:if-let*
#:when-let #:when-let
#:when-let* #:when-let*
;; Definitions
#:define-constant
;; Control flow
#:switch
#:eswitch
#:cswitch
#:whichever
#:xor
;; Hash tables ;; Hash tables
#:copy-hash-table #:copy-hash-table
#:hash-table-keys #:hash-table-keys
...@@ -24,14 +32,19 @@ ...@@ -24,14 +32,19 @@
#:rcurry #:rcurry
#:compose #:compose
#:multiple-value-compose #:multiple-value-compose
#:named-lambda
;; Lists ;; Lists
#:alist-plist
#:appendf #:appendf
#:circular-list #:circular-list
#:circular-list-p #:circular-list-p
#:circular-tree-p #:circular-tree-p
#:ensure-cons
#:ensure-list #:ensure-list
#:lastcar #:lastcar
#:make-circular-list #:make-circular-list
#:nunionf
#:plist-alist
#:proper-list-p #:proper-list-p
#:proper-list #:proper-list
#:mappend #:mappend
...@@ -41,6 +54,7 @@ ...@@ -41,6 +54,7 @@
#:remove-from-plist #:remove-from-plist
#:set-equal #:set-equal
#:setp #:setp
#:unionf
;; Numbers ;; Numbers
#:clamp #:clamp
#:gaussian-random #:gaussian-random
...@@ -79,6 +93,8 @@ ...@@ -79,6 +93,8 @@
#:format-symbol #:format-symbol
#:make-keyword #:make-keyword
#:make-gensym-list #:make-gensym-list
;; Strings
#:string-designator
;; Types ;; Types
#:of-type #:of-type
#:type= #:type=
......
(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))
(in-package :alexandria) (in-package :alexandria)
(declaim (inline ensure-symbol))
(defun ensure-symbol (name &optional (package *package*)) (defun ensure-symbol (name &optional (package *package*))
"Returns a symbol with name designated by NAME, accessible in 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 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" Example: (ENSURE-SYMBOL :CONS :CL) => CL:CONS, :EXTERNAL"
(let ((name (string name))) (intern (string name) package))
(values (or (find-symbol name package)
(intern name package)))))
(defun make-formatted-symbol (package name) (defun make-formatted-symbol (package name)
(case package (case package
...@@ -26,7 +26,8 @@ then creates a symbol named by that string. If PACKAGE is NIL, returns an ...@@ -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 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, and otherwise returns a symbol interned in the package designated by
PACKAGE." 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) (defun make-keyword (name)
"Interns the string designated by NAME in the KEYWORD package." "Interns the string designated by NAME in the KEYWORD package."
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment