genutils.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          genutils.lisp
   6 ;;;; Purpose:       Main general utility functions for GENUTILS package
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id: genutils.lisp,v 1.1 2002/10/06 13:21:47 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of Genutils, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; Genutils users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License.
  16 ;;;; *************************************************************************
  17
  18
  19 (in-package :genutils)
  20
  21 (declaim (optimize (speed 3) (safety 1)))
  22
  23 (defmacro bind-when ((bind-var boundForm) &body body)
  24   `(let ((,bind-var ,boundForm))
  25       (declare (ignore-if-unused ,bind-var))
  26       (when ,bind-var
  27         ,@body)))
  28
  29 (defmacro bind-if ((bind-var boundForm) yup &optional nope)
  30   `(let ((,bind-var ,boundForm))
  31       (if ,bind-var
  32          ,yup
  33          ,nope)))
  34
  35 ;; Anaphoric macros
  36
  37 (defmacro aif (test then &optional else)
  38   `(let ((it ,test))
  39      (if it ,then ,else)))
  40
  41 (defmacro awhen (test-form &body body)
  42   `(aif ,test-form
  43         (progn ,@body)))
  44
  45 (defmacro awhile (expr &body body)
  46   `(do ((it ,expr ,expr))
  47        ((not it))
  48      ,@body))
  49
  50 (defmacro aand (&rest args)
  51   (cond ((null args) t)
  52         ((null (cdr args)) (car args))
  53         (t `(aif ,(car args) (aand ,@(cdr args))))))
  54
  55 (defmacro acond (&rest clauses)
  56   (if (null clauses)
  57       nil
  58       (let ((cl1 (car clauses))
  59             (sym (gensym)))
  60         `(let ((,sym ,(car cl1)))
  61            (if ,sym
  62                (let ((it ,sym)) ,@(cdr cl1))
  63                (acond ,@(cdr clauses)))))))
  64
  65 (defmacro alambda (parms &body body)
  66   `(labels ((self ,parms ,@body))
  67      #'self))
  68
  69
  70 (defmacro aif2 (test &optional then else)
  71   (let ((win (gensym)))
  72     `(multiple-value-bind (it ,win) ,test
  73        (if (or it ,win) ,then ,else))))
  74
  75 (defmacro awhen2 (test &body body)
  76   `(aif2 ,test
  77          (progn ,@body)))
  78
  79 (defmacro awhile2 (test &body body)
  80   (let ((flag (gensym)))
  81     `(let ((,flag t))
  82        (while ,flag
  83          (aif2 ,test
  84                (progn ,@body)
  85                (setq ,flag nil))))))
  86
  87 (defmacro acond2 (&rest clauses)
  88   (if (null clauses)
  89       nil
  90       (let ((cl1 (car clauses))
  91             (val (gensym))
  92             (win (gensym)))
  93         `(multiple-value-bind (,val ,win) ,(car cl1)
  94            (if (or ,val ,win)
  95                (let ((it ,val)) ,@(cdr cl1))
  96                (acond2 ,@(cdr clauses)))))))
  97
  98
  99 ;; Debugging
 100
 101 (defmacro mac (expr)
 102 "Expand a macro"
 103   `(pprint (macroexpand-1 ',expr)))
 104
 105 (defmacro print-form-and-results (form)
 106   `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
 107
 108 (defun show (&optional (what :variables) (package *package*))
 109   (ecase what
 110     (:variables (show-variables package))
 111     (:functions (show-functions package))))
 112
 113 (defun show-variables (package)
 114   (do-symbols (s package)
 115     (multiple-value-bind (sym status)
 116         (find-symbol (symbol-name s) package)
 117       (when (and (or (eq status :external)
 118                      (eq status :internal))
 119                  (boundp sym))
 120         (format t "~&Symbol ~S~T -> ~S~%"
 121                 sym
 122                 (symbol-value sym))))))
 123
 124 (defun show-functions (package)
 125   (do-symbols (s package)
 126     (multiple-value-bind (sym status)
 127         (find-symbol (symbol-name s) package)
 128       (when (and (or (eq status :external)
 129                      (eq status :internal))
 130                  (fboundp sym))
 131         (format t "~&Function ~S~T -> ~S~%"
 132                 sym
 133                 (symbol-function sym))))))
 134
 135 #+allegro
 136 (ff:def-foreign-call (memory-status-dump "memory_status_dump")
 137     ()
 138   :strings-convert t)
 139
 140
 141 ;; Ensure functions
 142
 143 (defmacro ensure-integer (obj)
 144   "Ensure object is an integer. If it is a string, then parse it"
 145   `(if (stringp ,obj)
 146       (parse-integer ,obj)
 147     ,obj))
 148
 149 ;; Lists
 150
 151 (defun mklist (obj)
 152   "Make into list if atom"
 153   (if (listp obj) obj (list obj)))
 154
 155 (defun filter (fn lst)
 156   "Filter a list by function, eliminate elements where fn returns nil"
 157   (let ((acc nil))
 158     (dolist (x lst)
 159       (let ((val (funcall fn x)))
 160         (if val (push val acc))))
 161     (nreverse acc)))
 162
 163
 164 ;; Functions
 165
 166 (defun memo-proc (fn)
 167   "Memoize results of call to fn, returns a closure with hash-table"
 168   (let ((cache (make-hash-table :test #'equal)))
 169     #'(lambda (&rest args)
 170         (multiple-value-bind (val foundp) (gethash args cache)
 171           (if foundp
 172               val
 173               (setf (gethash args cache)
 174                     (apply fn args)))))))
 175
 176 (defun memoize (fn-name)
 177   (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
 178
 179 (defmacro defun-memo (fn args &body body)
 180   "Define a memoized function"
 181   `(memoize (defun ,fn ,args . ,body)))
 182
 183 (defmacro _f (op place &rest args)
 184   (multiple-value-bind (vars forms var set access)
 185                        (get-setf-expansion place)
 186     `(let* (,@(mapcar #'list vars forms)
 187             (,(car var) (,op ,access ,@args)))
 188        ,set)))
 189
 190 (defun compose (&rest fns)
 191   (if fns
 192       (let ((fn1 (car (last fns)))
 193             (fns (butlast fns)))
 194         #'(lambda (&rest args)
 195             (reduce #'funcall fns
 196                     :from-end t
 197                     :initial-value (apply fn1 args))))
 198       #'identity))
 199
 200 ;;; Loop macros
 201
 202 (defmacro until (test &body body)
 203   `(do ()
 204        (,test)
 205      ,@body))
 206
 207 (defmacro while (test &body body)
 208   `(do ()
 209        ((not ,test))
 210      ,@body))
 211
 212 (defmacro for ((var start stop) &body body)
 213   (let ((gstop (gensym)))
 214     `(do ((,var ,start (1+ ,var))
 215           (,gstop ,stop))
 216          ((> ,var ,gstop))
 217        ,@body)))
 218
 219
 220 ;;; Keyword functions
 221
 222 (defun remove-keyword (key arglist)
 223   (loop for sublist = arglist then rest until (null sublist)
 224         for (elt arg . rest) = sublist
 225         unless (eq key elt) append (list elt arg)))
 226
 227 (defun remove-keywords (key-names args)
 228   (loop for ( name val ) on args by #'cddr
 229         unless (member (symbol-name name) key-names
 230                        :key #'symbol-name :test 'equal)
 231         append (list name val)))
 232
 233 (defmacro in (obj &rest choices)
 234   (let ((insym (gensym)))
 235     `(let ((,insym ,obj))
 236        (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
 237                      choices)))))
 238
 239 (defmacro mean (&rest args)
 240   `(/ (+ ,@args) ,(length args)))
 241
 242 (defmacro with-gensyms (syms &body body)
 243   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 244           syms)
 245      ,@body))
 246
 247
 248 ;;; Mapping
 249
 250 (defun mapappend (fn list)
 251   (apply #'append (mapcar fn list)))
 252
 253
 254 (defun mapcar-append-string-nontailrec (func v)
 255 "Concatenate results of mapcar lambda calls"
 256   (aif (car v)
 257        (concatenate 'string (funcall func it)
 258                     (mapcar-append-string-nontailrec func (cdr v)))
 259        ""))
 260
 261
 262 (defun mapcar-append-string (func v &optional (accum ""))
 263 "Concatenate results of mapcar lambda calls"
 264   (aif (car v)
 265        (mapcar-append-string
 266         func
 267         (cdr v)
 268         (concatenate 'string accum (funcall func it)))
 269        accum))
 270
 271
 272 (defun mapcar2-append-string-nontailrec (func la lb)
 273 "Concatenate results of mapcar lambda call's over two lists"
 274   (let ((a (car la))
 275         (b (car lb)))
 276     (if (and a b)
 277       (concatenate 'string (funcall func a b)
 278                    (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
 279       "")))
 280
 281 (defun mapcar2-append-string (func la lb &optional (accum ""))
 282 "Concatenate results of mapcar lambda call's over two lists"
 283   (let ((a (car la))
 284         (b (car lb)))
 285     (if (and a b)
 286         (mapcar2-append-string
 287          func
 288          (cdr la)
 289          (cdr lb)
 290          (concatenate 'string accum (funcall func a b)))
 291       accum)))
 292
 293 ;;; Strings
 294
 295 (defmacro string-append (outputstr &rest args)
 296   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
 297
 298 (defmacro string-field-append (outputstr &rest args)
 299   `(setq ,outputstr (concatenate 'string ,outputstr ,@args)))
 300
 301 (defun list-to-string (lst)
 302   "Converts a list to a string, doesn't include any delimiters between elements"
 303   (format nil "~{~A~}" lst))
 304
 305 (defun count-string-words (str)
 306   (declare (simple-string str)
 307            (optimize (speed 3) (safety 0)))
 308   (let ((n-words 0)
 309         (in-word nil))
 310     (declare (fixnum n-words))
 311     (dotimes (i (length str))
 312       (let ((ch (char str i)))
 313         (declare (character ch))
 314         (if (alphanumericp ch)
 315             (unless in-word
 316               (incf n-words)
 317               (setq in-word t))
 318           (setq in-word nil))))
 319     n-words))
 320
 321 #+excl
 322 (defun delimited-string-to-list (string &optional (separator #\space))
 323   (excl:delimited-string-to-list string separator))
 324
 325 #-excl
 326 (defun delimited-string-to-list (sequence &optional (separator #\space))
 327 "Split a string by a delimitor"
 328   (loop
 329       with start = 0
 330       for end = (position separator sequence :start start)
 331       collect (subseq sequence start end)
 332       until (null end)
 333       do
 334     (setf start (1+ end))))
 335
 336 #+excl
 337 (defun list-to-delimited-string (list &optional (separator #\space))
 338   (excl:list-to-delimited-string list separator))
 339
 340 #-excl
 341 (defun list-to-delimited-string (list &optional (separator #\space))
 342   (let ((output (when list (format nil "~A" (car list)))))
 343     (dolist (obj (rest list))
 344       (setq output (concatenate 'string output
 345                                 (format nil "~A" separator)
 346                                 (format nil "~A" obj))))
 347     output))
 348
 349 (defun string-invert (str)
 350   "Invert case of a string"
 351   (declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
 352            (simple-string str))
 353   (let ((up nil) (down nil))
 354     (block skip
 355       (loop for char of-type character across str do
 356             (cond ((upper-case-p char) (if down (return-from skip str) (setf up t)))
 357                   ((lower-case-p char) (if up   (return-from skip str) (setf down t)))))
 358       (if up (string-downcase str) (string-upcase str)))))
 359
 360 (defun add-sql-quotes (s)
 361   (substitute-string-for-char s #\' "''"))
 362
 363 (defun escape-backslashes (s)
 364   (substitute-string-for-char s #\\ "\\\\"))
 365
 366 (defun substitute-string-for-char (procstr match-char subst-str)
 367 "Substitutes a string for a single matching character of a string"
 368   (let ((pos (position match-char procstr)))
 369     (if pos
 370         (concatenate 'string
 371           (subseq procstr 0 pos) subst-str
 372           (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
 373       procstr)))
 374
 375 (defun string-substitute (string substring replacement-string)
 376   "String substitute by Larry Hunter. Obtained from Google"
 377   (let ((substring-length (length substring))
 378         (last-end 0)
 379         (new-string ""))
 380     (do ((next-start
 381           (search substring string)
 382           (search substring string :start2 last-end)))
 383         ((null next-start)
 384          (concatenate 'string new-string (subseq string last-end)))
 385       (setq new-string
 386         (concatenate 'string
 387           new-string
 388           (subseq string last-end next-start)
 389           replacement-string))
 390       (setq last-end (+ next-start substring-length)))))
 391
 392
 393 (defun string-trim-last-character (s)
 394 "Return the string less the last character"
 395   (subseq s 0 (1- (length s))))
 396
 397 (defun string-hash (str &optional (bitmask 65535))
 398   (let ((hash 0))
 399     (declare (fixnum hash)
 400              (simple-string str))
 401     (dotimes (i (length str))
 402       (declare (fixnum i))
 403       (setq hash (+ hash (char-code (char str i)))))
 404     (logand hash bitmask)))
 405
 406 (defun string-not-null? (str)
 407   (and str (not (zerop (length str)))))
 408
 409 (defun whitespace? (c)
 410   (declare (character c))
 411   (declare (optimize (speed 3) (safety 0)))
 412   (or (char= c #\Space) (char= c #\Tab) (char= c #\Return) (char= c #\Linefeed)))
 413
 414 (defun not-whitespace? (c)
 415   (not (whitespace? c)))
 416
 417 (defun string-ws? (str)
 418   "Return t if string is all whitespace"
 419   (when (stringp str)
 420     (null (find-if #'not-whitespace? str))))
 421
 422
 423 ;;; Output
 424
 425 (unless (boundp '+indent-vector+)
 426   (defconstant +indent-vector+
 427       (make-array 15 :fill-pointer nil :adjustable nil
 428                   :initial-contents
 429                   '(""
 430                     "  "
 431                     "    "
 432                     "      "
 433                     "        "
 434                     "          "
 435                     "            "
 436                     "              "
 437                     "                "
 438                     "                  "
 439                     "                    "
 440                     "                      "
 441                     "                        "
 442                     "                          "
 443                     "                            "))))
 444
 445 (defmacro indent-spaces (n &optional stream)
 446   "Indent n*2 spaces to output stream"
 447   (let ((st (gensym)))
 448     `(let ((,st ,stream))
 449        (unless ,st
 450          (setq ,st *standard-output*))
 451        (when (plusp ,n)
 452          (if (< ,n 10)
 453              (princ (aref +indent-vector+ ,n) ,st)
 454            (dotimes (i ,n)
 455              (declare (fixnum i))
 456              (format ,st "  ")))))))
 457
 458 (defun print-list (l &optional (output *standard-output*))
 459 "Print a list to a stream"
 460   (if (consp l)
 461     (progn
 462       (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
 463       t)
 464     nil))
 465
 466 (defun print-rows (rows &optional (ostrm *standard-output*))
 467 "Print a list of list rows to a stream"
 468   (dolist (r rows)
 469     (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
 470     (terpri ostrm)))
 471
 472
 473 ;;; Symbol functions
 474
 475 (defmacro concat-symbol (&rest args)
 476   `(intern (concatenate 'string ,@args)))
 477
 478 (defmacro concat-symbol-pkg (pkg &rest args)
 479   `(intern (concatenate 'string ,@args) ,pkg))
 480
 481
 482 ;;; IO
 483
 484
 485 (defstruct buf
 486   vec (start -1) (used -1) (new -1) (end -1))
 487
 488 (defun bref (buf n)
 489   (svref (buf-vec buf)
 490          (mod n (length (buf-vec buf)))))
 491
 492 (defun (setf bref) (val buf n)
 493   (setf (svref (buf-vec buf)
 494                (mod n (length (buf-vec buf))))
 495         val))
 496
 497 (defun new-buf (len)
 498   (make-buf :vec (make-array len)))
 499
 500 (defun buf-insert (x b)
 501   (setf (bref b (incf (buf-end b))) x))
 502
 503 (defun buf-pop (b)
 504   (prog1
 505     (bref b (incf (buf-start b)))
 506     (setf (buf-used b) (buf-start b)
 507           (buf-new  b) (buf-end   b))))
 508
 509 (defun buf-next (b)
 510   (when (< (buf-used b) (buf-new b))
 511     (bref b (incf (buf-used b)))))
 512
 513 (defun buf-reset (b)
 514   (setf (buf-used b) (buf-start b)
 515         (buf-new  b) (buf-end   b)))
 516
 517 (defun buf-clear (b)
 518   (setf (buf-start b) -1 (buf-used  b) -1
 519         (buf-new   b) -1 (buf-end   b) -1))
 520
 521 (defun buf-flush (b str)
 522   (do ((i (1+ (buf-used b)) (1+ i)))
 523       ((> i (buf-end b)))
 524     (princ (bref b i) str)))
 525
 526
 527 (defun file-subst (old new file1 file2)
 528   (with-open-file (in file1 :direction :input)
 529      (with-open-file (out file2 :direction :output
 530                                 :if-exists :supersede)
 531        (stream-subst old new in out))))
 532
 533 (defun stream-subst (old new in out)
 534   (declare (string old new))
 535   (let* ((pos 0)
 536          (len (length old))
 537          (buf (new-buf len))
 538          (from-buf nil))
 539     (declare (fixnum pos len))
 540     (do ((c (read-char in nil :eof)
 541             (or (setf from-buf (buf-next buf))
 542                 (read-char in nil :eof))))
 543         ((eql c :eof))
 544       (declare (character c))
 545       (cond ((char= c (char old pos))
 546              (incf pos)
 547              (cond ((= pos len)            ; 3
 548                     (princ new out)
 549                     (setf pos 0)
 550                     (buf-clear buf))
 551                    ((not from-buf)         ; 2
 552                     (buf-insert c buf))))
 553             ((zerop pos)                   ; 1
 554              (princ c out)
 555              (when from-buf
 556                (buf-pop buf)
 557                (buf-reset buf)))
 558             (t                             ; 4
 559              (unless from-buf
 560                (buf-insert c buf))
 561              (princ (buf-pop buf) out)
 562              (buf-reset buf)
 563              (setf pos 0))))
 564     (buf-flush buf out)))
 565
 566
 567 ;;; Tree Functions
 568
 569 (defun remove-tree-if (pred tree)
 570   "Strip from tree of atoms that satistify predicate"
 571   (if (atom tree)
 572       (unless (funcall pred tree)
 573         tree)
 574     (let ((car-strip (remove-tree-if pred (car tree)))
 575           (cdr-strip (remove-tree-if pred (cdr tree))))
 576       (cond
 577        ((and car-strip (atom (cadr tree)) (null cdr-strip))
 578         (list car-strip))
 579        ((and car-strip cdr-strip)
 580         (cons car-strip cdr-strip))
 581        (car-strip
 582         car-strip)
 583        (cdr-strip
 584         cdr-strip)))))
 585
 586 (defun find-tree (sym tree)
 587   "Finds an atom as a car in tree and returns cdr tree at that positions"
 588   (if (or (null tree) (atom tree))
 589       nil
 590     (if (eql sym (car tree))
 591         (cdr tree)
 592       (aif (find-tree sym (car tree))
 593           it
 594         (aif (find-tree sym (cdr tree))
 595             it
 596           nil)))))
 597
 598 ;;; Files
 599
 600 (defun print-file-contents (file &optional (strm *standard-output*))
 601   "Opens a reads a file. Returns the contents as a single string"
 602   (when (probe-file file)
 603     (with-open-file (in file :direction :input)
 604                     (do ((line (read-line in nil 'eof)
 605                                (read-line in nil 'eof)))
 606                         ((eql line 'eof))
 607                       (format strm "~A~%" line)))))
 608
 609 (defun read-file-to-string (file)
 610   "Opens a reads a file. Returns the contents as a single string"
 611   (with-output-to-string (out)
 612     (with-open-file (in file :direction :input)
 613       (do ((line (read-line in nil 'eof)
 614                  (read-line in nil 'eof)))
 615           ((eql line 'eof))
 616         (format out "~A~%" line)))))
 617
 618 (defun read-file-to-strings (file)
 619   "Opens a reads a file. Returns the contents as a list of strings"
 620   (let ((lines '()))
 621     (with-open-file (in file :direction :input)
 622       (do ((line (read-line in nil 'eof)
 623                  (read-line in nil 'eof)))
 624           ((eql line 'eof))
 625         (push line lines)))
 626     (nreverse lines)))
 627
 628
 629 ;; Generalized equal system
 630
 631 (defun generalized-equal (obj1 obj2)
 632   (if (not (equal (type-of obj1) (type-of obj2)))
 633       (progn
 634         (terpri)
 635         (describe obj1)
 636         (describe obj2)
 637         nil)
 638     (typecase obj1
 639       (double-float
 640        (let ((diff (abs (/ (- obj1 obj2) obj1))))
 641          (if (> diff (* 10 double-float-epsilon))
 642              nil
 643            t)))
 644       (complex
 645        (and (generalized-equal (realpart obj1) (realpart obj2))
 646             (generalized-equal (imagpart obj1) (imagpart obj2))))
 647       (structure
 648        (generalized-equal-fielded-object obj1 obj2))
 649       (standard-object
 650        (generalized-equal-fielded-object obj1 obj2))
 651       (hash-table
 652        (generalized-equal-hash-table obj1 obj2)
 653        )
 654       (function
 655        (generalized-equal-function obj1 obj2))
 656       (string
 657        (string= obj1 obj2))
 658       (array
 659        (generalized-equal-array obj1 obj2))
 660       (t
 661        (equal obj1 obj2)))))
 662
 663
 664 (defun generalized-equal-function (obj1 obj2)
 665   (string= (function-to-string obj1) (function-to-string obj2)))
 666
 667 (defun generalized-equal-array (obj1 obj2)
 668   (block test
 669     (when (not (= (array-total-size obj1) (array-total-size obj2)))
 670       (return-from test nil))
 671     (dotimes (i (array-total-size obj1))
 672       (unless (generalized-equal (aref obj1 i) (aref obj2 i))
 673         (return-from test nil)))
 674     (return-from test t)))
 675
 676 (defun generalized-equal-hash-table (obj1 obj2)
 677   (block test
 678     (when (not (= (hash-table-count obj1) (hash-table-count obj2)))
 679       (return-from test nil))
 680     (maphash
 681      #'(lambda (k v)
 682          (multiple-value-bind (value found) (gethash k obj2)
 683            (unless (and found (generalized-equal v value))
 684              (return-from test nil))))
 685      obj1)
 686     (return-from test t)))
 687
 688 (defun generalized-equal-fielded-object (obj1 obj2)
 689   (block test
 690     (when (not (equal (class-of obj1) (class-of obj2)))
 691       (return-from test nil))
 692     (dolist (field (class-slot-names (class-name (class-of obj1))))
 693       (unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
 694         (return-from test nil)))
 695     (return-from test t)))
 696
 697 #+(or allegro lispworks)
 698 (defun class-slot-names (class-name)
 699   "Given a CLASS-NAME, returns a list of the slots in the class."
 700   (mapcar #'clos:slot-definition-name
 701           (clos:class-slots (find-class class-name))))
 702
 703 #-(or allegro lispworks)
 704 (defun class-slot-names (class-name)
 705   (warn "class-slot-names not supported on this platform"))
 706
 707
 708 (defun function-to-string (obj)
 709   "Returns the lambda code for a function. Relies on
 710 Allegro implementation-dependent features."
 711   (multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
 712     (declare (ignore closurep))
 713     (if lambda
 714           (format nil "#'~s" lambda)
 715       (if name
 716           (format nil "#'~s" name)
 717         (progn
 718           (print obj)
 719           (break))))))
 720
 721
 722 ;;; Formatting functions
 723
 724 (defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
 725   (multiple-value-bind (sec min hr dy mn yr wkday)
 726     (decode-universal-time
 727      (encode-universal-time s m hour day month year))
 728     (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
 729                    "Friday" "Saturday" "Sunday")
 730                  wkday)
 731             (elt '("January" "February" "March" "April" "May" "June"
 732                    "July" "August" "September" "October" "November"
 733                    "December")
 734                  (1- mn))
 735             (format nil "~A" dy) (format nil "~A" yr)
 736             (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
 737
 738
 739 (defun date-string (ut)
 740   (if (typep ut 'integer)
 741       (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
 742           (decode-universal-time ut)
 743         (declare (ignore daylight-p zone))
 744         (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~
 745 ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~
 746 ~2,'0d:~2,'0d:~2,'0d"
 747                 dow
 748                 day
 749                 (1- mon)
 750                 year
 751                 hr min sec))))
 752