;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- ;;; ;;;$Header: /ct/interp/dianaids.l,v 1.7 84/04/11 17:41:13 bill Exp $ ;;; ;;;$Log: /ct/interp/dianaids.l,v $ ;;;Revision 1.7 84/04/11 17:41:13 bill ;;;Shortened dianinspect to dianinsp. ;;; ;;;Revision 1.6 84/04/11 17:29:39 bill ;;;Added a load of dianinspect. ;;; ;;;Revision 1.5 84/02/12 18:47:40 mark ;;;Moved the pretty printer over into diana proper. ;;; ;;;Revision 1.4 84/01/30 23:23:33 mark ;;;Improved the handling of (sstatus feature diana_debugging) so ;;;that it properly reloads the nodes and attributes {to get needed ;;;read-time info} without messing up the state of affairs for ;;;mass compilations. Should be a transparent change. Nothing else ;;;should need recompilation. ;;; ;;;Revision 1.3 84/01/23 17:45:46 penny ;;;Prevented it from forcing diana_debugging on, which is a screw ;;;when compiling the whole shebang. ;;; ;;;Revision 1.2 84/01/13 06:34:21 mark ;;;This is the Pass Five version that corresponds to revision 1.28 of ;;;the New Diana. This file contains debugging aids that should not ;;;be loaded prior to dumplisping a production system. However they ;;;can be loaded on top of a non-debugging-mode system to give some ;;;help. (Runtime checks that were compiled away cannot be restored, ;;;of course.) These tools should be helpful to all Diana users. ;;; ;;;Revision 1.1 84/01/07 12:55:00 mark ;;;Initial revision ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; DIANAIDS ;;; ;;; Mark Miller 7-Jan-84 ;;; ;;; ;;; ;;; Being a collection of debugging and analysis aids for users of ;;; ;;; the CTAda Diana package. See on-line manual for details. It is ;;; ;;; ok to load this into a non-debugging version in order to get ;;; ;;; some help with debugging. However, already expanded calls to ;;; ;;; macros like diana_get will remain non-debugging, of course. ;;; ;;; You should make both debugging and non-debugging versions of ;;; ;;; this file itself. ;;; ;;; ;;; ;;; NB: This file should not normally be present in the production ;;; ;;; build of CTAda. These functions are not needed for the normal ;;; ;;; operation of the Interpreter/Debugger product. ;;; ;;; ;;; ;;; This file is part of a proprietary software project. Source ;;; ;;; code and documentation describing implementation details are ;;; ;;; available on a confidential, non-disclosure basis only. These ;;; ;;; materials, including this file in particular, are trade secrets ;;; ;;; of Computer * Thought Corporation. ;;; ;;; ;;; ;;; (c) Copyright 1982 and 1983, Computer * Thought Corporation. ;;; ;;; All Rights Reserved. ;;; ;;; ;;; ;;; Reference materials: ;;; ;;; Miller, December 1983. The CTAda Diana Users Manual (online). ;;; ;;; Ambler & Trawick, Chatin's Graph Coloring Algorithm as a ;;; ;;; Method for Assigning Positions to Diana Attributes. ;;; ;;; SIGPLAN NOTICES, V18, #2, February 1983. ;;; ;;; Robertson & Miller, 1982. The C*T Diana Virtual Machine. ;;; ;;; Foderaro and Sklower, The FRANZ LISP Manual, September 1981. ;;; ;;; Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981. ;;; ;;; Charniak et al., 1980. Artificial Intelligence Programming. ;;; ;;; Miller, 1982. The C*T Ada Tutor: Guide to the Implementation. ;;; ;;; Tartan Labs, 1982. The Diana Reference Manual. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Dependencies on External Files ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (comment assumes ctload and filemap) (declare (ct_includef 'intrpdcl)) (eval-when (compile load eval) (ct_load 'charmac) (ct_load 'aip) (ct_load 'compat) #+franz (ct_load 'format) (ct_load 'ctio) (ct_load 'polly) (ct_load 'chunks)) #$. (let ((prev-stat (status feature diana_debugging))) (unwind-protect (progn (sstatus feature diana_debugging) (cond ((or (not (boundp '*diana_attributes*)) (null *diana_attributes*) (not (boundp '*diana_nodetypes*)) (null *diana_nodetypes*)) ;;Reload diana atts and nodes for extra read-time info. (ct_reload 'dianatts) (ct_reload 'dianods) (ct_reload 'dianapos)) (t (ct_load 'dianatts) (ct_load 'dianods) (ct_load 'dianapos)))) (or prev-stat (sstatus nofeature diana_debugging)))) #$. (ct_load 'diana) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Special Variable Initializations ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+franz (declare (macros t)) #+franz (declare (localf diana_wffp_int)) (declare (special *diana_self_test*)) (or (boundp '*diana_self_test*) (setq *diana_self_test* nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Diana Well-Formed-Formula Predicate ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;; (defun diana_wffp (frob) ;;;;;;;;;; ;;; Returns non-nil iff frob is a well-formed Diana formula. ;;; Walks the entire structure to verify that it is well-formed ;;; every way. This is available only in systems compiled with ;;; (sstatus feature diana_debugging) in effect. (let ((*diana_wffp_seen_so_far* nil)) (declare (special *diana_wffp_seen_so_far*)) (diana_wffp_int frob))) ;;;;;;;;;;;;;; (defun diana_wffp_int (frob) ;;;;;;;;;;;;;; (declare (special *diana_wffp_seen_so_far*)) (let ((ans t)) (cond ((diana_nodep frob) (setq *diana_wffp_seen_so_far* (cons frob *diana_wffp_seen_so_far*)) (diana_mapc #'(lambda (att val) (cond ((not (diana_attributep att)) (return (setq ans nil))) ((not (diana_node_accepts_attributep frob att)) (return (setq ans nil))) ((not (diana_attribute_valuep att val)) (return (setq ans nil))) ((and (diana_nodep val) (not (memq val *diana_wffp_seen_so_far*))) (or (diana_wffp_int val) (return (setq ans nil)))))) frob) ans)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Summarizing Diana Nodetypes and Attributes Information ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;; (defun diana_summary_1att (a &optional (strm (terminal_output))) ;;;;;;;;;;;;;;;;;; (let ((prinlevel nil) (prinlength nil) (base 10.)) (format strm "~&~2D. ~S~%" (diana_attribute_position a) a))) ;;;;;;;;;;;;;;;;;;; (defun diana_summary_1node (n &optional (strm (terminal_output))) ;;;;;;;;;;;;;;;;;;; (let ((prinlevel nil) (prinlength nil) (base 10.) (atts (sort (subst nil nil (diana_contingent_attributes n)) #'alphalessp))) (format strm "~2&~S~% Size: ~S~% Structural Sons: ~S~%" n (diana_nodetype_size n) (diana_nodetype_structural n)) (format strm "~& Contingent Attributes:") (cond ((> (length atts) 3) (format strm "~% ~S~%" atts)) (t (format strm " ~S" atts))))) ;;;;;;;;;;;;; (defun diana_summary (&optional (strm (terminal_output))) ;;;;;;;;;;;;; ;;; Creates a human-readable listing to terminal or to a file ;;; which summarizes the major information about CTAda's Diana. (let* ((prinlevel nil) (prinlength nil) (base 10.) (atts (sort (subst nil nil *diana_attributes*) #'(lambda (a b) (< (diana_attribute_position a) (diana_attribute_position b))))) (hiatt (first (last atts))) (nods (sort (subst nil nil *diana_nodetypes*) #'(lambda (n m) (< (diana_nodetype_size n)(diana_nodetype_size m))))) (lenn (length nods)) (hinod (first (last nods))) (lena (length atts))) (format strm "~&There are ~S Diana Attributes defined.~%" lena) (format strm "~&Of these, ~S are Universal.~%" *diana_universals_count*) (format strm "~&There are ~S Diana Nodetypes defined.~%" lenn) (format strm "~2&The highest position was ~S, assigned to ~S~%" (diana_attribute_position hiatt) hiatt) (format strm "~&The largest node size was ~S, assigned to ~S~%" (diana_nodetype_size hinod) hinod) (format strm "~%~3F% of the nodetypes are size 16 {versus 32} hunks.~%" (times 100.0 (quotient (do ((x nods (cdr x)) (i 0 (1+ i))) ((> (diana_nodetype_size (car x)) 17.) i)) (float lenn)))) (format strm "~2&Attributes sorted by position:~%") (mapc #'(lambda (a) (diana_summary_1att a strm)) atts) (format strm "~2&Nodetypes sorted by size:~%") (mapc #'(lambda (n) (diana_summary_1node n strm)) nods) 'done)) ;;;;;;;;;;;;;;; (defun diana_summarize (&optional (fil (ct_load_get 'dianasum))) ;;;;;;;;;;;;;;; (with_open_outfile (f fil) (diana_summary f)) (format (terminal_output) "~&Diana summary written to ~S.~%" fil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Diana Self Test ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;; (defun diana_self_test (&optional (summaryp t)) ;;;;;;;;;;;;;;; ;;; Test consistency of Diana arity and sons stuff. ;;; Hand-construct a {hopefully} legal Diana structure, run it ;;; through the threadifier, and then pprint the result. Save ;;; the structure in a global specvar, for ease of debugging. (and summaryp (diana_summary)) (let ((nod1 (setq *diana_self_test* (diana_cons 'dn_compilation))) (nod2 (diana_cons 'dn_package_body)) (*diana_internp* t)) ;;Helpful for testing. (diana_put nod1 (list (diana_cons 'dn_comp_unit) (diana_cons 'dn_comp_unit) (diana_cons 'dn_comp_unit)) 'as_list) (diana_put nod1 '("Random Comments.") 'lx_comments) (diana_put (first (diana_get nod1 'as_list)) nod2 'as_unit_body) (diana_put nod2 '("This is the dn_package_body node.") 'lx_comments) (diana_put (second (diana_get nod1 'as_list)) (diana_cons 'dn_procedure) 'as_unit_body) (diana_put (third (diana_get nod1 'as_list)) (diana_cons 'dn_task_body) 'as_unit_body) (diana_put nod1 (list 1 100.) 'lx_srcpos) (diana_threadify nod1) (or (diana_wffp (diana_copy (diana_threadify nod1))) (lose 'wffp 'diana_self_test)) (ct_print (mapcar #'(lambda (x) (diana_get x 'ct_id)) (diana_children nod1))) (diana_pprint nod1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Diana Inspector Stuff ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;Load in a patch file to make the lispm inspector nicer for diana nodes. #+(and lispm (not LMI)) (eval-when (load eval) (ct_load 'dianinsp)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;