+++ /dev/null
-;;; -*-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 --------------------------------------------------
~mdw / sod / blobdiff