diff options
Diffstat (limited to 'qp.scm')
| -rw-r--r-- | qp.scm | 35 |
1 files changed, 18 insertions, 17 deletions
@@ -1,5 +1,5 @@ ;;;; "qp.scm" Print finite length representation for any Scheme object. -;;; Copyright (C) 1991, 1992, 1993, 1995 Aubrey Jaffer +;;; Copyright (C) 1991, 1992, 1993, 1995, 2003 Aubrey Jaffer ; ;Permission to copy this software, to modify it, to redistribute it, ;to distribute modified versions, and to use it for any purpose is @@ -8,7 +8,7 @@ ;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 +;2. I have made no warranty 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. ; @@ -17,9 +17,10 @@ ;promotional, or sales literature without prior written consent in ;each case. +;@ (define *qp-width* (output-port-width (current-output-port))) - -(define qp:qp +;@ +(define qp (let ((+ +) (- -) (< <) (= =) (>= >=) (apply apply) (boolean? boolean?) (car car) (cdr cdr) (char? char?) (display display) (eq? eq?) @@ -127,23 +128,23 @@ (lambda objs (cond - ((or (not *qp-width*) (= 0 *qp-width*)) + ((not *qp-width*) (for-each (lambda (x) (write x) (display #\ )) objs) (newline)) + ((= 0 *qp-width*) + (for-each (lambda (x) + (if (procedure? x) (display "#[proc]") (write x)) + (display #\ )) objs)) (else (qp-pairs (cdr objs) (- *qp-width* (qp-obj (car objs) (l-elt-room *qp-width* objs)))))))))) - -(define qp:qpn - (let ((newline newline) (apply apply) (qp:qp qp:qp)) - (lambda objs (apply qp:qp objs) (newline)))) - -(define qp:qpr - (let ((- -) (apply apply) (length length) (list-ref list-ref) (qp:qpn qp:qpn)) - (lambda objs (apply qp:qpn objs) +;@ +(define qpn + (let ((newline newline) (apply apply) (qp qp)) + (lambda objs (apply qp objs) (newline)))) +;@ +(define qpr + (let ((- -) (apply apply) (length length) (list-ref list-ref) (qpn qpn)) + (lambda objs (apply qpn objs) (list-ref objs (- (length objs) 1))))) - -(define qp qp:qp) -(define qpn qp:qpn) -(define qpr qp:qpr) |