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@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)