diff options
Diffstat (limited to 'qp.scm')
| -rw-r--r-- | qp.scm | 149 |
1 files changed, 149 insertions, 0 deletions
@@ -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) |