X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/a07d8d005f69c0f9f5da2e09c6ee39cb1e1801aa..dea4d05507e59ab779ed4bb209e05971d87e260c:/utilities.lisp diff --git a/utilities.lisp b/utilities.lisp deleted file mode 100644 index 7e9e092..0000000 --- a/utilities.lisp +++ /dev/null @@ -1,411 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Various handy utilities -;;; -;;; (c) 2009 Straylight/Edgeware -;;; - -;;;----- Licensing notice --------------------------------------------------- -;;; -;;; This file is part of the Simple Object Definition system. -;;; -;;; SOD is free software; you can redistribute it and/or modify -;;; it under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 2 of the License, or -;;; (at your option) any later version. -;;; -;;; SOD is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with SOD; if not, write to the Free Software Foundation, -;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -(cl:in-package #:sod) - -;;;-------------------------------------------------------------------------- -;;; List utilities. - -(defun mappend (function list &rest more-lists) - "Like a nondestructive MAPCAN. - - Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, - and return the result of appending all of the resulting lists." - (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) - -(define-condition inconsistent-merge-error (error) - ((candidates :initarg :candidates - :reader merge-error-candidates)) - (:documentation - "Reports an inconsistency in the arguments passed to MERGE-LISTS.") - (:report (lambda (condition stream) - (format stream "Merge inconsistency: failed to decide among ~A." - (merge-error-candidates condition))))) - -(defun merge-lists (lists &key pick (test #'eql)) - "Return a merge of the given LISTS. - - The resulting LIST contains the items of the given lists, with duplicates - removed. The order of the resulting list is consistent with the orders of - the input LISTS in the sense that if A precedes B in some input list then - A will also precede B in the output list. If the lists aren't consistent - (e.g., some list contains A followed by B, and another contains B followed - by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled. - - Item equality is determined by TEST. - - If there is an ambiguity at any point -- i.e., a choice between two or - more possible next items to emit -- then PICK is called to arbitrate. - PICK is called with two arguments: the list of candidate next items, and - the current output list. It should return one of the candidate items. If - PICK is omitted then an arbitrary choice is made. - - The primary use of this function is in computing class precedence lists. - By building the input lists and selecting the PICK function appropriately, - a variety of different CPL algorithms can be implemented." - - ;; In this loop, TAIL points to the last cons cell in the list. This way - ;; we can build the list up forwards, so as not to make the PICK function - ;; interface be weird. HEAD is a dummy cons cell inserted before the list, - ;; which gives TAIL something to point to initially. (If we had locatives, - ;; I'd have TAIL point to the thing holding the final NIL, but we haven't; - ;; instead, it points to the cons cell whose cdr holds the final NIL -- - ;; which means that we need to invent a cons cell if the list is empty.) - (do* ((head (cons nil nil)) - (tail head)) - ((null lists) (cdr head)) - - ;; The candidate items are the ones at the front of the input lists. - ;; Gather them up, removing duplicates. If a candidate is somewhere in - ;; one of the other lists other than at the front then we reject it. If - ;; we've just rejected everything, then we can make no more progress and - ;; the input lists were inconsistent. - (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test)) - (leasts (remove-if (lambda (item) - (some (lambda (list) - (member item (cdr list) :test test)) - lists)) - candidates)) - (winner (cond ((null leasts) - (error 'inconsistent-merge-error - :candidates candidates)) - ((null (cdr leasts)) - (car leasts)) - (pick - (funcall pick leasts (cdr head))) - (t (car leasts)))) - (new (cons winner nil))) - - ;; Check that the PICK function isn't conning us. - (assert (member winner leasts :test test)) - - ;; Update the output list and remove the winning item from the input - ;; lists. We know that it must be at the front of each input list - ;; containing it. At this point, we discard input lists entirely when - ;; they run out of entries. The loop ends when there are no more input - ;; lists left, i.e., when we've munched all of the input items. - (setf (cdr tail) new - tail new - lists (delete nil (mapcar (lambda (list) - (if (funcall test winner (car list)) - (cdr list) - list)) - lists)))))) - -;;;-------------------------------------------------------------------------- -;;; Strings and characters. - -(defun frob-case (string) - "Twiddles the case of STRING. - - If all the letters in STRING are uppercase, switch them to lowercase; if - they're all lowercase then switch them to uppercase. If there's a mix - then leave them all alone. This is an invertible transformation." - - ;; Given that this operation is performed by the reader anyway, it's - ;; surprising that there isn't a Common Lisp function to do this built - ;; in. - (let ((flags (reduce (lambda (state ch) - (logior state - (cond ((upper-case-p ch) 1) - ((lower-case-p ch) 2) - (t 0)))) - string - :initial-value 0))) - - ;; Now FLAGS has bit 0 set if there are any upper-case characters, and - ;; bit 1 if there are lower-case. So if it's zero there were no letters - ;; at all, and if it's three then there were both kinds; either way, we - ;; leave the string unchanged. Otherwise we know how to flip the case. - (case flags - (1 (string-downcase string)) - (2 (string-upcase string)) - (t string)))) - -(declaim (inline whitespace-char-p)) -(defun whitespace-char-p (char) - "Returns whether CHAR is a whitespace character. - - Whitespaceness is determined relative to the compile-time readtable, which - is probably good enough for most purposes." - (case char - (#.(loop for i below char-code-limit - for ch = (code-char i) - unless (with-input-from-string (in (string ch)) - (peek-char t in nil)) - collect ch) t) - (t nil))) - -;;;-------------------------------------------------------------------------- -;;; Symbols. - -(defun symbolicate (&rest symbols) - "Return a symbol named after the concatenation of the names of the SYMBOLS. - - The symbol is interned in the current *PACKAGE*. Trad." - (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) - -;;;-------------------------------------------------------------------------- -;;; Object printing. - -(defmacro maybe-print-unreadable-object - ((object stream &rest args) &body body) - "Print helper for usually-unreadable objects. - - If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY. - Otherwise just print using BODY." - (let ((func (gensym "PRINT"))) - `(flet ((,func () ,@body)) - (if *print-escape* - (print-unreadable-object (,object ,stream ,@args) - (,func)) - (,func))))) - -;;;-------------------------------------------------------------------------- -;;; Keyword arguments and lambda lists. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun transform-otherkeys-lambda-list (bvl) - "Process a simple lambda-list BVL which might contain &OTHER-KEYS. - - &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments - (which must also be present); &ALLOW-OTHER-KEYS must not be present. - - The behaviour is that - - * the presence of non-listed keyword arguments is permitted, as if - &ALLOW-OTHER-KEYS had been provided, and - - * a list of the keyword arguments other than the ones explicitly listed - is stored in the VAR. - - The return value is a replacement BVL which binds the &OTHER-KEYS variable - as an &AUX parameter if necessary. - - At least for now, fancy things like destructuring lambda-lists aren't - supported. I suspect you'll get away with a specializing lambda-list." - - (prog ((new-bvl nil) - (rest-var nil) - (keywords nil) - (other-keys-var nil) - (tail bvl)) - - find-rest - ;; Scan forwards until we find &REST or &KEY. If we find the former, - ;; then remember the variable name. If we find the latter first then - ;; there can't be a &REST argument, so we should invent one. If we - ;; find neither then there's nothing to do. - (when (endp tail) - (go ignore)) - (let ((item (pop tail))) - (push item new-bvl) - (case item - (&rest (when (endp tail) - (error "Missing &REST argument name")) - (setf rest-var (pop tail)) - (push rest-var new-bvl)) - (&aux (go ignore)) - (&key (unless rest-var - (setf rest-var (gensym "REST")) - (setf new-bvl (nconc (list '&key rest-var '&rest) - (cdr new-bvl)))) - (go scan-keywords))) - (go find-rest)) - - scan-keywords - ;; Read keyword argument specs one-by-one. For each one, stash it on - ;; the NEW-BVL list, and also parse it to extract the keyword, which - ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's - ;; nothing for us to do. - (when (endp tail) - (go ignore)) - (let ((item (pop tail))) - (push item new-bvl) - (case item - ((&aux &allow-other-keys) (go ignore)) - (&other-keys (go fix-tail))) - (let ((keyword (if (symbolp item) - (intern (symbol-name item) :keyword) - (let ((var (car item))) - (if (symbolp var) - (intern (symbol-name var) :keyword) - (car var)))))) - (push keyword keywords)) - (go scan-keywords)) - - fix-tail - ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var. - (pop new-bvl) - (when (endp tail) - (error "Missing &OTHER-KEYS argument name")) - (setf other-keys-var (pop tail)) - (push '&allow-other-keys new-bvl) - - ;; There should be an &AUX next. If there isn't, assume there isn't - ;; one and provide our own. (This is safe as long as nobody else is - ;; expecting to plumb in lambda keywords too.) - (when (and (not (endp tail)) (eq (car tail) '&aux)) - (pop tail)) - (push '&aux new-bvl) - - ;; Add our shiny new &AUX argument. - (let ((keys-var (gensym "KEYS")) - (list-var (gensym "LIST"))) - (push `(,other-keys-var (do ((,list-var nil) - (,keys-var ,rest-var (cddr ,keys-var))) - ((endp ,keys-var) (nreverse ,list-var)) - (unless (member (car ,keys-var) - ',keywords) - (setf ,list-var - (cons (cadr ,keys-var) - (cons (car ,keys-var) - ,list-var)))))) - new-bvl)) - - ;; Done. - (return (nreconc new-bvl tail)) - - ignore - ;; Nothing to do. Return the unmolested lambda-list. - (return bvl)))) - -(defmacro lambda-otherkeys (bvl &body body) - "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword." - `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body)) - -(defmacro defun-otherkeys (name bvl &body body) - "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword." - `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body)) - -(defmacro defmethod-otherkeys (name &rest stuff) - "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword." - (do ((quals nil) - (stuff stuff (cdr stuff))) - ((listp (car stuff)) - `(defmethod ,name ,@(nreverse quals) - ,(transform-otherkeys-lambda-list (car stuff)) - ,@(cdr stuff))) - (push (car stuff) quals))) - -;;;-------------------------------------------------------------------------- -;;; Iteration macros. - -(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body) - "Macro for iterating over general sequences. - - Iterates over a (sub)sequence SEQ, delimited by START and END (which are - evaluated). For each item of SEQ, BODY is invoked with VAR bound to the - item, and INDEXVAR (if requested) bound to the item's index. (Note that - this is different from most iteration constructs in Common Lisp, which - work by mutating the variable.) - - The loop is surrounded by an anonymous BLOCK and the loop body forms an - implicit TAGBODY, as is usual. There is no result-form, however." - - (let ((seqvar (gensym "SEQ")) - (startvar (gensym "START")) - (endvar (gensym "END")) - (ivar (gensym "INDEX")) - (bodyfunc (gensym "BODY"))) - - (flet ((loopguts (indexp listp use-endp) - ;; Build a DO-loop to do what we want. - (let* ((do-vars nil) - (end-condition (if use-endp - `(endp ,seqvar) - `(>= ,ivar ,endvar))) - (item (if listp - `(car ,seqvar) - `(aref ,seqvar ,ivar))) - (body-call `(,bodyfunc ,item))) - (when listp - (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar)) - do-vars)) - (when indexp - (push `(,ivar ,startvar (1+ ,ivar)) do-vars)) - (when indexvar - (setf body-call (append body-call (list ivar)))) - `(do ,do-vars (,end-condition) ,body-call)))) - - `(block nil - (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) - (tagbody ,@body))) - (let* ((,seqvar ,seq) - (,startvar ,start)) - (etypecase ,seqvar - (vector - (let ((,endvar (or ,end (length ,seqvar)))) - ,(loopguts t nil nil))) - (list - (let ((,endvar ,end)) - (if ,endvar - ,(loopguts t t nil) - ,(loopguts indexvar t t))))))))))) - -;;;-------------------------------------------------------------------------- -;;; Meta-object hacking. - -(defgeneric copy-instance-using-class (class object &rest initargs) - (:documentation - "Return a copy of OBJECT. - - OBJECT is assumed to be an instance of CLASS. The copy returned is a - fresh instance whose slots have the same values as OBJECT except where - overridden by INITARGS.") - - (:method ((class standard-class) object &rest initargs) - (let ((copy (apply #'allocate-instance class initargs))) - (dolist (slot (class-slots class)) - (if (slot-boundp-using-class class object slot) - (setf (slot-value-using-class class copy slot) - (slot-value-using-class class object slot)) - (slot-makunbound-using-class class copy slot))) - (apply #'shared-initialize copy nil initargs) - copy))) - -(defun copy-instance (object &rest initargs) - "Return a copy of OBJECT. - - The copy returned is a fresh instance whose slots have the same values as - OBJECT except where overridden by INITARGS." - (apply #'copy-instance-using-class (class-of object) object initargs)) - -(defmacro default-slot ((instance slot) &body value &environment env) - "If INSTANCE's SLOT is unbound, set it to VALUE. - - Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only - evaluated if it's needed." - - (let* ((quotep (constantp slot env)) - (instancevar (gensym "INSTANCE")) - (slotvar (if quotep slot (gensym "SLOT")))) - `(let ((,instancevar ,instance) - ,@(and (not quotep) `((,slotvar ,slot)))) - (unless (slot-boundp ,instancevar ,slotvar) - (setf (slot-value ,instancevar ,slotvar) - (progn ,@value)))))) - -;;;----- That's all, folks --------------------------------------------------