diff --git a/alexandria.asd b/alexandria.asd index d129ff02ac929907e9d5d177449fc3739d64600a..b7c58dafb1686b36cbfed141666c36087a4e68eb 100644 --- a/alexandria.asd +++ b/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")))) diff --git a/control-flow.lisp b/control-flow.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5f683688acbe6d5e8a5529396d065f2939a125c3 --- /dev/null +++ b/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)))))) \ No newline at end of file diff --git a/definitions.lisp b/definitions.lisp new file mode 100644 index 0000000000000000000000000000000000000000..b1667c2fcbc2617ff70c66d10a548d6cbb3a7229 --- /dev/null +++ b/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)))) diff --git a/functions.lisp b/functions.lisp index 95d0c2a0d57a7826adfc657ae21cd23cce3a3a28..6d02660b15d4888d5071786d394cca9b3b3753b9 100644 --- a/functions.lisp +++ b/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))))))) diff --git a/lists.lisp b/lists.lisp index 1fabed3c54a65e9b34723ee043c6c73f943aab7d..ce2a710e7d71ab634b5e24565342a2b33c8f750e 100644 --- a/lists.lisp +++ b/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) diff --git a/package.lisp b/package.lisp index 485a85ab704e58809b8ffa8446ad403b4bd9e5ea..c05f2c009a338c1acb1cd503382b618c1d61882d 100644 --- a/package.lisp +++ b/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= diff --git a/strings.lisp b/strings.lisp new file mode 100644 index 0000000000000000000000000000000000000000..e9fd91c9615584c61b32a4b422cb9cda048b9ea7 --- /dev/null +++ b/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)) diff --git a/symbols.lisp b/symbols.lisp index a6baa2e6cef976d654a766dce06bd8e6022ef24c..ecb267c0ffd6cf6e2074285690c575357723d7ab 100644 --- a/symbols.lisp +++ b/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."