chiark - git - mdw - lisp/blob - mdw-base.lisp

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