Browse files

A working but untested version. See README for plans :)

  • Loading branch information...
1 parent 1d1a63e commit d3107ae6e24fd8c8d1af70efdd4e15b989740112 @vseloved committed Nov 22, 2009
Showing with 7,860 additions and 1 deletion.
  1. +5 −0 .gitignore
  2. +29 −0 AUTHORS
  3. +27 −0 LICENSE
  4. +99 −1 README
  5. +12 −0 TODO
  6. +97 −0 anaphoric.lisp
  7. +24 −0 array.lisp
  8. +290 −0 bind.lisp
  9. +16 −0 condition.lisp
  10. +123 −0 control.lisp
  11. +136 −0 core.lisp
  12. +617 −0 distro.lisp
  13. +38 −0 experimental.lisp
  14. +167 −0 function.lisp
  15. +271 −0 genhash.lisp
  16. +136 −0 hash-table.lisp
  17. +17 −0 impl.lisp
  18. +3,483 −0 iter.lisp
  19. +25 −0 iter.txt
  20. +164 −0 list.lisp
  21. +290 −0 number.lisp
  22. +46 −0 object.lisp
  23. +431 −0 packages.lisp
  24. +164 −0 pkg.lisp
  25. +257 −0 pkg.txt
  26. +49 −0 rutils.asd
  27. +11 −0 rutils.lisp
  28. +257 −0 seq.lisp
  29. +87 −0 seq.txt
  30. +306 −0 sequence.lisp
  31. +9 −0 short-after.lisp
  32. +33 −0 short.lisp
  33. +51 −0 split-sequence.txt
  34. +52 −0 string.lisp
  35. +19 −0 tree.lisp
  36. +22 −0 user.lisp
View
5 .gitignore
@@ -0,0 +1,5 @@
+*~
+*.fasl
+\#*
+.*
+!.gitignore
View
29 AUTHORS
@@ -0,0 +1,29 @@
+The authors and contributors to the utilities in this system include (in alphabetical order):
+* Andreas Fuchs
+* Arthur Lemmens
+* Attila Lendvai
+* Denis Budyak
+* Garry W. King
+* Ingvar Mattsson
+* Joerg Hoehle
+* Jonathan Amsterdam
+* Kaz Kylheku
+* Kevin Rosenberg
+* Luis Oliveira
+* Marco Baringer
+* Nikodemus Siivola
+* Pascal J. Bourguignon
+* Paul Graham
+* Robert Strandh
+* Tobias C. Rittweiler
+* Vsevolod Dyomkin
+
+Though it seems impossible to determine precisely the original author of every function or macro, at least some of the most important utilities' authors can be listed:
+* Arthur Lemmens: SPLIT-SEQUENCE
+* Ingvar Mattsson: GENHASH
+* Jonathan Amsterdam, Andreas Fuchs, Joerg Hoehle, Denis Budyak: ITERATE
+* Kaz Kylheku: PKG
+* Marco Baringer: DO-/MAPTREE, PARSE-FLOAT
+* Vsevolod Dyomkin: BIND, SEQ, DISTRO
+
+Besides, all of the utilities were at least minorly modified by Vsevolod Dyomkin to ensure consistency of documentation, use the same set of basic utilities and sometimes in other ways as well.
View
27 LICENSE
@@ -0,0 +1,27 @@
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ - Redistributions of source code must retain this copyright
+ notice, this list of conditions, the following disclaimer and the
+ AUTHORS file.
+
+ - Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+ - Neither the name of Edward Marco Baringer, nor BESE, nor the names
+ of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
100 README
@@ -1,2 +1,100 @@
+REASONABLE-UTILITIES (RUTILS) is yet another general purpose utilities package for COMMON-LISP.
-:iter and :split-sequence are added to features
+=== Rationale ===
+
+The other utility packages in CL-land include: CL-UTILITIES, METATILITIES, ARNESI and ALEXANDRIA to name a few. There are following motivations for creating another collection:
+
+ 1. Virually everyone talks about utilities in CL (probably, due to Paul Graham's "On Lisp", that starts with a chapter on the importance of utilities). But the existing utility packages are not enough visible and widespread either due to: not enough utility :), poor names, or lack of community involvement. The best and, probably, quite usable package is, in my opinion, ALEXANDRIA, which has a great team of developers, but basically suffers from 2 shortcommings:
+ - bad name (not recognized as a utilities package)
+ - the idea to be a "good citizen" in the CL world and not include code from other well-established, but specific utilities packages (SPLIT-SEQUENCE, ITERATE, ANAPHORA, ...)
+
+The second problem is most important, for the utility package should be as much all-around, all-encompasing one as possible. Because it should be used in most of the libraries, and library authors, for obvious reasons, don't like to add dependencies. This is one of the causes of not enough spread of such very useful packages, as ITERATE: one or two usages of the ITER macro often don't justify the dependency on an additional package. Yet, if all various utilities are collected under one roof, it should be a much more reasonable choice to depend on them.
+
+
+ 2. Yet the reverse of coin of all-encompassing utilities' package is bloat. It is a common complain about the CL standard, that it lacks modularity, and the utilities' package can as well suffer from the same problem. But the solution to it is found and implementated using the CL package mechanism: every part of functionality (like list or hash-table handling) is segmented into it's own package. Every package name is formed according to the following template: RUTILS.<functionality> (like: RUTILS.LIST, RUTILS.ITER). So it's a 1 dependency (1 ASDF system) - multiple packages, that can be used on demand, depending on the project's needs. Besides, there are umbrella packages, that include most of the useful functionality, omiting only experimental stuff. A style distinction of different naming conventions is also taken into consideration, so both long and short names are allowed to coexist and be selected according to one's preferences. So there are such umbrella packages as: RUTILS.USER and RUTILS.USR.
+
+
+ 3. Support for growth of CL
+
+Our aim is to include in this package as much of the work done in the previous periods and scattered over the Internet, as possible. Those utilities are unified in this package and a lot of effort is put into better documenting them.
+
+Besides we want to support some (or several) community process for developing the CL environment and incorporating into it new ideas, that are proved important and useful.
+
+One of such processes is CDR (http://cdr.eurolisp.org) and we aim to provide an implementation of every CDR proposal, that targets "user-space" (i.e. does not require efforts on the implementation side).
+
+Besides there is RUTILS.EXPERIMENTAL package, that will include some of the ideas, that are not yet tested enough, but might become valuable in the future.
+
+Finally, the most important goal of this project is to gather around it a big community of Lisp enthusiasts, that will be able to make their impact in improving it. That is why it is planned to establish a web-site, that will allow posting and dicussing of the suggestions of features to be added to the collection.
+
+As well additional maintainers for the project are needed.
+
+
+ 4. What is included and excluded
+
+Included
+--------
+Additional control constructs:
+ - Anaphoric utilities
+ - Basic (control.lisp)
+ - Symbols' and literals' manipulation (core.lisp)
+ - A general BIND macro
+ - ITER macro with keywords support (see iter.txt)
+ - PKG: read time manipulation of package visibility (see pkg.txt)
+
+Enhanced handling of:
+ - Arrays
+ - Conditions
+ - Lists
+ - Functions
+ - Hash-tables (+ GENHASH, CDR 2)
+ - Numbers (incl. CDR 5)
+ - Objects
+ - Sequences
+ (+ an implementation of the SEQ protocol, loosely based on Clojure, see seq.txt
+ + SPLIT-SEQUENCE, see split-sequence.txt)
+ - String handling
+ - Tree handling
+
+Excluded
+--------
+* Support for concurrency. The reason is not, that we consider this not useful or general-purpose enough, but rather, that it's a whole new paradigm, and the scope of RUTILS is too small to comfortably accomodate it.
+Look at:
+ - CL-STM
+ - PCALL
+ - PORTABLE-FUTURES
+ - CL-MUPROC
+ - BUTTERFLY (proprietary)
+
+* Functional features. As in the above, it's as well a whole other paradigm. It has a limited, but reasonable support in CL. Other features should be unified in it's own package, and maybe RUTILS can serve as a model for such package or even accomodate it in the future.
+Look at:
+ - SERIES
+ - CLAZY
+ - CL-UNIFICATION
+
+* Collections are as well a separate area in CS, so it requires a lot of effort to maintain and develop a comprehensive package in it.
+Look at:
+ - FSET
+ - CL-CONTAINERS
+
+* MOP. MOP abstraction layer is a CDR and it is as well an essential part of CL. It is implemented in CLOSER-MOP, and there are plans to integrate it in the future.
+
+
+=== Additional notes ===
+
+See LICENSE for usage permissions.
+See AUTHORS for credits.
+
+The following symbols are added to *FEATURES*:
+ - :iter
+ - :split-sequence
+ - :seq
+
+
+=== TODO ===
+
+ - finish documenting (85% done)
+ - implement a test-suite
+ - establish documentation extraction process
+ - put up on the Net and publish the code of Community Process website
+ - engage new maintainers
+ - see TODO for plans of new utilities integration
View
12 TODO
@@ -0,0 +1,12 @@
+Utilities, cinsidered for integration:
+
+ - add literal syntax for short lambdas of more than one argument (involving %1 %2 ...)
+ - DLISTS (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/a44fb824bf659c00?scoring=d&pli=1)
+ - DLAMBDA (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/34192536f61e18f2?pli=1)
+ - SETF'ers for NTHCDR, LAST etc (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/497f71d67f07a93d?pli=1)
+ - Anonymous packages (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/aad37c2a0a76af0c?pli=1)
+ - DEFV (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/ccc7bad0d82942a4?pli=1)
+ - HashCons (http://groups.google.com/group/comp.lang.lisp/browse_frm/thread/d2b4c2ebb97c820c?pli=1)
+ - MACROEXPAND-DAMMIT (http://john.freml.in/macroexpand-dammit)
+ - Some Cybertiggr utilities (http://cybertiggyr.com/gene/tigris/tigris.html#SECTION00610000000000000000) -- seem to be orphaned
+ - List comprehensions (http://blog.superadditive.com/2007/11/09/list-comprehensions-in-common-lisp/)
View
97 anaphoric.lisp
@@ -0,0 +1,97 @@
+;;; RUTILS anaphoric utils
+;;; see LICENSE file for permissions
+
+
+(in-package "REASONABLE-UTILITIES.ANAPHORIC/IT")
+
+(locally-enable-literal-syntax :sharp-backq)
+
+
+(defmacro if-it (test then &optional else)
+ "Like <_:fun if />. IT is bound to <_:arg test />"
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(defmacro when-it (test &body body)
+ "Like <_:fun when />. IT is bound to <_:arg test />"
+ `(let ((it ,test))
+ (when it
+ ,@body)))
+
+(defmacro and-it (&rest args)
+ "Like <_:fun and />. IT is bound to the value of
+the previous <_:fun and /> form"
+ (cond ((null args) t)
+ ((null (cdr args)) (car args))
+ (t `(when-it ,(car args) (and-it ,@(cdr args))))))
+
+(defmacro dowhile-it (test &body body)
+ "Like <_:fun dowhile />. IT is bound to <_:arg test />"
+ `(do ((it ,test ,test))
+ ((not it))
+ ,@body))
+
+(defmacro cond-it (&body body)
+ "Like <_:fun cond />. IT is bound to the passed <_:fun cond /> test"
+ `(let (it)
+ (cond
+ ,@(mapcar #``((setf it ,(car _)) ,(cadr _))
+ ;; uses the fact, that SETF returns the value set
+ body))))
+
+
+(in-package "REASONABLE-UTILITIES.ANAPHORIC/A")
+
+(abbrev aand rutils.anaphoric/it:and-it)
+(abbrev acond rutils.anaphoric/it:cond-it)
+(abbrev adowhile rutils.anaphoric/it:dowhile-it)
+(abbrev aif rutils.anaphoric/it:if-it)
+(abbrev awhen rutils.anaphoric/it:when-it)
+
+
+(in-package "REASONABLE-UTILITIES.ANAPHORIC/LET")
+
+(defmacro if-let (var test then &optional else)
+ "Like <_:fun if />. <_:arg Var /> will be bound to <_:arg test />"
+ `(let ((,var ,test))
+ (if ,var ,then ,else)))
+
+(defmacro when-let (var test &body body)
+ "Like <_:fun when />. <_:arg Var /> will be bound to <_:arg test />"
+ `(let ((,var ,test))
+ (when ,var
+ ,@body)))
+
+(defmacro and-let (var &rest args)
+ "Like <_:fun and />. <_:arg Var /> will be bound to the value of
+the previous <_:fun and /> form"
+ (cond ((null args) t)
+ ((null (cdr args)) (car args))
+ (t `(when-let ,var ,(car args) (and-let ,@(cdr args))))))
+
+(defmacro dowhile-let (var test &body body)
+ "Like <_:fun dowhile />. <_:arg Var /> will be bound to <_:arg test />"
+ `(do ((,var ,test ,test))
+ ((not ,var))
+ ,@body))
+
+(defmacro cond-let (var &body body)
+ "Like <_:fun cond />. <_:arg Var /> will be bound to
+the passed <_:fun cond /> test"
+ `(let (,var)
+ (cond
+ ,@(mapcar #``((setf ,var ,(car _)) ,(cadr _))
+ ;; uses the fact, that SETF returns the value set
+ body))))
+
+
+(in-package "REASONABLE-UTILITIES.ANAPHORIC/BIND")
+
+(abbrev and-bind rutils.anaphoric/let:and-let)
+(abbrev cond-bind rutils.anaphoric/let:cond-let)
+(abbrev dowhile-bind rutils.anaphoric/let:dowhile-let)
+(abbrev if-bind rutils.anaphoric/let:if-let)
+(abbrev when-bind rutils.anaphoric/let:when-let)
+
+
+;;; end
View
24 array.lisp
@@ -0,0 +1,24 @@
+;;; RUTILS array handling
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.ARRAY")
+
+
+(defun copy-array (array &key
+ (element-type (array-element-type array))
+ (fill-pointer (and (array-has-fill-pointer-p array)
+ (fill-pointer array)))
+ (adjustable (adjustable-array-p array)))
+ "Returns an undisplaced copy of <_:arg array />, with same
+<_:arg fill-pointer /> and <_:arg adjustab />ility (if any)
+as the original, unless overridden by the keyword arguments"
+ (let ((dims (array-dimensions array)))
+ ;; Dictionary entry for ADJUST-ARRAY requires adjusting a
+ ;; displaced array to a non-displaced one to make a copy
+ (adjust-array
+ (make-array dims
+ :element-type element-type :fill-pointer fill-pointer
+ :adjustable adjustable :displaced-to array)
+ dims)))
+
+;;; end
View
290 bind.lisp
@@ -0,0 +1,290 @@
+;;; RUTILS BIND macro
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.BIND")
+
+(locally-enable-literal-syntax :sharp-backq)
+
+
+(defmacro bind ((&rest clauses) &body body)
+ "A general binding construct, which aims to incorporate all ~
+frequently used binding forms, and provide an extension interface.
+
+Dispatches to the primitive CL binding forms. Dispatch is performed ~
+at comile-time by structural and identity comparisons (although any other ~
+comparison approach can be utilized) according to the dispatch rules, ~
+that are stored in <_:var *bind-dispatch-table* />. Rules are evaluated ~
+in the order of their addition, so the most specific ones should be ~
+added at the top. Each binding is performed sequentially, so the effect ~
+is similar to <_:fun let* />, rather than <_:fun let />"
+ (let ((rez body))
+ (mapc #`(setf rez `((,@(apply #'expand-bind-clause _ rez))))
+ (reverse clauses))
+ (car rez)))
+
+(defparameter *bind-dispatch-table* (make-array 0 :fill-pointer t)
+ "A vector, storing BIND-RULES")
+
+(defmacro def-bind-rule (rule expansion)
+ "Add a new BIND-RULE, which is specified as a pair of anonymous functions:
+ - a predicate, by which the rule is triggered
+ - an expansion
+to <_:var *bind-dispatch-table* />.
+A free variable <_:arg clause /> is captures inside boh functions, ~
+while the second one as well captures <_:arg body />"
+ `(vector-push-extend (cons (lambda (clause)
+ (and (listp clause) ,@rule))
+ (lambda (clause &rest body)
+ ,expansion))
+ *bind-dispatch-table*))
+
+(defun expand-bind-clause (clause &rest body)
+ "Try to find a rule for the <_:arg clause /> in ~
+<_:var *bind-dispatch-table* /> and expand it into the code, ~
+otherwise signal an error"
+ (apply (or (cdr (find t *bind-dispatch-table*
+ :key #`(funcall (car _) clause)))
+ (error "No bind rule for clause: ~a" clause))
+ clause body))
+
+;; rules
+
+(def-bind-rule ((dyadic clause)
+ (stringp (car clause))
+ (symbolp (cadr clause)))
+ `(with-input-from-string (,(cadr clause) ,(car clause))
+ ,@body))
+
+(def-bind-rule ((single clause)
+ (symbolp (car clause)))
+ `(with-output-to-string (,(car clause))
+ ,@body))
+
+(def-bind-rule ((if (dyadic clause)
+ (pathnamep (cadr clause))
+ (keywordp (caddr clause)))
+ (symbolp (car clause)))
+ `(with-open-file (,(car clause) ,(cadr clause) ,@(cddr clause))
+ ,@body))
+
+(def-bind-rule ((dyadic clause)
+ (symbolp (car clause))
+ (not (keywordp (car clause))))
+ `(let (,clause)
+ ,@body))
+
+(def-bind-rule ((dyadic clause)
+ (listp (car clause)))
+ `(tmpl-bind ,(car clause) ,(cadr clause)
+ ,@body))
+
+(def-bind-rule ((cddr clause)
+ (every #`(and (symbolp _) (not (keywordp _))) (butlast clause))
+ (listp (last1 clause)))
+ `(multiple-value-bind ,(butlast clause) ,@(last clause)
+ ,@body))
+
+#+nil
+(def-bind-rule ((intersection clause '(:slots :accessors))
+ (not (keywordp (last1 clause))))
+ (ds-bind (slots accessors)
+ (loop :for decl :in (last1 (butlast clause))
+ :if (symbolp decl) :collect decl :into slot-decls
+ :else :if (listp decl) :collect decl :into accessor-decls
+ :else :do (warn "Improper slot/accessor declaration: ~
+~a -- in BIND-clause: ~a"
+ decl clause)
+ :finally (return (list slot-decls accessor-decls)))
+ (let ((instance (gensym))
+ (rez body))
+ (when slots
+ (setf rez `((with-slots ,slots ,instance ,@rez))))
+ (when accessors
+ (setf rez `((with-accessors ,accessors ,instance ,@rez))))
+ `(let ((,instance ,(last1 clause))) ,@rez))))
+
+#+:cl-ppcre
+(def-bind-rule ((tryadic clause)
+ (listp (car clause)))
+ `(cl-ppcre:register-groups-bind
+ ,(car clause) (,(cadr clause) ,(caddr clause))
+ ,@body))
+
+
+;; destructuring
+
+(defmacro tmpl-bind (tmpl seq &body body)
+ "Perform destructuring on collection <_:arg coll /> ~
+to the template <_:arg tmpl />"
+ (let ((gseq (gensym "SEQ"))
+ (gkeys (gensym "KEYS")))
+ (wrap-bindings (make-bindings nil tmpl seq gseq gkeys) body)))
+
+(defun make-bindings (state tmpl seq gseq gkeys &optional (n 0))
+ "Prepare binding forms for <_:fun ds-bind-seq />"
+ (when tmpl
+ (case (car tmpl)
+ (&whole (if (null state)
+ (if-it (cadr tmpl)
+ (add-binding
+ `(let* ((,gseq ,seq)
+ (,it ,gseq)))
+ :regular (cddr tmpl) seq gseq gkeys (1+ n))
+ (error "No more bindings after &whole"))
+ (error "&whole not at the start")))
+ (&optional (if (member state '(nil :regular))
+ (if-it (cadr tmpl)
+ (add-binding
+ `(let ((,it (ignore-errors (elt ,gseq ,n)))))
+ :optional (cddr tmpl) seq gseq gkeys (1+ n))
+ (error "No more bindings after &optional"))
+ (error "&optional after &key/&rest")))
+ (&key (if (member state '(nil :regular :rest))
+ (if-it (cadr tmpl)
+ (add-binding
+ `(let* ((,gkeys (subseq ,gseq ,n))
+ (,it (getf ,gkeys ,(mkeyw it)))))
+ :key (cddr tmpl) seq gseq gkeys (1+ n))
+ (error "No more bindings after &key"))
+ (error "&key after &optional")))
+ (&rest (if (member state '(nil :regular :optional))
+ (if-it (cadr tmpl)
+ (add-binding `(let ((,it (subseq ,gseq ,n))))
+ :rest (cddr tmpl) seq gseq gkeys n)
+ (error "No more bindings after &rest"))
+ (error "&rest after &key")))
+ (otherwise (let ((var (car tmpl)))
+ (case state
+ (:regular (add-binding
+ `(let ((,var (elt ,gseq ,n))))
+ :regular (cdr tmpl) seq gseq gkeys (1+ n)))
+ (:optional (add-binding
+ `(let ((,var (ignore-errors (elt ,gseq ,n)))))
+ :optional (cdr tmpl) seq gseq gkeys (1+ n)))
+ (:key (add-binding
+ `(let ((,var (getf ,gkeys ,(mkeyw var)))))
+ :key (cdr tmpl) seq gseq gkeys (1+ n)))
+ (:rest nil)
+ (otherwise (add-binding
+ `(let* ((,gseq ,seq)
+ (,var (elt ,gseq ,n))))
+ :regular (cdr tmpl) seq gseq gkeys
+ (1+ n)))))))))
+
+(defun add-binding (binding &rest args)
+ ""
+ (cons binding (apply #'make-bindings args)))
+
+(defun wrap-bindings (bindings body)
+ "Wrap <_:arg bindings /> around <_:arg body />"
+ (if bindings (append (car bindings)
+ (list (wrap-bindings (cdr bindings) body)))
+ `(progn ,@body)))
+
+
+;; dsetq
+
+(defmacro dsetq (template value)
+ "Destructuring assignment; supports both <_:code (values ...) />
+for destructuring a multiple-value form and NIL as a variable name,
+meaning to ignore that position,
+e.g. <_:code (dsetq (values (a . b) nil c) form) />"
+ (do-dsetq template value nil))
+
+(defun do-dsetq (template value &optional (bindings? t) type)
+ ""
+ (cond
+ ((null template) (dsetq-error "Can't bind to nil"))
+ ((var-spec-p template) ; not only (symbolp template)
+ (when bindings?
+ (make-default-binding template :type type))
+ `(setq ,(extract-var template) ,value))
+ ;; m-v-setq
+ ((and (consp template) (eq (car template) 'values))
+ ;; Just do a simple check for the most common errors. There's no way we
+ ;; can catch all problems.
+ (if (or (atom value) (member (car value) '(car cdr cdar caar aref get)))
+ (dsetq-error "Multiple values make no sense for this expression" )
+ (make-mv-dsetqs (cdr template) value bindings?)))
+ (t (with-gensyms (temp)
+ `(let ((,temp ,value))
+ ,.(when type
+ `((declare (type ,type ,temp))))
+ ,.(make-dsetqs template temp bindings?)
+ ,temp)))))
+
+(defun make-dsetqs (template value bindings?)
+ ""
+ (cond
+ ((null template) nil)
+ ((var-spec-p template)
+ (when bindings?
+ (make-default-binding template))
+ `((setq ,(extract-var template) ,value)))
+ ((atom template) (dsetq-error "Invalid binding form: ~a" template))
+ ((eq (car template) 'values)
+ (dsetq-error "Multiple-value destructuring cannot be nested"))
+ (t (nconc (make-dsetqs (car template) `(car ,value) bindings?)
+ (make-dsetqs (cdr template) `(cdr ,value) bindings?)))))
+
+(defun make-mv-dsetqs (templates value bindings?)
+ ""
+ (let (temps vars tplates)
+ (declare (type list temps vars tplates))
+ (dolist (tp templates)
+ (if (and tp (var-spec-p tp)) ; either var or (the type var)
+ (progn (push nil tplates)
+ (push nil temps)
+ (push (extract-var tp) vars)
+ (when bindings?
+ (make-default-binding tp)))
+ ;; either NIL or destructuring template
+ (let ((temp (gensym "VALUE")))
+ (push tp tplates)
+ (push temp temps)
+ (push temp vars))))
+ (setq temps (nreverse temps))
+ (setq vars (nreverse vars))
+ (setq tplates (nreverse tplates))
+ (let ((mv-setq `(multiple-value-setq ,vars ,value))
+ (temp-vars (remove nil temps))) ; remove, don't delete
+ (if temp-vars
+ `(let ,temp-vars
+ (declare (ignorable .,temp-vars)) ; in case of NIL template
+ ,mv-setq
+ ,.(mapcan (lambda (tplate temp)
+ (make-dsetqs tplate temp bindings?))
+ tplates temps)
+ (car vars))
+ mv-setq))))
+
+;; utils
+
+(defun dsetq-error (format-string &rest args)
+ "Signal an <_:fun error /> in <_:fun dsetq />"
+ (apply #'error (strcat "DSETQ: " format-string) args))
+
+(defun the-expression-p (x)
+ "Test wheather <_:arg x /> is a <_:fun the />-declaration"
+ (and (consp x) (eq (first x) 'the)))
+
+(defun var-spec-p (x)
+ "Test wheather <_:arg x /> is a <_:fun the />-declaration or a symbol"
+ (or (the-expression-p x) (symbolp x)))
+
+(defun extract-var (var-spec)
+ "Either extract variable name from <_:fun the />-expression <_:arg var-spec />
+or return <_:arg var-spec /> as-is"
+ (if (the-expression-p var-spec) (third var-spec)
+ var-spec))
+
+(defun make-default-binding (var-spec &optional type)
+ ""
+ (let ((var (extract-var var-spec)))
+ (cond
+ ((null var-spec) nil)
+ ((not (symbolp var)) (dsetq-error "The variable ~a is not a symbol" var))
+ (t (add-binding var :regular nil)))))
+
+
+;;; end
View
16 condition.lisp
@@ -0,0 +1,16 @@
+;;; RUTILS condition handling
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.CONDITION")
+
+(defmacro maybe (form)
+ "Return a value, returned by a <_:arg form /> or nil,
+if <_:class error /> is signalled"
+ `(restart-case
+ (handler-bind ((error #'(lambda (c)
+ (declare (ignore condition))
+ (invoke-restart 'skip))))
+ ,form)
+ (skip () nil)))
+
+;;; end
View
123 control.lisp
@@ -0,0 +1,123 @@
+;; For license see LICENSE
+
+(in-package "REASONABLE-UTILITIES.CONTROL")
+
+(proclaim '(optimize speed))
+
+
+;; do
+
+(defmacro dowhile (test &rest body)
+ "Execute <_:arg body /> in a <_:fun do />-loop, while <_:arg test />
+is satisfied"
+ `(do ()
+ ((not ,test))
+ ,@body))
+
+(defmacro dountil (test &body body)
+ "Execute <_:arg body /> in a <_:fun do />-loop, until <_:arg test />
+is satisfied"
+ `(do ()
+ (,test)
+ ,@body))
+
+
+;; gcase
+
+(defmacro gcase ((keyform &key (test #'eql) err) &body clauses)
+ "Generalized case. Unlike <_:fun case /> it can use any <_:arg test />
+function. <_:class Type-errors /> signaled by <_:arg test /> function's
+applicattion are coverted to <_:class warnings />, unless <_:arg err />
+is provided"
+ (unless (listp clauses)
+ (error "~a -- bad clause in CASE" clauses))
+ (let ((it (gensym "IT")))
+ `(let ((,it ,keyform))
+ (cond
+ ,@(loop :for clause-and-tail :on clauses
+ :collect
+ (if (and (find (caar clause-and-tail) '(t otherwise))
+ (not (cdr clause-and-tail)))
+ `(t ,@(cdar clause-and-tail))
+ (with-gensyms (e)
+ `((handler-case (funcall ,test ,it ,(caar clause-and-tail))
+ (type-error (,e)
+ (funcall (if ,err #'error #'warn)
+ "The value ~a is not of type ~a"
+ (type-error-datum ,e)
+ (type-error-expected-type ,e))))
+ ,@(cdar clause-and-tail)))))))))
+
+;; logic
+
+(defmacro when/t (condition &body body)
+ "Like <_:fun when />, but returns T instead of NIL,
+if condition doesn't satisfy. Is logically equivalent to:
+<_:code (or (not condition) (progn body)) />,
+but cleraly expresses intent"
+ `(if ,condition (progn ,@body)
+ t))
+
+(defun or2 (x y)
+ "OR for 2 arguments as a function"
+ (or x y))
+
+(defun and2 (x y)
+ "AND for 2 arguments as a function"
+ (and x y))
+
+(defun xor2 (x y)
+ "XOR for 2 arguments as a function"
+ (or (and x (not y))
+ (and (not x) y)))
+
+(defmacro xor (&rest args)
+ "Evaluates the <_:arg args /> one at a time. If more than one returns T,
+evaluation stops and NIL is returned. If exactly one arg returns T that,
+value is returned"
+ (let ((state (gensym "XOR-state-"))
+ (block-name (gensym "XOR-block-"))
+ (arg-temp (gensym "XOR-arg-temp-")))
+ `(let (,state ,arg-temp)
+ (block ,block-name
+ ,@(loop
+ :for arg :in args
+ :collect `(setf ,arg-temp ,arg)
+ :collect `(when ,arg-temp
+ ;; arg is T, this can change the state
+ (if ,state
+ ;; a second T value, return NIL
+ (return-from ,block-name nil)
+ ;; a first T, swap the state
+ (setf ,state ,arg-temp))))
+ (return-from ,block-name ,state)))))
+
+(defun less (x y)
+ "Like <, but works for NIL values of <_:arg x /> and <_:arg y />.
+Obviously, NIL is <_:fun less />, than anything"
+ (cond ((null x) y)
+ ((null y) nil)
+ (t (< x y))))
+
+(defun not-more (x y)
+ "Like <=, but works for NIL values of <_:arg x /> and <_:arg y />
+Obviously, NIL is <_:fun less />, than anything"
+ (cond ((null x) y)
+ ((null y) nil)
+ (t (<= x y))))
+
+(defun more (x y)
+ "Like >, but works for NIL values of <_:arg x /> and <_:arg y />
+Obviously, NIL is <_:fun less />, than anything"
+ (cond ((null x) nil)
+ ((null y) x)
+ (t (> x y))))
+
+(defun not-less (x y)
+ "Like >=, but works for NIL values of <_:arg x /> and <_:arg y />
+Obviously, NIL is <_:fun less />, than anything"
+ (cond ((null x) nil)
+ ((null y) x)
+ (t (>= x y))))
+
+;;; end
View
136 core.lisp
@@ -0,0 +1,136 @@
+;; For license see LICENSE
+
+(in-package "REASONABLE-UTILITIES.CORE")
+
+(proclaim '(optimize speed))
+
+
+(defmacro eval-always (&body body)
+ "Wrap <_:arg body /> in <_:fun eval-when /> with all keys
+\(compile, load and execute) mentioned"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@body))
+
+(defmacro abbrev (short long)
+ "Abbreviate a <_:arg long /> MACRO or FUNCTION name as <_:arg short />"
+ `(eval-always
+ (cond
+ ((special-operator-p ',long)
+ (error "Can't ABBREViate a special-operator ~a" ',long))
+ ((macro-function ',long)
+ (setf (macro-function ',short) (macro-function ',long)))
+ ((fboundp ',long)
+ (setf (fdefinition ',short) (fdefinition ',long)))
+ (t
+ (error "Can't ABBREViate ~a" ',long)))
+ (setf (documentation ',short 'function) (documentation ',long 'function))
+ ',short))
+
+
+;; literal syntax
+
+(defgeneric enable-literal-syntax (which)
+ (:documentation "Dynamically modify read-table
+to enable some reader-macros"))
+
+(defgeneric disable-literal-syntax (which)
+ (:documentation "Dynamically modify read-table
+to disable some reader-macros"))
+
+(defmacro locally-enable-literal-syntax (which)
+ "Modify read-table to enable some reader-macros
+at compile/load time"
+ `(eval-always
+ (enable-literal-syntax ,which)))
+
+(defmacro locally-disable-literal-syntax (which)
+ "Modify read-table to disable some reader-macros
+at compile/load time"
+ `(eval-always
+ (disable-literal-syntax ,which)))
+
+
+;; symbols
+
+(defun make-gensym-list (length &optional (x "G"))
+ "Return a list of <_:arg length /> gensyms,
+using the second (optional, defaulting to \"G\") argument"
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop :repeat length :collect (gensym g))))
+
+(defmacro with-gensyms ((&rest names) &body body)
+ "Provide gensyms for given <_:arg names />"
+ `(let ,(loop :for n :in names :collect `(,n (gensym)))
+ ,@body))
+
+(abbrev with-unique-names with-gensyms)
+
+(defmacro once-only (specs &body forms)
+ "Evaluate <_:arg forms /> with names rebound to temporary variables, ensuring
+that each is evaluated only once.
+
+Each <_:arg spec /> must be either a NAME, or a (NAME INITFORM), with plain
+NAME using the named variable as initform.
+
+Example:
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "OO"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n) ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+(proclaim '(inline ensure-symbol ensure-keyword))
+
+(eval-always
+ (defun ensure-symbol (obj &key (format "~a") package)
+ "Make a symbol in either <_:arg package /> or <_:var *package* />
+from <_:arg obj /> according to <_:arg format />"
+ (intern (string-upcase (format nil format obj))
+ (or package *package*))))
+
+(eval-always
+ (defun ensure-keyword (obj &key (format "~a"))
+ "Make a keyword from <_:arg obj /> according to <_:arg format />"
+ (ensure-symbol obj :format format :package :keyword)))
+
+(defun package-symbols (package)
+ "List all symbols in a <_:arg package />"
+ (loop :for sym :being :the :present-symbol :of package
+ :collect sym))
+
+(defun package-external-symbols (package)
+ "List all symbols in a <_:arg package />"
+ (loop :for sym :being :the :external-symbol :of package
+ :collect sym))
+
+(defun export-exported-symbols (from-package to-package)
+ "Make the exported symbols in <_:arg from-package />
+be also exported from <_:arg to-package />."
+ (use-package from-package to-package)
+ (do-external-symbols (sym (find-package from-package))
+ (export sym (find-package to-package))))
+
+(defmacro defconst (name value &optional doc)
+ "<_:fun Defconstant /> only, whent it's not already defined"
+ `(eval-always
+ (unless (boundp ',name)
+ (defconstant ,name ,value ,doc))))
+
+
+;;; end
View
617 distro.lisp
@@ -0,0 +1,617 @@
+;; For license see LICENSE
+
+#+nil
+(defpackage "REASONABLE-UTILITIES.DISTRO"
+ (:nicknames "RUTILS.DISTRO")
+ (:use :common-lisp "RUTILS.CORE" "RUTILS.SHORT" "RUTILS.FUNCTION"
+ "RUTILS.OBJ")
+ (:documentation "Systems, distributions and environment control suite")
+ (:export #:*settings*
+ #:*search-paths*
+ #:*install-path*
+ #:*distros*
+ #:*platforms*
+
+ ;; environment
+ #:defenv
+ #:envcond
+ #:in-env
+
+ ;; system definition
+ #:asdf-system
+ #:simple-system
+ #:standard-system
+ #:defsystem
+
+ ;; operations
+ #:op
+ #:perform
+
+ ;; extension API
+ #:def-op-hook
+ #:sort-parts-for-specific-order
+ ;; system selection strategies
+
+
+ ;; platform
+
+ ;; condition
+ #:distro-error))
+
+(in-package "RUTILS.DISTRO")
+
+
+;; settings
+
+(defvar *settings* (make-hash-table)
+ "Table of settings, which includes the following ones (default is marked with *):
+:mode - operation mode - :auto* or :interactive
+:silent - supress all warnings? - nil*
+:allow-version-overwrite - action on the request to load the system with new version - t*
+:v-mismatch-strategy - what to do, if the requested version(s) of the system
+ is/are not found, but others are.
+ Options: :closest-bigger*, :first, :prompt, :download, ...
+ (:prompt will signal an error, if :mode is not :interactive)
+")
+
+;; :v-ambiguity-strategy - what to do, if several systems with one version are found? - :first*, :prompt
+
+
+(defmacro warn-if (&rest args)
+ "<_:fun Warn />, unless in :silent mode"
+ `(unless (gethash :silent *settings*)
+ (warn ,@args)))
+
+
+;; util
+
+(declaim (inline by-key sys-sym v-from-string sys< part< get-deps match-env-prefix ensure-env))
+
+(defconstant +future+ 9999999999)
+
+(defun by-key (node key &optional (test 'eql))
+ "Like <_:code (getf plist key) /> but for the case, when <_:arg node /> is
+not a proper <_:type plist />. As well, arbitrary <_:arg test /> can be used"
+ (when-it (position key node :test test)
+ (nth (1+ it) node)))
+
+(defun sys-sym (name)
+ "Make <_:arg name /> into the symbol from <_:pkg distros />"
+ (mksym name :package 'distros))
+
+(defun v-from-string (str)
+ "From a string version spec, like 1.4.2 make a list one: (1 4 2)"
+ (cl-ppcre:split "(\\.)|(:)|(~)|(-)|(_)|(,)|(\\+)" str))
+
+(defun till/= (op lst1 lst2)
+ "Like <_:fun <= /> or <_:fun >= /> (depending on <_:arg op />: '< or '>,
+but operates on lists in thios manner: traverses them in parallel,
+while consecutive elements are <_:fun = />;
+then either one of the lists ends (if it's <_:arg lst1 />, result is nil,
+otherwise -- t), or result is <_:arg op /> applied to the first mismatching
+element pair"
+ (block whole
+ (let* ((l2 (length lst2))
+ (i2 0))
+ (dolist (e1 lst1)
+ (let ((e2 (when (< i2 l2) (elt lst2 i2))))
+ (if (eql e1 e2)
+ (incf i2)
+ (return-from whole
+ (or (not e2)
+ (funcall op e1 e2)))))))
+ t))
+
+(defun match-v (v v-spec)
+ "Match <_:arg v /> as a list (like (0 1 2)) against the <_:arg v-spec />
+either as a plain list (in this case match by <_:fun equalp />), or as a
+plist of a form (:from (0 1 2) :to (1 0 0)), where either :from or :to part
+may be missing and both are considered inclusive"
+ (if (keywordp (car v-spec))
+ ;; it's a range spec
+ (let ((from (getf v-spec :from))
+ (to (getf v-spec :to)))
+ (and (if from (till/= '> v from) t)
+ (if to (till/= '< v to) t)))
+ ;; otherwise it's an exact spec
+ (equalp v v-spec))))
+
+(defun sys< (a b)
+ "System precedence order (by dependence)"
+ (find (sys-name a) (sys-deps b) :test #'string=))
+
+(defun part< (a b)
+ "Part precedence order (by dependence)"
+ (find (car (mklist a)) (get-deps b) :test #'string=))
+
+(defun get-deps (lst)
+ "From a list (<file> :on <deps> ...) get <deps> list"
+ (by-key lst :on))
+
+(defun match-env-prefix (key)
+ "Does <_:arg key /> start with ENV- prefix?"
+ (let ((key-str (princ-to-string key)))
+ (string= (subseq key-str 0
+ (if (> (length key-str) 4)
+ 4 0))
+ "ENV-")))
+
+(defun ensure-env (key)
+ "Ensure, that <_:arg key /> starts with ENV- prefix"
+ (if (match-env-prefix env) env ; leave as is
+ (mkey key :format "env-~a")))
+
+(defun file-write-date (pathspec)
+ "Determine"
+ #+sbcl #+unix (+ (sb-posix:stat-mtime (sb-posix:stat pathspec)) 2209075200)) ; + 70 years and some
+
+
+
+;; environment
+
+(defgeneric in-env (env)
+ (:documentation "Set-up the context of the environment <_:arg env />")
+ (:method (env)
+ (error (format nil "Environment ~a ot defined" env))))
+
+(defmacro defenv (key (&key sys-paths root install-path platform)
+ &body body)
+ "Define new environment (ephemeral object) by defining it's context
+\(<_:args sys-path root install-path and platform />) and additional
+actions, needed to be performed, when switching to it (as a <_:arg body />
+of a method specialised on this environment designator).
+The environment is designated by a keyword :ENV-<_:arg key />, and it's
+method is defined so, as to exclude other environments with the designator,
+constructed the same way"
+ (let ((env (ensure-env env)))
+ (once-only (sys-paths root install-path platform)
+ `(defmethod in-env ((env (eql ,env)))
+ (setf *features*
+ (delete-if #'match-env-prefix *features*))
+ (push ,env *features*)
+ (when ,sys-paths
+ (setf *search-paths* ,sys-paths)
+ #+asdf (setf asdf:*central-registry* ,sys-paths))
+ (when ,root
+ (setf *default-pathname-defaults* ,root))
+ (when ,install-path
+ (setf *install-path* install-path))
+ (when ,platform
+ (setf *platform* ,platform))
+ ,@body))))
+
+(defmacro envcond (&body clauses)
+ "Like <_:fun cond /> but operates on"
+ `(cond
+ ,@(loop :for clause-and-tail :on clauses
+ :collect (if (and (eq (caar clause-and-tail) t)
+ (not (cdr clause-and-tail)))
+ `(t ,@(cdar clause-and-tail))
+ `((find (ensure-env ,(caar clause-and-tail)) *features*)
+ ,@(cdar clause-and-tail))))))
+
+
+;; system definition
+
+(defvar *search-paths* '("/usr/share/lisp")
+ "Where to search for system definition files")
+
+(defvar *install-path* "/usr/share/lisp"
+ "Where to install downloaded DISTROS")
+
+(defvar *distros* (make-hash-table)
+ "Table of known system objects indexed by systems' name and aliases")
+
+(defmacro defsystem (name (&optional (system-class 'standard-system)) &rest args)
+ "Define a system of class <_:arg system-class />, add it to <_:var *distros* />
+and export from <_:pkg distros />"
+ (with-gensyms (ref sys aliases)
+ `(eval-always
+ (let* ((,ref (let ((,ref (sys-sym name)))
+ (export ref 'distros)
+ ref))
+ (,sys (make-instance ,system-class
+ :name ,ref
+ ,@args))
+ (,aliases (mapcar #`(export _ 'distros)
+ (getf ',args :aliases))))
+ (mapc #`(setf (gethash _ *distros*) ,sys)
+ (cons ,ref ,aliases))))))
+
+(defclass simple-system ()
+ ((name :reader sys-name :initarg :name
+ :initform (error "Name is required for system"))
+ (v :reader sys-v :initarg v
+ :documentation "version-spec in list form, like (0 4 2)")
+ (meta :reader sys-meta :initform (make-hash-table)
+ :documentation "meta information, like author, maintainer, description etc")
+ (path :accessor sys-path :initarg :path
+ :documentation "path, from which the system was last loaded")
+ (parts :accessor sys-parts :initarg :parts
+ :documentation "list of parts and their dependencies")
+ (deps :accessor sys-deps :initarg :deps :initform nil
+ :documentation "list of dependencies on other systems")
+ (ext-deps :accessor sys-ext-deps :initarg :ext-deps :initform nil
+ :documentation "list of dependencies on external (non-Lisp) libraries")
+ (stamp :reader sys-stamp :initarg :stamp
+ :documentation "timestamp of the time of start of last load operation"))
+ (:documentation "Information about the system, available to the management system"))
+
+(defclass standard-system (simple-system)
+ ((aliases :reader sys-aliases :initarg :aliases
+ :documentation "list of alternative names, by which the
+system can be found in <_:var *disros* />")
+ (url :accessor sys-url :initarg :url
+ :documentation "a canonical distro URL")
+ (parts-order
+ :documentation "tree of parts in order of precedence")
+ (deps-order
+ :documentation "full set of dependencies in order of precedence"))
+ (:documentation "Information about the DISTRO, available to the management system"))
+
+(defclass asdf-system (simple-system)
+ ()
+ (:documentation "Information about the ASDF system, available to the management system"))
+
+(defmethod obj-equal ((a standard-system) (b standard-system))
+ (and (string= (sys-name a) (sys-name b))
+ (equalp (sys-v a) (sys-v b))))
+
+(defmethod initialize-instance :after
+ ((system standard-system) &key meta &allow-other-keys)
+ "Add meta info and calculate precedence order for
+<_:slot standard-system deps /> and <_:slot standard-system parts />"
+ (setf (sys-meta system) (etypecase meta
+ (hash-table meta)
+ (list (hash-table-from-list meta)))
+
+ (slot-value system 'deps-order)
+ (sort (copy-seq (sys-deps system)) #'sys<)
+
+ (slot-value system 'parts-order)
+ (sort-parts (copy-seq (sys-parts system)))))
+
+(defmethod (setf sys-deps) :after ((system standard-system))
+ "Recompute dependency order for <_:slot standard-system deps />
+after their redefinition"
+ (setf (slot-value system 'deps-order)
+ (sort (copy-seq (sys-deps system)) #'sys<)))
+
+(defmethod (setf sys-parts) :after ((system standard-system))
+ "Recompute dependency order for <_:slot standard-system parts />
+after their redefinition"
+ (setf (slot-value system 'parts-order)
+ (sort-parts (copy-seq (sys-parts system)))))
+
+(defmethod print-object ((sys simple-system) stream)
+ (print-unreadable-object (sys stream :type t :identity t)
+ (ignore-errors
+ (prin1 (sys-name sys) stream))))
+
+
+;; sorting parts & deps
+
+(defun sort-parts (parts-spec)
+ "Sort parts in dependency precedence order.
+<_:arg Parts-spec /> is in general a tree of the following form:
+spec = ([:random|:serial|...]
+ <file>|(<file>)
+ (<file> :on <file-list>) ; dependencies
+ (<dir> <spec> ; subsystem definition
+ :on <file-list>) ; dependencies
+ (<file>|<dir> <spec> ; external dependencies -- i.e. handled not by DISTR
+ :by <handler-object> ; Lisp handler object, either performing some action
+ ; in-house or calling external utils
+ :with <handler-arglist>)) ; arguments fo handler
+There can be multiple :ext subsystems."
+ (let ((maybe-order (car parts-spec)))
+ (if (keywordp maybe-order)
+ (let ((parts (cdr parts-spec)))
+ (case maybe-order
+ (:serial (mapcar #`(let ((spec (mklist _)))
+ (if (listp (cadr spec)) ; it's a subsystem (subdir)
+ (setf (cadr spec) (sort-parts (cadr spec)))
+ (car (mklist spec)))) ; single file
+ parts))
+ (:random (sort parts #'part<))
+ (otherwise (sort-parts-for-specific-order maybe-order parts))))
+ ;; random order -- default
+ (sort-parts (cons :random parts-spec)))))
+
+(defgeneric sort-parts-for-specific-order (order parts-lst)
+ (:documentation "API function. For extending system definitions with special orders.
+In default case just signals a <_:cond distro-error />")
+ (:method (order parts-list)
+ (error 'distro-error
+ :msg (format nil "Order :~a not implemented" order))))
+
+
+;; find system
+
+(defun find-system (designator &optional v)
+ ""
+ (let ((ref (sys-sym designator))
+ (ref-str (string-downcase (ensure-string designator))))
+ (or (gethash ref *distros*)
+ (mv-bind (sys-d alternates-d) (find-on-disk ref-str)
+ (or sys
+ (mv-bind (sys-w alternates-w) (find-on-web ref-str)
+ (or sys-w
+ (select-system (nconc alternates-d alternates-w)
+ (gethash *settings* :v-mismatch-strategy)))))))))
+
+(defun find-on-disk (name)
+ "Find on disk in <_:var *search-paths* /> the system directory
+\(should start with <_:arg name />)"
+ (labels ((last-part (regex string)
+ (last1 (cl-ppcre:split regex string)))
+ (get-subdirs (dir)
+ (filter #`(when (cl-fad:directory-pathname-p _)
+ (last-part "/" (prin1-to-string
+ (cl-fad:pathname-as-directory _))))
+ (cl-fad:list-directory dir))))
+ (loop
+ :with name := name
+ :with paths := *search-paths*
+ :while paths :nconc
+ (let* ((dir (pop paths))
+ (subdirs (get-subdirs dir)))
+ (mapcar #`(pushnew _ paths :test #'string-equal) subdirs)
+; (remove-if-not #`(cl-ppcre:scan *known-extensions-scanner* (car _))
+ (filter #`(when (cl-ppcre:scan (strcat "(?i)^" name) _)
+ (list (strcat dir "/" _)
+ (last-part "(-)|(_)" _)))
+ subdirs)))))
+
+(defvar *known-extensions-scanner* (cl-ppcre:make-scanner "(?i).(dst)|(asd)$")
+ "Scanner to find system definition files by extension")
+
+;;;;;;;;;;???
+(defun select-system (system &optional (strategy #'first-closest-version-system))
+ "
+Default <_:arg strategy /> is to select at least some system
+with the <_:arg v />ersion, closest to the desired one.
+Any other system selection strategy can be given"
+ (funcall strategy (sys-name system) (sys-v system) (find-system name)))
+
+
+;; system selection strategies
+
+;; operation modes: :interactive and :automatic
+
+(defun select-all-systems-by-versions (path-variants v name)
+ "Interactive"
+ (if-it (remove-if-not #`(string= (second _) v) path-variants :key #'second)
+ (nconc it
+ (sort (remove it path-variants #'string= :key #'second)
+ #'string> :key #'second))
+ (sort path-variants #'string> :key #'second)))
+
+(defun select-all-systems-matching-versions (path-variants v name)
+ "Interactive"
+ (remove-if-not #`(string= (second _) v) path-variants :key #'second))
+
+(defun select-first-closest-version-system (name v path-variants)
+ ""
+ (car (or (find v path-variants :test #'string= :key #'second)
+ (when-it (car (sort (remove-if-not #`(string> (second _) v) path-variants)
+ #'string< :key #'second))
+ (warn-if (format nil "Couldn't find system ~a of version: ~a. Using version: ~a"
+ name v (second it)))
+ it)
+ (when-it (car (sort (remove-if-not #`(string< (second _) v) path-variants)
+ #'string> :key #'second))
+ (warn-if (format nil "Couldn't find system ~a of version: ~a. Using version: ~a"
+ name v (second it)))
+ it))))
+
+(defun select-first-matching-version-system (name v path-variants)
+ ""
+ (or (find v path-variants :test #'string= :key #'second)
+ (and (warn-if (format nil "No source for version ~a of system ~a found."
+ v name))
+ nil)))
+
+
+;; download
+
+
+;; extract & install
+;; taken from ASDF-INSTALL
+
+(defparameter *tar-program*
+ (progn
+ "tar"
+ #+darwin "gnutar"
+ #+(or sunos netbsd) "gtar")
+ "")
+
+(defun get-tar-directory (packagename)
+ ""
+ (let* ((tar (with-output-to-string (o)
+ (or (sb-ext:run-program *tar-program*
+ (list "-tzf" (namestring packagename))
+ :output o
+ :search t
+ :wait t)
+ (error "can't list archive"))))
+ (first-line (subseq tar 0 (position #\Newline tar))))
+ (if (find #\/ first-line)
+ (subseq first-line 0 (position #\/ first-line))
+ first-line)))
+
+(defun untar-package (source packagename)
+ ""
+ (with-output-to-string (o)
+ (or (sb-ext:run-program *tar-program*
+ (list "-C" (namestring source)
+ "-xzvf" (namestring packagename)) ; j = bzip2
+ :output o
+ :search t
+ :wait t)
+ (error "can't untar"))))
+
+(defun install-package (source system packagename)
+ "Returns a list of asdf system names for installed asdf systems"
+ (ensure-directories-exist source)
+ (ensure-directories-exist system)
+ (let* ((tdir (get-tar-directory packagename))
+ (*default-pathname-defaults*
+ (merge-pathnames (make-pathname :directory `(:relative ,tdir))
+ source)))
+ (princ (untar-package source packagename))
+ (loop for asd in (directory
+ (make-pathname :name :wild :type "asd"))
+ do (let ((target (merge-pathnames
+ (make-pathname :name (pathname-name asd)
+ :type (pathname-type asd))
+ system)))
+ (when (probe-file target)
+ (sb-posix:unlink target))
+ #-win32
+ (sb-posix:symlink asd target))
+ collect (pathname-name asd))))
+
+
+;; perform methods
+
+(defgeneric perform (op system &key &allow-other-keys)
+ (:documentation "Perform <_:arg op />erations on <_:arg system />s"))
+
+(defmethod perform ((op (eql :check)) (system standard-system) &key &allow-other-keys)
+ (labels ((rec-check (parts path)
+ (every #'identity
+ (mapcar #`(and (probe-file (strcat path "/" (car part)))
+ (if (listp (cadr part)) ; recurse into subsystems
+ (rec-verify (cadr part))
+ t))
+ parts))))
+ (block check
+ (let ((parts (sys-parts system)))
+ (mapc #`(when (rec-check parts (car _))
+ (return-from check (car _)))
+ system))
+ nil)))
+
+(macrolet ((processing-files (op stamp)
+ `(let ((cur-path (or (sys-path system)
+ (select-system system)))
+ (cur-stamp (sys-stamp system))
+ (new-stamp (get-universal-time)))
+ (when (and cur-stamp (> cur-stamp new-stamp))
+ (warn-if "Previous timestamp exceeds current time"))
+ (if (perform :check system)
+ (progn (process-files ,op
+ (slot-value system 'parts-order)
+ cur-path
+ :stamp ,stamp)
+ (with-slots (stamp path) system
+ (setf stamp new-stamp
+ path cur-path))
+ (values t
+ cur-path))
+ (error 'distro-error
+ :msg (format nil "Verification failed for system: ~a"
+ (sys-name system)))))))
+
+ (defmethod perform ((op (eql :compile)) (system standard-system) &key &allow-other-keys)
+ (processing-files 'compile-file (or cur-stamp +future+)))
+
+ (defmethod perform ((op (eql :recompile)) (system standard-system) &key &allow-other-keys)
+ (processing-files 'compile-file 0))
+
+ (defmethod perform ((op (eql :load)) (system standard-system) &key &allow-other-keys)
+ (processing-files 'load (or cur-stamp +future+)))
+
+ (defmethod perform ((op (eql :reload)) (system standard-system) &key &allow-other-keys)
+ (processing-files 'load 0)))
+
+(defmethod perform ((op (eql :test)) (system standard-system) &key &allow-other-keys)
+ (error "Need to define system-specific test method"))
+
+#+nil
+(defmethod perform ((op (eql :update)) (system standard-system) &key &allow-other-keys)
+ "Update the system from canonical link. If <_:arg v /> is given,
+update for that version, otherwise -- for latest"
+ (download (sys-name system)
+
+
+(defmethod perform ((op (eql :update-deps)) (system standard-system) &key &allow-other-keys)
+ (dolist (dep (slot-value system 'deps-order))
+ )
+
+(defun op (op sys-name &rest args)
+ "A shortcut to <_:fun perform />"
+ (apply #'perform op (find-system sys-name) args))
+
+(defmacro def-op-hook ((qualifier method system) &body body)
+ "Define modifier methods (standard method combination)"
+ `(defmethod ,qualifier ((op (eql ,method)) (system (eql ,system)) &key &allow-other-keys)
+ ,@body))
+
+
+;; files processing
+
+(defun process-files (op file-list path &key stamp force ext ext-args)
+ "Apply <_:arg op /> to files from <_:arg file-list /> list of names,
+located by <_:arg path />, when the last modification time of the appropriate"
+ (flet ((fullname (path name)
+ (strcat path "/" name ".lisp")))
+ (loop :with processed-nodes
+ :for node :in file-list
+ :for name := (car node)
+ :for pathspec := (fullname path name)
+ :for need := (or force (find (by-key node :on) processed-nodes))
+ ;; after sorting we know, where to start, but since the order is incomplete, there may be files,
+ ;; that should not be touched on the way: if their immediate deps are not in processed files
+
+ :for ext := (or ext (by-key node :by)) :and ext-args := (or ext-args (by-key node :with))
+ :do (cond ((listp (cadr node)) ; it's a subsystem
+ (when (process-files op
+ (cadr node)
+ (fullname path name)
+ :stamp stamp :force need
+ :ext ext :ext-args ext-args)
+ (push name processed-nodes)))
+ (ext ; process with external processor
+ (handler-case
+ (progn (apply ext op pathspec stamp need ext-args)
+ (push name processed-nodes))
+ (error () (error 'distro-error
+ :msg (format nil
+ "Error running external processor ~a with ~a"
+ ext ext-args)))))
+ ((or need ; for processing complete subsystem
+ (< (file-modify-date (compile-file-pathname pathspec)) stamp))
+ (funcall op pathspec)
+ (push name processed-nodes))))))
+
+
+#|
+;; platforms
+
+(defvar *platform* nil
+ "The OS or VM, on which our Lisp runs")
+
+(defvar *platforms* (make-hash-table)
+ "Table of external package inquiry methods, specific to each platform")
+
+(eval-always
+ (setf (gethash :debian *platforms*)
+ (lambda (pkg-str v)
+ (let ((stream (get-output (strcat_ "dpkg -l" pkg-str))))
+ (unless (and (equal (read stream) "ii")
+ (equal ())
+|#
+
+
+;; conditions
+
+(define-condition distro-error (error)
+ ((msg :initarg msg))
+ (:documentation "A base class for distro related conditions")
+ (:report (lambda (condition stream)
+ (format stream "~a" msg))))
+
+
+;;; end
View
38 experimental.lisp
@@ -0,0 +1,38 @@
+;;; RUTILS experimental stuff
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.EXPERIMENTAL")
+
+
+;; defmulti
+
+(define-method-combination multi (dispatch-fn)
+ ((all *))
+ (:arguments &whole args)
+ `(or ,@(mapcar (lambda (method)
+ `(when (find (apply ,dispatch-fn ,args)
+ (method-qualifiers ,method))
+ (call-method ,method)))
+ all)))
+
+(defmacro defmulti (fun-name dispatch-fn lambda-list)
+ "Clojure style multimethods:
+
+CL-USER> (defmulti foo #'length (collection))
+#<STANDARD-GENERIC-FUNCTION FOO (0)>
+CL-USER> (defmethod foo 3 (x) (format t \"~a contains 3 things\" x))
+#<STANDARD-METHOD FOO 3 (T) {B6238A9}>
+CL-USER> (defmethod foo 10 (_) (format t \"A collection of 10 elements.~%\"))
+#<STANDARD-METHOD FOO 10 (T) {B03CBC9}>
+CL-USER> (foo \"yes\")
+yes contains 3 things
+NIL
+CL-USER> (foo (range 10))
+A collection of 10 elements.
+NIL
+"
+ `(defgeneric ,fun-name ,lambda-list
+ (:method-combination multi ,dispatch-fn)))
+
+
+;;; end
View
167 function.lisp
@@ -0,0 +1,167 @@
+;; For license see MIT-LICENSE
+
+(in-package "REASONABLE-UTILITIES.FUNCTION")
+
+
+;; literal syntax
+
+(eval-always
+ (defun |#`-reader| (stream char arg)
+ "Reader syntax for one argument lambdas. Examples:
+- #`(+ 2 _) => (lambda (x) (+ 2 x))
+- #`((1+ _) (print _)) => (lambda (x) (1+ x) (print x))"
+ (declare (ignore char arg))
+ (let ((sexp (read stream t nil t))
+ (x (gensym "X")))
+ `(lambda (,x)
+ ,@(subst x '_ (if (listp (car sexp)) sexp (list sexp))))))
+
+ (defmethod enable-literal-syntax ((which (eql :sharp-backq)))
+ (set-dispatch-macro-character #\# #\` #'|#`-reader|))
+
+ (defmethod disable-literal-syntax ((which (eql :sharp-backq)))
+ (set-dispatch-macro-character #\# #\` (make-reader-error-fun #\`))))
+
+
+;; ensure function
+
+(declaim (inline mkfun ensure-function))
+
+(declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+(eval-always
+ (defun ensure-function (function-designator)
+ "Return the function, designated by <_:arg function-designator />:
+if <_:arg function-designator /> is a function, it is returned, otherwise
+it must be a function name and its <_:fun fdefinition /> is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator))))
+
+(abbrev mkfun ensure-function)
+
+(defmethod mk ((to (eql 'function)) smth &key &allow-other-keys)
+ (mkfun smth))
+
+
+;; composition and partial application
+
+(defun disjoin (predicate &rest more-predicates)
+ "Return the function, that applies each of <_:arg predicate /> and
+<_:arg more-predicates /> functions in turn to its arguments,
+returning the primary value of the first predicate that returns true,
+without calling the remaining predicates.
+If none of the predicates returns true, NIL is returned."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((predicate (ensure-function predicate))
+ (more-predicates (mapcar #'ensure-function more-predicates)))
+ (lambda (&rest arguments)
+ (or (apply predicate arguments)
+ (some (lambda (p)
+ (declare (type function p))
+ (apply p arguments))
+ more-predicates)))))
+
+(defun conjoin (predicate &rest more-predicates)
+ "Return the function, that applies each of <_:arg predicate /> and
+<_:arg more-predicates /> functions in turn to its arguments,
+returning NIL if any of the predicates returns false,
+without calling the remaining predicates. If none of the predicates
+returns false, returns the primary value of the last predicate."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (and (apply predicate arguments)
+ ;; Cannot simply use CL:EVERY because we want to return the
+ ;; non-NIL value of the last predicate if all succeed.
+ (do ((tail (cdr more-predicates) (cdr tail))
+ (head (car more-predicates) (car tail)))
+ ((not tail)
+ (apply head arguments))
+ (unless (apply head arguments)
+ (return nil))))))
+
+
+(defun compose (function &rest more-functions)
+ "Return the function, composed of <_:arg function /> and
+<_:arg more-functions />, that applies its arguments to each in turn,
+starting from the rightmost of <_:arg more-functions />, and then
+calling the next one with the primary value of the last"
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (funcall f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+(define-compiler-macro compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "COMPOSE")))
+ `(let ,(loop for f in funs for arg in args
+ collect `(,f (ensure-function ,arg)))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+(defun multiple-value-compose (function &rest more-functions)
+ "Return the function, composed of <_:arg function /> and
+<_:arg more-functions />, that applies its arguments to each in turn,
+starting from the rightmost of <_:arg more-functions />, and then
+calling the next one with all the return values of the last"
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (reduce (lambda (f g)
+ (let ((f (ensure-function f))
+ (g (ensure-function g)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ (multiple-value-call f (apply g arguments)))))
+ more-functions
+ :initial-value function))
+
+(define-compiler-macro multiple-value-compose (function &rest more-functions)
+ (labels ((compose-1 (funs)
+ (if (cdr funs)
+ `(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
+ `(apply ,(car funs) arguments))))
+ (let* ((args (cons function more-functions))
+ (funs (make-gensym-list (length args) "MV-COMPOSE")))
+ `(let ,(mapcar #'list funs args)
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest arguments)
+ (declare (dynamic-extent arguments))
+ ,(compose-1 funs))))))
+
+(defun curry (function &rest arguments)
+ "Return the function, that applies <_:arg arguments /> and the arguments
+it is called with to <_:arg function />"
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+(define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY")))
+ `(let ,(mapcar #'list curries arguments)
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,function ,@curries more)))))
+
+(defun rcurry (function &rest arguments)
+ "Return the function, that applies the arguments it is called with
+and <_:arg arguments /> to <_:arg function />"
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+;;; end
View
271 genhash.lisp
@@ -0,0 +1,271 @@
+;;; RUTILS GENHASH implementation (see CDR 2)
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.GENHASH")
+
+
+(defvar *hash-test-designator-map* (make-hash-table)
+ "Hash-table of <_:class hash-table-designator />s for GENERIC-HASH-TABLE")
+
+(defvar *initialized* nil
+ "A generalized boolean, designating, wheather the GENHASH ~
+machinery was initialized")
+
+(define-condition hash-exists (simple-error) ()
+ (:default-initargs
+ :format-control "Hash table type ~a already registered"))
+
+(define-condition unknown-hash (simple-error) ()
+ (:default-initargs
+ :format-control "Unknown hash table type ~a"))
+
+
+(defclass hash-test-designator ()
+ ((test-designator :reader test-designator :initarg :test-designator)
+ (hash-function :reader hash-function :initarg :hash-function)
+ (eq-test :reader eq-test :initarg :eq-test)
+ (builtin :reader builtin :initarg :builtin :initform nil))
+ (:documentation
+ "Exhastfully specifies the hash-function of GENERIC-HASH-TABLE"))
+
+(defclass hash-container ()
+ ((buckets :accessor buckets :initarg :buckets)
+ (allocated-buckets :accessor allocated-buckets :initarg :allocated-buckets)
+ (used-buckets :accessor used-buckets :initform 0)
+ (stored-items :accessor stored-items :initarg :stored-items)
+ (test-designator :reader test-designator :initarg :test-designator))
+ (:documentation
+ "A GENERIC-HASH-TABLE, which allows for use of any ~
+<_:class hash-test-designator />"))
+
+(defun register-test-designator (test-designator hash-function equal-function)
+ "Add new <_:class hash-test-designator /> to ~
+<_:var *hash-test-designator-map* />, if it's not already present in it"
+ (when (gethash test-designator *hash-test-designator-map*)
+ (let ((hashfun (gethash test-designator *hash-test-designator-map*)))
+ (unless (and (eql hash-function (hash-function hashfun))
+ (eql equal-function (eq-test hashfun)))
+ (error 'hash-exists :format-arguments (list test-designator)))))
+ (let ((hash-foo (make-instance 'hash-test-designator
+ :test-designator test-designator
+ :hash-function hash-function
+ :eq-test equal-function)))
+ (setf (gethash test-designator *hash-test-designator-map*)
+ hash-foo)))
+
+(defun register-builtin (test-designator)
+ "Register a <_:class hash-test-designator /> as a builtin"
+ (setf (gethash test-designator *hash-test-designator-map*)
+ (make-instance 'hash-test-designator :builtin t)))
+
+(defun make-generic-hash-table (&key (size 17) (test 'eql))
+ "Make GENERIC-HASH-TABLE, that can be either bultin <_:type hash-table />, ~
+if the <_:arg test />-function is one of the 4, allow ~
+<_:fun hash-table-test />s, or an an instance of <_:class hash-container />"
+ (let ((test-designator test))
+ (let ((nick (gethash test-designator *hash-test-designator-map*)))
+ (unless nick
+ (error 'unknown-hash :format-arguments (list test-designator)))
+
+ (if (builtin nick) (make-hash-table :test test-designator :size size)
+ (let ((storage (make-array (list size) :initial-element nil)))
+ (make-instance 'hash-container
+ :buckets storage
+ :stored-items 0
+ :allocated-buckets size
+ :test-designator test-designator))))))
+
+
+;; Add, get and remove values
+
+(defgeneric hashref (key table &optional default)
+ (:documentation "The analog of <_:fun gethash />"))
+
+(defgeneric (setf hashref) (value key table &optional default)
+ (:documentation "The analog of <_:fun setf <_:fun gethash /> _>"))
+
+(defgeneric hashrem (key table)
+ (:documentation "The analog of <_:fun remhash />"))
+
+(defgeneric hashmap (key table)
+ (:documentation "The analog of <_:fun maphash />"))
+
+(defgeneric hashclr (key)
+ (:documentation "The analog of <_:fun clrhash />"))
+
+
+(defun expand-hash-table (table)
+ "Grow the GENERIC-HASH-TABLE <_:arg table />"
+ (let* ((new-size (1+ (* 2 (allocated-buckets table))))
+ (new-buckets (make-array (list new-size) :initial-element nil)))
+ (let ((old-data (buckets table)))
+ (setf (allocated-buckets table) new-size)
+ (setf (used-buckets table) 0)
+ (setf (buckets table) new-buckets )
+ (loop :for bucket :across old-data :do
+ (loop :for chunk :in bucket :do
+ (setf (hashref (car chunk) table)
+ (cdr chunk))))))
+ table)
+
+(defmethod hashref (key (table hash-container) &optional default)
+ (let ((hash-type (gethash (test-designator table)
+ *hash-test-designator-map*)))
+ (let ((hash (funcall (hash-function hash-type) key)))
+ (let ((bucket
+ (aref (buckets table)
+ (mod hash (allocated-buckets table)))))
+ (let ((data default) found (eqfun (eq-test hash-type)))
+ (flet ((check (chunk)
+ (when (funcall eqfun (car chunk) key)
+ (setf data (cdr chunk)
+ found t))))
+ (loop :for chunk :in bucket :until found :do
+ (check chunk))
+ (values data found)))))))
+
+(defmethod hashref (key (table hash-table) &optional default)
+ (gethash key table default))
+
+(defmethod (setf hashref) (value key (table hash-container) &optional def)
+ (declare (ignore def))
+ (let ((container (gethash (test-designator table)
+ *hash-test-designator-map*)))
+ (when (= (allocated-buckets table) (used-buckets table))
+ (expand-hash-table table))
+
+ (let ((hash (funcall (hash-function container) key))
+ (buckets (buckets table))
+ (size (allocated-buckets table)))
+ (let* ((bucket-ix (mod hash size))
+ (bucket (aref buckets bucket-ix)))
+ (if (null (aref buckets bucket-ix))
+ (progn (setf (aref buckets bucket-ix)
+ (cons (cons key value) bucket))
+ (incf (used-buckets table))
+ (incf (stored-items table)))
+ (let ((check
+ (member key bucket
+ :key #'car :test (eq-test container))))
+ (if check
+ (setf (cdr (car check)) value)
+ (progn (setf (aref buckets bucket-ix)
+ (cons (cons key value) bucket))
+ (incf (stored-items table)))))))))
+ value)
+
+(defmethod (setf hashref) (value key (table hash-table) &optional default)
+ (declare (ignore default))
+ (setf (gethash key table) value))
+
+(defmethod hashrem (key (table hash-container))
+ (when (hashref key table nil)
+ (let ((container (gethash (test-designator table)
+ *hash-test-designator-map*)))
+ (let* ((hash (funcall (hash-function container) key))
+ (buckets (buckets table))
+ (size (allocated-buckets table))
+ (bucket-ix (mod hash size))
+ (bucket (aref buckets bucket-ix)))
+ (setf (aref buckets bucket-ix)
+ (delete key bucket :test (eq-test container) :key 'car))
+ (unless (aref buckets bucket-ix)
+ (decf (used-buckets table)))
+ (decf (stored-items table))))
+ t))
+
+(defmethod hashrem (key (table hash-table))
+ (remhash key table))
+
+(defmethod hashclr ((table hash-container))
+ (setf (used-buckets table) 0)
+ (loop :for ix :from 0 :below (allocated-buckets table) :do
+ (setf (aref (buckets table) ix) nil))
+ table)
+
+(defmethod hashclr ((table hash-table))
+ (clrhash table))
+
+
+;;; Hash table iteration
+
+(defmethod all-hash-keys ((table hash-container))
+ (loop for list across (buckets table)
+ append (mapcar #'car list)))
+
+(defmethod all-hash-keys ((table hash-table))
+ (loop for key being the hash-keys of table
+ collect key))
+
+(defmethod hashmap (fn (table hash-container))
+ (let ((buckets (buckets table)))
+ (loop :for bucket :across buckets :do
+ (loop :for chunk :in bucket :do
+ (funcall fn (car chunk) (cdr chunk))))))
+
+(defmethod hashmap (fn (table hash-table))
+ (maphash fn table))
+
+(defmacro with-generic-hash-table-iterator ((name table) &body body)
+ "The analog of <_:fun with-hash-table-iterator />"
+ (let ((table-des (gensym "TABLE"))
+ (the-keys (gensym "KEYS")))
+ `(let* ((,table-des ,table)
+ (,the-keys (all-hash-keys ,table-des)))
+ (macrolet ((,name ()
+ `(when-it (car ,',the-keys)
+ (prog1
+ (values t
+ it
+ (hashref it ,',table-des))
+ (setf ,',the-keys (cdr ,',the-keys))))))
+ ,@body))))
+
+
+;; Hash table information
+
+(defgeneric generic-hash-table-count (table)
+ (:documentation "The analog of <_:fun hash-table-count />"))
+
+(defgeneric generic-hash-table-size (table)
+ (:documentation "The analog of <_:fun hash-table-size />"))
+
+(defgeneric generic-hash-table-p (table)
+ (:documentation "Belonging to GENERIC-HASH-TABLE hierarchy predicate"))
+
+
+(defmethod generic-hash-table-count ((table hash-container))
+ (stored-items table))
+
+(defmethod generic-hash-table-count ((table hash-table))
+ (hash-table-count table))
+
+
+(defmethod generic-hash-table-size ((table hash-container))
+ (used-buckets table))
+
+(defmethod generic-hash-table-size ((table hash-table))
+ (hash-table-size table))
+
+
+(defmethod generic-hash-table-p ((table t))
+ nil)
+(defmethod generic-hash-table-p ((table hash-container))
+ t)
+(defmethod generic-hash-table-p ((table hash-table))
+ t)
+
+;; Setting up default hash tables
+
+(unless *initialized*
+ (setf *initialized* t)
+ (register-test-designator 'eq #'sxhash #'eq)
+ (register-test-designator 'eql #'sxhash #'eql)
+ (register-test-designator 'equal #'sxhash #'equal)
+ (register-test-designator 'equalp #'sxhash #'equalp)
+ (register-builtin #'eq)
+ (register-builtin #'eql)
+ (register-builtin #'equal)
+ (register-builtin #'equalp))
+
+;;; end
View
136 hash-table.lisp
@@ -0,0 +1,136 @@
+;;; RUTILS hash-table handling
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.HASH-TABLE")
+
+
+;; literal syntax
+
+(defun |#{-reader| (stream char arg)
+ "Reader syntax for hash-tables. Examples:
+- #{:a 1 :b 2} => #<HASH-TABLE :TEST EQL :COUNT 2>
+ It holds 2 key/value pairs: (:a 1) (:b 2)
+- #{equalp \"a\" 1 \"b\" 2} => #<HASH-TABLE :TEST EQUALP :COUNT 2>
+ It holds 2 key/value pairs: (\"a\" 1) (\"b\" 2)"
+ (declare (ignore char arg))
+ (let* ((sexp (read-delimited-list #\} stream t))
+ (test (when (oddp (length sexp))
+ (car sexp)))
+ (kv-pairs (if test (cdr sexp) sexp)))
+ `(hash-table-from-list (list ,@kv-pairs) ,test)))
+
+(defmethod enable-literal-syntax ((which (eql :hash-table)))
+ (set-dispatch-macro-character #\# #\{ #'|#{-reader|)
+ (set-macro-character #\} (get-macro-character #\) nil)))
+
+(defmethod disable-literal-syntax ((which (eql :hash-table)))
+ (set-dispatch-macro-character #\# #\{ (make-reader-error-fun #\{))
+ (set-macro-character #\} nil))
+
+(defmethod to-string ((obj hash-table) &optional stream)
+ (format stream "#{~@[~a ;~]~a}~%"
+ (unless (eq (hash-table-test obj) 'eql)
+ (hash-table-test obj))
+ (with-output-to-string (out)
+ (maphash (lambda (k v)
+ (format out "~%~a ~a" k v))
+ obj))))
+
+;; copy
+
+(defun copy-hash-table (ht &key key test size
+ rehash-size rehash-threshold)
+ "Returns a copy of hash table <_:arg ht />, with the same keys and values.
+The copy has the same properties as the original, unless overridden
+by the keyword arguments.
+
+Before each of the original values is set into the new hash-table,
+<_:arg key /> is invoked on the value. As <_:arg key /> defaults to
+<_:fun identity />, a shallow copy is returned by default"
+ (setf key (or key 'identity))
+ (setf test (or test (hash-table-test ht)))
+ (setf size (or size (hash-table-size ht)))
+ (setf rehash-size (or rehash-size (hash-table-rehash-size ht)))
+ (setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold ht)))
+ (let ((copy (make-hash-table :test test :size size
+ :rehash-size rehash-size
+ :rehash-threshold rehash-threshold)))
+ (maphash (lambda (k v)
+ (setf (gethash k copy) (funcall key v)))
+ ht)
+ copy))
+
+
+;; sequencing
+
+(proclaim '(inline
+ hash-table-keys hash-table-values hash-table-vals
+ maphash-keys maphash-values maphash-vals))
+
+(defun hash-table-keys (ht)
+ "Return a list of keys of hash-table <_:arg ht />"
+ (loop for k being the hash-keys of ht
+ collect k))
+
+(defun maphash-keys (function ht)
+ "Like <_:fun maphash />, but calls <_:arg function />
+with each key in the hash table <_:arg ht />"
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (funcall function k))
+ ht))
+
+(eval-always
+ (defun hash-table-values (ht)
+ "Return a list of values of hash-table <_:arg ht />"
+ (loop for v being the hash-values of ht
+ collect v))
+
+ (defun maphash-values (function ht)
+ "Like <_:fun maphash />, but calls <_:arg function />
+with each value in the hash table <_:arg ht />"
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (funcall function v))
+ ht)))
+
+(abbrev hash-table-vals hash-table-values)
+(abbrev maphash-vals maphash-values)
+
+(defun hash-table-from-list (lst &optional test)
+ "Returns a hash-table containing the keys and values,
+alternating in <_:arg lst />. Unless hash-table <_:arg test />
+is provided, it will be '<_:fun eql />"
+ (loop
+ :with ht = (make-hash-table :test (or test 'eql))
+ :for (k v) :on lst :by #'cddr
+ :do (setf (gethash k ht) v)
+ :finally (return ht)))
+
+(defun hash-table-to-list (ht)
+ "Returns a list containing the keys and values of hash-table <_:arg ht />"
+ (with-hash-table-iterator (gen-fn ht)
+ (loop
+ :for (valid key val) = (multiple-value-list (gen-fn))
+ :unless valid :do (return rez)
+ :nconc (list key val) :into rez)))
+
+(defun hash-table-from-alist (alst &optional test)
+ "Returns a hash-table containing the keys and values,
+alternating in <_:arg alst />. Unless hash-table <_:arg test />
+is provided, it will be '<_:fun eql />"
+ (loop
+ :with ht = (make-hash-table :test (or test 'eql))
+ :for (k . v) :in alst
+ :do (setf (gethash k ht) v)
+ :finally (return ht)))
+
+(defun hash-table-to-alist (ht)
+ "Returns an alist containing the keys and values of hash-table <_:arg ht />"
+ (with-hash-table-iterator (gen-fn ht)
+ (loop
+ :for (valid key val) = (multiple-value-list (gen-fn))
+ :unless valid :do (return rez)
+ :collect (cons key val) :into rez)))
+
+;;; end
View
17 impl.lisp
@@ -0,0 +1,17 @@
+;;; RUTILS implementation specific code
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.CORE")
+
+(defun make-reader-error-fun (char)
+ (lambda (stream char arg)
+ (declare (ignore stream arg))
+ #+sbcl (error 'sb-int:simple-reader-error :stream *error-output*
+ :format-control "no dispatch function defined for #\~c"
+ :format-arguments (list char))
+ #-(or sbcl)
+ (error 'simple-error :stream *error-output*
+ :format-control "no dispatch function defined for #\~c"
+ :format-arguments (list char))))
+
+;;; end
View
3,483 iter.lisp
3,483 additions, 0 deletions not shown because the diff is too large. Please use a local Git client to view these changes.
View
25 iter.txt
@@ -0,0 +1,25 @@
+ITER -- ITERATE with KEYWORDS
+-----------------------------
+
+Idea: provide the possibility to use the powerful ITERATE macro without the need to import (and effectively lock) around 40 quite common names, some of which conflict with the CL-USER package. Besides, simplify, regularize and document the code base, so that it could be easily supported and further extended (at least one bug was found during this process).
+
+
+Improvements and changes to original ITERATE:
+
+* used and improved Denis Budyak's support for keywords from the KEYWORD (and not ITERATE) package
+
+* added additional keywords, which can't be duplicated as symbols from ITERATE package due to CL-USER lock
+ * :search
+ * :reduce
+ * :adjoin, :append, :nconc, :union, :nunion
+
+* removed ITERATE entry-point (and left only ITER) to distinguish (to some extent) from original ITERATE without keyword support
+
+* documented
+
+* simplified bindings and conditional evaluation: used bind, when/unless, cond where appropriate, removed #L
+
+* in WALK added symbol-macros' processing
+
+* bug fixes:
+ - removed ' before ,RESULT-TYPE in RETURN-COLLECTION-CODE, so that non-constant RESULT-TYPEs could be passed to :INTO clause
View
164 list.lisp
@@ -0,0 +1,164 @@
+;;; RUTILS list handling
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.LIST")
+
+(locally-enable-literal-syntax :sharp-backq)
+
+
+(proclaim
+ '(inline last1 single dyadic tryadic append1 conc1 ensure-list mklist))
+
+
+(defun last1 (lst &optional (n 1))
+ "Get the <_:arg N />th element of a <_:arg lst /> from end,
+starting from the last one (which is number 1)"
+ (car (last lst n)))
+
+(defun butlast2 (lst &optional (n 1))
+ "Split <_:arg lst /> in 2 parts and return them as multiple values:
+head and tail. If (= <_:arg n /> 1), which is the most common case,
+the tail will be a single element, otherwise -- a list as well"
+ (values (butlast lst n)
+ (if (eql n 1) (last1 lst)
+ (last lst n))))
+
+(defun single (lst)
+ "Test wheather <_:arg lst /> contains exactly 1 element"
+ (and (consp lst) (not (cdr lst))))
+
+(defun dyadic (lst)
+ "Test wheather <_:arg lst /> contains exactly 2 elements"
+ (and (consp lst) (cdr lst) (not (cddr lst))))
+
+(defun tryadic (lst)
+ "Test wheather <_:arg lst /> contains exactly 3 elements"
+ (and (consp lst) (cddr lst) (not (cdddr lst))))
+
+
+(eval-always
+ (defun ensure-list (obj)
+ "Wrap <_:arg obj /> in a list, if it's not a list"
+ (if (listp obj) obj (list obj))))
+
+(abbrev mklist ensure-list)
+
+(defmethod mk ((to (eql 'list)) smth &key &allow-other-keys)
+ (mklist smth))
+
+
+(defmacro with-output-to-list ((out) &body body)
+ "A simple list analogue of <_:fun with-output-to-string />, which ~
+supports the general pattern of using list as an accumulator.
+<_:arg Out /> is bound to a fresh list, that will be returned
+<_:fun nrevers />ed. <_:arg Body /> is wraped in implicit <_:fun block /> NIL"
+ `(let ((,out (list)))
+ (block nil
+ (unwind-protect
+ (progn ,@body)))
+ (nreverse ,out)))
+
+
+(defun group (lst n)
+ "Split <_:arg lst /> into a list of lists of length <_:arg n />"
+ (declare (integer n))
+ (when (zerop n) (error "zero length"))
+ (labels ((rec (src acc)
+ (let ((rest (nthcdr n src)))
+ (if (consp rest)
+ (rec rest (cons (subseq src 0 n) acc))
+ (nreverse (cons src acc))))))
+ (when lst
+ (rec lst nil))))
+
+(defun flatten (lst)
+ "Flatten <_:arg lst />"
+ (labels ((rec (x acc)
+ (cond ((null x) acc)
+ ((atom x) (cons x acc))
+ (t (rec (car x) (rec (cdr x) acc))))))
+ (rec lst nil)))
+
+(defun rearrange-pairs (pairs)
+ "From a list of <_:fun cons />-<_:arg pairs /> make 2 separate lists"
+ (loop :for pair :in pairs
+ :collect (car pair) :into fsts
+ :collect (cdr pair) :into secs
+ :finally (return (values fsts secs))))
+
+(defun mapfil (fun lst)
+ "Accumulate in the resulting list only non-NIL results of application
+of <_:arg fun /> to subsequent elements of <_:arg lst />.
+Often called FILTER. This name is selected for consistency with other ~
+map- function as well as to allow the name FILTER to be used for ~
+general sequences."
+ (let (accum)
+ (dolist (x lst)
+ (let ((val (funcall fun x)))
+ (when val (push val accum))))
+ (nreverse accum)))
+
+(defun interlay (lst &rest lsts)
+ "Return a list, whose elements are subsequently taken from
+<_:arg lst /> and each of <_:arg lsts /> as:
+1st of lst, 1st of 1st of lsts, ..., 1st of last of lsts, 2nd of lst, ..."
+ (apply #'mapcan (lambda (&rest els)
+ els)
+ lst lsts))
+
+(defun first-n (lst num &optional (step 1))
+ "Return a list with <_:arg NUM /> elements, which are taken from <_:arg LST />
+by this formula: INDEX of ELEMENT = I * STEP for I from 0"
+ (declare (type (integer 1) step))
+ (loop :for rst :on lst :by #`(nthcdr step _)
+ :repeat num
+ :collect (car rst)))
+
+
+;; plist
+
+(defun plist-p (lst)
+ "Test wheather <_:arg lst /> is a properly formed plist"
+ (when (listp lst)
+ (loop :for rest :on lst :by #'cddr
+ :unless (and (keywordp (car rest))
+ (cdr rest))
+ :do (return nil)
+ :finally (return lst))))
+
+(defun alist-to-plist (alst)
+ "Make a plist from an alist <_:arg alst />"
+ (mapcan #`(list (car _) (cdr _)) alst))
+
+(defun plist-to-alist (plst)
+ "Make an alist from a plist <_:arg plst />"
+ (loop :for pair :on plst :by #'cddr
+ :collect (cons (car pair) (cadr pair))))
+
+(defun remove-from-plist (plist &rest keys)
+ "Returns a propery-list with same keys and values as <_:arg plist />,
+except that keys in the list designated by <_:arg keys /> and values,
+corresponding to them are removed. The returned property-list may share
+structure with the <_:arg plist />, but <_:arg plist /> is not destructively
+modified. Keys are compared using <_:fun eq />"
+ (declare (optimize (speed 3)))
+ (loop :for (key . rest) :on plist :by #'cddr
+; :do (assert rest () "Expected a proper plist, got ~S" plist)
+ :unless (member key keys :test #'eq)
+ :collect key :and :collect (first rest)))
+
+(defun delete-from-plist (plist &rest keys)
+ "Just like <_:fun remove-from-plist />, but this version may destructively
+modify the provided <_:arg plist />"
+ (declare (optimize (speed 3)))
+ (loop :for pos := 0 :then (incf pos 2)
+ :for (key . rest) := (nthcdr pos plist)
+ :while rest
+; :do (assert rest () "Expected a proper plist, got ~S" plist)
+ :do (when (member key keys :test #'eq)
+ (rplacd (nthcdr (1- pos) plist) (nthcdr (+ pos 2) plist))
+ (decf pos 2))
+ :finally (return plist)))
+
+
+;;; end
View
290 number.lisp
@@ -0,0 +1,290 @@
+;;; RUTILS number handling (incl. CDR 5)
+;;; see LICENSE file for permissions
+
+(in-package "REASONABLE-UTILITIES.NUMBER")
+
+(locally-enable-literal-syntax :sharp-backq)
+
+
+;; range
+
+(defun map-range (fun min max &optional (step 1))
+ "Map <_:fun fun /> across the integer range
+from <_:arg min /> to <_:arg max /> by <_:arg step />"
+ (loop :for i :from min :upto max :by step
+ :collect (funcall fun i)))
+
+(defmacro do-range ((index &optional min max step return-value)
+ &body body)
+ ""
+ (assert (or min max)
+ (min max)
+ "Must specify at least MIN or MAX")
+ `(loop
+ :for ,index ,@(when min `(:from ,min))
+ ,@(when max `(:upto ,max))
+ ,@(when step `(:by ,step))
+ :do (progn ,@body)
+ :finally (return ,return-value)))
+
+(defclass range ()
+ ((start :initarg :start :reader range-start :initform 0)
+ (end :initarg :end :reader range-end)
+ (step :initarg :step :reader range-step :initform 1))
+ (:documentation ""))
+
+(defun range (start &key end step)
+ ""
+ (make-instance 'range :start start :end end :step step))
+
+#+:seq
+(defmethod rutils.seq:seq ((coll range) &optional (start-pos 0))
+ (make-instance 'seq :ref coll :pos start-pos
+ :itr #`(with-slots (step end) coll
+ (let ((rez (+ start-pos (* _ step))))
+ (and (or (not end) (<= rez end))
+ (values rez
+ _))))))
+
+;; float
+
+(defun parse-float (float-string
+ &key (start 0) (end nil) (radix 10)
+ (junk-allowed t)
+ (type 'single-float)
+ (decimal-character #\.))
+ "A simple way to parse a float is <_:code
+\(read-from-string (prin1-to-string value)) />
+This is a more versatile function, which allows to specialize
+different expected float representations"
+ (flet ((radix-values (radix)
+ (assert (<= 2 radix 35)
+ (radix)
+ "RADIX must be between 2 and 35 (inclusive), not ~D." radix)
+ (make-array radix
+ :displaced-to "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ :displaced-index-offset 0
+ :element-type
+ #+lispworks 'base-char
+ #-lispworks 'character)))
+ (let ((radix-array (radix-values radix))
+ (integer-part 0)
+ (mantissa 0)
+ (mantissa-size 1)
+ (sign 1))
+ (with-input-from-string (float-stream (string-upcase
+ (string-trim '(#\Space #\Tab)
+ float-string))
+ :start start :end end)
+ (labels ((peek () (peek-char nil float-stream nil nil nil))
+ (next () (read-char float-stream nil nil nil))
+ (sign () (cond ; reads the (optional) sign of the number
+ ((char= (peek) #\+) (next) (setf sign 1))
+ ((char= (peek) #\-) (next) (setf sign -1)))
+ (integer-part))
+ (integer-part ()
+ (cond
+ ((position (peek) radix-array)
+ ;; the next char is a valid char
+ (setf integer-part (+ (* integer-part radix)
+ (position (next) radix-array)))
+ ;; again
+ (return-from integer-part (integer-part)))
+ ((null (peek))
+ ;; end of string
+ (done))
+ ((char= decimal-character (peek))
+ ;; the decimal separator
+ (next)
+ (return-from integer-part (mantissa)))
+ ;; junk
+ (junk-allowed (done))
+ (t (bad-string))))
+ (mantissa ()
+ (cond
+ ((position (peek) radix-array)