Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

first commit Git not Darcs

  • Loading branch information...
commit fb1bc7d616fd812e1361529bb9b56bc80bc8a5ed 0 parents
Nick Allen authored
BIN  doc/.DS_Store
Binary file not shown
206 doc/pretty-function.html
@@ -0,0 +1,206 @@
+<?xml version="1.0"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+ <head>
+ <title>pretty-function</title>
+ <link rel="stylesheet" type="text/css" href="style.css"/>
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
+</head>
+
+
+
+
+<body>
+ <div class="header">
+ <h1>pretty-function</h1>
+ </div>
+
+ <h3>introduction</h3>
+
+ <p>`pretty-function' provides an API for making individual functions pprint differently when written to an output stream.</p>
+
+ <h3>download</h3>
+
+ <p>wait 2 seconds, I'm uploading it as your reading this</p>
+
+<h3>license</h3>
+
+<p><a href="http://en.wikipedia.org/wiki/BSD_License">BSD</a> &copy; 2007 <a href="http://streamtech.nl">Streamtech</a></p>
+
+<h3>supported implimentations</h3>
+
+<p><a href="#enable-pretty-function-printing"><code>ENABLE-PRETTY-FUNCTION-PRINTING</code></a> seems to work and the tests in pretty-function-test.lisp pass on the following implimentations:</p>
+
+<ul>
+ <li>ACL</li>
+ <li>Clisp</li>
+ <li>CMUCL</li>
+ <li>Lispworks</li>
+ <li>OpenMCL/MCL</li>
+ <li>SBCL</li>
+</ul>
+
+<p>the rest should fail gracefully by not pprinting pretty functions any differently from normal functions</p>
+
+<h3>when to use pretty functions</h3>
+
+<p>`pretty-functions' is intended to make code with a lot of first class functions and closures saner to debug.</p>
+
+<p>there is a little extra work involved when creating or garbage-collecting pretty functions, so they probubly shouldn't be used in situations where arbitrarily large amounts of closures being created and garbage-collected at runtime.</p>
+
+<p>a good example use-case is a <a href="http://weitz.de/hunchentoot/">hunchentoot</a>-powered web application:</p>
+
+<p>hunchentoot deals with HTTP requests by means of a global <a href="http://weitz.de/hunchentoot/#handlers">dispatch table</a>. the dispatch table is a list of function indicators ("dispatchers") that often contains a buch of closures (such as the one created by <code><a href="http://weitz.de/hunchentoot/#create-static-file-dispatcher-and-handler">create-static-file-dispatcher-and-handler</a></code>). when hunchentoot gets an HTTP request, each dispatcher is called with the request object as an argument. when a dispatcher decides to handle this request, it signals its intent by returning another function (a "handler") that, when called, does all the HTML/HTTP stuff associated with handling the request.</p>
+
+<p>dispatchers are perfect canidates for pretty-functions since, as pretty functions, they can pprint something informative like</p>
+
+<pre class="code">#&lt;static-file-dispatcher "/foo/bar.html"&gt;</pre>
+
+<p>instead of the usual</p>
+
+<pre class="code">#&lt;what-the-hell-am-i&gt;</pre>
+
+<p>in a stack trace or when a programmer is visually inspecting the dispatch table via the REPL.</p>
+
+<p>hunchentoot's dynamically generated handlers, on the other hand, are not good canidates for pretty function forms because there could be <a href="http://en.wikipedia.org/wiki/Indefinite_and_fictitious_large_numbers">zillions</a> of them being created and garbage collected at runtime.</p>
+
+<p>the existence of pretty functions in a lisp image does not create any more work when creating or garbage collecting "normal" functions or closures (those not created with pretty function forms).</p>
+
+<h3>api</h3>
+
+<div class="def" >
+ <p><span>function</span><br/> <code><a name="enable-pretty-function-printing"></a><b>ENABLE-PRETTY-FUNCTION-PRINTING</b> (&amp;optional (priority 0) (table *print-pprint-dispatch*))</code></p>
+</div>
+ <div class="desc">
+ <p>modifies the pprint dispatch table <code>TABLE</code> to pprint functions using their pretty function printer (see <a href="#get-function-printer"><code>GET-FUNCTION-PRINTER</code></a>).</p>
+
+ <p>this means that you can make all the pretty functions you want, but until you run</p>
+
+ <pre class="code">(enable-pretty-function-printing)</pre>
+
+ <p>they wont print differently in the REPL or in stack traces!</p>
+
+ <p>for info on its arguments, see <a href="http://www.lisp.org/HyperSpec/Body/fun_set-pprint-dispatch.html"><code>SET-PPRINT-DISPATCH</code></a>.</p>
+</div>
+
+<div class="def">
+ <p><span>macro</span><br/> <code><b><a name="named-lambda"></a>NAMED-LAMBDA</b> (name lambda-list &amp;body body)</code></p>
+</div>
+
+<div class="desc">
+
+ <p>like <a href="http://www.lisp.org/HyperSpec/Body/sym_lambda.html"><code>LAMBDA</code></a> except the resultant function is written as</p>
+
+ <pre class="code">#&lt;named-lambda NAME&gt;</pre>
+
+ <p>when pprinted to a stream and pretty printing functions is enabled (see <a href="#enable-pretty-function-printing"><code>ENABLE-PRETTY-FUNCTION-PRINTING</code></a>).</p>
+
+ <p><code>NAME</code> is not evaluated.</p>
+
+ <p>caveat: unlike <a href="http://www.lisp.org/HyperSpec/Body/sym_lambda.html"><code>LAMBDA</code></a>, <a href="#named-lambda"><code>NAMED-LAMBDA</code></a> cannot be used as the first element of a list.</p>
+
+ <p>so</p>
+
+ <pre class="code">((lambda (a b) (+ a b)) 5 6) => 11</pre>
+
+ <p>but</p>
+
+ <pre class="code">((named-lambda mistake (a b) (+ a b)) 5 6) ==> THROWS AN ERROR</pre>
+</div>
+
+<div class="def">
+ <p><span>macro</span><br/> <code><b>NAMED-LAMBDA*</b> (name-form lambda-list &amp;body body)</code></p>
+</div>
+
+<div class="desc">
+
+ <p>like <a href="#named-lambda"><code>NAMED-LAMBDA</code></a> except <code>NAME-FORM</code> is evaluated</p>
+</div>
+
+<div class="def">
+ <p><span>macro</span><br/> <code><b><a name="with-function-printer"></a>WITH-FUNCTION-PRINTER</b> (printer fn-form)</code></p>
+</div>
+
+<div class="desc">
+
+ <p>returns the result of evaluating <code>FN-FORM</code>, which should return a function.</p>
+
+ <p>the resultant function will be written by <code>PRINTER</code> when pprinted to a stream and pretty printing functions is enabled (see <a href="#enable-pretty-function-printing"><code>ENABLE-PRETTY-FUNCTION-PRINTING</code></a>).</p>
+
+ <p><code>PRINTER</code> should be a lambda expression or name of a function that takes <code>STREAM</code> as its only argument and prints a pretty representation of <code>FUNCTION</code> to that <code>STREAM</code></p>
+
+<pre class="code">
+CL-USER> (enable-pretty-function-printing)
+
+CL-USER> (let ((n 0))
+ (setf x (with-function-printer (lambda (s) (format s "#&lt;counter ~A&gt;" n))
+ (lambda () (incf n)))))
+
+#&lt;counter 0&gt;
+
+CL-USER> (funcall x)
+1
+
+CL-USER> x
+#&lt;counter 1&gt;
+</pre>
+</div>
+
+
+<div class="def">
+ <p><span>variable</span><br/> <code><b>*PRETTY-FUNCTION-PRINTING-SUPPORTED-P*</b></code></p>
+</div>
+
+<div class="desc">
+
+ <p>is <code>T</code> on implimentations that support pretty function printing, <code>NIL</code> on the rest</p>
+</div>
+
+<div class="def">
+ <p><span>function</span><br/> <code><b>PRINT-PRETTY-FUNCTION-TABLE</b> (&amp;optional (stream *standard-output*))</code></p>
+</div>
+
+<div class="desc">
+
+ <p>prints all known pretty functions</p>
+</div>
+
+<div class="def">
+ <p><span>function</span><br/> <code><b>CLEAR-PRETTY-FUNCTION-TABLE</b> (&amp;optional (stream *standard-output*))</code></p>
+</div>
+
+<div class="desc">
+
+ <p>turns all known pretty functions into normal, non-pretty functions.</p>
+
+ <p>individual pretty functions can also be turned back into normal functions by <code>SETF</code>-ing their <a href="#get-function-printer"><code>GET-FUNCTION-PRINTER</code></a> to <code>NIL</code></p>
+</div>
+
+<div class="def">
+ <p><span>function</span><br/> <a name="get-function-printer"></a><code><b>GET-FUNCTION-PRINTER</b> (function)</code></p>
+</div>
+
+<div class="desc">
+
+ <p>returns the function responsible for pprinting the pretty function <code>FUNCTION</code> or <code>NIL</code> if <code>FUNCTION</code> is not a pretty function.</p>
+
+ <p>you can turn a non-pretty function into a pretty function by <code>SETF</code>-ing <code><a href="#get-function-printer">GET-FUNCTION-PRINTER</a></code> to a an acceptible printer (see <a href="#with-function-printer"><code>WITH-FUNCTION-PRINTER</code></a>). you can also turn a pretty function back into a normal function by <code>SETF</code>-ing its <a href="#get-function-printer"><code>GET-FUNCTION-PRINTER</code></a> to <code>NIL</code></p>
+</div>
+
+ <h3>Mailing Lists</h3>
+ <ul>
+ <li>
+ <a
+ href="http://www.common-lisp.net/mailman/listinfo/pretty-function-devel">
+ pretty-function-devel</a><br/>for developers</li>
+ <li>
+ <a
+ href="http://www.common-lisp.net/mailman/listinfo/pretty-function-announce">
+ pretty-function-announce</a><br/>for announcements.</li>
+ <li>
+ email the author/maintainer (Nick Allen) directly at nallen05@&lt;first-letter-of-Google&gt;mail.com</li>
+ </ul>
+
+ </body>
+</html>
68 doc/style.css
@@ -0,0 +1,68 @@
+body {
+ margin: 0;
+ font-family: times new roman,tahoma, arial, sans-serif;
+ padding: 1em 3em;
+
+ color: black;
+}
+
+h1 {
+ font-family: arial, sans-serif;
+ border-bottom: 3px solid #009ACD;
+}
+
+h3 {
+ font-family: arial, sans-serif;
+ font-size: 12pt;
+}
+
+p {
+ margin-left: 1em;
+}
+
+code {
+ font-family: monospace, courier-new;
+ font-size: 1.2em;
+}
+
+pre.code {
+ margin-left: 3em;
+ padding: 7px;
+ border: 1px solid #999999;
+ font-family: monospace;
+}
+
+.def {
+ margin-top: 1.5em;
+ font-family: courier;
+ padding-left: 1em;
+}
+
+.def span {
+ color: #555555;
+ font-weight: bold;
+ font-family: tahoma, arial, sans-serif;
+ font-size: .8em;
+}
+
+.desc {
+ margin-left: 3em;
+}
+
+thead {
+ font-weight: bold;
+}
+
+a:link {
+ color: #00688B;
+ text-decoration: none;
+}
+
+a:visited {
+ color: #00688B;
+ text-decoration: none;
+}
+
+a:hover {
+ text-decoration: underline;
+}
130 pretty-function-test.lisp
@@ -0,0 +1,130 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; -*-
+;; Sun Oct 21 17:22:01 2007 by Nick Allen <nallen05@gmail.com>
+;; pretty-function-test.lisp
+
+
+;; note: these tests require ptester, see http://www.cliki.net/ptester
+
+;; note: I had trouble forcing GC during this file on some lisps, so to check
+;; if the pretty functions are really being garbage collected you have
+;; to do it yourself
+
+;; 1. run the tests in this file
+;; 2. force a full garbage collection
+;; 3. run: (print-pretty-function-table)
+
+;; if you don't see anything like #<TEST-1234567> or
+;; #<test-pretty-function-printer> then the functions from these
+;; tests were garbage collected
+
+
+(defpackage :pretty-function.test
+ (:use :cl :pretty-function))
+
+(in-package :pretty-function.test)
+
+(setf ptester:*break-on-test-failures* t)
+
+
+
+;suport
+
+(defparameter *supported* nil)
+
+(ptester:test #+(or allegro clisp cmu lispworks mcl sbcl) t
+ #-(or allegro clisp cmu lispworks mcl sbcl) nil
+ (setf *supported*
+ (not (not (find "pretty-function" *modules* :test #'string-equal)))))
+
+(ptester:test *supported* *pretty-function-printing-supported-p*)
+
+
+
+;enabling
+
+;should this work on a temporary table?
+
+(if *supported*
+ (ptester:test-no-warning (enable-pretty-function-printing))
+ (ptester:test-warning (enable-pretty-function-printing)))
+
+
+
+;fn-printer
+
+(defparameter *printer-string* "#<test-pretty-function-printer>")
+
+(defparameter *printer*
+ (lambda (s) (write-string *printer-string* s)))
+
+(let ((fn (lambda () (print 5))))
+
+ (ptester:test nil (get-function-printer fn))
+
+ (ptester:test-no-error (setf (get-function-printer fn) *printer*))
+
+ (ptester:test *printer* (get-function-printer fn))
+
+ (ptester:test t
+ (progn
+ #+(or allegro clisp lispworks mcl)
+ (block finding
+ (maphash (lambda (fn printer)
+ (declare (ignore fn))
+ (if (eq *printer* printer)
+ (return-from finding t)))
+ pretty-function::*weak-fn-ht*)
+ nil)
+
+ #+(or cmu sbcl)
+ (not (not (find *printer*
+ pretty-function::*weak-fn-alist*
+ :key #'rest))))))
+
+
+
+;make sure function printer prints correctly
+
+(if *supported*
+ (ptester:test *printer-string*
+ (with-output-to-string (out)
+ (write (with-function-printer *printer*
+ (lambda () (print 5)))
+ :stream out
+ :pretty t))
+ :test #'string=))
+
+
+
+;WITH-FUNCTION-PRINTER
+
+(ptester:test (if *supported*
+ *printer*)
+ (get-function-printer (with-function-printer *printer*
+ (lambda () (print 5)))))
+
+
+
+;named-lambda*
+
+(ptester:test *supported*
+ (not (not (search "TEST-1234567"
+ (with-output-to-string (out)
+ (write (named-lambda* (concatenate 'string
+ "TEST-"
+ "123"
+ "4567")
+ () (print 5))
+ :stream out
+ :pretty t))))))
+
+
+
+;named-lambda
+
+(ptester:test *supported*
+ (not (not (search "TEST-1234567"
+ (with-output-to-string (out)
+ (write (named-lambda "TEST-1234567" () (print 5))
+ :stream out
+ :pretty t))))))
12 pretty-function.asd
@@ -0,0 +1,12 @@
+;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; -*-
+
+(in-package :cl-user)
+
+(defpackage :pretty-function.system
+ (:use :cl :asdf))
+
+(in-package :pretty-function.system)
+
+(asdf:defsystem :pretty-function
+ :version "0.1"
+ :components ((:file "pretty-function")))
370 pretty-function.lisp
@@ -0,0 +1,370 @@
+;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; -*-
+;; Sun Oct 21 11:55:20 2007 by Nick Allen <nallen05@gmail.com>
+;; pretty-function.lisp
+
+;; Copyright (c) 2007, Streamtech (http://streamtech.nl)
+;; All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;; * Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; * Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; * Neither the name of the <organization> nor the
+;; names of its contributors may be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY STREAMTECH ``AS IS'' AND ANY
+;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY
+;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;; function: ENABLE-PRETTY-FUNCTION-PRINTING (&optional (priority 0) (table *print-pprint-dispatch*))
+
+;; modifies the pprint dispatch table `TABLE' to pprint functions using their pretty
+;; function printer (see GET-FUNCTION-PRINTER)
+
+;; this means that you can make all the pretty functions you want, but until you run
+
+;; (enable-pretty-function-printing)
+
+;; they wont print differently in the REPL or in stack traces!
+
+;; macro: NAMED-LAMBDA (name lambda-list &body body)
+
+;; like LAMBDA except the resultant function is written as #<named-lambda NAME>
+;; when pprinted to a stream when pretty printing functions is enabled (see
+;; ENABLE-PRETTY-FUNCTION-PRINTING) and *PRINT-PRETTY* is T
+
+;; `NAME' is not evaluated.
+
+;; caveat: unlike lambda, NAMED-LAMBDA cannot be used as the first element of a list
+
+;; ((lambda (a b) (+ a b)) 5 6) => 11
+
+;; ((named-lambda mistake (a b) (+ a b)) 5 6) ==> THROWS AN ERROR
+
+;; macro: NAMED-LAMBDA* (name-form lambda-list &body body)
+
+;; like `NAMED-LAMBDA' except NAME-FORM is evaluated
+
+;; macro: WITH-FUNCTION-PRINTER (printer fn-form)
+
+;; returns the result of evaluating `FN-FORM', which should evaluate to a function.
+
+;; this function will now be pprinted with `PRINTER' when written to a stream and pretty
+;; printing functions is enabled (see ENABLE-PRETTY-FUNCTION-PRINTING) and *PRINT-PRETTY*
+;; is T.
+
+;; `PRINTER' should be a lambda expression or name of a function that takes
+;; `STREAM' as its only argument and prints a pretty representation of `FUNCTION' to
+;; `STREAM'
+
+;; CL-USER> (enable-pretty-function-printing)
+
+;; CL-USER> (let ((n 0))
+;; (setf x (with-function-printer (lambda (s) (format s "#<counter ~A>" n))
+;; (lambda () (incf n)))))
+
+;; #<counter 0>
+
+;; CL-USER> (funcall x)
+;; 1
+
+;; CL-USER> x
+;; #<counter 1>
+
+;; variable: *PRETTY-FUNCTION-PRINTING-SUPPORTED-P*
+
+;; is T on implimentations that support pretty function printing, NIL on the rest
+
+;; function: PRINT-PRETTY-FUNCTION-TABLE (&optional (stream *standard-output*))
+
+;; prints all known pretty functions
+
+;; function: CLEAR-PRETTY-FUNCTION-TABLE (&optional (stream *standard-output*))
+
+;; turns all known pretty functions into normal, non-pretty functions.
+
+;; individual pretty functions can be turned back into normal functions by SETF-ing their
+;; GET-FUNCTION-PRINTER to NIL
+
+;; function: GET-FUNCTION-PRINTER (function)
+
+;; returns the printer that is responsible for printing function printing `FUNCTION'. returns NIL if
+;; `FUNCTION' is not a pretty function.
+
+;; you can turn a non-pretty function into a pretty function by SETF-ing GET-FUNCTION-PRINTER to a
+;; an acceptible printer (see WITH-FUNCTION-PRINTER). you can also turn a pretty function back into
+;; a normal function by SETF-ing its GET-FUNCTION-PRINTER to NIL
+
+
+(defpackage :pretty-function
+ (:use :cl)
+ (:export ;; enabling pretty function printing
+ #:enable-pretty-function-printing
+
+ ;; using
+ #:named-lambda
+ #:named-lambda*
+ #:with-function-printer
+
+ ;; debugging
+ #:*pretty-function-printing-supported-p*
+ #:print-pretty-function-table
+ #:clear-pretty-function-table
+ #:get-function-printer))
+
+
+(in-package :pretty-function)
+
+
+;supported implimentations
+
+(defparameter *pretty-function-printing-supported-p*
+
+ #+(or allegro clisp cmu lispworks mcl sbcl) t
+
+ #-(or allegro clisp cmu lispworks mcl sbcl) nil
+)
+
+
+;enabling pretty function printing
+
+(defvar *pretty-function-printing-enabled-p* nil)
+
+(defun enable-pretty-function-printing (&optional (priority 0) (table *print-pprint-dispatch*))
+
+ #+(or allegro clisp cmu lispworks mcl sbcl)
+ (progn
+ (set-pprint-dispatch 'function '.print-pretty-function priority table)
+ (setf *print-pretty* t)
+ (let ((% (not *pretty-function-printing-enabled-p*)))
+ (setf *pretty-function-printing-enabled-p* t)
+ %))
+
+ #-(or allegro clisp cmu mcl lispworks sbcl)
+ (warn "pretty function printing is not supported on ~A ~A"
+ (lisp-implementation-type)
+ (lisp-implementation-version)))
+
+(defun .print-pretty-function (s fn)
+ (let ((printer (get-function-printer fn)))
+ (if printer
+ (funcall (coerce printer 'function) s)
+ (let ((*print-pretty* nil))
+ (write fn :stream s)))))
+
+
+;the machinary
+
+#+allegro
+ (defvar *weak-fn-ht* (make-hash-table :test #'eq
+ :weak-keys t))
+
+#+(or clisp mcl)
+(defvar *weak-fn-ht* (make-hash-table :test #'eq
+ :weak :key))
+
+#+lispworks
+(defvar *weak-fn-ht* (make-hash-table :test #'eq
+ :weak-kind :key))
+
+#+(or cmu sbcl)
+(progn
+
+ (defvar *weak-fn-alist* nil)
+
+ (defvar *weak-fn-alist-outdated-p* nil)
+
+ (defun .outdate-weak-fn-alist ()
+ (setf *weak-fn-alist-outdated-p* t)))
+
+#+cmu
+(progn
+
+ (defun .update-weak-fn-alist ()
+ (if *weak-fn-alist-outdated-p*
+ (setf *weak-fn-alist* (remove-if-not (lambda (a)
+ (and (rest a)
+ (ext:weak-pointer-value (first a))))
+ *weak-fn-alist*)
+ *weak-fn-alist-outdated-p* nil)))
+
+ (pushnew '.update-weak-fn-alist ext:*after-gc-hooks*))
+
+#+sbcl
+(progn
+
+ (defun .update-weak-fn-alist ()
+ (setf *weak-fn-alist* (remove-if-not (lambda (a)
+ (and (rest a)
+ (sb-ext:weak-pointer-value (first a))))
+ *weak-fn-alist*)
+ *weak-fn-alist-outdated-p* nil))
+
+ (pushnew '.update-weak-fn-alist sb-ext:*after-gc-hooks*))
+
+;WITH-FUNCTION-PRINTER macro
+
+(defmacro with-function-printer (printer fn)
+
+ #+(or allegro lispworks mcl clisp)
+ `(let ((p ,printer)
+ (f ,fn))
+ (setf (gethash f *weak-fn-ht*) p)
+ f)
+
+ #+cmu
+ `(let ((p ,printer)
+ (f ,fn))
+ (let ((w (extensions:make-weak-pointer f)))
+ (push (cons w p) *weak-fn-alist*)
+ (extensions:finalize f #'.outdate-weak-fn-alist)
+ f))
+
+ #+sbcl
+ `(let ((p ,printer)
+ (f ,fn))
+ (let ((w (sb-ext:make-weak-pointer f)))
+ (push (cons w p) *weak-fn-alist*)
+ (sb-ext:finalize f #'.outdate-weak-fn-alist)
+ f)))
+
+
+
+;NAMED-LAMBDA and NAMED-LAMBDA* macros
+
+(defmacro named-lambda (name lambda-list &body body)
+
+ #+(or allegro clisp cmu lispworks mcl sbcl)
+ `(named-lambda* ',name ,lambda-list ,@body)
+
+ #-(or allegro clisp cmu lispworks mcl sbcl)
+ `(lambda ,lambda-list ,@body))
+
+(defmacro named-lambda* (name-form lambda-list &body body)
+
+ #+(or allegro clisp cmu lispworks mcl sbcl)
+ `(with-function-printer (lambda (s) (format s "#<named-lambda ~A>" ,name-form))
+ (lambda ,lambda-list ,@body))
+
+ #-(or allegro clisp cmu lispworks mcl sbcl)
+ `(progn ,name-form
+ (lambda ,lambda-list ,@body)))
+
+;FUNCTION-PRINTER fn
+
+(defun get-function-printer (fn)
+
+ #+(or allegro lispworks mcl clisp) (values (gethash fn *weak-fn-ht*))
+
+ #+sbcl (rest (assoc fn *weak-fn-alist* :key #'sb-ext:weak-pointer-value))
+
+ #+cmu (rest (assoc fn *weak-fn-alist* :key #'ext:weak-pointer-value))
+
+ #-(or allegro clisp cmu lispworks mcl sbcl) nil
+)
+
+(defsetf get-function-printer (fn) (printer)
+
+ #+(or allegro clisp lispworks mcl)
+ `(let ((p ,printer)
+ (f ,fn))
+ (if p
+ (setf (gethash f *weak-fn-ht*) p)
+ (remhash f *weak-fn-ht*))
+ p)
+
+ #+cmu
+ `(let ((f ,fn)
+ (p ,printer))
+ (let ((a (assoc f
+ *weak-fn-alist*
+ :key #'ext:weak-pointer-value)))
+ (cond (a (setf (rest a) p)
+ (if (null p)
+ (.outdate-weak-fn-alist)))
+ (t (push (cons (ext:make-weak-pointer f) p)
+ *weak-fn-alist*)
+ (ext:finalize f #'.outdate-weak-fn-alist)))
+ p))
+
+ #+sbcl
+ `(let ((f ,fn)
+ (p ,printer))
+ (let ((a (assoc f
+ *weak-fn-alist*
+ :key #'sb-ext:weak-pointer-value)))
+ (cond (a (setf (rest a) p)
+ (if (null p)
+ (.outdate-weak-fn-alist)))
+ (t (push (cons (sb-ext:make-weak-pointer f) p)
+ *weak-fn-alist*)
+ (sb-ext:finalize f #'.outdate-weak-fn-alist)))
+ p))
+
+ #-(or allegro clisp cmu lispworks mcl sbcl)
+ `(progn ,fn ,printer)
+)
+
+;PRINT-PRETTY-FUNCTION-TABLE
+
+(defun print-pretty-function-table (&optional (stream *standard-output*))
+
+ #+(or allegro clisp lispworks mcl)
+ (let ((n (hash-table-count *weak-fn-ht*)))
+ (format stream "~%there are ~A pretty function~p in the pretty function table~%" n n)
+ (maphash (lambda (fn printer)
+ (declare (ignore fn))
+ (funcall printer stream)
+ (terpri stream))
+ *weak-fn-ht*))
+
+ #+(or cmu sbcl)
+ (let ((n (length *weak-fn-alist*)))
+ (format stream "~%there are ~A pretty function~p in the pretty function table~%" n n)
+ (mapc (lambda (%)
+ (funcall (rest %) stream)
+ (terpri stream))
+ *weak-fn-alist*))
+
+ #-(or allegro clisp cmu lispworks mcl sbcl)
+ (warn "The implimentation you are using does not support pretty function printing")
+
+ (values))
+
+;CLEAR-PRETTY-FUNCTION-TABLE
+
+(defun clear-pretty-function-table (&optional (stream *standard-output*))
+
+ #+(or allegro clisp lispworks mcl)
+ (let ((n (hash-table-count *weak-fn-ht*)))
+ (if (zerop n)
+ (format stream "The pretty function table is empty!~%")
+ (format stream "~A pretty function~p deleted from the pretty function table~%" n n))
+ (clrhash *weak-fn-ht*))
+
+
+ #+(or cmu sbcl)
+ (let ((n (length *weak-fn-alist*)))
+ (if (zerop n)
+ (format stream "The pretty function table is empty!~%")
+ (format t "~A pretty function~p deleted from the pretty function table~%" n n))
+ (setf *weak-fn-alist* nil))
+
+ #-(or allegro clisp cmu lispworks mcl sbcl)
+ (warn "The implimentation you are using does not support pretty function printing")
+
+ (values))
+
+#+(or allegro clisp cmu mcl lispworks sbcl)
+(provide :pretty-function)
Please sign in to comment.
Something went wrong with that request. Please try again.