| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Various handy utilities |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 11 | ;;; |
| 12 | ;;; SOD is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; SOD is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with SOD; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 27 | (handler-bind ((warning #'muffle-warning)) |
| 28 | (cl:defpackage #:sod-utilities |
| 29 | (:use #:common-lisp |
| 30 | |
| 31 | ;; MOP from somewhere. |
| 32 | #+sbcl #:sb-mop |
| 33 | #+(or cmu clisp) #:mop |
| 34 | #+ecl #:clos)))) |
| 35 | |
| 36 | (cl:in-package #:sod-utilities) |
| 37 | |
| 38 | ;;;-------------------------------------------------------------------------- |
| 39 | ;;; Common symbols. |
| 40 | ;;; |
| 41 | ;;; Sometimes, logically independent packages will want to use the same |
| 42 | ;;; symbol, and these uses (by careful design) don't conflict with each |
| 43 | ;;; other. If we export the symbols here, then the necessary sharing will |
| 44 | ;;; happen automatically. |
| 45 | |
| 46 | (export 'int) ; used by c-types and optparse |
| 47 | |
| 48 | ;;;-------------------------------------------------------------------------- |
| 49 | ;;; Macro hacks. |
| 50 | |
| 51 | (export 'with-gensyms) |
| 52 | (defmacro with-gensyms ((&rest binds) &body body) |
| 53 | "Evaluate BODY with variables bound to fresh symbols. |
| 54 | |
| 55 | The BINDS are a list of entries (VAR [NAME]), and a singleton list can be |
| 56 | replaced by just a symbol; each VAR is bound to a fresh symbol generated |
| 57 | by (gensym NAME), where NAME defaults to the symbol-name of VAR." |
| 58 | `(let (,@(mapcar (lambda (bind) |
| 59 | (multiple-value-bind (var name) |
| 60 | (if (atom bind) |
| 61 | (values bind (concatenate 'string |
| 62 | (symbol-name bind) "-")) |
| 63 | (destructuring-bind |
| 64 | (var &optional |
| 65 | (name (concatenate 'string |
| 66 | (symbol-name var) "-"))) |
| 67 | bind |
| 68 | (values var name))) |
| 69 | `(,var (gensym ,name)))) |
| 70 | binds)) |
| 71 | ,@body)) |
| 72 | |
| 73 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 74 | (defun strip-quote (form) |
| 75 | "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO. |
| 76 | |
| 77 | If FORM is a symbol whose constant value is `nil' then return `nil'. |
| 78 | Otherwise return FORM unchanged. This makes it easier to inspect constant |
| 79 | things. This is a utility for `once-only'." |
| 80 | |
| 81 | (cond ((and (consp form) |
| 82 | (eq (car form) 'quote) |
| 83 | (cdr form) |
| 84 | (null (cddr form))) |
| 85 | (let ((body (cadr form))) |
| 86 | (if (or (not (or (consp body) (symbolp body))) |
| 87 | (member body '(t nil)) |
| 88 | (keywordp body)) |
| 89 | body |
| 90 | form))) |
| 91 | ((and (symbolp form) (boundp form) (null (symbol-value form))) |
| 92 | nil) |
| 93 | (t |
| 94 | form)))) |
| 95 | |
| 96 | (export 'once-only) |
| 97 | (defmacro once-only ((&rest binds) &body body) |
| 98 | "Macro helper for preventing repeated evaluation. |
| 99 | |
| 100 | The syntax is actually hairier than shown: |
| 101 | |
| 102 | once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* ) |
| 103 | { FORM }* |
| 104 | |
| 105 | So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list |
| 106 | can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR. |
| 107 | But before them you can have keyword arguments. Only one is defined so |
| 108 | far. See below for the crazy things that does. |
| 109 | |
| 110 | The result of evaluating a ONCE-ONLY form is a form with the structure |
| 111 | |
| 112 | (let ((#:GS1 VALUE-FORM1) |
| 113 | ... |
| 114 | (#:GSn VALUE-FORMn)) |
| 115 | STUFF) |
| 116 | |
| 117 | where STUFF is the value of the BODY forms, as an implicit progn, in an |
| 118 | environment with the VARs bound to the corresponding gensyms. |
| 119 | |
| 120 | As additional magic, if any of the VALUE-FORMs is actually constant (as |
| 121 | determined by inspection, and aided by `constantp' if an :environment is |
| 122 | supplied, then no gensym is constructed for it, and the VAR is bound |
| 123 | directly to the constant form. Moreover, if the constant form looks like |
| 124 | (quote FOO) for a self-evaluating FOO then the outer layer of quoting is |
| 125 | stripped away." |
| 126 | |
| 127 | ;; We need an extra layer of gensyms in our expansion: we'll want the |
| 128 | ;; expansion to examine the various VALUE-FORMs to find out whether they're |
| 129 | ;; constant without evaluating them repeatedly. This also helps with |
| 130 | ;; another problem: we explicitly encourage the rebinding of a VAR |
| 131 | ;; (probably a macro argument) to a gensym which will be bound to the value |
| 132 | ;; of the form previously held in VAR itself -- so the gensym and value |
| 133 | ;; form must exist at the same time and we need two distinct variables. |
| 134 | |
| 135 | (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-")) |
| 136 | (let ((env nil)) |
| 137 | |
| 138 | ;; First things first: let's pick up the keywords. |
| 139 | (loop |
| 140 | (unless (and binds (keywordp (car binds))) |
| 141 | (return)) |
| 142 | (ecase (pop binds) |
| 143 | (:environment (setf env (pop binds))))) |
| 144 | |
| 145 | ;; Now we'll investigate the bindings. Turn each one into a list (VAR |
| 146 | ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note |
| 147 | ;; above. |
| 148 | (let ((canon (mapcar (lambda (bind) |
| 149 | (multiple-value-bind (var form) |
| 150 | (if (atom bind) |
| 151 | (values bind bind) |
| 152 | (destructuring-bind |
| 153 | (var &optional (form var)) bind |
| 154 | (values var form))) |
| 155 | (list var form |
| 156 | (gensym (format nil "T-~A-" |
| 157 | (symbol-name var)))))) |
| 158 | binds))) |
| 159 | |
| 160 | `(let* (,@(and env `((,envvar ,env))) |
| 161 | (,lets nil) |
| 162 | ,@(mapcar (lambda (bind) |
| 163 | (destructuring-bind (var form temp) bind |
| 164 | (declare (ignore var)) |
| 165 | `(,temp ,form))) |
| 166 | canon) |
| 167 | ,@(mapcar (lambda (bind) |
| 168 | (destructuring-bind (var form temp) bind |
| 169 | (declare (ignore form)) |
| 170 | `(,var |
| 171 | (cond ((constantp ,temp |
| 172 | ,@(and env `(,envvar))) |
| 173 | (strip-quote ,temp)) |
| 174 | ((symbolp ,temp) |
| 175 | ,temp) |
| 176 | (t |
| 177 | (let ((,sym (gensym |
| 178 | ,(concatenate 'string |
| 179 | (symbol-name var) |
| 180 | "-")))) |
| 181 | (push (list ,sym ,temp) ,lets) |
| 182 | ,sym)))))) |
| 183 | canon)) |
| 184 | (flet ((,bodyfunc () ,@body)) |
| 185 | (if ,lets |
| 186 | `(let (,@(nreverse ,lets)) ,(,bodyfunc)) |
| 187 | (,bodyfunc)))))))) |
| 188 | |
| 189 | (export 'parse-body) |
| 190 | (defun parse-body (body &key (docp t) (declp t)) |
| 191 | "Parse the BODY into a docstring, declarations and the body forms. |
| 192 | |
| 193 | These are returned as three lists, so that they can be spliced into a |
| 194 | macro expansion easily. The declarations are consolidated into a single |
| 195 | `declare' form. If DOCP is nil then a docstring is not permitted; if |
| 196 | DECLP is nil, then declarations are not permitted." |
| 197 | (let ((decls nil) |
| 198 | (doc nil)) |
| 199 | (loop |
| 200 | (cond ((null body) (return)) |
| 201 | ((and declp (consp (car body)) (eq (caar body) 'declare)) |
| 202 | (setf decls (append decls (cdr (pop body))))) |
| 203 | ((and docp (stringp (car body)) (not doc) (cdr body)) |
| 204 | (setf doc (pop body))) |
| 205 | (t (return)))) |
| 206 | (values (and doc (list doc)) |
| 207 | (and decls (list (cons 'declare decls))) |
| 208 | body))) |
| 209 | |
| 210 | ;;;-------------------------------------------------------------------------- |
| 211 | ;;; Locatives. |
| 212 | |
| 213 | (export '(loc locp)) |
| 214 | (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) |
| 215 | "Locative data type. See `locf' and `ref'." |
| 216 | (reader nil :type function) |
| 217 | (writer nil :type function)) |
| 218 | |
| 219 | (export 'locf) |
| 220 | (defmacro locf (place &environment env) |
| 221 | "Slightly cheesy locatives. |
| 222 | |
| 223 | (locf PLACE) returns an object which, using the `ref' function, can be |
| 224 | used to read or set the value of PLACE. It's cheesy because it uses |
| 225 | closures rather than actually taking the address of something. Also, |
| 226 | unlike Zetalisp, we don't overload `car' to do our dirty work." |
| 227 | (multiple-value-bind |
| 228 | (valtmps valforms newtmps setform getform) |
| 229 | (get-setf-expansion place env) |
| 230 | `(let* (,@(mapcar #'list valtmps valforms)) |
| 231 | (make-loc (lambda () ,getform) |
| 232 | (lambda (,@newtmps) ,setform))))) |
| 233 | |
| 234 | (export 'ref) |
| 235 | (declaim (inline ref (setf ref))) |
| 236 | (defun ref (loc) |
| 237 | "Fetch the value referred to by a locative." |
| 238 | (funcall (loc-reader loc))) |
| 239 | (defun (setf ref) (new loc) |
| 240 | "Store a new value in the place referred to by a locative." |
| 241 | (funcall (loc-writer loc) new)) |
| 242 | |
| 243 | (export 'with-locatives) |
| 244 | (defmacro with-locatives (locs &body body) |
| 245 | "Evaluate BODY with implicit locatives. |
| 246 | |
| 247 | LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a |
| 248 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it |
| 249 | defaults to SYM. As an abbreviation for a common case, LOCS may be a |
| 250 | symbol instead of a list. |
| 251 | |
| 252 | The BODY is evaluated in an environment where each SYM is a symbol macro |
| 253 | which expands to (ref LOC-EXPR) -- or, in fact, something similar which |
| 254 | doesn't break if LOC-EXPR has side-effects. Thus, references, including |
| 255 | `setf' forms, fetch or modify the thing referred to by the LOC-EXPR. |
| 256 | Useful for covering over where something uses a locative." |
| 257 | (setf locs (mapcar (lambda (item) |
| 258 | (cond ((atom item) (list item item)) |
| 259 | ((null (cdr item)) (list (car item) (car item))) |
| 260 | (t item))) |
| 261 | (if (listp locs) locs (list locs)))) |
| 262 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) |
| 263 | (ll (mapcar #'cadr locs)) |
| 264 | (ss (mapcar #'car locs))) |
| 265 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) |
| 266 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) |
| 267 | `(,sym (ref ,tmp))) ss tt)) |
| 268 | ,@body)))) |
| 269 | |
| 270 | ;;;-------------------------------------------------------------------------- |
| 271 | ;;; Anaphorics. |
| 272 | |
| 273 | (export 'it) |
| 274 | |
| 275 | (export 'aif) |
| 276 | (defmacro aif (cond cons &optional (alt nil altp)) |
| 277 | "If COND is not nil, evaluate CONS with `it' bound to the value of COND. |
| 278 | |
| 279 | Otherwise, if given, evaluate ALT; `it' isn't bound in ALT." |
| 280 | (once-only (cond) |
| 281 | `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt))))) |
| 282 | |
| 283 | (export 'awhen) |
| 284 | (defmacro awhen (cond &body body) |
| 285 | "If COND, evaluate BODY as a progn with `it' bound to the value of COND." |
| 286 | `(let ((it ,cond)) (when it ,@body))) |
| 287 | |
| 288 | (export 'aand) |
| 289 | (defmacro aand (&rest forms) |
| 290 | "Like `and', but anaphoric. |
| 291 | |
| 292 | Each FORM except the first is evaluated with `it' bound to the value of |
| 293 | the previous one. If there are no forms, then the result it `t'; if there |
| 294 | is exactly one, then wrapping it in `aand' is pointless." |
| 295 | (labels ((doit (first rest) |
| 296 | (if (null rest) |
| 297 | first |
| 298 | `(let ((it ,first)) |
| 299 | (if it ,(doit (car rest) (cdr rest)) nil))))) |
| 300 | (if (null forms) |
| 301 | 't |
| 302 | (doit (car forms) (cdr forms))))) |
| 303 | |
| 304 | (export 'acond) |
| 305 | (defmacro acond (&body clauses &environment env) |
| 306 | "Like COND, but with `it' bound to the value of the condition. |
| 307 | |
| 308 | Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is |
| 309 | non-nil then evaluate the FORMs with `it' bound to the non-nil value, and |
| 310 | return the value of the last FORM; if there are no FORMs, then return `it' |
| 311 | itself. If the CONDITION is nil then continue with the next clause; if |
| 312 | all clauses evaluate to nil then the result is nil." |
| 313 | (labels ((walk (clauses) |
| 314 | (if (null clauses) |
| 315 | `nil |
| 316 | (once-only (:environment env (cond (caar clauses))) |
| 317 | (if (and (constantp cond) |
| 318 | (if (and (consp cond) (eq (car cond) 'quote)) |
| 319 | (cadr cond) cond)) |
| 320 | (if (cdar clauses) |
| 321 | `(let ((it ,cond)) |
| 322 | (declare (ignorable it)) |
| 323 | ,@(cdar clauses)) |
| 324 | cond) |
| 325 | `(if ,cond |
| 326 | ,(if (cdar clauses) |
| 327 | `(let ((it ,cond)) |
| 328 | (declare (ignorable it)) |
| 329 | ,@(cdar clauses)) |
| 330 | cond) |
| 331 | ,(walk (cdr clauses)))))))) |
| 332 | (walk clauses))) |
| 333 | |
| 334 | (export '(acase aecase atypecase aetypecase)) |
| 335 | (defmacro acase (value &body clauses) |
| 336 | `(let ((it ,value)) (case it ,@clauses))) |
| 337 | (defmacro aecase (value &body clauses) |
| 338 | `(let ((it ,value)) (ecase it ,@clauses))) |
| 339 | (defmacro atypecase (value &body clauses) |
| 340 | `(let ((it ,value)) (typecase it ,@clauses))) |
| 341 | (defmacro aetypecase (value &body clauses) |
| 342 | `(let ((it ,value)) (etypecase it ,@clauses))) |
| 343 | |
| 344 | (export 'asetf) |
| 345 | (defmacro asetf (&rest places-and-values &environment env) |
| 346 | "Anaphoric update of places. |
| 347 | |
| 348 | The PLACES-AND-VALUES are alternating PLACEs and VALUEs. Each VALUE is |
| 349 | evaluated with IT bound to the current value stored in the corresponding |
| 350 | PLACE." |
| 351 | `(progn ,@(loop for (place value) on places-and-values by #'cddr |
| 352 | collect (multiple-value-bind |
| 353 | (temps inits newtemps setform getform) |
| 354 | (get-setf-expansion place env) |
| 355 | `(let* (,@(mapcar #'list temps inits) |
| 356 | (it ,getform)) |
| 357 | (multiple-value-bind ,newtemps ,value |
| 358 | ,setform)))))) |
| 359 | |
| 360 | ;;;-------------------------------------------------------------------------- |
| 361 | ;;; MOP hacks (not terribly demanding). |
| 362 | |
| 363 | (export 'instance-initargs) |
| 364 | (defgeneric instance-initargs (instance) |
| 365 | (:documentation |
| 366 | "Return a plausble list of initargs for INSTANCE. |
| 367 | |
| 368 | The idea is that you can make a copy of INSTANCE by invoking |
| 369 | |
| 370 | (apply #'make-instance (class-of INSTANCE) |
| 371 | (instance-initargs INSTANCE)) |
| 372 | |
| 373 | The default implementation works by inspecting the slot definitions and |
| 374 | extracting suitable initargs, so this will only succeed if enough slots |
| 375 | actually have initargs specified that `initialize-instance' can fill in |
| 376 | the rest correctly. |
| 377 | |
| 378 | The list returned is freshly consed, and you can destroy it if you like.") |
| 379 | (:method ((instance standard-object)) |
| 380 | (mapcan (lambda (slot) |
| 381 | (aif (slot-definition-initargs slot) |
| 382 | (list (car it) |
| 383 | (slot-value instance (slot-definition-name slot))) |
| 384 | nil)) |
| 385 | (class-slots (class-of instance))))) |
| 386 | |
| 387 | (export '(copy-instance copy-instance-using-class)) |
| 388 | (defgeneric copy-instance-using-class (class instance &rest initargs) |
| 389 | (:documentation |
| 390 | "Metaobject protocol hook for `copy-instance'.") |
| 391 | (:method ((class standard-class) instance &rest initargs) |
| 392 | (let ((copy (allocate-instance class))) |
| 393 | (dolist (slot (class-slots class)) |
| 394 | (let ((name (slot-definition-name slot))) |
| 395 | (when (slot-boundp instance name) |
| 396 | (setf (slot-value copy name) (slot-value instance name))))) |
| 397 | (apply #'shared-initialize copy nil initargs)))) |
| 398 | (defun copy-instance (object &rest initargs) |
| 399 | "Construct and return a copy of OBJECT. |
| 400 | |
| 401 | The new object has the same class as OBJECT, and the same slot values |
| 402 | except where overridden by INITARGS." |
| 403 | (apply #'copy-instance-using-class (class-of object) object initargs)) |
| 404 | |
| 405 | (export '(generic-function-methods method-specializers |
| 406 | eql-specializer eql-specializer-object)) |
| 407 | |
| 408 | ;;;-------------------------------------------------------------------------- |
| 409 | ;;; List utilities. |
| 410 | |
| 411 | (export 'make-list-builder) |
| 412 | (defun make-list-builder (&optional initial) |
| 413 | "Return a simple list builder." |
| 414 | |
| 415 | ;; The `builder' is just a cons cell whose cdr will be the list that's |
| 416 | ;; wanted. Effectively, then, we have a list that's one item longer than |
| 417 | ;; we actually want. The car of this extra initial cons cell is always the |
| 418 | ;; last cons in the list -- which is now well defined because there's |
| 419 | ;; always at least one. |
| 420 | |
| 421 | (let ((builder (cons nil initial))) |
| 422 | (setf (car builder) (last builder)) |
| 423 | builder)) |
| 424 | |
| 425 | (export 'lbuild-add) |
| 426 | (defun lbuild-add (builder item) |
| 427 | "Add an ITEM to the end of a list BUILDER." |
| 428 | (let ((new (cons item nil))) |
| 429 | (setf (cdar builder) new |
| 430 | (car builder) new)) |
| 431 | builder) |
| 432 | |
| 433 | (export 'lbuild-add-list) |
| 434 | (defun lbuild-add-list (builder list) |
| 435 | "Add a LIST to the end of a list BUILDER. The LIST will be clobbered." |
| 436 | (when list |
| 437 | (setf (cdar builder) list |
| 438 | (car builder) (last list))) |
| 439 | builder) |
| 440 | |
| 441 | (export 'lbuild-list) |
| 442 | (defun lbuild-list (builder) |
| 443 | "Return the constructed list." |
| 444 | (cdr builder)) |
| 445 | |
| 446 | (export 'mappend) |
| 447 | (defun mappend (function list &rest more-lists) |
| 448 | "Like a nondestructive `mapcan'. |
| 449 | |
| 450 | Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, |
| 451 | and return the result of appending all of the resulting lists." |
| 452 | (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) |
| 453 | |
| 454 | (export 'cross-product) |
| 455 | (defun cross-product (&rest pieces) |
| 456 | "Return the cross product of the PIECES. |
| 457 | |
| 458 | Each arguments may be a list, or a (non-nil) atom, which is equivalent to |
| 459 | a singleton list containing just that atom. Return a list of all possible |
| 460 | lists which can be constructed by taking one item from each argument list |
| 461 | in turn, in an arbitrary order." |
| 462 | (reduce (lambda (piece tails) |
| 463 | (mapcan (lambda (tail) |
| 464 | (mapcar (lambda (head) |
| 465 | (cons head tail)) |
| 466 | (if (listp piece) piece |
| 467 | (list piece)))) |
| 468 | tails)) |
| 469 | pieces |
| 470 | :from-end t |
| 471 | :initial-value '(nil))) |
| 472 | |
| 473 | (export 'distinguished-point-shortest-paths) |
| 474 | (defun distinguished-point-shortest-paths (root neighbours-func) |
| 475 | "Moderately efficient shortest-paths-from-root computation. |
| 476 | |
| 477 | The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC |
| 478 | accepts a VERTEX as its only argument, and returns a list of conses (V . |
| 479 | C) for each of the VERTEX's neighbours, indicating that there is an edge |
| 480 | from VERTEX to V, with cost C. |
| 481 | |
| 482 | The return value is a list of entries (COST . REV-PATH) for each vertex |
| 483 | reachable from the ROOT; the COST is the total cost of the shortest path, |
| 484 | and REV-PATH is the path from the ROOT, in reverse order -- so the first |
| 485 | element is the vertex itself and the last element is the ROOT. |
| 486 | |
| 487 | The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to |
| 488 | produce its output list. The computation as a whole takes O(N^2) time, |
| 489 | where N is the number of vertices in the graph, assuming there is at most |
| 490 | one edge between any pair of vertices." |
| 491 | |
| 492 | ;; This is a listish version of Dijkstra's shortest-path algorithm. It |
| 493 | ;; could be made more efficient by using a fancy priority queue rather than |
| 494 | ;; a linear search for finding the nearest live element (see below), but it |
| 495 | ;; still runs pretty well. |
| 496 | |
| 497 | (let ((map (make-hash-table)) |
| 498 | (dead nil) |
| 499 | (live (list (list 0 root)))) |
| 500 | (setf (gethash root map) (cons :live (car live))) |
| 501 | (loop |
| 502 | ;; The dead list contains a record, in output format (COST . PATH), for |
| 503 | ;; each vertex whose shortest path has been finally decided. The live |
| 504 | ;; list contains a record for the vertices of current interest, also in |
| 505 | ;; output format; the COST for a live record shows the best cost for a |
| 506 | ;; path using only dead vertices. |
| 507 | ;; |
| 508 | ;; Each time through here, we pull an item off the live list and |
| 509 | ;; push it onto the dead list, so we do at most N iterations total. |
| 510 | |
| 511 | ;; If there are no more live items, then we're done; the remaining |
| 512 | ;; vertices, if any, are unreachable from the ROOT. |
| 513 | (when (null live) (return)) |
| 514 | |
| 515 | ;; Find the closest live vertex to the root. The linear scan through |
| 516 | ;; the live list costs at most N time. |
| 517 | (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live)) |
| 518 | (best-cost (car best)) |
| 519 | (best-path (cdr best)) |
| 520 | (best-vertex (car best-path))) |
| 521 | |
| 522 | ;; Remove the chosen vertex from the LIVE list, and add the |
| 523 | ;; appropriate record to the dead list. We must have the shortest |
| 524 | ;; path to this vertex now: we have the shortest path using currently |
| 525 | ;; dead vertices; any other path must use at least one live vertex, |
| 526 | ;; and, by construction, the path through any such vertex must be |
| 527 | ;; further than the path we already have. |
| 528 | ;; |
| 529 | ;; Removal from the live list uses a linear scan which costs N time. |
| 530 | (setf live (delete best live)) |
| 531 | (push best dead) |
| 532 | (setf (car (gethash best-vertex map)) :dead) |
| 533 | |
| 534 | ;; Work through the chosen vertex's neighbours, adding each of them |
| 535 | ;; to the live list if they're not already there. If a neighbour is |
| 536 | ;; already live, and we find a shorter path to it through our chosen |
| 537 | ;; vertex, then update the neighbour's record. |
| 538 | ;; |
| 539 | ;; The chosen vertex obviously has at most N neighbours. There's no |
| 540 | ;; more looping in here, so performance is as claimed. |
| 541 | (dolist (neigh (funcall neighbours-func best-vertex)) |
| 542 | (let* ((neigh-vertex (car neigh)) |
| 543 | (neigh-cost (+ best-cost (cdr neigh))) |
| 544 | (neigh-record (gethash neigh-vertex map))) |
| 545 | (cond ((null neigh-record) |
| 546 | ;; If the neighbour isn't known, then now's the time to |
| 547 | ;; make a fresh live record for it. |
| 548 | (let ((new-record (list* :live neigh-cost |
| 549 | neigh-vertex best-path))) |
| 550 | (push (cdr new-record) live) |
| 551 | (setf (gethash neigh-vertex map) new-record))) |
| 552 | ((and (eq (car neigh-record) :live) |
| 553 | (< neigh-cost (cadr neigh-record))) |
| 554 | ;; If the neighbour is live, and we've found a better path |
| 555 | ;; to it, then update its record. |
| 556 | (setf (cadr neigh-record) neigh-cost |
| 557 | (cdddr neigh-record) best-path))))))) |
| 558 | dead)) |
| 559 | |
| 560 | (export '(inconsistent-merge-error |
| 561 | merge-error-candidates merge-error-present-function)) |
| 562 | (define-condition inconsistent-merge-error (error) |
| 563 | ((candidates :initarg :candidates |
| 564 | :reader merge-error-candidates) |
| 565 | (present :initarg :present :initform #'identity |
| 566 | :reader merge-error-present-function)) |
| 567 | (:documentation |
| 568 | "Reports an inconsistency in the arguments passed to `merge-lists'.") |
| 569 | (:report (lambda (condition stream) |
| 570 | (format stream "Merge inconsistency: failed to decide between ~ |
| 571 | ~{~#[~;~A~;~A and ~A~:;~ |
| 572 | ~@{~A, ~#[~;and ~A~]~}~]~}" |
| 573 | (mapcar (merge-error-present-function condition) |
| 574 | (merge-error-candidates condition)))))) |
| 575 | |
| 576 | (export 'merge-lists) |
| 577 | (defun merge-lists (lists &key pick (test #'eql) (present #'identity)) |
| 578 | "Return a merge of the given LISTS. |
| 579 | |
| 580 | The resulting list contains the items of the given LISTS, with duplicates |
| 581 | removed. The order of the resulting list is consistent with the orders of |
| 582 | the input LISTS in the sense that if A precedes B in some input list then |
| 583 | A will also precede B in the output list. If the lists aren't consistent |
| 584 | (e.g., some list contains A followed by B, and another contains B followed |
| 585 | by A) then an error of type `inconsistent-merge-error' is signalled. The |
| 586 | offending items are filtered for presentation through the PRESENT function |
| 587 | before being attached to the condition, so as to produce a more useful |
| 588 | diagnostic message. |
| 589 | |
| 590 | Item equality is determined by TEST. |
| 591 | |
| 592 | If there is an ambiguity at any point -- i.e., a choice between two or |
| 593 | more possible next items to emit -- then PICK is called to arbitrate. |
| 594 | PICK is called with two arguments: the list of candidate next items, and |
| 595 | the current output list. It should return one of the candidate items. |
| 596 | The order of the candidates in the list given to the PICK function |
| 597 | reflects their order in the input LISTS: item A will precede item B in the |
| 598 | candidates list if and only if an occurrence of A appears in an earlier |
| 599 | input list than any occurrence of item B. (This completely determines the |
| 600 | order of the candidates: it is not possible that two candidates appear in |
| 601 | the same input list, since that would resolve the ambiguity between them.) |
| 602 | If PICK is omitted then the item chosen is the one appearing in the |
| 603 | earliest of the input lists: i.e., effectively, the default PICK function |
| 604 | is |
| 605 | |
| 606 | (lambda (candidates output-so-far) |
| 607 | (declare (ignore output-so-far)) |
| 608 | (car candidates)) |
| 609 | |
| 610 | The primary use of this function is in computing class precedence lists. |
| 611 | By building the input lists and selecting the PICK function appropriately, |
| 612 | a variety of different CPL algorithms can be implemented." |
| 613 | |
| 614 | (do ((lb (make-list-builder))) |
| 615 | ((null lists) (lbuild-list lb)) |
| 616 | |
| 617 | ;; The candidate items are the ones at the front of the input lists. |
| 618 | ;; Gather them up, removing duplicates. If a candidate is somewhere in |
| 619 | ;; one of the other lists other than at the front then we reject it. If |
| 620 | ;; we've just rejected everything, then we can make no more progress and |
| 621 | ;; the input lists were inconsistent. |
| 622 | (let* ((candidates (delete-duplicates (mapcar #'car lists) |
| 623 | :test test :from-end t)) |
| 624 | (leasts (remove-if (lambda (item) |
| 625 | (some (lambda (list) |
| 626 | (member item (cdr list) :test test)) |
| 627 | lists)) |
| 628 | candidates)) |
| 629 | (winner (cond ((null leasts) |
| 630 | (error 'inconsistent-merge-error |
| 631 | :candidates candidates |
| 632 | :present present)) |
| 633 | ((null (cdr leasts)) |
| 634 | (car leasts)) |
| 635 | (pick |
| 636 | (funcall pick leasts (lbuild-list lb))) |
| 637 | (t (car leasts))))) |
| 638 | |
| 639 | ;; Check that the PICK function isn't conning us. |
| 640 | (assert (member winner leasts :test test)) |
| 641 | |
| 642 | ;; Update the output list and remove the winning item from the input |
| 643 | ;; lists. We know that it must be at the front of each input list |
| 644 | ;; containing it. At this point, we discard input lists entirely when |
| 645 | ;; they run out of entries. The loop ends when there are no more input |
| 646 | ;; lists left, i.e., when we've munched all of the input items. |
| 647 | (lbuild-add lb winner) |
| 648 | (setf lists (delete nil (mapcar (lambda (list) |
| 649 | (if (funcall test winner (car list)) |
| 650 | (cdr list) |
| 651 | list)) |
| 652 | lists)))))) |
| 653 | |
| 654 | (export 'categorize) |
| 655 | (defmacro categorize ((itemvar items &key bind) categories &body body) |
| 656 | "Categorize ITEMS into lists and invoke BODY. |
| 657 | |
| 658 | The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR |
| 659 | will contain the current item. The BIND argument is a list of LET*-like |
| 660 | clauses. The CATEGORIES are a list of clauses of the form (SYMBOL |
| 661 | PREDICATE). |
| 662 | |
| 663 | The behaviour of the macro is as follows. ITEMVAR is assigned (not |
| 664 | bound), in turn, each item in the list ITEMS. The PREDICATEs in the |
| 665 | CATEGORIES list are evaluated in turn, in an environment containing |
| 666 | ITEMVAR and the BINDings, until one of them evaluates to a non-nil value. |
| 667 | At this point, the item is assigned to the category named by the |
| 668 | corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an |
| 669 | error is signalled; a PREDICATE consisting only of T will (of course) |
| 670 | match anything; it is detected specially so as to avoid compiler warnings. |
| 671 | |
| 672 | Once all of the ITEMS have been categorized in this fashion, the BODY is |
| 673 | evaluated as an implicit PROGN. For each SYMBOL naming a category, a |
| 674 | variable named after that symbol will be bound in the BODY's environment |
| 675 | to a list of the items in that category, in the same order in which they |
| 676 | were found in the list ITEMS. The final values of the macro are the final |
| 677 | values of the BODY." |
| 678 | |
| 679 | (let* ((cat-names (mapcar #'car categories)) |
| 680 | (cat-match-forms (mapcar #'cadr categories)) |
| 681 | (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string |
| 682 | (symbol-name name) "-"))) |
| 683 | cat-names)) |
| 684 | (items-var (gensym "ITEMS-"))) |
| 685 | `(let (,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) |
| 686 | (let ((,items-var ,items)) |
| 687 | (dolist (,itemvar ,items-var) |
| 688 | (let* ,bind |
| 689 | (cond ,@(mapcar (lambda (cat-match-form cat-var) |
| 690 | `(,cat-match-form |
| 691 | (push ,itemvar ,cat-var))) |
| 692 | cat-match-forms cat-vars) |
| 693 | ,@(and (not (member t cat-match-forms)) |
| 694 | `((t (error "Failed to categorize ~A" |
| 695 | ,itemvar)))))))) |
| 696 | (let ,(mapcar (lambda (name var) |
| 697 | `(,name (nreverse ,var))) |
| 698 | cat-names cat-vars) |
| 699 | ,@body)))) |
| 700 | |
| 701 | (export 'partial-order-minima) |
| 702 | (defun partial-order-minima (items order) |
| 703 | "Return a list of minimal items according to the non-strict partial ORDER. |
| 704 | |
| 705 | The ORDER function describes the partial order: (funcall ORDER X Y) should |
| 706 | return true if X precedes or is equal to Y in the order." |
| 707 | (reduce (lambda (tops this) |
| 708 | (let ((new nil) (keep t)) |
| 709 | (dolist (top tops) |
| 710 | (cond ((funcall order top this) |
| 711 | (setf keep nil) |
| 712 | (push top new)) |
| 713 | ((not (funcall order this top)) |
| 714 | (push top new)))) |
| 715 | (nreverse (if keep (cons this new) new)))) |
| 716 | items |
| 717 | :initial-value nil)) |
| 718 | |
| 719 | (export 'find-duplicates) |
| 720 | (defun find-duplicates (report sequence &key (key #'identity) (test #'eql)) |
| 721 | "Call REPORT on each pair of duplicate items in SEQUENCE. |
| 722 | |
| 723 | Duplicates are determined according to the KEY and TEST funcitons." |
| 724 | (when (symbolp test) (setf test (symbol-function test))) |
| 725 | (cond ((zerop (length sequence)) nil) |
| 726 | ((or (eq test #'eq) |
| 727 | (eq test #'eql) |
| 728 | (eq test #'equal) |
| 729 | (eq test #'equalp)) |
| 730 | (let ((seen (make-hash-table :test test))) |
| 731 | (map nil (lambda (item) |
| 732 | (let ((k (funcall key item))) |
| 733 | (multiple-value-bind (previous matchp) |
| 734 | (gethash k seen) |
| 735 | (if matchp (funcall report item previous) |
| 736 | (setf (gethash k seen) item))))) |
| 737 | sequence))) |
| 738 | ((listp sequence) |
| 739 | (do ((tail sequence (cdr tail)) |
| 740 | (i 0 (1+ i))) |
| 741 | ((endp tail)) |
| 742 | (let* ((item (car tail)) |
| 743 | (match (find (funcall key item) sequence |
| 744 | :test test :key key :end i))) |
| 745 | (when match (funcall report item match))))) |
| 746 | ((vectorp sequence) |
| 747 | (dotimes (i (length sequence)) |
| 748 | (let* ((item (aref sequence i)) |
| 749 | (pos (position (funcall key item) sequence |
| 750 | :key key :test test :end i))) |
| 751 | (when pos (funcall report item (aref sequence pos)))))) |
| 752 | (t |
| 753 | (error 'type-error :datum sequence :expected-type 'sequence)))) |
| 754 | |
| 755 | ;;;-------------------------------------------------------------------------- |
| 756 | ;;; Strings and characters. |
| 757 | |
| 758 | (export 'frob-identifier) |
| 759 | (defun frob-identifier (string &key (swap-case t) (swap-hyphen t)) |
| 760 | "Twiddles the case of STRING. |
| 761 | |
| 762 | If all the letters in STRING are uppercase, and SWAP-CASE is true, then |
| 763 | switch them to lowercase; if they're all lowercase then switch them to |
| 764 | uppercase. If there's a mix then leave them all alone. At the same time, |
| 765 | if there are underscores but no hyphens, and SWAP-HYPHEN is true, then |
| 766 | switch them to hyphens, if there are hyphens and no underscores, switch |
| 767 | them underscores, and if there are both then leave them alone. |
| 768 | |
| 769 | This is an invertible transformation, which turns vaguely plausible Lisp |
| 770 | names into vaguely plausible C names and vice versa. Lisp names with |
| 771 | `funny characters' like stars and percent signs won't be any use, of |
| 772 | course." |
| 773 | |
| 774 | ;; Work out what kind of a job we've got to do. Gather flags: bit 0 means |
| 775 | ;; there are upper-case letters; bit 1 means there are lower-case letters; |
| 776 | ;; bit 2 means there are hyphens; bit 3 means there are underscores. |
| 777 | ;; |
| 778 | ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set |
| 779 | ;; if we have to frob case; bit 3 is set if we have to swap hyphens and |
| 780 | ;; underscores. So use this to select functions which do bits of the |
| 781 | ;; mapping, and then compose them together. |
| 782 | (let* ((flags (reduce (lambda (state ch) |
| 783 | (logior state |
| 784 | (cond ((upper-case-p ch) 1) |
| 785 | ((lower-case-p ch) 2) |
| 786 | ((char= ch #\-) 4) |
| 787 | ((char= ch #\_) 8) |
| 788 | (t 0)))) |
| 789 | string |
| 790 | :initial-value 0)) |
| 791 | (mask (logxor flags (ash flags 1))) |
| 792 | (letter (cond ((or (not swap-case) (not (logbitp 1 mask))) |
| 793 | (constantly nil)) |
| 794 | ((logbitp 0 flags) |
| 795 | (lambda (ch) |
| 796 | (and (alpha-char-p ch) (char-downcase ch)))) |
| 797 | (t |
| 798 | (lambda (ch) |
| 799 | (and (alpha-char-p ch) (char-upcase ch)))))) |
| 800 | (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen)) |
| 801 | (constantly nil)) |
| 802 | ((logbitp 2 flags) |
| 803 | (lambda (ch) (and (char= ch #\-) #\_))) |
| 804 | (t |
| 805 | (lambda (ch) (and (char= ch #\_) #\-)))))) |
| 806 | |
| 807 | (if (logbitp 3 (logior mask (ash mask 2))) |
| 808 | (map 'string (lambda (ch) |
| 809 | (or (funcall letter ch) |
| 810 | (funcall uscore-hyphen ch) |
| 811 | ch)) |
| 812 | string) |
| 813 | string))) |
| 814 | |
| 815 | (export 'whitespace-char-p) |
| 816 | (declaim (inline whitespace-char-p)) |
| 817 | (defun whitespace-char-p (char) |
| 818 | "Returns whether CHAR is a whitespace character. |
| 819 | |
| 820 | Whitespaceness is determined relative to the compile-time readtable, which |
| 821 | is probably good enough for most purposes." |
| 822 | (case char |
| 823 | (#.(loop for i below char-code-limit |
| 824 | for ch = (code-char i) |
| 825 | unless (with-input-from-string (in (string ch)) |
| 826 | (peek-char t in nil)) |
| 827 | collect ch) t) |
| 828 | (t nil))) |
| 829 | |
| 830 | (export 'update-position) |
| 831 | (declaim (inline update-position)) |
| 832 | (defun update-position (char line column) |
| 833 | "Updates LINE and COLUMN appropriately for having read the character CHAR. |
| 834 | |
| 835 | Returns the new LINE and COLUMN numbers." |
| 836 | (case char |
| 837 | ((#\newline #\vt #\page) |
| 838 | (values (1+ line) 0)) |
| 839 | ((#\tab) |
| 840 | (values line (logandc2 (+ column 8) 7))) |
| 841 | (t |
| 842 | (values line (1+ column))))) |
| 843 | |
| 844 | (export 'backtrack-position) |
| 845 | (declaim (inline backtrack-position)) |
| 846 | (defun backtrack-position (char line column) |
| 847 | "Updates LINE and COLUMN appropriately for having unread CHAR. |
| 848 | |
| 849 | Well, actually an approximation for it; it will likely be wrong if the |
| 850 | last character was a tab. But when the character is read again, it will |
| 851 | be correct." |
| 852 | |
| 853 | ;; This isn't perfect: if the character doesn't actually match what was |
| 854 | ;; really read then it might not actually be possible: for example, if we |
| 855 | ;; push back a newline while in the middle of a line, or a tab while not at |
| 856 | ;; a tab stop. In that case, we'll just lose, but hopefully not too badly. |
| 857 | (case char |
| 858 | |
| 859 | ;; In the absence of better ideas, I'll set the column number to zero. |
| 860 | ;; This is almost certainly wrong, but with a little luck nobody will ask |
| 861 | ;; and it'll be all right soon. |
| 862 | ((#\newline #\vt #\page) (values (1- line) 0)) |
| 863 | |
| 864 | ;; Winding back a single space is sufficient. If the position is |
| 865 | ;; currently on a tab stop then it'll advance back here next time. If |
| 866 | ;; not, we're going to lose anyway because the previous character |
| 867 | ;; certainly couldn't have been a tab. |
| 868 | (#\tab (values line (1- column))) |
| 869 | |
| 870 | ;; Anything else: just decrement the column and cross fingers. |
| 871 | (t (values line (1- column))))) |
| 872 | |
| 873 | ;;;-------------------------------------------------------------------------- |
| 874 | ;;; Functions. |
| 875 | |
| 876 | (export 'compose) |
| 877 | (defun compose (&rest functions) |
| 878 | "Composition of functions. Functions are applied left-to-right. |
| 879 | |
| 880 | This is the reverse order of the usual mathematical notation, but I find |
| 881 | it easier to read. It's also slightly easier to work with in programs. |
| 882 | That is, (compose F1 F2 ... Fn) is what a category theorist might write as |
| 883 | F1 ; F2 ; ... ; Fn, rather than F1 o F2 o ... o Fn." |
| 884 | |
| 885 | (labels ((compose1 (func-a func-b) |
| 886 | (lambda (&rest args) |
| 887 | (multiple-value-call func-b (apply func-a args))))) |
| 888 | (if (null functions) #'values |
| 889 | (reduce #'compose1 (cdr functions) |
| 890 | :initial-value (car functions))))) |
| 891 | |
| 892 | ;;;-------------------------------------------------------------------------- |
| 893 | ;;; Variables. |
| 894 | |
| 895 | (export 'defvar-unbound) |
| 896 | (defmacro defvar-unbound (var doc) |
| 897 | "Make VAR a special variable with documentation DOC, but leave it unbound." |
| 898 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
| 899 | (defvar ,var) |
| 900 | (setf (documentation ',var 'variable) ',doc) |
| 901 | ',var)) |
| 902 | |
| 903 | ;;;-------------------------------------------------------------------------- |
| 904 | ;;; Symbols. |
| 905 | |
| 906 | (export 'symbolicate) |
| 907 | (defun symbolicate (&rest symbols) |
| 908 | "Return a symbol named after the concatenation of the names of the SYMBOLS. |
| 909 | |
| 910 | The symbol is interned in the current `*package*'. Trad." |
| 911 | (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) |
| 912 | |
| 913 | ;;;-------------------------------------------------------------------------- |
| 914 | ;;; Object printing. |
| 915 | |
| 916 | (export 'maybe-print-unreadable-object) |
| 917 | (defmacro maybe-print-unreadable-object |
| 918 | ((object stream &rest args) &body body) |
| 919 | "Print helper for usually-unreadable objects. |
| 920 | |
| 921 | If `*print-escape*' is set then print OBJECT unreadably using BODY. |
| 922 | Otherwise just print using BODY." |
| 923 | (with-gensyms (print) |
| 924 | `(flet ((,print () ,@body)) |
| 925 | (if *print-escape* |
| 926 | (print-unreadable-object (,object ,stream ,@args) |
| 927 | (,print)) |
| 928 | (,print))))) |
| 929 | |
| 930 | (export 'print-ugly-stuff) |
| 931 | (defun print-ugly-stuff (stream func) |
| 932 | "Print not-pretty things to the stream underlying STREAM. |
| 933 | |
| 934 | The Lisp pretty-printing machinery, notably `pprint-logical-block', may |
| 935 | interpose additional streams between its body and the original target |
| 936 | stream. This makes it difficult to make use of the underlying stream's |
| 937 | special features, whatever they might be." |
| 938 | |
| 939 | ;; This is unpleasant. Hacky hacky. |
| 940 | #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream) |
| 941 | (let ((target (sb-pretty::pretty-stream-target stream))) |
| 942 | (pprint-newline :mandatory stream) |
| 943 | (funcall func target)) |
| 944 | (funcall func stream)) |
| 945 | #+cmu '(if (typep stream 'pp:pretty-stream) |
| 946 | (let ((target (pp::pretty-stream-target stream))) |
| 947 | (pprint-newline :mandatory stream) |
| 948 | (funcall func target)) |
| 949 | (funcall func stream)) |
| 950 | '(funcall func stream))) |
| 951 | |
| 952 | ;;;-------------------------------------------------------------------------- |
| 953 | ;;; Iteration macros. |
| 954 | |
| 955 | (export 'dosequence) |
| 956 | (defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) |
| 957 | &body body |
| 958 | &environment env) |
| 959 | "Macro for iterating over general sequences. |
| 960 | |
| 961 | Iterates over a (sub)sequence SEQ, delimited by START and END (which are |
| 962 | evaluated). For each item of SEQ, BODY is invoked with VAR bound to the |
| 963 | item, and INDEXVAR (if requested) bound to the item's index. (Note that |
| 964 | this is different from most iteration constructs in Common Lisp, which |
| 965 | work by mutating the variable.) |
| 966 | |
| 967 | The loop is surrounded by an anonymous BLOCK and the loop body forms an |
| 968 | implicit TAGBODY, as is usual. There is no result-form, however." |
| 969 | |
| 970 | (once-only (:environment env start end) |
| 971 | (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-") |
| 972 | (endvar "END-") (bodyfunc "BODY-")) |
| 973 | (multiple-value-bind (docs decls body) (parse-body body :docp nil) |
| 974 | (declare (ignore docs)) |
| 975 | |
| 976 | (flet ((loopguts (indexp listp endvar) |
| 977 | ;; Build a DO-loop to do what we want. |
| 978 | (let* ((do-vars nil) |
| 979 | (end-condition (if endvar |
| 980 | `(>= ,ivar ,endvar) |
| 981 | `(endp ,seqvar))) |
| 982 | (item (if listp |
| 983 | `(car ,seqvar) |
| 984 | `(aref ,seqvar ,ivar))) |
| 985 | (body-call `(,bodyfunc ,item))) |
| 986 | (when listp |
| 987 | (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar)) |
| 988 | do-vars)) |
| 989 | (when indexp |
| 990 | (push `(,ivar ,start (1+ ,ivar)) do-vars)) |
| 991 | (when indexvar |
| 992 | (setf body-call (append body-call (list ivar)))) |
| 993 | `(do ,do-vars (,end-condition) ,body-call)))) |
| 994 | |
| 995 | `(block nil |
| 996 | (let ((,seqvar ,seq)) |
| 997 | (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) |
| 998 | ,@decls |
| 999 | (tagbody ,@body))) |
| 1000 | (etypecase ,seqvar |
| 1001 | (vector |
| 1002 | (let ((,endvar (or ,end (length ,seqvar)))) |
| 1003 | ,(loopguts t nil endvar))) |
| 1004 | (list |
| 1005 | (if ,end |
| 1006 | ,(loopguts t t end) |
| 1007 | ,(loopguts indexvar t nil)))))))))))) |
| 1008 | |
| 1009 | ;;;-------------------------------------------------------------------------- |
| 1010 | ;;; Structure accessor hacks. |
| 1011 | |
| 1012 | (export 'define-access-wrapper) |
| 1013 | (defmacro define-access-wrapper (from to &key read-only) |
| 1014 | "Make (FROM THING) work like (TO THING). |
| 1015 | |
| 1016 | If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like |
| 1017 | (setf (TO THING) VALUE). |
| 1018 | |
| 1019 | This is mostly useful for structure slot accessors where the slot has to |
| 1020 | be given an unpleasant name to avoid it being an external symbol." |
| 1021 | `(progn |
| 1022 | (declaim (inline ,from ,@(and (not read-only) `((setf ,from))))) |
| 1023 | (defun ,from (object) |
| 1024 | (,to object)) |
| 1025 | ,@(and (not read-only) |
| 1026 | `((defun (setf ,from) (value object) |
| 1027 | (setf (,to object) value)))))) |
| 1028 | |
| 1029 | ;;;-------------------------------------------------------------------------- |
| 1030 | ;;; Condition and error utilities. |
| 1031 | |
| 1032 | (export 'designated-condition) |
| 1033 | (defun designated-condition (default-type datum arguments |
| 1034 | &key allow-pointless-arguments) |
| 1035 | "Return the condition designated by DATUM and ARGUMENTS. |
| 1036 | |
| 1037 | DATUM and ARGUMENTS together are a `condition designator' of (some |
| 1038 | supertype of) DEFAULT-TYPE; return the condition so designated." |
| 1039 | (typecase datum |
| 1040 | (condition |
| 1041 | (unless (or allow-pointless-arguments (null arguments)) |
| 1042 | (error "Argument list provided with specific condition")) |
| 1043 | datum) |
| 1044 | (symbol |
| 1045 | (apply #'make-condition datum arguments)) |
| 1046 | ((or string function) |
| 1047 | (make-condition default-type |
| 1048 | :format-control datum |
| 1049 | :format-arguments arguments)) |
| 1050 | (t |
| 1051 | (error "Unexpected condition designator datum ~S" datum)))) |
| 1052 | |
| 1053 | (export 'simple-control-error) |
| 1054 | (define-condition simple-control-error (control-error simple-error) |
| 1055 | ()) |
| 1056 | |
| 1057 | (export 'invoke-associated-restart) |
| 1058 | (defun invoke-associated-restart (restart condition &rest arguments) |
| 1059 | "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS. |
| 1060 | |
| 1061 | Find an active restart designated by RESTART; if CONDITION is not nil, |
| 1062 | then restrict the search to restarts associated with CONDITION, and |
| 1063 | restarts not associated with any condition. If no such restart is found |
| 1064 | then signal an error of type `control-error'; otherwise invoke the restart |
| 1065 | with the given ARGUMENTS." |
| 1066 | (apply #'invoke-restart |
| 1067 | (or (find-restart restart condition) |
| 1068 | (error 'simple-control-error |
| 1069 | :format-control "~:[Restart ~S is not active~;~ |
| 1070 | No active `~(~A~)' restart~]~ |
| 1071 | ~@[ for condition ~S~]" |
| 1072 | :format-arguments (list (symbolp restart) |
| 1073 | restart |
| 1074 | condition))) |
| 1075 | arguments)) |
| 1076 | |
| 1077 | (export '(enclosing-condition enclosed-condition)) |
| 1078 | (define-condition enclosing-condition (condition) |
| 1079 | ((%enclosed-condition :initarg :condition :type condition |
| 1080 | :reader enclosed-condition)) |
| 1081 | (:documentation |
| 1082 | "A condition which encloses another condition |
| 1083 | |
| 1084 | This is useful if one wants to attach additional information to an |
| 1085 | existing condition. The enclosed condition can be obtained using the |
| 1086 | `enclosed-condition' function.") |
| 1087 | (:report (lambda (condition stream) |
| 1088 | (princ (enclosed-condition condition) stream)))) |
| 1089 | |
| 1090 | (export 'information) |
| 1091 | (define-condition information (condition) |
| 1092 | ()) |
| 1093 | |
| 1094 | (export 'simple-information) |
| 1095 | (define-condition simple-information (simple-condition information) |
| 1096 | ()) |
| 1097 | |
| 1098 | (export 'info) |
| 1099 | (defun info (datum &rest arguments) |
| 1100 | "Report some useful diagnostic information. |
| 1101 | |
| 1102 | Establish a simple restart named `noted', and signal the condition of type |
| 1103 | `information' designated by DATUM and ARGUMENTS. Return non-nil if the |
| 1104 | restart was invoked, otherwise nil." |
| 1105 | (restart-case |
| 1106 | (signal (designated-condition 'simple-information datum arguments)) |
| 1107 | (noted () :report "Noted." t))) |
| 1108 | |
| 1109 | (export 'noted) |
| 1110 | (defun noted (&optional condition) |
| 1111 | "Invoke the `noted' restart, possibly associated with the given CONDITION." |
| 1112 | (invoke-associated-restart 'noted condition)) |
| 1113 | |
| 1114 | (export 'promiscuous-cerror) |
| 1115 | (defun promiscuous-cerror (continue-string datum &rest arguments) |
| 1116 | "Like standard `cerror', but robust against sneaky changes of conditions. |
| 1117 | |
| 1118 | It seems that `cerror' (well, at least the version in SBCL) is careful |
| 1119 | to limit its restart to the specific condition it signalled. But that's |
| 1120 | annoying, because `sod-parser:with-default-error-location' substitutes |
| 1121 | different conditions carrying the error-location information." |
| 1122 | (restart-case (apply #'error datum arguments) |
| 1123 | (continue () |
| 1124 | :report (lambda (stream) |
| 1125 | (apply #'format stream continue-string datum arguments)) |
| 1126 | nil))) |
| 1127 | |
| 1128 | (export 'cerror*) |
| 1129 | (defun cerror* (datum &rest arguments) |
| 1130 | (apply #'promiscuous-cerror "Continue" datum arguments)) |
| 1131 | |
| 1132 | ;;;-------------------------------------------------------------------------- |
| 1133 | ;;; CLOS hacking. |
| 1134 | |
| 1135 | (export 'default-slot) |
| 1136 | (defmacro default-slot ((instance slot &optional (slot-names t)) |
| 1137 | &body value |
| 1138 | &environment env) |
| 1139 | "If INSTANCE's slot named SLOT is unbound, set it to VALUE. |
| 1140 | |
| 1141 | Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we |
| 1142 | obey the `shared-initialize' protocol). SLOT-NAMES defaults to `t', so |
| 1143 | you can use it in `initialize-instance' or similar without ill effects. |
| 1144 | Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only |
| 1145 | evaluated if it's needed." |
| 1146 | |
| 1147 | (once-only (:environment env instance slot slot-names) |
| 1148 | `(when ,(if (eq slot-names t) |
| 1149 | `(not (slot-boundp ,instance ,slot)) |
| 1150 | `(and (not (slot-boundp ,instance ,slot)) |
| 1151 | (or (eq ,slot-names t) |
| 1152 | (member ,slot ,slot-names)))) |
| 1153 | (setf (slot-value ,instance ,slot) |
| 1154 | (progn ,@value))))) |
| 1155 | |
| 1156 | (export 'define-on-demand-slot) |
| 1157 | (defmacro define-on-demand-slot (class slot (instance) &body body) |
| 1158 | "Defines a slot which computes its initial value on demand. |
| 1159 | |
| 1160 | Sets up the named SLOT of CLASS to establish its value as the implicit |
| 1161 | progn BODY, by defining an appropriate method on `slot-unbound'." |
| 1162 | (multiple-value-bind (docs decls body) (parse-body body) |
| 1163 | (with-gensyms (classvar slotvar) |
| 1164 | `(defmethod slot-unbound |
| 1165 | (,classvar (,instance ,class) (,slotvar (eql ',slot))) |
| 1166 | ,@docs ,@decls |
| 1167 | (declare (ignore ,classvar)) |
| 1168 | (setf (slot-value ,instance ',slot) (block ,slot ,@body)))))) |
| 1169 | |
| 1170 | ;;;----- That's all, folks -------------------------------------------------- |