summaryrefslogtreecommitdiffstats
path: root/qp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'qp.scm')
-rw-r--r--qp.scm149
1 files changed, 149 insertions, 0 deletions
diff --git a/qp.scm b/qp.scm
new file mode 100644
index 0000000..3eed54d
--- /dev/null
+++ b/qp.scm
@@ -0,0 +1,149 @@
+;;;; "qp.scm" Print finite length representation for any Scheme object.
+;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define *qp-width* (output-port-width (current-output-port)))
+
+(define qp:qpn
+ (let ((newline newline) (apply apply))
+ (lambda objs (apply qp:qp objs) (newline))))
+
+(define qp:qpr
+ (let ((- -) (apply apply) (length length) (list-ref list-ref))
+ (lambda objs (apply qp:qpn objs)
+ (list-ref objs (- (length objs) 1)))))
+
+(define qp:qp
+ (let
+ ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?)
+ (car car) (cdr cdr) (char? char?) (display display) (eq? eq?)
+ (for-each for-each) (input-port? input-port?)
+ (not not) (null? null?) (number->string number->string)
+ (number? number?) (output-port? output-port?) (eof-object? eof-object?)
+ (procedure? procedure?) (string-length string-length)
+ (string? string?) (substring substring)
+ (symbol->string symbol->string) (symbol? symbol?)
+ (vector-length vector-length) (vector-ref vector-ref)
+ (vector? vector?) (write write) (quotient quotient))
+ (letrec
+ ((num-cdrs
+ (lambda (pairs max-cdrs)
+ (cond
+ ((null? pairs) 0)
+ ((< max-cdrs 1) 1)
+ ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1))))
+ (else 1))))
+
+ (l-elt-room
+ (lambda (room pairs)
+ (quotient room (num-cdrs pairs (quotient room 8)))))
+
+ (qp-pairs
+ (lambda (cdrs room)
+ (cond
+ ((null? cdrs) 0)
+ ((not (pair? cdrs))
+ (display " . ")
+ (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs))))
+ ((< 11 room)
+ (display #\ )
+ ((lambda (used)
+ (+ (qp-pairs (cdr cdrs) (- room used)) used))
+ (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs)))))
+ (else
+ (display " ...") 4))))
+
+ (v-elt-room
+ (lambda (room vleft)
+ (quotient room (min vleft (quotient room 8)))))
+
+ (qp-vect
+ (lambda (vect i room)
+ (cond
+ ((= (vector-length vect) i) 0)
+ ((< 11 room)
+ (display #\ )
+ ((lambda (used)
+ (+ (qp-vect vect (+ i 1) (- room used)) used))
+ (+ 1 (qp-obj (vector-ref vect i)
+ (v-elt-room (- room 1)
+ (- (vector-length vect) i))))))
+ (else
+ (display " ...") 4))))
+
+ (qp-string
+ (lambda (str room)
+ (cond
+ ((>= (string-length str) room 3)
+ (display (substring str 0 (- room 3)))
+ (display "...")
+ room)
+ (else
+ (display str)
+ (string-length str)))))
+
+ (qp-obj
+ (lambda (obj room)
+ (cond
+ ((null? obj) (write obj) 2)
+ ((boolean? obj) (write obj) 2)
+ ((char? obj) (write obj) 8)
+ ((number? obj) (qp-string (number->string obj) room))
+ ((string? obj)
+ (display #\")
+ ((lambda (ans) (display #\") ans)
+ (+ 2 (qp-string obj (- room 2)))))
+ ((symbol? obj) (qp-string (symbol->string obj) room))
+ ((input-port? obj) (display "#[input]") 8)
+ ((output-port? obj) (display "#[output]") 9)
+ ((procedure? obj) (display "#[proc]") 7)
+ ((eof-object? obj) (display "#[eof]") 6)
+ ((vector? obj)
+ (set! room (- room 3))
+ (display "#(")
+ ((lambda (used) (display #\)) (+ used 3))
+ (cond
+ ((= 0 (vector-length obj)) 0)
+ ((< room 8) (display "...") 3)
+ (else
+ ((lambda (used) (+ (qp-vect obj 1 (- room used)) used))
+ (qp-obj (vector-ref obj 0)
+ (v-elt-room room (vector-length obj))))))))
+ ((pair? obj)
+ (set! room (- room 2))
+ (display #\()
+ ((lambda (used) (display #\)) (+ 2 used))
+ (if (< room 8) (begin (display "...") 3)
+ ((lambda (used)
+ (+ (qp-pairs (cdr obj) (- room used)) used))
+ (qp-obj (car obj) (l-elt-room room obj))))))
+ (else (display "#[unknown]") 10)))))
+
+ (lambda objs
+ (cond
+ ((= 0 *qp-width*)
+ (for-each (lambda (x) (write x) (display #\ )) objs)
+ (newline))
+ (else
+ (qp-pairs (cdr objs)
+ (- *qp-width*
+ (qp-obj (car objs) (l-elt-room *qp-width* objs))))))))))
+
+(define qp qp:qp)
+(define qpn qp:qpn)
+(define qpr qp:qpr)