| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; $Id$ |
| 4 | ;;; |
| 5 | ;;; Basic definitions |
| 6 | ;;; |
| 7 | ;;; (c) 2005 Mark Wooding |
| 8 | ;;; |
| 9 | |
| 10 | ;;;----- Licensing notice --------------------------------------------------- |
| 11 | ;;; |
| 12 | ;;; This program 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 | ;;; This program 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 this program; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | ;;;-------------------------------------------------------------------------- |
| 27 | ;;; Package things. |
| 28 | |
| 29 | (defpackage #:mdw.base |
| 30 | (:use #:common-lisp) |
| 31 | #+cmu (:import-from #:extensions #:fixnump)) |
| 32 | |
| 33 | (in-package #:mdw.base) |
| 34 | |
| 35 | ;;;-------------------------------------------------------------------------- |
| 36 | ;;; Useful types. |
| 37 | |
| 38 | (export 'unsigned-fixnum) |
| 39 | (deftype unsigned-fixnum () |
| 40 | "Unsigned fixnums; useful as array indices and suchlike." |
| 41 | `(mod ,most-positive-fixnum)) |
| 42 | |
| 43 | ;;;-------------------------------------------------------------------------- |
| 44 | ;;; Some simple macros to get things going. |
| 45 | |
| 46 | (export 'compile-time-defun) |
| 47 | (defmacro compile-time-defun (name args &body body) |
| 48 | "Define a function which can be used by macros during the compilation |
| 49 | process." |
| 50 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
| 51 | (defun ,name ,args ,@body))) |
| 52 | |
| 53 | (export 'show) |
| 54 | (defmacro show (x) |
| 55 | "Debugging tool: print the expression X and its values." |
| 56 | (let ((tmp (gensym))) |
| 57 | `(let ((,tmp (multiple-value-list ,x))) |
| 58 | (fresh-line) |
| 59 | (pprint-logical-block (*standard-output* nil :per-line-prefix ";; ") |
| 60 | (format t |
| 61 | "~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]" |
| 62 | ',x |
| 63 | ,tmp)) |
| 64 | (terpri) |
| 65 | (values-list ,tmp)))) |
| 66 | |
| 67 | (export 'stringify) |
| 68 | (defun stringify (str) |
| 69 | "Return a string representation of STR. Strings are returned unchanged; |
| 70 | symbols are converted to their names (unqualified!). Other objects are |
| 71 | converted to their print representations." |
| 72 | (typecase str |
| 73 | (string str) |
| 74 | (symbol (symbol-name str)) |
| 75 | (t (princ-to-string str)))) |
| 76 | |
| 77 | (export 'functionify) |
| 78 | (defun functionify (func) |
| 79 | "Convert the function-designator FUNC to a function." |
| 80 | (declare (type (or function symbol) func)) |
| 81 | (etypecase func |
| 82 | (function func) |
| 83 | (symbol (symbol-function func)))) |
| 84 | |
| 85 | (export 'mappend) |
| 86 | (defun mappend (function list &rest more-lists) |
| 87 | "Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding |
| 88 | a list. Return the concatenation of all the resulting lists. Like |
| 89 | mapcan, but nondestructive." |
| 90 | (apply #'append (apply #'mapcar function list more-lists))) |
| 91 | |
| 92 | (export 'listify) |
| 93 | (compile-time-defun listify (x) |
| 94 | "If X is a (possibly empty) list, return X; otherwise return (list X)." |
| 95 | (if (listp x) x (list x))) |
| 96 | |
| 97 | (compile-time-defun do-fix-pair (x y defaultp) |
| 98 | "Helper function for fix-pair and pairify." |
| 99 | (flet ((singleton (x) (values x (if defaultp y x)))) |
| 100 | (cond ((atom x) (singleton x)) |
| 101 | ((null (cdr x)) (singleton (car x))) |
| 102 | ((atom (cdr x)) (values (car x) (cdr x))) |
| 103 | ((cddr x) (error "Too many elements for a pair.")) |
| 104 | (t (values (car x) (cadr x)))))) |
| 105 | |
| 106 | (export 'fix-pair) |
| 107 | (compile-time-defun fix-pair (x &optional (y nil defaultp)) |
| 108 | "Return two values extracted from X. It works as follows: |
| 109 | (A) -> A, Y |
| 110 | (A B) -> A, B |
| 111 | (A B . C) -> error |
| 112 | (A . B) -> A, B |
| 113 | A -> A, Y |
| 114 | where Y defaults to A if not specified." |
| 115 | (do-fix-pair x y defaultp)) |
| 116 | |
| 117 | (export 'pairify) |
| 118 | (compile-time-defun pairify (x &optional (y nil defaultp)) |
| 119 | "As for fix-pair, but returns a list instead of two values." |
| 120 | (multiple-value-call #'list (do-fix-pair x y defaultp))) |
| 121 | |
| 122 | (export 'whitespace-char-p) |
| 123 | (defun whitespace-char-p (ch) |
| 124 | "Return whether CH is a whitespace character or not." |
| 125 | (case ch |
| 126 | (#.(loop for i below char-code-limit |
| 127 | for ch = (code-char i) |
| 128 | unless (with-input-from-string (in (string ch)) |
| 129 | (peek-char t in nil)) |
| 130 | collect ch) |
| 131 | t) |
| 132 | (t nil))) |
| 133 | |
| 134 | (export 'defconstant*) |
| 135 | (defmacro defconstant* (name value &key doc test) |
| 136 | "Define a constant, like `defconstant'. The TEST is an equality test used |
| 137 | to decide whether to override the current definition, if any." |
| 138 | (let ((temp (gensym))) |
| 139 | `(eval-when (:compile-toplevel :load-toplevel :execute) |
| 140 | (let ((,temp ,value)) |
| 141 | (unless (and (boundp ',name) |
| 142 | (funcall ,(or test ''eql) (symbol-value ',name) ,temp)) |
| 143 | (defconstant ,name ,value ,@(and doc (list doc)))) |
| 144 | ',name)))) |
| 145 | |
| 146 | (export 'slot-uninitialized) |
| 147 | (declaim (ftype (function nil ()) slot-unitialized)) |
| 148 | (defun slot-uninitialized () |
| 149 | "A function which signals an error. Can be used as an initializer form in |
| 150 | structure definitions without doom ensuing." |
| 151 | (error "No initializer for slot.")) |
| 152 | |
| 153 | (export 'parse-body) |
| 154 | (compile-time-defun parse-body (body &key (allow-docstring-p t)) |
| 155 | "Given a BODY (a list of forms), parses it into three sections: a |
| 156 | docstring, a list of declarations (forms beginning with the symbol |
| 157 | `declare') and the body forms. The result is returned as three lists |
| 158 | (even the docstring), suitable for interpolation into a backquoted list |
| 159 | using `@,'. If ALLOW-DOCSTRING-P is nil, docstrings aren't allowed at |
| 160 | all." |
| 161 | (let ((doc nil) (decls nil)) |
| 162 | (do ((forms body (cdr forms))) (nil) |
| 163 | (let ((form (and forms (car forms)))) |
| 164 | (cond ((and allow-docstring-p (not doc) (stringp form) (cdr forms)) |
| 165 | (setf doc form)) |
| 166 | ((and (consp form) |
| 167 | (eq (car form) 'declare)) |
| 168 | (setf decls (append decls (cdr form)))) |
| 169 | (t (return (values (and doc (list doc)) |
| 170 | (and decls (list (cons 'declare decls))) |
| 171 | forms)))))))) |
| 172 | |
| 173 | (export 'with-parsed-body) |
| 174 | (defmacro with-parsed-body |
| 175 | ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body) |
| 176 | "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR |
| 177 | to the body, DECLVAR to the declarations, and DOCVAR to (a list |
| 178 | containing) the docstring, and evaluate BODY." |
| 179 | `(multiple-value-bind |
| 180 | (,docvar ,declvar ,bodyvar) |
| 181 | (parse-body ,form :allow-docstring-p ,docp) |
| 182 | ,@(if docp nil `((declare (ignore ,docvar)))) |
| 183 | ,@body)) |
| 184 | |
| 185 | (export 'fixnump) |
| 186 | #-cmu |
| 187 | (progn |
| 188 | (declaim (inline fixnump)) |
| 189 | (defun fixnump (object) |
| 190 | "Answer non-nil if OBJECT is a fixnum, or nil if it isn't." |
| 191 | (typep object 'fixnum))) |
| 192 | |
| 193 | ;;;-------------------------------------------------------------------------- |
| 194 | ;;; Generating symbols. |
| 195 | |
| 196 | (export 'with-gensyms) |
| 197 | (defmacro with-gensyms (syms &body body) |
| 198 | "Everyone's favourite macro helper." |
| 199 | `(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym)))) |
| 200 | (listify syms))) |
| 201 | ,@body)) |
| 202 | |
| 203 | (export 'let*/gensyms) |
| 204 | (defmacro let*/gensyms (binds &body body) |
| 205 | "A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE |
| 206 | defaults to VAR. The result is that BODY is evaluated in a context where |
| 207 | each VAR is bound to a gensym, and in the final expansion, each of those |
| 208 | gensyms will be bound to the corresponding VALUE." |
| 209 | (labels ((more (binds) |
| 210 | (let ((tmp (gensym "TMP")) (bind (car binds))) |
| 211 | `((let ((,tmp ,(cadr bind)) |
| 212 | (,(car bind) (gensym ,(symbol-name (car bind))))) |
| 213 | `(let ((,,(car bind) ,,tmp)) |
| 214 | ,,@(if (cdr binds) |
| 215 | (more (cdr binds)) |
| 216 | body))))))) |
| 217 | (if (null binds) |
| 218 | `(progn ,@body) |
| 219 | (car (more (mapcar #'pairify (listify binds))))))) |
| 220 | |
| 221 | ;;;-------------------------------------------------------------------------- |
| 222 | ;;; Capturing places as symbols. |
| 223 | |
| 224 | (defmacro %place-ref (getform setform newtmp) |
| 225 | "Grim helper macro for with-places." |
| 226 | (declare (ignore setform newtmp)) |
| 227 | getform) |
| 228 | |
| 229 | (define-setf-expander %place-ref (getform setform newtmp) |
| 230 | "Grim helper macro for with-places." |
| 231 | (values nil nil newtmp setform getform)) |
| 232 | |
| 233 | (export 'with-places) |
| 234 | (defmacro with-places (clauses &body body &environment env) |
| 235 | "Define symbols which refer to `setf'-able places. |
| 236 | |
| 237 | The syntax is similar to `let'. The CLAUSES are a list of (NAME PLACE) |
| 238 | pairs. Each NAME is defined as a symbol-macro referring to the |
| 239 | corresponding PLACE: a mention of the NAME within the BODY forms extracts |
| 240 | the current value(s) of the PLACE, while a `setf' (or `setq', because |
| 241 | symbol macros are strange like that) of a NAME updates the value(s) in the |
| 242 | PLACE. The returned values are those of the BODY, evaluated as an |
| 243 | implicit `progn'." |
| 244 | |
| 245 | (let ((temp-binds nil) |
| 246 | (macro-binds nil)) |
| 247 | (dolist (clause clauses) |
| 248 | (destructuring-bind (name place) clause |
| 249 | (multiple-value-bind (valtmps valforms newtmps setform getform) |
| 250 | (get-setf-expansion place env) |
| 251 | (setf temp-binds |
| 252 | (nconc (nreverse (mapcar #'list valtmps valforms)) |
| 253 | temp-binds)) |
| 254 | (push `(,name (%place-ref ,getform ,setform ,newtmps)) |
| 255 | macro-binds)))) |
| 256 | `(let (,@(nreverse temp-binds)) |
| 257 | (symbol-macrolet (,@(nreverse macro-binds)) |
| 258 | ,@body)))) |
| 259 | |
| 260 | (export 'with-places/gensyms) |
| 261 | (defmacro with-places/gensyms (clauses &body body) |
| 262 | "A kind of a cross between `with-places' and `let*/gensyms'. |
| 263 | |
| 264 | This is a hairy helper for writing `setf'-like macros. The CLAUSES are a |
| 265 | list of (NAME [PLACE]) pairs, where the PLACE defaults to NAME, and a |
| 266 | bare NAME may be written in place of the singleton list (NAME). The |
| 267 | PLACEs are evaluated. |
| 268 | |
| 269 | The BODY forms are evaluated as an implicit `progn', with each NAME bound |
| 270 | to a gensym, to produce a Lisp form, called the `kernel'. The result of |
| 271 | the `with-places/gensyms' macro is then itself a Lisp form, called the |
| 272 | `result'. |
| 273 | |
| 274 | The effect of evaluating the `result' form is to evaluate the `kernel' |
| 275 | form with each of the gensyms stands for the value(s) stored in the |
| 276 | corresponding PLACE; a `setf' (or `setq') of one of the gensyms updates |
| 277 | the value(s) in the corresponding PLACE. The values returned by the |
| 278 | `result' form are the values returned by the `kernel'." |
| 279 | |
| 280 | (let* ((clauses (mapcar #'pairify clauses)) |
| 281 | (names (mapcar #'car clauses)) |
| 282 | (places (mapcar #'cadr clauses)) |
| 283 | (gensyms (mapcar (lambda (name) (gensym (symbol-name name))) |
| 284 | names))) |
| 285 | ``(with-places (,,@(mapcar (lambda (gensym place) |
| 286 | ``(,',gensym ,,place)) |
| 287 | gensyms places)) |
| 288 | ,(let (,@(mapcar (lambda (name gensym) |
| 289 | `(,name ',gensym)) |
| 290 | names gensyms)) |
| 291 | ,@body)))) |
| 292 | |
| 293 | ;;;-------------------------------------------------------------------------- |
| 294 | ;;; Some simple yet useful control structures. |
| 295 | |
| 296 | (export 'nlet) |
| 297 | (defmacro nlet (name binds &body body) |
| 298 | "Scheme's named let." |
| 299 | (multiple-value-bind (vars vals) |
| 300 | (loop for bind in binds |
| 301 | for (var val) = (pairify bind nil) |
| 302 | collect var into vars |
| 303 | collect val into vals |
| 304 | finally (return (values vars vals))) |
| 305 | `(labels ((,name ,vars |
| 306 | ,@body)) |
| 307 | (,name ,@vals)))) |
| 308 | |
| 309 | (export 'while) |
| 310 | (defmacro while (cond &body body) |
| 311 | "If COND is false, evaluate to nil; otherwise evaluate BODY and try again." |
| 312 | `(loop (unless ,cond (return)) (progn ,@body))) |
| 313 | |
| 314 | (export 'until) |
| 315 | (defmacro until (cond &body body) |
| 316 | "If COND is true, evaluate to nil; otherwise evaluate BODY and try again." |
| 317 | `(loop (when ,cond (return)) (progn ,@body))) |
| 318 | |
| 319 | (compile-time-defun do-case2-like (kind vform clauses) |
| 320 | "Helper function for `case2' and `ecase2'." |
| 321 | (with-gensyms (scrutinee argument) |
| 322 | `(multiple-value-bind (,scrutinee ,argument) ,vform |
| 323 | (declare (ignorable ,argument)) |
| 324 | (,kind ,scrutinee |
| 325 | ,@(mapcar (lambda (clause) |
| 326 | (destructuring-bind |
| 327 | (cases (&optional varx vary) &rest forms) |
| 328 | clause |
| 329 | `(,cases |
| 330 | ,@(if varx |
| 331 | (list `(let ((,(or vary varx) ,argument) |
| 332 | ,@(and vary |
| 333 | `((,varx ,scrutinee)))) |
| 334 | ,@forms)) |
| 335 | forms)))) |
| 336 | clauses))))) |
| 337 | |
| 338 | (export 'caase2) |
| 339 | (defmacro case2 (vform &body clauses) |
| 340 | "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT. |
| 341 | The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a |
| 342 | standard `case' clause has the form (CASES FORMS...). The `case2' form |
| 343 | evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in |
| 344 | order, just like `case'. If there is a match, then the corresponding |
| 345 | FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to |
| 346 | the SCRUTINEE (where specified). Note the bizarre defaulting behaviour: |
| 347 | ARGVAR is less optional than SCRUVAR." |
| 348 | (do-case2-like 'case vform clauses)) |
| 349 | |
| 350 | (export 'ecase2) |
| 351 | (defmacro ecase2 (vform &body clauses) |
| 352 | "Like `case2', but signals an error if no clause matches the SCRUTINEE." |
| 353 | (do-case2-like 'ecase vform clauses)) |
| 354 | |
| 355 | (export 'setf-default) |
| 356 | (defmacro setf-default (&rest specs) |
| 357 | "Like setf, but only sets places which are currently nil. |
| 358 | |
| 359 | The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE |
| 360 | is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the |
| 361 | default is /not/ stored. The result is the (new) value of the last |
| 362 | PLACE." |
| 363 | `(progn ,@(do ((list nil) |
| 364 | (specs specs (cddr specs))) |
| 365 | ((endp specs) (nreverse list)) |
| 366 | (unless (cdr specs) |
| 367 | (error "Odd number of arguments for `setf-default'.")) |
| 368 | (push (with-places/gensyms ((place (car specs))) |
| 369 | `(or ,place (setf ,place ,(cadr specs)))) |
| 370 | list)))) |
| 371 | |
| 372 | ;;;-------------------------------------------------------------------------- |
| 373 | ;;; Update-in-place macros built using with-places. |
| 374 | |
| 375 | (export 'update-place) |
| 376 | (defmacro update-place (op place &rest args) |
| 377 | "Update PLACE with (OP PLACE . ARGS), returning the new value." |
| 378 | (with-places/gensyms (place) |
| 379 | `(setf ,place (,op ,place ,@args)))) |
| 380 | |
| 381 | (export 'update-place-after) |
| 382 | (defmacro update-place-after (op place &rest args) |
| 383 | "Update PLACE with (OP PLACE . ARGS), returning the old value." |
| 384 | (with-places/gensyms (place) |
| 385 | (with-gensyms (x) |
| 386 | `(let ((,x ,place)) |
| 387 | (setf ,place (,op ,x ,@args)) |
| 388 | ,x)))) |
| 389 | |
| 390 | (export 'incf-after) |
| 391 | (defmacro incf-after (place &optional (by 1)) |
| 392 | "Increment PLACE by BY, returning the old value." |
| 393 | `(update-place-after + ,place ,by)) |
| 394 | |
| 395 | (export 'decf-after) |
| 396 | (defmacro decf-after (place &optional (by 1)) |
| 397 | "Decrement PLACE by BY, returning the old value." |
| 398 | `(update-place-after - ,place ,by)) |
| 399 | |
| 400 | ;;;-------------------------------------------------------------------------- |
| 401 | ;;; Locatives. |
| 402 | |
| 403 | (export 'locp) |
| 404 | (defstruct (loc (:predicate locp) (:constructor make-loc (reader writer))) |
| 405 | "Locative data type. See `locf' and `ref'." |
| 406 | (reader (slot-uninitialized) :type function :read-only t) |
| 407 | (writer (slot-uninitialized) :type function :read-only t)) |
| 408 | |
| 409 | (export 'locf) |
| 410 | (defmacro locf (place &environment env) |
| 411 | "Slightly cheesy locatives. (locf PLACE) returns an object which, using |
| 412 | the `ref' function, can be used to read or set the value of PLACE. It's |
| 413 | cheesy because it uses closures rather than actually taking the address of |
| 414 | something. Also, unlike Zetalisp, we don't overload `car' to do our dirty |
| 415 | work." |
| 416 | (multiple-value-bind |
| 417 | (valtmps valforms newtmps setform getform) |
| 418 | (get-setf-expansion place env) |
| 419 | `(let* (,@(mapcar #'list valtmps valforms)) |
| 420 | (make-loc (lambda () ,getform) |
| 421 | (lambda (,@newtmps) ,setform))))) |
| 422 | |
| 423 | (export 'ref) |
| 424 | (declaim (inline ref (setf ref))) |
| 425 | (defun ref (loc) |
| 426 | "Fetch the value referred to by a locative." |
| 427 | (funcall (loc-reader loc))) |
| 428 | (defun (setf ref) (new loc) |
| 429 | "Store a new value in the place referred to by a locative." |
| 430 | (funcall (loc-writer loc) new)) |
| 431 | |
| 432 | (export 'with-locatives) |
| 433 | (defmacro with-locatives (locs &body body) |
| 434 | "LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a |
| 435 | symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it |
| 436 | defaults to SYM. As an abbreviation for a common case, LOCS may be a |
| 437 | symbol instead of a list. The BODY is evaluated in an environment where |
| 438 | each SYM is a symbol macro which expands to (ref LOC-EXPR) -- or, in fact, |
| 439 | something similar which doesn't break if LOC-EXPR has side-effects. Thus, |
| 440 | references, including `setf' forms, fetch or modify the thing referred to |
| 441 | by the LOC-EXPR. Useful for covering over where something uses a |
| 442 | locative." |
| 443 | (setf locs (mapcar #'pairify (listify locs))) |
| 444 | (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs)) |
| 445 | (ll (mapcar #'cadr locs)) |
| 446 | (ss (mapcar #'car locs))) |
| 447 | `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll)) |
| 448 | (symbol-macrolet (,@(mapcar (lambda (sym tmp) |
| 449 | `(,sym (ref ,tmp))) ss tt)) |
| 450 | ,@body)))) |
| 451 | |
| 452 | ;;;----- That's all, folks -------------------------------------------------- |