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