[movitz-cvs] CVS update: movitz/losp/muerte/print.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Tue Apr 13 14:22:02 UTC 2004
Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv18310
Modified Files:
print.lisp
Log Message:
Tried to be somewhat more clever about avoiding keyword-parsing in
calls to write.
Date: Tue Apr 13 10:22:02 2004
Author: ffjeld
Index: movitz/losp/muerte/print.lisp
diff -u movitz/losp/muerte/print.lisp:1.5 movitz/losp/muerte/print.lisp:1.6
--- movitz/losp/muerte/print.lisp:1.5 Tue Apr 6 10:29:33 2004
+++ movitz/losp/muerte/print.lisp Tue Apr 13 10:22:02 2004
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef at acm.org>
;;;; Created at: Mon Sep 3 11:48:19 2001
;;;;
-;;;; $Id: print.lisp,v 1.5 2004/04/06 14:29:33 ffjeld Exp $
+;;;; $Id: print.lisp,v 1.6 2004/04/13 14:22:02 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -100,9 +100,9 @@
(write-char comma-char stream))
nil)
-(defun write-integer (x stream &key (base *print-base*) (radix *print-radix*)
- mincol (padchar #\space)
- (sign-always nil) (comma-char #\,) (comma-interval nil))
+(defun write-integer (x stream base radix
+ &optional mincol (padchar #\space)
+ (sign-always nil) (comma-char #\,) (comma-interval nil))
(when radix
(case base
(10) ; put a #\. at the end.
@@ -124,7 +124,7 @@
(8 #.(cl:format cl:nil "~O" movitz::+movitz-most-negative-fixnum+))
(10 #.(cl:format cl:nil "~D" movitz::+movitz-most-negative-fixnum+))
(16 #.(cl:format cl:nil "~X" movitz::+movitz-most-negative-fixnum+))
- (t "minus-hack"))
+ (t (break "minus-hack!?")))
stream))))
(sign-always
(values #\+ x))
@@ -160,170 +160,197 @@
(pretty *print-pretty*) (radix *print-radix*)
((:readably *print-readably*) *print-readably*)
right-margin)
- (declare (dynamic-extent key-args)
- (special *read-base* *package*)
- (ignore case circle pprint-dispatch miser-width right-margin lines))
- (cond
- ((and *print-safely* (not safe-recursive-call))
- (handler-case (apply #'write object :safe-recursive-call t key-args)
- (t (condition)
- (write-string "#<printer error>" stream))))
- ((and (not pretty)
- (not *never-use-print-object*))
- (print-object object stream))
- (t (let ((do-escape-p (or *print-escape* *print-readably*))
- (stream (output-stream-designator stream))
- (*print-level* (minus-if level 1)))
- (typecase object
- (character
- (if (not do-escape-p)
- (write-char object stream)
- (progn
- (write-string "#\\" stream)
- (let ((name (char-name object)))
- (if name
- (write-string name stream)
- (write-char object stream))))))
- (null
- (write-string (symbol-name nil) stream))
- ((or cons tag5)
- (cond
- ((and *print-level* (minusp *print-level*))
- (write-char #\# stream))
- ((and (eq 'quote (car object))
- (not (cddr object)))
- (write-char #\' stream)
- (write (cadr object) :stream stream))
- (t (labels ((write-cons (c stream length)
- (cond
- ((and length (= 0 length))
- (write-string "...)"))
- (t (write (car c) :stream stream)
- (typecase (cdr c)
- (null
- (write-char #\) stream))
- (cons
- (write-char #\space stream)
- (write-cons (cdr c) stream (minus-if length 1)))
- (t
- (write-string " . " stream)
- (write (cdr c) :stream stream)
- (write-char #\) stream)))))))
- (write-char #\( stream)
- (write-cons object stream length)))))
- (integer
- (write-integer object stream :base base :radix radix))
- (string
- (if do-escape-p
- (stream-write-escaped-string stream object #\")
- (write-string object stream)))
- (symbol ; 22.1.3.3 Printing Symbols
- (flet ((write-symbol-name (symbol stream)
- (let ((name (symbol-name symbol)))
- (if (and (plusp (length name))
- (every (lambda (c)
- (or (upper-case-p c)
- (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=))
- (digit-char-p c)))
- name)
- (not (every (lambda (c)
- (or (digit-char-p c *read-base*)
- (member c '(#\.))))
- name)))
- (write-string name stream)
- (stream-write-escaped-string stream name #\|)))))
- (cond
- ((not do-escape-p)
- (write-symbol-name object stream))
- ((eq (symbol-package object) (find-package "KEYWORD"))
- (write-string ":" stream)
- (write-symbol-name object stream))
- ((or (eq (symbol-package object) *package*)
- (eq (find-symbol (string object))
- object))
- (write-symbol-name object stream))
- ((symbol-package object)
- (let ((package (symbol-package object)))
- (write-string (package-name package) stream)
- (write-string (if (gethash (symbol-name object)
- (package-object-external-symbols package))
- ":" "::")
- stream)
- (write-symbol-name object stream)))
- ((not (symbol-package object))
- (when *print-gensym*
- (write-string "#:" stream))
- (write-symbol-name object stream))
- (t (error "Huh?")))))
- (vector
- (cond
- ((and *print-level* (minusp *print-level*))
- (write-char #\# stream))
- ((or array *print-readably*)
- (write-string "#(" stream)
- (cond
- ((and length (< length (length object)))
- (dotimes (i length)
- (unless (= 0 i)
- (write-char #\space stream))
- (write (aref object i)))
- (write-string " ...)" stream))
- (t (dotimes (i (length object))
- (unless (= 0 i)
- (write-char #\space stream))
- (write (aref object i) :stream stream))
- (write-char #\) stream))))
- (t (print-unreadable-object (object stream :identity t)
- (princ (type-of object) stream)))))
- (standard-gf-instance
- (print-unreadable-object (object stream)
- (format stream "gf ~S" (funobj-name object))))
- (compiled-function
- (print-unreadable-object (object stream)
- (format stream "function ~S" (funobj-name object))))
- (hash-table
- (print-unreadable-object (object stream :identity nil :type nil)
- (format stream "~S hash-table with ~D entries"
- (let ((test (hash-table-test object)))
- (if (typep test 'compiled-function)
- (funobj-name test)
- test))
- (hash-table-count object))))
- (package
- (if (package-name object)
- (print-unreadable-object (object stream :identity nil :type nil)
- (format stream "Package ~A with ~D+~D symbols"
- (package-name object)
- (hash-table-count (package-object-external-symbols object))
- (hash-table-count (package-object-internal-symbols object))))
- (print-unreadable-object (object stream :identity t :type t))))
- (t (if (not *never-use-print-object*)
- (print-object object stream)
- (print-unreadable-object (object stream :identity t)
- (cond
- ((typep object 'std-instance)
- (write-string "[std-instance]" stream)
- (write (standard-instance-access (std-instance-class object) 0) :stream stream))
- ((typep object 'standard-gf-instance)
- (write-string "[std-gf-instance]" stream))
- (t (princ (type-of object) stream))))))))))
- object)
+ (numargs-case
+ (t (object &key safe-recursive-call
+ ;; lines miser-width pprint-dispatch right-margin case circle
+ ((:stream *standard-output*) *standard-output*)
+ ((:array *print-array*) *print-array*)
+ ((:base *print-base*) *print-base*)
+ ((:escape *print-escape*) *print-escape*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:length *print-length*) *print-length*)
+ ((:level *print-level*) *print-level*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:readably *print-readably*) *print-readably*))
+ (cond
+ ((and *print-safely* (not safe-recursive-call))
+ (handler-case (write object :safe-recursive-call t)
+ (t (condition)
+ (write-string "#<printer error>"))))
+ (t (write object))))
+ (1 (object)
+ (let ((stream (output-stream-designator *standard-output*)))
+ (cond
+ ((and (not *print-pretty*)
+ (not *never-use-print-object*))
+ (print-object object stream))
+ (t (let ((do-escape-p (or *print-escape* *print-readably*))
+ (*print-level* (minus-if *print-level* 1)))
+ (typecase object
+ (character
+ (if (not do-escape-p)
+ (write-char object stream)
+ (progn
+ (write-string "#\\" stream)
+ (let ((name (char-name object)))
+ (if name
+ (write-string name stream)
+ (write-char object stream))))))
+ (null
+ (write-string (symbol-name nil) stream))
+ ((or cons tag5)
+ (let ((level *print-level*)
+ (length *print-length*))
+ (cond
+ ((and level (minusp level))
+ (write-char #\# stream))
+ ((and (eq 'quote (car object))
+ (not (cddr object)))
+ (write-char #\' stream)
+ (write (cadr object)))
+ (t (labels ((write-cons (c stream length)
+ (cond
+ ((and length (= 0 length))
+ (write-string "...)"))
+ (t (write (car c))
+ (typecase (cdr c)
+ (null
+ (write-char #\) stream))
+ (cons
+ (write-char #\space stream)
+ (write-cons (cdr c) stream (minus-if length 1)))
+ (t
+ (write-string " . " stream)
+ (write (cdr c))
+ (write-char #\) stream)))))))
+ (write-char #\( stream)
+ (write-cons object stream length))))))
+ (integer
+ (write-integer object stream *print-base* *print-radix*))
+ (string
+ (if do-escape-p
+ (stream-write-escaped-string stream object #\")
+ (write-string object stream)))
+ (symbol ; 22.1.3.3 Printing Symbols
+ (flet ((write-symbol-name (symbol stream)
+ (let ((name (symbol-name symbol)))
+ (if (and (plusp (length name))
+ (every (lambda (c)
+ (or (upper-case-p c)
+ (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=))
+ (digit-char-p c)))
+ name)
+ (not (every (lambda (c)
+ (or (digit-char-p c *read-base*)
+ (member c '(#\.))))
+ name)))
+ (write-string name stream)
+ (stream-write-escaped-string stream name #\|)))))
+ (cond
+ ((not do-escape-p)
+ (write-symbol-name object stream))
+ ((eq (symbol-package object) (find-package "KEYWORD"))
+ (write-string ":" stream)
+ (write-symbol-name object stream))
+ ((or (eq (symbol-package object) *package*)
+ (eq (find-symbol (string object))
+ object))
+ (write-symbol-name object stream))
+ ((symbol-package object)
+ (let ((package (symbol-package object)))
+ (write-string (package-name package) stream)
+ (write-string (if (gethash (symbol-name object)
+ (package-object-external-symbols package))
+ ":" "::")
+ stream)
+ (write-symbol-name object stream)))
+ ((not (symbol-package object))
+ (when *print-gensym*
+ (write-string "#:" stream))
+ (write-symbol-name object stream))
+ (t (error "Huh?")))))
+ (vector
+ (let ((level *print-level*)
+ (length *print-length*))
+ (cond
+ ((and level (minusp level))
+ (write-char #\# stream))
+ ((or *print-array* *print-readably*)
+ (write-string "#(" stream)
+ (cond
+ ((and length (< length (length object)))
+ (dotimes (i length)
+ (unless (= 0 i)
+ (write-char #\space stream))
+ (write (aref object i)))
+ (write-string " ...)" stream))
+ (t (dotimes (i (length object))
+ (unless (= 0 i)
+ (write-char #\space stream))
+ (write (aref object i)))
+ (write-char #\) stream))))
+ (t (print-unreadable-object (object stream :identity t)
+ (princ (type-of object) stream))))))
+ (standard-gf-instance
+ (print-unreadable-object (object stream)
+ (format stream "gf ~S" (funobj-name object))))
+ (compiled-function
+ (print-unreadable-object (object stream)
+ (format stream "function ~S" (funobj-name object))))
+ (hash-table
+ (print-unreadable-object (object stream :identity nil :type nil)
+ (format stream "~S hash-table with ~D entries"
+ (let ((test (hash-table-test object)))
+ (if (typep test 'compiled-function)
+ (funobj-name test)
+ test))
+ (hash-table-count object))))
+ (package
+ (if (package-name object)
+ (print-unreadable-object (object stream :identity nil :type nil)
+ (format stream "Package ~A with ~D+~D symbols"
+ (package-name object)
+ (hash-table-count (package-object-external-symbols object))
+ (hash-table-count (package-object-internal-symbols object))))
+ (print-unreadable-object (object stream :identity t :type t))))
+ (t (if (not *never-use-print-object*)
+ (print-object object stream)
+ (print-unreadable-object (object stream :identity t)
+ (cond
+ ((typep object 'std-instance)
+ (write-string "[std-instance]" stream)
+ (write (standard-instance-access (std-instance-class object) 0)))
+ ((typep object 'standard-gf-instance)
+ (write-string "[std-gf-instance]" stream))
+ (t (princ (type-of object) stream)))))))))))
+ object)))
(defun prin1 (object &optional stream)
- (write object :stream stream :escape t))
+ (let ((*standard-output* (output-stream-designator stream))
+ (*print-escape* t))
+ (write object)))
(defun princ (object &optional stream)
- (write object :stream stream :escape nil :readably nil))
+ (let ((*standard-output* (output-stream-designator stream))
+ (*print-escape* nil)
+ (*print-readably* nil))
+ (write object)))
(defun print (object &optional stream)
- (terpri stream)
- (write object :stream stream :escape t)
- (write-char #\Space stream)
- object)
+ (let ((*standard-output* (output-stream-designator stream))
+ (*print-escape* t))
+ (write-char #\newline)
+ (write object)
+ (write-char #\Space)
+ object))
(defun pprint (object &optional stream)
- (write object :stream stream :escape t :pretty t)
- (values))
+ (let ((*standard-output* (output-stream-designator stream))
+ (*print-escape* t)
+ (*print-pretty* t))
+ (write object)
+ (values)))
(defun terpri (&optional stream)
(write-char #\newline stream)
More information about the Movitz-cvs
mailing list