;;; -*- cold-load:t; Mode:Common-Lisp; Base:10; Package:si-*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; ;;; This has been adapted from the Spice Lisp pretty printer, ;;; written by Skef Wholey. ;;; ;;; This package provides the following functions: ;;; ;;; (PPRIN1 Object &Optional Output-Stream) [EXPR] ;;; Analog of PRIN1. Prettily prints the object to the given stream ;;; with special characters slashified. ;;; ;;; (PPRINC Object &Optional Output-Stream) [EXPR] ;;; Analog of PRINC. Special characters are not slashified. ;;; ;;; (PPRINT Object &Optional Output-Stream) [EXPR] ;;; Analog of PRINT. TERPRI + PPRIN1 + SPACE. ;;; ;;; (GRINDEF Function-Name) [MACRO] ;;; Prettily prints the definition of the function named by Function-Name. ;;; ;;; (DEFPRINT Function-Name Definiton) [MACRO] ;;; Defines how lists whose CAR is Function-Name will be printed. ;;; ;;; 04-25-89 DAB Added all function, variables, flavors and instances that are documented to export list. ;;; 4/13/89 JLM Changed PP-UNBACKQUOTIFY to get rid of ZLC:FILLARRAY call ;;; 4/11/89 JLM CHanged (PUTPROP ... usage to (SETF (GET ... ;;; Pretty printing is done in two steps: ;;; 1] Converting the lisp object to a PP-Obj structure, and ;;; 2] Printing that structure in some pretty fashion. ;;; ;;; There are 3 levels of "prettiness" that are used in printing an object: ;;; 1] Basic grinding: formatting according to a handful of simple ;;; parameters. This is done by the function Basically-Grind. ;;; 2] Simple, common ways of formating Defuns, Dos, etc. The ;;; specifications for how an object is printed this way are either ;;; positive integers specifying the number of "special arguments" or ject holds ;;; a list of PP-Objs; if it is STRING, then Object has a string representation ;;; of the object, and if it is SPACE, the PP-Obj is a marker for a possible ;;; line break. The Callish slot holds what might be a function name from the ;;; original form. ;;; In order to suppress consing , the structures are allocated on an array *print-array* ;;; they are of type grouped array. ;;; To allow multiprocessing print-structure is allocated of a print-structure resource ;;; Each time the resource has to create a such array, it will preallocate standard objects. (export '(sys:pprin1 ;function ; DAB 04-25-89 sys:pprinc ;function ) 'sys) (defvar *pprint-notify-fun* nil "function to be invoked while printing (used by the Inspector)") (defvar print-structure nil) (defvar pprint-buffer-stream) (defvar pprint-print-structure-start 0) ;; This indicate where to start allocating new object to print ;; note that the beginning of each *print-structure* is permanently allocated by (pprint-init) ;; for very often used objects. (defstruct (pp-obj (:type :grouped-array) (:constructor nil) (:size-macro size-of-pp-obj) (:copier nil) (:default-pointer print-structure)) (type 'simple :read-only t) (length () :read-only t :type fixnum) (object () :read-only t) (callish () :read-only t) (location () :read-only t)) ;;PHD 3/4/87 Added deallocator to get rid of locatives. ;;JK 3/26/87 Specify a function rather than a form for the deallocator so the cold-loader can handle it. (defresource pprint-resource () :constructor (let ((print-structure (make-array (* 100 (size-of-pp-obj)) :fill-pointer 0)) (pprint-buffer-stream (make-string-output-stream))) (pprint-init) (cons print-structure pprint-buffer-stream)) :deallocator pprint-resource-deallocator :initial-copies 0) (defun pprint-resource-deallocator (ignore object) (let ((array (car object))) (without-interrupts (setf (aref array 4) nil) (%blt-typed (locf (pp-obj-location 0 array )) (locf (pp-obj-location (size-of-pp-obj) array)) (floor (length array )(size-of-pp-obj)) (size-of-pp-obj))))) ;;; This here macro is preferable to calling the keyword-parsing function. (defmacro make-pp-obj (&key (type ''simple) length object callish location) `(let ((obj (vector-push-extend ,type print-structure (* 100 (size-of-pp-obj))))) (vector-push ,length print-structure ) (vector-push ,object print-structure) (vector-push ,callish print-structure ) (vector-push ,location print-structure) obj)) ;;; Pre-computed pp-objs for quicker printing: (defparameter pp-space-obj ()) (defparameter pp-open-paren-obj ()) (defparameter pp-close-paren-obj ()) (defparameter pp-sharp-open-paren-obj ()) (defparameter pp-sharp-open-angle-obj ()) (defparameter pp-close-angle-obj ()) (defparameter pp-dot-obj ()) (defparameter pp-dotdotdot-obj ()) (defparameter pp-starstar-obj ()) (defparameter pp-nil-obj ()) (defparameter pp-sharp-angle-array-rank-obj ()) (defparameter pp-sharp-obj ()) (defparameter pp-a-obj ()) (defparameter pp-dotdotdot-close-paren-obj ()) (defparameter pp-function ()) (defparameter pp-quote ()) (defparameter pp-backquote ()) (defparameter pp-comma ()) (defparameter pp-comma-at-sign ()) (defparameter pp-comma-dot ()) (defparameter pp-dot-comma ()) (defparameter pp-null-list ()) (defun pprint-init () ;;CLM for PHD 10/20/87 Fixed SPR#??? (as yet unsubmitted) "No leading space before ..." "Initializes the pretty printer." (setq pp-space-obj (make-pp-obj :type 'space :length 1) pp-open-paren-obj (make-pp-obj :type 'string :length 1 :object "(") pp-close-paren-obj (make-pp-obj :type 'string :length 1 :object ")") pp-sharp-open-paren-obj (make-pp-obj :type 'string :length 2 :object "#(") pp-sharp-open-angle-obj (make-pp-obj :type 'string :length 2 :object "#<") pp-close-angle-obj (make-pp-obj :type 'string :length 1 :object ">") pp-dot-obj (make-pp-obj :type 'string :length 1 :object ".") pp-dotdotdot-obj (make-pp-obj :type 'string :length 4 :object " ...") pp-starstar-obj (make-pp-obj :type 'string :length 2 :object "**") pp-nil-obj (make-pp-obj :type 'string :length 3 :object "NIL") pp-sharp-angle-array-rank-obj (make-pp-obj :type 'string :length 14 :object "#= => >). ;;AB for PHD 6/16/87 Fixed pp-objify so circular flavor and structures are printed right. (defun pp-objify (object location &optional (currlevel 0)) "Returns a PP-Obj structure which is used to prettily print the Object." (declare (special pprint-string)) (flet ((objify (object currlevel ) (typecase object (cons (pp-objify-list object location currlevel)) (null pp-nil-obj) (structure (pp-objify-atom object location )) (string (pp-objify-atom object location )) (vector (pp-objify-vector object location currlevel)) (array (pp-objify-array object location currlevel)) (t (pp-objify-atom object location ))))) (if (and *print-level* (> currlevel (the fixnum *print-level*))) pp-sharp-obj (if (and *print-circle* (or (consp object) (and (arrayp object) (not (named-structure-p object))))) ;; This is a candidate for circular or shared structure printing. ;; See what the hash table says about the object: ;; NIL - occurs only once. ;; T - occurs more than once, but no occurrences printed yet. ;; Allocate a label this time and print #label= as prefix. ;; A number - that is the label. Print only #label#. (catch 'label-printed (let ((lab (modifyhash object print-hash-table #'(lambda (key value key-found-p) key key-found-p (cond ((null value) nil) ((eq value t) (incf print-label-number)) (t (let ((*print-base* 10.) (*print-radix* NIL) (*print-circle* nil) (*print-pretty* nil) (*nopoint t) (start (length pprint-string))) (write-char #\#) (print-object value 0 *standard-output* '(:string-out)) (write-char #\#) (throw 'label-printed (make-pp-obj :length (- (length pprint-string) start) :object start)))))))) ob ob1) (setf ob1 (objify object currlevel )) (if lab (progn (setf ob (let ((*print-base* 10.) (*print-radix* NIL) (*print-circle* nil) (*print-pretty* nil) (*nopoint t) (start (length pprint-string))) (write-char #\#) (print-object lab 0 *standard-output* '(:string-out)) (write-char #\=) (make-pp-obj :length (- (length pprint-string) start) :object start :location location))) (make-pp-obj :length (+ (pp-obj-length ob) (pp-obj-length ob1)) :type 'complex :object (list ob ob1) :location location)) ob1))) (objify object currlevel ))))) (defun pp-objify-atom (object location ) "Makes a PP-Obj for an atom." (declare (special pprint-string)) (let ((start (length pprint-string))) (print-object object 0 *standard-output* '(:string-out)) ;(output-object object) (make-pp-obj :length (- (length pprint-string) start) :object start :location location))) (defun pp-objify-vector (object location currlevel) ;;CLM for PHD 10/20/87 Fixed SPR#??? "No leading space before ..." (declare (fixnum currlevel)) "Makes a PP-Obj for a vector." (if (or (not *print-array*) ;; phd 4/7/86 leave the printing of bit-vectors to the regular print. (typep object 'bit-vector)) (pp-objify-atom object location) (do* ((index 0 (1+ index)) (terminus (length (the vector object))) (total-length 2) (result (list pp-sharp-open-paren-obj)) (splice result)) ((or (and *print-length* (>= index *print-length*)) (= index terminus)) (cond ((/= index terminus) (end-cons splice pp-dotdotdot-obj) (setq total-length (+ 4 total-length)))) (end-cons splice pp-close-paren-obj) (make-pp-obj :type 'complex :length (1+ total-length) :object result :location location)) (declare (fixnum index total-length terminus)) (cond ((> index 0) (end-cons splice pp-space-obj) (setq total-length (1+ total-length)))) (end-cons splice (pp-objify (aref object index) location (1+ currlevel)))))) (defun pp-objify-array (object location currlevel) "Makes a PP-Obj for an array." (let ((rank-obj (pp-objify (array-rank object) location currlevel))) (if (not *print-array*) (pp-objify-atom object location) (let ((result (list nil))) (pretty-array-guts object (array-dimensions object) currlevel 0 result) (make-pp-obj :type 'complex :length (+ 1 (pp-obj-length rank-obj) 1 (do ((total 0) (stuff (cdr result) (cdr stuff))) ((null stuff) total) (setq total (+ total (pp-obj-length (car stuff)))))) :object (list* pp-sharp-obj rank-obj pp-a-obj (cdr result)) :location location))))) ;;PHD 4/10/87 Fixed print-level test (>= => >). (defun pretty-array-guts (array dimensions currlevel index splice) (cond ((null dimensions) (end-cons splice (pp-objify (ar-1-force array index) (ar-1-force array index) currlevel)) (values splice (1+ index))) ((and (not (null *print-level*)) (> currlevel *print-level*)) (end-cons splice pp-sharp-obj) (values splice index)) (t (do* ((index index) (times 0 (1+ times)) (limit (pop dimensions)) (res (list nil)) (splice1 res)) ((or (= times limit) (and (not (null *print-length*)) (= times *print-length*))) (values (progn (if (not (= times limit)) (end-cons splice1 pp-dotdotdot-close-paren-obj) (end-cons splice1 pp-close-paren-obj)) (end-cons splice (make-pp-obj :type 'complex :length (1+ (do ((total 0) (stuff (cdr res) (cdr stuff))) ((null stuff) total) (setq total (+ total (pp-obj-length (car stuff)))))) :object (list* pp-open-paren-obj (cdr res)) :callish nil )) splice) index)) (if (not (zerop times)) (progn (end-cons splice1 pp-space-obj))) (multiple-value-setq (splice1 index) (pretty-array-guts array dimensions (1+ currlevel) index splice1)))))) (defun pp-objify-list-guts (object location currlevel) ;;;CLM for PHD 10/20/87 Fixed SPR#??? "No leading space before ..." ;;;phd 2/13 This is a new function coming from pp-objify-list, it does not check ;;;for pprint-handlers or simple-read-macros. (declare (fixnum currlevel)) (declare (special callish)) (do* ((object object (cdr object)) (callish (if (and (symbolp (car object)) (neq 'quote (car object)) (or (fboundp (car object)) (member (car object) '(lambda global:lambda named-lambda global:named-lambda) :test #'eq))) (car object))) (currlength 0 (1+ currlength)) (total-length 1) (result (list pp-open-paren-obj)) (splice result)) ((or (and *print-length* (>= currlength (the fixnum *print-length*))) (null object)) (cond (object (end-cons splice pp-dotdotdot-obj) (setq total-length (+ total-length 4)))) (end-cons splice pp-close-paren-obj) (make-pp-obj :type 'complex :length (1+ total-length) :object result :callish callish :location location)) (declare (fixnum currlength total-length)) (declare (special callish)) (cond ((> currlength 0) (end-cons splice pp-space-obj) (setq total-length (1+ total-length)))) (end-cons splice (pp-objify (car object) (locf (car object)) (1+ currlevel))) (setq total-length (+ (pp-obj-length (car splice)) total-length)) (cond ((or (not (listp (cdr object))) ;;phd 6/20/86 Added support for circular list. (and *print-circle* (plusp currlength) (gethash (cdr object) print-hash-table))) (end-cons splice pp-space-obj) (end-cons splice pp-dot-obj) (end-cons splice pp-space-obj) (end-cons splice (pp-objify (cdr object) (locf (cdr object))(1+ currlevel))) (setq total-length (+ total-length 3 (pp-obj-length (car splice)))) (setq object ()))))) (defun pp-objify-list (object location currlevel) "Makes a PP-Obj for a list." ;;;phd 2/4/86 Fixed simple-read-macro callish property, it should be nil. ;;;phd 2/13/86 Turn callish nil when dealing with (quote ) (declare (fixnum currlevel)) (declare (special callish)) (cond ((null object) (if (and (boundp 'callish) callish) pp-null-list pp-nil-obj)) ((and (symbolp (car object)) (get (car object) 'pprint-handler)) (funcall (get (car object ) 'pprint-handler) object location currlevel)) ((and (symbolp (car object)) (get (car object) 'simple-read-macro) (listp (cdr object)) (cadr object) (null (cddr object))) (let ((argument (pp-objify (cadr object) (locf (cadr object)) currlevel)) (macro (symbol-value (get (car object) 'simple-read-macro)))) (make-pp-obj :type 'complex :length (+ (pp-obj-length argument) (pp-obj-length macro)) :object (list macro argument ) :callish nil :location location))) (t (pp-objify-list-guts object location currlevel)))) (defun pp-objify-displaced (object location currlevel) (declare (ignore location)) (pp-objify-list (second object) (locf (cadr object)) currlevel)) (defun pp-objify-function-sign (object location currlevel) (declare (special callish)) (if (and (boundp 'callish ) callish (listp (cdr object)) (cadr object) ;; phd 2/15/86 add a check to see if the argument to function is really a function. (functionp (cadr object))(null (cddr object))) (let ((argument (pp-objify (cadr object) (locf (cadr object)) currlevel)) (macro (symbol-value (get (car object) 'simple-read-macro)))) (make-pp-obj :type 'complex :length (+ (pp-obj-length argument) (pp-obj-length macro)) :object (list macro argument ) :callish nil :location location)) (pp-objify-list-guts object location currlevel))) (defun pp-objify-bq-top-level (object location currlevel) (pp-objify-list `(grind-bq ,(pp-unbackquotify object)) location currlevel)) ;Convert the backquote form to a list resembling what the user typed in, ;with "calls" to grind-comma, etc., representing the commas. (defun pp-unbackquotify (exp) ;;phd 1/20/86 Fixed pprint of backquotes. (cond ((or (numberp exp) (eq exp t) (null exp) (stringp exp) (keywordp exp)) exp) ((symbolp exp) `(grind-comma ,exp)) ((atom exp) exp) ((eq (car exp) 'quote) (cond ((symbolp (cadr exp)) (cadr exp)) ((and (consp (cadr exp))(eq (caadr exp) 'grind-comma)) `(grind-comma ,exp)) (t (cadr exp)))) ((eq (car exp) 'xr-bq-vector) ;;(ZLC:fillarray nil (mapcar 'pp-unbackquotify (cdr exp))) (make-array (length (mapcar 'pp-unbackquotify (cdr exp))) :initial-contents (mapcar 'pp-unbackquotify (cdr exp)))) ((eq (car exp) 'xr-bq-cons) (cons (pp-unbackquotify (cadr exp)) (pp-unbackquotify-segment (cddr exp) nil t))) ((eq (car exp) 'xr-bq-list) (mapcar 'pp-unbackquotify (cdr exp))) ((eq (car exp) 'xr-bq-list*) (nconc (mapcar 'pp-unbackquotify (butlast (cdr exp))) (pp-unbackquotify-segment (last exp) t t))) ((eq (car exp) 'xr-bq-append) (nconc (mapcon 'pp-unbackquotify-segment (butlast(cdr exp)) (circular-list t) (circular-list nil)) (pp-unbackquotify-segment (last exp) t t))) ((eq (car exp) 'xr-bq-nconc) (nconc (mapcon 'pp-unbackquotify-segment (butlast(cdr exp)) (circular-list nil) (circular-list nil)) (pp-unbackquotify-segment (last exp) nil t))) (t `(grind-comma ,exp)))) ;Convert a thing in a backquote-form which should appear as a segment, not an element. ;The argument is the list whose car is the segment-form, ;and the value is the segment to be appended into the resulting list. (defun pp-unbackquotify-segment (loc copy-p tail-p) ;;phd 1/20/86 Fixed pprint of backquotes. (if (consp copy-p) (setf copy-p (car copy-p))) (if (consp tail-p) (setf tail-p (car tail-p))) (cond ((and tail-p (atom (cdr loc))) (let ((tem (pp-unbackquotify (car loc)))) (cond ((and (listp tem) (eq (car tem) 'grind-comma)) (if copy-p (list `(grind-comma-atsign ,(car loc))) (list `(grind-dot-comma ,(car loc))))) (t tem)))) ((and (listp (car loc)) (eq (caar loc) 'quote) (listp (cadar loc))) (cadar loc)) (t (list (list (if copy-p 'grind-comma-atsign 'grind-comma-dot) (car loc)))))) (defun pp-objify-comment (object location currlevel &aux result) (setf result (list (pp-objify (second object) (locf (cadr object)) currlevel))) (do* ((i (nthcdr 2 object) (cdr i)) (length (pp-obj-length (car result)) (if (stringp (car i)) (1+ (+ length (length (car i)))) length)) (splice result)) ((null i) ;; This hair is to determine if there was two ; or just one. (when (let ((comm-string (dolist (obj (cdr result)); get the first comment, skipping the font changes objects (case (pp-obj-type obj) (comment (return (pp-obj-object obj))) (otherwise nil))))) (dotimes (i (1- (length comm-string)) nil) (case (char comm-string i) (#\; (return t)) (#\ (incf i)) (otherwise (return nil))))) (setf (cdr result) (cons pp-space-obj (cdr result)))) (make-pp-obj :type 'complex :object result :length length :callish 'comment :location location)) (if (stringp (car i)) (progn (end-cons splice (make-pp-obj :type 'comment :length (1+ (length (car i))) :object (car i) :callish nil :location location)) (when (cdr i) (end-cons splice pp-space-obj))) (end-cons splice (make-pp-obj :type 'string :length 0 :object (make-array 2 :element-type 'string-char :initial-contents (list #\ (car i))) :callish nil :location location))) )) ;;; Printing the PP-Obj: ;;; Break-Always = T causes newlines at every SPACE. Many-On-a-Line = T ;;; causes as many objects as possible to be put on a line if the whole object ;;; won't fit on a line. If Many-On-a-Line is (), then each component will ;;; be put on a separate line if the whole object won't fit on a line. ;;; An Indent-Style = NORMAL causes components on successive lines to line ;;; up with the column following the end of the first component (e.g. a left ;;; paren). An Indent-Style = PAST-NAME causes components on successive ;;; lines to line up with the first column of the third component (e.g. the ;;; first argument to a function.) A fixnum Indent-Style causes components ;;; to be indented that many spaces past the first column of the first ;;; component. Charpos is the column we believe we're starting to print ;;; in. (defun basically-grind (object break-always many-on-a-line indent-style charpos) (declare (fixnum charpos)) "Prints out an object constructed by PP-Objify." (if (or break-always (and (null many-on-a-line) (> (+ (pp-obj-length object) charpos) pp-line-length))) (break-always-grind (pp-obj-object object) indent-style charpos) (break-sometimes-grind (pp-obj-object object) indent-style charpos))) (defun break-always-grind (object indent-style charpos) (declare (fixnum charpos)) "Prints each component of the Object on its own line." (do ((components object (cdr components)) (indent-pos (indentation object indent-style charpos)) break-occured) ((null components) break-occured) (cond ((eq (pp-obj-type (car components)) 'space) (fresh-line ) (tab-over indent-pos) (setq charpos indent-pos) (setf break-occured t)) (t (when (eq break-occured 'partial) (tab-over indent-pos)) (if (master-grind (car components) charpos) (setf break-occured t)) (setq charpos (+ charpos (pp-obj-length (car components)))))))) (defun break-sometimes-grind (object indent-style charpos) (declare (fixnum charpos)) "Prints as many components as possible on each line." (do* ((components object (cdr components)) (early-indent-pos (indentation object 1 charpos)) (late-indent-pos (indentation object indent-style charpos)) (indent-pos early-indent-pos) break-occured) ((null components) break-occured) (declare (fixnum indent-pos)) (cond ((eq (pp-obj-type (car components)) 'space) (cond ((or break-occured (> (+ charpos (pp-obj-length (cadr components))) pp-line-length)) (fresh-line) (setf break-occured t) (tab-over indent-pos) (setq charpos indent-pos)) (t (setq indent-pos late-indent-pos) (write-char #\space) (setq charpos (1+ charpos))))) (t (when (eq break-occured 'partial) (tab-over indent-pos)) (setf break-occured (master-grind (car components) charpos)) (setq charpos (+ charpos (pp-obj-length (car components)))))))) ;;; Specially grind acts on the Specially-Grind property of the Callish slot ;;; of the given object, which must be an integer. If this number is ;;; positive, that many SPACE PP-Objs following the function name indent ;;; ala PAST-NAME. The following forms are indented 2 in and given ;;; separate lines. If the number is negative, minus that many SPACE PP-Objs ;;; simply space over, and the rest are again indented 2 on separate lines. (defun specially-grind (object charpos) (let ((spec (get (pp-obj-callish object) 'specially-grind))) (if (plusp spec) (special-arg-grind (pp-obj-object object) spec charpos) (top-line-grind (pp-obj-object object) (- spec) charpos)) t)) (defun special-arg-grind (object spec charpos) (do ((components object (cdr components)) (body-indent) (indent-pos charpos)) ((or (null components) (eq (pp-obj-type (car components)) 'space)) (when components (write-char #\space) (setq components (cdr components)) (setq indent-pos (+ indent-pos 1)) (do((i spec)) ((= i 0)) (cond ((null components) (return nil)) ((eq (pp-obj-type (car components)) 'complex) (decf i) (break-always-grind (pp-obj-object (car components)) 1 indent-pos)) ((eq (car components) pp-nil-obj) (decf i) (write-string "()")) ((eq (pp-obj-type (car components)) 'space) (write-char #\newline) (tab-over indent-pos)) (t (decf i) (master-grind (car components) indent-pos))) (setq components (cdr components))) (if components (break-always-grind components 1 body-indent)))) (master-grind (car components) charpos) (setq indent-pos (+ indent-pos (pp-obj-length (car components)))) (if (eq (car components) pp-open-paren-obj) (setq body-indent indent-pos))) t) (defun top-line-grind (object spec charpos) ;;; phd 2/4/86 Fixed it so the spaced components are printed at the rigth indentation. (do ((components object (cdr components)) (spaces-seen 0) (body-indent) (indent-pos charpos)) ((or (null components) (= spaces-seen spec)) ;; (when components ;; (master-grind (pop components) indent-pos)) (when components (break-always-grind components 1 (or body-indent (+ charpos 1))))) (cond ((eq (pp-obj-type (car components)) 'space) (setq spaces-seen (1+ spaces-seen)) (write-char #\space) (setq indent-pos (1+ indent-pos))) (t (master-grind (car components) indent-pos) (setq indent-pos (+ indent-pos (pp-obj-length (car components)))) (if (and (null body-indent) (eq (car components) pp-open-paren-obj)) (setq body-indent indent-pos)))))) (defun commented-form-grind (object charpos) (break-always-grind (pp-obj-object object) 0 charpos) (write-char #\return ) 'partial) (defun comment-grind (object indent-style charpos) (declare (ignore indent-style charpos)) (write-char #\;) (write-string (pp-obj-object object)) nil) (defun setq-grind (object charpos) (setf object (pp-obj-object object)) (do* ((components object (cdr components)) (between-subsetq nil ) (early-indent-pos (indentation object 1 charpos)) (late-indent-pos (indentation object 'past-name charpos)) (indent-pos early-indent-pos) (first-space t ) (break-occured nil)) ((null components ) break-occured) (declare (fixnum indent-pos)) (cond ((eq (pp-obj-type (car components)) 'space) (if (null between-subsetq ) (cond ((or (null first-space) (> (+ charpos (pp-obj-length (cadr components))) pp-line-length)) (write-char #\newline) (setf break-occured t) (tab-over indent-pos) (setq charpos indent-pos)) (t (setq indent-pos late-indent-pos) (setf first-space nil) (write-char #\space) (setq charpos (1+ charpos)))) (cond ((> (+ charpos (pp-obj-length (cadr components))) pp-line-length) (write-char #\newline) (setf break-occured t) (tab-over indent-pos) (setq charpos indent-pos)) (t (setq indent-pos late-indent-pos) (write-char #\space) (setq charpos (1+ charpos))))) (setf between-subsetq (null between-subsetq ))) (t (setf break-occured (master-grind (car components) charpos)) (setq charpos (+ charpos (pp-obj-length (car components)))))))) (defun hairily-grind (object charpos) (funcall (get (pp-obj-callish object)'hairily-grind) object charpos)) ; (error "I'm not yet implemented.")) ;;; Master-Grind dispatches to grinders various levels of intelligence ;;; by looking at the PP-Obj handed to it. (defun master-grind (object charpos) (declare (special pprint-string)) ;;;phd 11/25/85 Fixed printing of NIL. (cond ((eq (pp-obj-type object) 'simple) (let ((start (pp-obj-object object)) (len (pp-obj-length object))) (when *pprint-notify-fun* (funcall *pprint-notify-fun* object (pp-obj-location object) t len)) (write-string pprint-string *standard-output* :start start :end (+ start len))) nil) ((eq (pp-obj-type object) 'string) (if (eq object pp-nil-obj) (progn (when *pprint-notify-fun* (funcall *pprint-notify-fun* object (pp-obj-location object) t 3)) (print-object nil 0 *standard-output* '(:string-out))) (write-string (pp-obj-object object))) nil) ((eq (pp-obj-type object) 'comment) (comment-grind object 'past-name charpos)) ((pp-obj-callish object) (when *pprint-notify-fun* (funcall *pprint-notify-fun* 'start-of-object (pp-obj-location object) nil nil)) (cond ((get (pp-obj-callish object) 'specially-grind) (specially-grind object charpos)) ((get (pp-obj-callish object) 'hairily-grind) (hairily-grind object charpos)) ;; phd 2/4/86 tried to have a better default for macros ((or (special-form-p (pp-obj-callish object)) (macro-function (pp-obj-callish object))) (basically-grind object () t 3 charpos)) (t (basically-grind object () t 'past-name charpos))) (when *pprint-notify-fun* (funcall *pprint-notify-fun* 'end-of-object nil nil nil ))) (t (when *pprint-notify-fun* (funcall *pprint-notify-fun* 'start-of-object (pp-obj-location object) nil nil)) (basically-grind object () t 'normal charpos) (when *pprint-notify-fun* (funcall *pprint-notify-fun* 'end-of-object nil nil nil ))))) (Defun output-pretty-object (object &optional location initial-indentation) "Prettily outputs the Object to *Standard-Output*" (using-resource (res pprint-resource) (let* ((print-structure (car res)) (character-attribute-table (character-attribute-table *readtable*)) (pprint-buffer-stream (cdr res)) (pprint-string (send pprint-buffer-stream :get-string))) (declare (special pprint-string)) (setf (fill-pointer pprint-string) 0) (setf (fill-pointer print-structure )pprint-print-structure-start ) ;(setf (string-output-stream-index pprint-buffer-stream) 0) (let ((pp-line-length (or pp-line-length (COND ((MEMber ':SIZE-IN-CHARACTERS (send *Standard-Output* ':WHICH-OPERATIONS) :test #'eq) (1- (send *Standard-Output* ':SIZE-IN-CHARACTERS)))) 95))) (master-grind (let ((*standard-output* pprint-buffer-stream)) (pp-objify object (or location ':top-level))) (or initial-indentation 0)))))) (defun pprin1 (object &optional (*standard-output* *standard-output*)) "Prettily outputs the Object to the Stream slashifying special characters." ;(setup-printer-state) (let ((*print-escape* t)) (print-circle (output-pretty-object object)))) (defun pprinc (object &optional (*standard-output* *standard-output*)) "Prettily outputs the Object to the Stream without slashifying." ;(setup-printer-state) (let ((*print-escape* ())) (print-circle(output-pretty-object object)))) ;;5/13/88 CLM - fixed to take T or NIL as optional arguments. (defun pprint (object &optional stream) "Prettily outputs the Object preceded by a newline and followed by a space." (case stream ((nil) (setq stream *standard-output*)) ((t) (setq stream *terminal-io*))) (let ((*standard-output* stream)) (write-char #\newline) (pprin1 object) (write-char #\space) (values))) (defun pretty-lambda-to-defun (name lambda &optional arglist) `(defun ,name ,(or arglist (cadr lambda)) ,@(if (and (null (cdddr lambda)) (listp (caddr lambda)) (eq (caaddr lambda) 'block)) (cddr (caddr lambda)) (cddr lambda)))) (defvar grindef) ;Remembers the last argument to GRINDEf ;;Grind the definitions of one or more functions. With no arguments, ;;repeat the last operation. (defmacro grindef ( &rest fcns) "Pretty print the definitions of each of FCNS. This prints expressions such as could be evaluated to give each of FCNS its current value and/or function definition." `(progn ,@(if fcns `((setq grindef ',fcns))) (mapc #'grindef-1 grindef) ;Grind each function (values))) (deff-macro pprint-def #'grindef) ;;;; Grind the definition of a function. (defun grindef-1 (fcn &optional (real-io *standard-output*) &aux exp exp1 tem grind-renaming-alist) (block nil (cond ((and (symbolp fcn) (boundp fcn)) (pprint `(setq ,fcn ',(symbol-value fcn)) real-io))) (unless (fdefinedp fcn) (return-from grindef-1 ())) (setq exp (fdefinition fcn)) ;; Grind any levels of encapsulation, as they want it. (do () (nil) (setq exp1 exp) (and (consp exp) (eq (car exp) 'macro) (setq exp1 (cdr exp))) (unless (and (not (symbolp exp1)) (setq tem (get-debug-info-field (get-debug-info-struct exp1) 'encapsulated-definition))) (return ())) (when (get (cadr tem) 'encapsulation-pprint-function) (funcall (get (cadr tem) 'encapsulation-pprint-function) fcn exp1 real-io)) (and (eq (cadr tem) 'rename-within) (setq grind-renaming-alist (get-debug-info-field (get-debug-info-struct exp1) :renamings))) (unless (fdefinedp (car tem)) (return-from grindef-1 ())) (setq exp (fdefinition (car tem)))) ;; Now process the basic definition. (setq tem (if (and (consp exp) (eq (car exp) 'macro)) (cdr exp) exp)) (and (typep tem 'compiled-function) (cond ((get-debug-info-field (get-debug-info-struct tem) :interpreted-definition) (setq exp (get-debug-info-field (get-debug-info-struct tem) :interpreted-definition))))) (and (consp fcn) (eq (car fcn) :within) (eq exp (caddr fcn)) (return-from grindef-1 ())) (pprint (cond ((atom exp) `(deff ,fcn ',exp)) ((eq (car exp) 'macro) (cond ((typep (cdr exp) 'compiled-function) `(deff ,fcn ',exp)) (t `(macro ,fcn ,@(grind-flush-lambda-head (cdr exp)))))) ((member (car exp) '(subst named-subst global:subst global:named-subst) :test #'eq) `(defsubst ,fcn ,@(grind-flush-lambda-head exp))) ((not (member (car exp) '(lambda named-lambda global:lambda global:named-lambda) :test #'eq)) `(fdefine ',fcn ',exp)) ((and (consp fcn) (eq (car fcn) :method)) (setq tem (grind-flush-lambda-head exp)) (setq tem (cons (cdar tem) (cdr tem)));Remove OPERATION arg `(defmethod ,(cdr fcn) ,@tem)) (t `(defun ,fcn ,@(grind-flush-lambda-head exp)))) real-io)) (terpri real-io)) (defun grind-flush-lambda-head (named-lambda) (if (atom named-lambda) named-lambda (let* ((lambda (lambda-exp-args-and-body named-lambda))) (multiple-value-bind (body declare-list doc-string) (parse-body (cdr lambda) nil) (if (and (consp (car body)) (eq (caar body) 'block)) `(,(car lambda) ,.(and doc-string (list doc-string)) ,@declare-list . ,(cddar body)) lambda))))) ;;AB for PHD 6/19/87 Fixed grind-top-level so it can print with *print-circle* bound to T. SPR 5557. (DEFUN grind-top-level (exp &optional (grind-width nil) grind-real-io grind-untyo-p grind-displaced (terpri-p t) (*pprint-notify-fun* nil) (loc (cons exp nil)) grind-format (initial-indentation 0)) "Pretty-print the list EXP on stream GRIND-REAL-IO. NOTE That it is an obsolete function, PPRINT should be used instead. GRIND-WIDTH is the width to fit within; NIL is the default, meaning try to find out the stream's width or else use 95. characters. GRIND-UNTYO-P, GRIND-DISPLACED and GRIND-FORMAT are ignored. TERPRI-P non-NIL says go to a fresh line before printing. *PPRINT-NOTIFY-FUN*, if non-NIL, is called for each cons-cell processed. Use this to keep records of how list structure was traversed during printing. LOC is the location where EXP was found, for passing to *PPRINT-NOTIFY-FUN*. INITIAL-INDENTATION is the horizontal indent to use for the first line. Additional lines are indented relative to the first." (declare (ignore grind-untyo-p grind-displaced grind-format)) (let-if grind-width ((pp-line-length grind-width)) (let-if grind-real-io ((*standard-output* grind-real-io)) (when terpri-p (terpri)) (unless (zerop initial-indentation ) (tab-over initial-indentation)) (let ((object exp)) (print-circle (output-pretty-object exp loc initial-indentation)))))) (defmacro defprint (function-name way) "Defines a Way for PPrint to print a call to the function named by Function-Name. See ??? for details." (if (listp way) `(setf (get ',function-name ',(car way)) ',(cadr way)) `(setf (get ',function-name 'specially-grind) ',way))) ;;`(putprop ',function-name ',(cadr way) ',(car way)) ; jlm 4/11/89 ;;`(putprop ',function-name ',way 'specially-grind))) ; jlm 4/11/89 ;;; DefPrints for some common things: (defprint block 1) (defprint case -1) (defprint catch 1) (defprint catch-all 2) (defprint ccase -1) (defprint comment (hairily-grind commented-form-grind)) (defprint compiler-let 1) (defprint cond 0) (defprint define-modify-macro -3) (defprint define-setf-method -2) (defprint defmacro -2) (defprint defun -2) (defprint defstruct -1) (defprint defsubst -2) (defprint defmethod -2) (defprint defselect -1) (defprint defsetf -3) (defprint deftype -2) (defprint do 2) (defprint do* 2) (defprint do-all-symbols -1) (defprint do-external-symbols -1) (defprint do-internal-symbols -1) (defprint do-named 3) (defprint do*-named 3) (defprint do-symbols -1) (defprint dolist -1) (defprint dotimes -1) (defprint ecase -1) (defprint etypecase -1) (defprint eval-when -1) (defprint flet 1) (defprint function (simple-read-macro pp-function)) (defprint function (pprint-handler pp-objify-function-sign)) ;; The next 3 added 4/3/89 by D.N.G. (defprint ticlos:generic-function 1) (defprint ticlos:generic-flet 1) (defprint ticlos:generic-labels 1) (defprint if -1) (defprint labels 1) (defprint lambda -1) (defprint global:lambda -1) (defprint let 1) (defprint let* 1) (defprint macro -2) (defprint macrolet 1) (defprint multiple-value-setq -1) (defprint multiple-value-bind -2) (defprint mvcall -1) (defprint named-lambda -2) (defprint global:named-lambda -2) (defprint named-subst -2) (defprint global:named-subst -2) (defprint prog 1) ; eventually hairier (defprint prog* 1) (defprint prog1 0) (defprint prog2 0) (defprint progn 0) (defprint progv 2) (defprint quote (simple-read-macro pp-quote)) (defprint setf (hairily-grind setq-grind)) (defprint setq (hairily-grind setq-grind)) (defprint subst 1) (defprint throw 2) (defprint typecase -1) (defprint unless -1) (defprint unwind-all 2) (defprint unwind-protect 1) (defprint when -1) (defprint with-open-file -1) (defprint with-open-stream -1) (defprint with-input-from-string -1) (defprint with-output-to-string -1) ;; Backquote handlers (defprint grind-bq (simple-read-macro pp-backquote)) (defprint grind-comma (simple-read-macro pp-comma)) (defprint grind-comma-atsign (simple-read-macro pp-comma-at-sign)) (defprint grind-comma-dot (simple-read-macro pp-comma-dot)) (defprint grind-dot-comma (simple-read-macro pp-dot-comma)) (defprint xr-bq-cons (pprint-handler pp-objify-bq-top-level)) (defprint xr-bq-list (pprint-handler pp-objify-bq-top-level)) (defprint xr-bq-list* (pprint-handler pp-objify-bq-top-level)) (defprint xr-bq-append (pprint-handler pp-objify-bq-top-level)) (defprint xr-bq-nconc (pprint-handler pp-objify-bq-top-level)) ;; Special handlers (defprint si:displaced (pprint-handler pp-objify-displaced)) ;(defprint transl:tr-comm (pprint-handler pp-objify-comment)) ;; initialize the pprint system (clear-resource 'pprint-resource) (pushnew ':GRINDEF *features*) ; added 12/10/87 by DNG