;;; -*- Mode: LISP; Package: USER; Base: 10.; Fonts: cptfont -*-
;;; $Header: /ct/debug/datades.l,v 1.1 85/06/27 10:11:43 bill Exp $
(putprop 'datades "$Revision: 1.1 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            datades.l                             ;;;
;;;                                                                  ;;;
;;; William Brew                                        11-9-84      ;;;
;;;                                                                  ;;;
;;; Utilities for describing instances of Ada data types.            ;;;
;;;                                                                  ;;;
;;; 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 1984,  Computer * Thought Corporation.             ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes ct_load and some suitable file_map are present)

(eval-when (compile load eval) (ct_load 'aip))	   ; AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))  ; Franz/LM compat pkg.

(eval-when (compile load eval) (ct_load 'ctstrl))  ;New strings

(eval-when (compile load eval) (ct_load 'ctio))    ;Compatable io


(eval-when (compile load eval) (ct_load 'dbutils)) ; Debugger utilities

#+franz
(eval-when (load eval) (ct_load 'screens))         ; Windows, asks
#+lispm
(eval-when (load eval) (ct_load 'lmscreens))       ; Windows, asks


(eval-when (compile load eval) (ct_load 'ctadadt)) ; Ada data types (records),flavs

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Flavor definitions --

(ct_defflavor dt_unreachable_type
	   ((current_value "unreachable"))	; The current value of this object
	   (ada_datatype)
	   :gettable-instance-variables
	   :settable-instance-variables
	   :initable-instance-variables)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
#+franz (setq *flavor-expand-macros* t)

(defconst *db%unreachable_object* (make-instance 'dt_unreachable_type)
  "A dummy data type object to use when we hit a dead end")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macro definitions --

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Callable Functions/Methods -- 

;;;
;;; Inits and setups
;;;

;;; Init the data describer module
(defun db%init_datades ()
  nil)

;;; Start the data describer module
(defun db%start_datades ()
  nil)

;;;
;;;Defaults methods for all data types.
;;;

;;;Default describe value method. Just call the print object function on ourselves.
(ct_defmethod (ada_datatype describe_value) (features stream)
  features
  (db%print_object self stream))

;;; Default refine value method. Just return your self.
(ct_defmethod (ada_datatype refine_value) (node features stream)
  node features stream
  self)

;;;Default sub_refine method. Just return ourselves.
(ct_defmethod (ada_datatype sub_refine_value) (node features stream)
  node features stream
  self)

;;;Default modify value method. Do nothing. Data types should do something themselves.
;;;Return the current value string if the stream is nil.
(defmethod (ada_datatype modify_value) (node features stream)
  node features
  (if (null stream)
      (ct_send self 'describe_value (remq 'refine features) nil)))

;;;
;;;Enumeration types
;;;

;;;Ask the user for a new value.
(ct_defmethod (dt_enumeration_type modify_value) (node features stream)
  node
  (cond ((memq 'modify features)
	 (ct_if stream (ct_princ " -> " stream))
	 (setq current_value
	       (db%ask_diana_literal "New value? "
				    (diana_get sm_defn 'as_list) current_value))
	 (ct_send self 'describe_value (remq 'refine features) stream))))

;;;
;;;Integer types
;;;

;;;Ask the user for a new value.
(ct_defmethod (dt_integer_type modify_value) (node features stream)
  node
  (cond ((memq 'modify features)
	 (ct_if stream (ct_princ " -> " stream))
	 (setq current_value
	       (db%ask_integer "New value? " (first range) (second range) current_value))
	 (ct_send self 'describe_value (remq 'refine features) stream))))


;;;
;;;Floating point types
;;;

;;;Ask the user for a new value.
(ct_defmethod (dt_floating_type modify_value) (node features stream)
  node
  (cond ((memq 'modify features)
	 (ct_if stream (ct_princ " -> " stream))
	 (setq current_value
	       (db%ask_float "New value? " (first range) (second range) current_value))
	 (ct_send self 'describe_value (remq 'refine features) stream))))

;;;
;;;Fixed point types
;;;

;;;Ask the user for a new value.
(ct_defmethod (dt_fixed_point_type modify_value) (node features stream)
  node
  (cond ((memq 'modify features)
	 (ct_if stream (ct_princ " -> " stream))
	 (setq current_value
	       (real_to_fpv_conversion
		 (db%ask_float
		   "New value? " *l* *r* (float (fpv_to_real_conversion current_value)))
		 small_power pointpos))
	 (ct_send self 'describe_value (remq 'refine features) stream))))

;;;
;;;Array types
;;;

;;; Refine the value of an array. If we have the refine feature, then print ... and refine.
;;; Otherwise return our self.
(ct_defmethod (dt_array_type refine_value) (node features stream &aux robject)
  (cond ((memq 'refine features)
	 (cond (stream
		(ct_format stream "...~%")
		(db%diana_printself node stream)))
	 (setq robject (ct_send self 'sub_refine_value node features stream))
	 (ct_if stream (ct_princ " = " stream))
	 robject)
	(t self)))

;;; Sub refine the value of an array type object. First check to see if we should
;;; just print the value of the entire array with out any further refinement.
;;; If we do need to refine, then call then loop though the indices for the
;;; array and ask the user for a value to use. If we are really writing to a
;;; stream and not just a string, then echo back the refinement in Ada syntax
;;; as we go. When we have all the indices, then get the value of that element
;;; and call the refine on it using the type spec for the array object.
(ct_defmethod (dt_array_type sub_refine_value) (node features stream)
  node
  (ct_if (or (not (memq 'refine features))
	     (eq 'all (db%ask_literal "Refine the array's value or print all of it?"
				      '(refine all))))
	 self
	 (ct_send (ct_send self 'get_val (ct_send self ask_indices stream))
		  'sub_refine_value node features stream)))

;;;Ask the user for a set of array indices and echo things in Ada syntax.
(ct_defmethod (dt_array_type ask_indices) (stream)
  (loop with index = nil
	for (low high) in index_list
	for separator = "(" then ","
	if (and (numberp low) (numberp high))
	do (setq index (db%ask_integer "Index value: " low high))
	if (and (diana_nodep low) (diana_nodep high))
	do (setq index
		 (db%ask_diana_literal
		   "Index value: "
		   (loop for enum_id in (diana_get (extract_basetype low) 'as_list)
			 if (<= (diana_get low 'sm_pos)
				(diana_get enum_id 'sm_pos)
				(diana_get high 'sm_pos))
			 collect enum_id)))
	if stream
	do (ct_format stream "~a~d" separator (db%printable_index index))
	collect index
	finally (ct_if stream (ct_princ ")" stream))))

;;;
;;;Record types
;;;

;;; Refine the value of a record. If we have the refine feature, then print ... and refine.
;;; Otherwise return our self.
(ct_defmethod (dt_record_type refine_value) (node features stream &aux robject)
  (cond ((memq 'refine features)
	 (cond (stream
		(ct_format stream "...~%")
		(db%diana_printself node stream)))
	 (setq robject (ct_send self 'sub_refine_value node features stream))
	 (ct_if stream (ct_princ " = " stream))
	 robject)
	(t self)))

;;; Sub refine the value of a record type. Ask the user whether they want the whole thing
;;; or just part. If they want part then get the alist of available fields from the
;;; record and ask the user which one. Then print the name and try to refine further.
(ct_defmethod (dt_record_type sub_refine_value) (node features stream)
  node
  (ct_if (or (not (memq 'refine features))
	     (eq 'all (db%ask_literal "Refine the record's value or print all of it?"
				      '(refine all))))
	 self
	 (ct_send (ct_send self 'get_val (ct_send self ask_component stream))
		  'sub_refine_value node features stream)))

;;;Ask for a particular component of the record.
(ct_defmethod (dt_record_type ask_component) (stream)
  (let ((comp_id
	  (db%ask_diana_literal
	    "Record component: "
	    (loop for (comp_id . thing) in (ada_record_value%record current_value)
		  collect comp_id))))
    (ct_if stream (ct_format stream ".~a" (db%diana_printself comp_id nil)))
    comp_id))

;;;
;;;Access types
;;;

;;; Refine the value of an accessor. If we have the refine feature, then print ... and refine.
;;; Otherwise return our self.
(ct_defmethod (dt_access_type refine_value) (node features stream &aux robject)
  (cond ((memq 'refine features)
	 (cond (stream
		(ct_format stream "...~%")
		(db%diana_printself node stream)))
	 (setq robject (ct_send self 'sub_refine_value node features stream))
	 (ct_if stream (ct_princ " = " stream))
	 robject)
	(t self)))

;;; Sub refine an access type object. Two possibilities exist. Either we want the value
;;; of the pointer itself or we want the object that it is pointing to.
(ct_defmethod (dt_access_type sub_refine_value) (node features stream)
  node
  (ct_if (or (not (memq 'refine features))
	     (eq 'accessor (db%ask_literal "Accessed object or the accessor?"
					   '(accessed accessor))))
	 self
	 (cond ((eq current_value '*unassigned*)
		(send *db%unreachable_object* :set-current_value "<unassigned access>")
		*db%unreachable_object*)
	       ((eq current_value '*null*)
		(send *db%unreachable_object* :set-current_value "<null access>")
		*db%unreachable_object*)
	       (t
		(ct_if stream (ct_princ ".all" stream))
		(ct_send current_value 'sub_refine_value node features stream)))))

;;;
;;;Task types
;;;

;;;
;;;Entry types (not really used by the debugger)
;;;

(ct_defmethod (dt_entry_type describe_value) (features stream)
  features stream
  (lose 'db%ddes_describe_entry 'describe_value '("Attempt to describe an entry type")))

(ct_defmethod (dt_entry_type refine_value) (node features stream)
  node features stream
  (lose 'db%ddes_refine_entry 'refine_value '("Attempt to refine an entry type")))

(ct_defmethod (dt_entry_type modify_value) (node features stream)
  node features stream
  (lose 'db%ddes_modify_entry 'modify_value '("Attempt to modify an entry type")))

;;;
;;;Type types (not really used by the debugger)
;;;

(ct_defmethod (dt_type_type describe_value) (features stream)
  features stream
  (lose 'db%ddes_describe_type 'describe_value '("Attempt to describe a type type")))

(ct_defmethod (dt_type_type refine_value) (node features stream)
  node features stream
  (lose 'db%ddes_refine_type 'refine_value '("Attempt to refine a type type")))

(ct_defmethod (dt_type_type modify_value) (node features stream)
  node features stream
  (lose 'db%ddes_modify_type 'modify_value '("Attempt to modify a type type")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Methods -- 

;;; Print the object. We check to see if the object knows how to
;;; print itself. If so then do it. Else it is an error.
(defun db%print_object (object stream)
  (let ((prinlength 10.)
	(prinlevel 2.))
    (cond ((or (get-handler-for object 'printself) (get-handler-for object ':printself))
	   (ct_send object 'printself stream))
	  ((symbolp object)
	   (db%formstring stream (get object 'printself)))
	  (t (db%formstring stream "<cannot print self>"))))); --NB should be a
                                                             ; lose eventually
  
;;;A printself method for the unreachable object. The value should be a string
;;;indicating why we reached the unreachable.
(ct_defmethod (dt_unreachable_type printself) (stream)
  (db%formstring stream current_value))

;;; Ask the user for an enumeration literal from the specified set.
(defun db%ask_diana_literal (prompt enum_list &optional default_value)
  (db%ask_literal prompt (mapcar #'(lambda (enum_id) (list (db%diana_printself enum_id nil)
							   enum_id))
				 enum_list)
		  default_value))

;;;Get a printable version of an array index.
(defun db%printable_index (index)
  (cond ((fixp index) index)
	((diana_nodep index)
	 (db%diana_printself index nil))
	(t (lose 'db%insp_bad_index 'db%printable_index '("Unknown index type")))))

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;