(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "COMPILER")

(il:filecreated "21-Sep-88 12:35:01" il:{eris}<lispcore>internal>library>xclc-debug.\;2
 12518  

      il:|changes| il:|to:|  (printers return-node throw-node)
                             (il:vars il:xclc-debugcoms)

      il:|previous| il:|date:| "11-Jan-88 19:40:48" il:{eris}<lispcore>internal>library>xclc-debug.\;1
)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:xclc-debugcoms)

(il:rpaqq il:xclc-debugcoms

          (

(il:* il:|;;;| "Debugging support for the XCL Compiler")


           
           (il:* il:|;;| "Printing nodes")


           (il:define-types printers)
           (il:functions defprinter set-pf)
           (il:commands "setpf")
                                                             (il:* il:\; 

                                                           "mv-prog1-node progv-node ")

           (printers block-node call-node catch-node if-node go-node labels-node lambda-node 
                  literal-node mv-call-node mv-prog1-node opcodes-node progn-node return-node 
                  setq-node tagbody-node throw-node unwind-protect-node var-ref-node variable-struct)
           (printers d-assem::dvar d-assem::dtag d-assem::djump d-assem::dlambda d-assem:dcode)
           
           (il:* il:|;;| "Mutator functions for SEdit")


           (il:functions oam eoc)
           
           (il:* il:|;;| "Useful Exec commands")


           (il:commands "ic2")
           
           (il:* il:|;;| "Arrange to use the proper compiler.")


           (il:prop (il:filetype il:makefile-environment)
                  il:xclc-debug)))



(il:* il:|;;;| "Debugging support for the XCL Compiler")





(il:* il:|;;| "Printing nodes")



(def-define-type printers
 "XCL Compiler node printing functions")

(defdefiner (defprinter
 (:prototype (lambda (name)
                                               (and (symbolp name)
                                                    `(defprinter ,name ("Object" stream)
                                                                       "Body"))))) printers (type
                                                                                             args 
                                                                                             &body
                                                                                             (body
                                                                                              decls))
   (let ((print-fn (intern (concatenate 'string "\\print-" (string type))
                          (symbol-package type))))
        `(progn (defun ,print-fn (,@args $$depth)
                   (declare
 (ignore $$depth))
                   ,decls
                   (if (or (null *print-level*)
                           (>= *print-level* 0))
                       (let ((*print-level* (and *print-level* (1- *print-level*))))
                            ,@body)
                       (princ "#" ,(second args))))
                (set-pf ',type ',print-fn))))

(defun set-pf
 (type fn)
   (let ((ps (cl::parsed-structure type)))
        (and ps (setf (cl::ps-print-function ps)
                      fn))))

(defcommand "setpf"
 (type fn)
   (let ((ps (cl::parsed-structure type)))
        (and ps (prog1 (cl::ps-print-function ps)
                    (setf (cl::ps-print-function ps)
                          fn)))))



(il:* il:\; "mv-prog1-node progv-node ")



(defprinter block-node
 (node stream)
                           (format stream "#<Block ~S ~S>" (block-name node)
                                  (block-stmt node)))

(defprinter call-node
 (call stream)
                          (format stream "#<Call ~S ~{~S~^ ~}>" (call-fn call)
                                 (call-args call)))

(defprinter catch-node
 (node stream)
                           (format stream "#<Catch ~S ~S>" (catch-tag node)
                                  (catch-stmt node)))

(defprinter if-node
 (node stream)
                        (format stream "#<If ~S ~S ~S>" (if-pred node)
                               (if-then node)
                               (if-else node)))

(defprinter go-node
 (node stream)
                        (format stream "#<Go ~S>" (go-tag node)))

(defprinter labels-node
 (lab stream)
                            (format stream "#<Labels (~{(~S ~S)~}) ~S>"
                                   (mapcan #'(lambda (fn-binding)
                                                    (list (car fn-binding)
                                                          (cdr fn-binding)))
                                          (labels-funs lab))
                                   (labels-body lab)))

(defprinter lambda-node
 (lam stream)
                            (format
                             stream "#<Lambda ~:S ~S>"
                             `(,@(lambda-required lam)
                               ,@(and (lambda-optional lam)
                                      (cons '&optional
                                            (il:for
 opt-var il:in
 (lambda-optional lam)
                                               il:collect

                                               (if (and (literal-p (second opt-var))
                                                        (null (literal-value (second opt-var)))
                                                        (null (third opt-var)))
                                                   (first opt-var)
                                                   opt-var))))
                               ,@(and (lambda-rest lam)
                                      (list '&rest (lambda-rest lam)))
                               ,@(and (lambda-keyword lam)
                                      (cons '&key
                                            (il:for
 key-var il:in
 (lambda-keyword lam)
                                               il:collect
 (cond
                                                                 ((and (string= (first key-var)
                                                                              (variable-name
                                                                               (second key-var)))
                                                                       (literal-p (third key-var))
                                                                       (null (literal-value
                                                                              (third key-var)))
                                                                       (null (fourth key-var)))
                                                                  (second key-var))
                                                                 ((string= (first key-var)
                                                                         (variable-name (second
                                                                                         key-var)))
                                                                  (cdr key-var))
                                                                 (t `((,(first key-var)
                                                                       ,(second key-var))
                                                                      ,@(cddr key-var)))))))
                               ,@(and (lambda-allow-other-keys lam)
                                      (list '&allow-other-keys)))
                             (lambda-body lam)))

(defprinter literal-node
 (lit stream)
                             (format stream "#<Lit: ~S>" (literal-value lit)))

(defprinter mv-call-node
 (obj stream)
                             (format stream "#<MV-Call: ~S~{~^ ~S~}>" (mv-call-fn obj)
                                    (mv-call-arg-exprs obj)))

(defprinter mv-prog1-node
 (node stream)
                              (format stream "#<MV-Prog1: ~{~S~^ ~}>" (mv-prog1-stmts node)))

(defprinter opcodes-node
 (node stream)
                             (let ((*package* (il:loadtimeconstant (find-package "IL")))
                                   (*print-case* :downcase))
                                  (format stream "#<Opcodes ~{~S~^ ~}>" (opcodes-bytes node))))

(defprinter progn-node
 (node stream)
                           (format stream "#<Progn ~{~S~^ ~}>" (progn-stmts node)))

(defprinter return-node
 (node stream)
                            (format stream "#<Return ~S ~S>" (return-block node)
                                   (return-value node)))

(defprinter setq-node
 (node stream)
                          (format stream "#<Setq ~S ~S>" (variable-name (setq-var node))
                                 (setq-value node)))

(defprinter tagbody-node
 (node stream)
                             (princ "#<Tagbody" stream)
                             (dolist (segment (tagbody-segments node))
                                 (format stream "~{ ~S~}~{ ~S~}" (segment-tags segment)
                                        (segment-stmts segment)))
                             (princ ">" stream))

(defprinter throw-node
 (node stream)
                           (format stream "#<Throw ~S ~S>" (throw-tag node)
                                  (throw-value node)))

(defprinter unwind-protect-node
 (up stream)
                                    (format stream "#<U-P ~S ~S>" (unwind-protect-stmt up)
                                           (unwind-protect-cleanup up)))

(defprinter var-ref-node
 (ref stream)
                             (format stream "#<Ref: ~S>" (var-ref-variable ref)))

(defprinter variable-struct
 (var stream)
                                (format stream "#<~A: ~S>" (case (variable-kind var)
                                                               (:function "Fn")
                                                               (:variable "Var"))
                                       (variable-name var)))

(defprinter d-assem::dvar
 (d-assem::var stream)
                              (format stream "#<DVar ~S>" (d-assem::dvar-name d-assem::var)))

(defprinter d-assem::dtag
 (d-assem::tag stream)
                              (format stream "#<DTag @ ~O,~O>" (il:\\hiloc d-assem::tag)
                                     (il:\\loloc d-assem::tag)))

(defprinter d-assem::djump
 (d-assem::jump stream)
                               (format stream "#<DJump @ ~O,~O>" (il:\\hiloc d-assem::jump)
                                      (il:\\loloc d-assem::jump)))

(defprinter d-assem::dlambda
 (d-assem::dlambda stream)
                                 (format stream "#<DLambda ~S>" (d-assem::dlambda-name 
                                                                       d-assem::dlambda)))

(defprinter d-assem:dcode
 (d-assem:dcode stream)
                              (format stream "#<DCode ~S>" (d-assem::dcode-frame-name d-assem:dcode)))



(il:* il:|;;| "Mutator functions for SEdit")



(defun oam
 (form)
   (copy-tree (optimize-and-macroexpand-1 form (il:loadtimeconstant (make-env))
                     (il:loadtimeconstant (make-context)))))

(defun eoc
 (form)
   (let ((*environment* (il:loadtimeconstant (make-env)))
         (*context* (il:loadtimeconstant (make-context)))
         (fn (car form))
         (args (cdr form)))
        (assert (eq (car fn)
                    'il:openlambda)
               nil "EOC called on a non-OPENLAMBDA")
        (expand-openlambda-call fn args)))



(il:* il:|;;| "Useful Exec commands")



(defcommand "ic2"
 (xcl-user::hi xcl-user::lo)
   (flet ((xcl-user::octal (xcl-user::n)
                 (read-from-string (format nil "#o~D" xcl-user::n))))
         (let ((xcl-user::code (il:\\vag2 (xcl-user::octal xcl-user::hi)
                                      (xcl-user::octal xcl-user::lo))))
              (if (compiled-function-p xcl-user::code)
                  (il:inspectcode xcl-user::code)
                  (inspect xcl-user::code)))))



(il:* il:|;;| "Arrange to use the proper compiler.")



(il:putprops il:xclc-debug
 il:filetype
 :compile-file)

(il:putprops il:xclc-debug
 il:makefile-environment
 (:readtable "XCL" :package "COMPILER"))
(il:putprops il:xclc-debug il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop