;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/dianaio.l,v 1.31 85/06/14 13:33:35 bill Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                           DIANA_IO.L                             ;;;
;;; James R. Miller and Penny Muncaster-Jewell	       April 6, 1983 ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;;                                                                  ;;;
;;; 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:                                             ;;;
;;;   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. ;;;
;;;   Miller & Robertson, 1983.  /mnt/ct/ctlisp/diana.l		     ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|

What remains to be done:

	* Finalize specification of special attribute lists in
		CONS_DIANA_SEGMENT_WORKER and RESTORE_DIANA_STRUCTURE

|#

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

(comment Assumes ct_load and some suitable ct_daba 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 'time))		;Timing functions. 

(eval-when (compile load eval) (ct_load 'diana))	;Diana functions

(eval-when (compile load eval) (ct_load 'sema)) 	;Diana functions

(eval-when (compile load eval) (ct_load 'ctflav))	; flavor pkg

#+franz (eval-when (compile load eval) (ct_load 'loop))	;Lispm loop

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

#+franz (declare (macros t))

(declare (special *already_dumped_nodes*		;used by CONS_DIANA_
		  *to_be_added_to_symtab*
		  *nodelist*		  		;SEGMENT
		  *reloaded_diana*	  		;see LGO
		  *last_diana*		  		;see COMPILE_ADA
                  *old_and_new_branchlist* 	;hash to speed up instantiation
		  ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;;MAKE_LIBRARY_UNIT: *******************************************************
;;;Creates and returns a CT_ADA_LIBRARY_UNIT with the given 
;;;LIBRARY_UNIT_NAME and DIANA.
       ;;;;;;;;;;;;;;;;;
(defun make_library_unit (library_unit_name diana)
       ;;;;;;;;;;;;;;;;;

    (ct_make_instance 'ct_ada_library_unit
		   'library_unit_name library_unit_name
		   'diana diana
		   'pathname nil
		   'working_diana_branches nil
		   'diana_branches nil))


;;;CT_ADA_LIBRARY_UNIT: *****************************************************
;;;flavor definition that supports moving Diana structures from db to files
	      ;;;;;;;;;;;;;;;;;;;
(ct_defflavor ct_ada_library_unit 
	      ;;;;;;;;;;;;;;;;;;;

    (library_unit_name
     diana
     pathname
     diana_branches
     working_diana_branches)
    ()
    :gettable-instance-variables
    :settable-instance-variables)


;;;(CT_ADA_LIBRARY_UNIT CHANGE_DIANA_REPRESENTATION): ***********************
;;;Change the unit's Diana representation (perhaps, after a recompilation)
;;;to DIANA_GRAPH:  delete the file containing the old representation and save the
;;;new Diana representation in DIANA.
				   ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit change_diana_representation) (diana_graph)
				   ;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (ct_send self 'delete_diana_file)
    (setq diana diana_graph))


;;;(CT_ADA_LIBRARY_UNIT DELETE_DIANA_BRANCHES):******************************
;;;Free up the space occupied by DIANA_BRANCHES and DELETE_DIANA_BRANCHES.
				   ;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit delete_diana_branches) ()
				   ;;;;;;;;;;;;;;;;;;;;;

   (setq diana_branches nil
	 working_diana_branches nil))


;;;(CT_ADA_LIBRARY_UNIT DELETE_DIANA_FILE): *********************************
;;;The Diana representation of this unit has changed, such that its file is
;;;out of date.  Delete the file (if one exists), and clear the unit's
;;;PATHNAME.
				   ;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit delete_diana_file) ()
				   ;;;;;;;;;;;;;;;;;

    (cond ((ct_probef pathname)
	   (ct_deletef pathname)))
    (setq pathname nil))


;;;(CT_ADA_LIBRARY_UNIT DIANA): *********************************************
;;;Return the library unit's diana diana_graph, one way or another...
				   ;;;;;
(ct_defmethod (ct_ada_library_unit diana) ()
				   ;;;;;

    (cond

       ;;Is the diana_graph present as the value of DIANA?  If so, return it.

       (diana)

       ;;Otherwise, the diana_graph is in a file.  Load the DIANA_BRANCHES from
       ;;PATHNAME and instantiate them into DIANA.

       (t (setq diana_branches (read_diana_branches_from_file pathname))
	  (setq diana (ct_send self 'instantiate_diana_branches)))))


;;;(CT_ADA_LIBRARY_UNIT EXTERNAL_REPRESENTATION): ***************************
;;;Return a pointer to the offline representation of a diana_graph.  It may or
;;;may not be necessary to create a new file in doing so.
				   ;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit external_representation) ()
				   ;;;;;;;;;;;;;;;;;;;;;;;

    (cond

       ;;If PATHNAME is non-nil, its contents haven't been changed since
       ;;the last time it was written -- otherwise, a :DELETE_DIANA_FILE
       ;;message would have been sent to the library unit.  Recycle the old
       ;;file by returning a list pointing to that file.

       (pathname
	  (list 'ct_ada_library_unit library_unit_name pathname))

       ;;Here, PATHNAME must be null: the unit has either been changed or it
       ;;never existed.  Cons up a file name out of the library unit name
       ;;and a gensym, destructure and write the diana_graph to that file, and
       ;;return a list pointing to that new file.

	  (t
	     (setq pathname (string-append library_unit_name "." (gensym 'f)))
	     (write_diana_to_file diana pathname)
	     (list 'ct_ada_library_unit library_unit_name pathname))))
;;; use hash tables instead of list
       ;;;;;;;;;;;;;;;;;;
(defun find_new_node_name (old)
       ;;;;;;;;;;;;;;;;;;
    (assq old
	#+franz (arraycall t *old_and_new_branchlist* (smalltemphash old))
	#+lispm (aref *old_and_new_branchlist* (smalltemphash old))))
       ;;;;;;;;;;;;;;;;;
(defun add_new_node_name (old new)
       ;;;;;;;;;;;;;;;;;
    (let* ((haddr (smalltemphash old))
	   (hentry #+franz (arraycall t *old_and_new_branchlist*  haddr)
	           #+lispm (aref *old_and_new_branchlist* haddr)))
	#+franz (set (arrayref *old_and_new_branchlist*  haddr)
		     (cons `(,old . ,new) hentry))
	#+lispm (aset (cons `(,old . ,new) hentry)
		      *old_and_new_branchlist*  haddr)))
       ;;;;;;;;;;;;;;;;;;
(defun find_add_to_symtab (old)
       ;;;;;;;;;;;;;;;;;;
    (assq old
	#+franz (arraycall t *to_be_added_to_symtab* (smalltemphash old))
	#+lispm (aref *to_be_added_to_symtab* (smalltemphash old))))
       ;;;;;;;;;;;;;
(defun add_to_symtab (old new)
       ;;;;;;;;;;;;;
;  (if (or (null old) (null new)) (break 'bad-add))
    (let* ((haddr (smalltemphash old))
	   (hentry #+franz (arraycall t *to_be_added_to_symtab* haddr)
	           #+lispm (aref *to_be_added_to_symtab* haddr)))
	#+franz (set (arrayref *to_be_added_to_symtab* haddr)
		     (cons `(,old . ,new) hentry))
	#+lispm (aset (cons `(,old . ,new) hentry)
		      *to_be_added_to_symtab* haddr)))
       ;;;;;;;;;;;;;;;
(defun add_to_symtab_p (id )
       ;;;;;;;;;;;;;;;
; Wrong, the nconc implied by the mapcan will clober the symbol table!! --wab
;  (mapcan #'(lambda(arrayel)
;	    (cond ((equal id (car arrayel))
;		   arrayel)
;		  (t nil)))
  (assoc id
	 #+franz (arraycall t *to_be_added_to_symtab*
			    (smalltemphash id))
	 #+lispm (aref *to_be_added_to_symtab*
		       (smalltemphash id))))

;;;(CT_ADA_LIBRARY_UNIT INSTANTIATE_DIANA_BRANCHES): ***************************
;;;Convert a library unit's DIANA_BRANCHES into a real diana tree.
	    			   ;;;;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit instantiate_diana_branches) ()    
				   ;;;;;;;;;;;;;;;;;;;;;;;;;;

    (let ((newbranchlist nil)
	  (*old_and_new_branchlist* (small_temporary_hasharray))
	  (already_there nil)
	  (*to_be_added_to_symtab* (small_temporary_hasharray))
	  (*add_to_symtab_list* nil))
      
      ;;Work with a fresh copy of the unit's diana branches.
      
      (setq working_diana_branches (copytree diana_branches))
      
      ;;For each of the branches in the file, set the branch's CT_ID
      ;;to the branch itself and also hang the branch off the CT_ID's
      ;;property list, and keep a list of the CT_ID's.
      
      (loop with ident = nil
	    and newident = nil
	    for branch in working_diana_branches
 	    do

            (let* ((ntpos
		     (diana_attribute_position 'ct_nodetype))
		   (nbranch (diana_cons (aref *index_diana_nodes*
					      (nth ntpos branch))))
		   (b branch))
	      (diana_mapc
		#'(lambda (attr val)
		    (cond ((equal attr 'lx_srcpos)
			   (diana_put nbranch
				      (source_region 0 0 0 0 "library" 0 0)
				      attr)
			   (ct_pop b))
			  ((equal attr 'ct_nodetype)
			   (diana_put nbranch val attr)
			   (ct_pop b))
			  ((equal attr 'lx_symrep)
			   (cond ((stringp (car b))
				  (diana_put nbranch
					   (list 'lex_ident (exploden (ct_pop b)))
					   attr))
				 (t (diana_put nbranch
					   (ct_pop b)  attr)))
			   )
			  ((equal attr 'ct_cont)
			   (diana_put nbranch (list "*to_be_continued*") attr)
			   (ct_pop b))
			  ((equal (car b)  '*)
			   (diana_put nbranch nil attr)
			   (ct_pop b))
			  (t (diana_put nbranch (ct_pop b) attr))))
		nbranch)
	      ;(break look-at-branch-and-nbranch)
	      (setq branch nbranch))
	    
	    ;;Get the branch's old ident from the branch, and create 
	    ;;its new ident. This is slightly changed to accommodate
	    ;;those already installed
	    (setq ident (diana_get branch 'ct_id))
            (cond ((eq (diana_nodetype_get branch) 'dn_already_in_there)
		   (setq branch (eval  ident )
			 already_there t
			 newident ident))
		  (t (setq  already_there nil
			    newident (make_new_node_name
				       (bare_file_name pathname) ident))))
	    
	    ;;Save the old ident on BRANCHLIST, and the pairing of old
	    ;;and new identifiers on OLD_AND_NEW_IDENTIFERS.
	    
	    (ct_push newident newbranchlist)
	    (add_new_node_name ident newident)
            
	    
	    ;;The goal here is to come up with each branch properly
	    ;;installed in the symbol table, with all embedded Diana
	    ;;nodes re-instantiated (in place of their ct_id's).  This
	    ;;depends upon whether or not the node already exists in
	    ;;the symbol table: all parts of a program should point
	    ;;to the same instantiation of TRUE, for instance.  Hence,
	    ;;if it's appropriate to do so, try to install BRANCH in
	    ;;the symbol table via ADD_ID_TO_SYMTAB.  If anything is
	    ;;returned, it's an already-existing node that should be
	    ;;used instead of the node read from the file: use that
	    ;;for the value of the new ident instead of the branch.
	    
	    (set newident
		 
		 ;;Should we try to install BRANCH in the symbol table?
		 
		 (cond ((and (not already_there)
			     (diana_node_accepts_attributep branch 'ct_st_class)
			     (diana_get branch 'ct_st_class))
			(let* ((symid (diana_get branch 'ct_id))
			       (id (add_to_symtab_p symid )))
			  (cond (id 
				 (cdr id))
			        (t
			         (add_to_symtab symid  branch)
				 (ct_push branch *add_to_symtab_list*)
				 branch
				 ))))
		       
		       ;;Don't try to install BRANCH in the symbol
		       ;;table: just use it as NEWIDENT's value.
		       
		       (t branch)))
;	    (and (null (symeval newident)) (break 'instantiate))
	    )
      
      ;;For each branch in BRANCHLIST, replace all the gensym'ed 
      ;;symbols in that branch with the contents of the corresponding 
      ;;branch, being sure to preserve eq-ness. RESTORE_DIANA_STRUCTURE
      ;;should be sure to look down all embedded lists on the branch.
      
      (loop for branch in (reverse newbranchlist)
	    do
	    
	    ;;Restore the branch: the old branch is saved under its new
	    ;;name (NEW_BRANCH_NAME). RESTORE_DIANA_STRUCTURE may 
	    ;;rplaca additional branches into this branch, for which it 
	    ;;will need access to the list of old and new name pairings.
	    
	    (restore_diana_structure branch))
      ;;; need to add the symbols in the *to_be_added_to_symtab*
      ;;; list to the symbol table
     (mapc #'(lambda (branch)
	       (let ((existing_symbol
		       (add_id_to_symtab
			 (la_id
			   (and
			     (diana_node_accepts_attributep branch 'lx_symrep)
			     (diana_get branch 'lx_symrep))
			   (diana_get branch 'ct_pnl)
			   (diana_get branch 'lx_srcpos)
			   branch
			   (and
			     (diana_node_accepts_attributep branch 'ct_st_class)
			     (diana_get branch 'ct_st_class))
			   (and
			     (diana_node_accepts_attributep branch 'ct_st_type)
			     (diana_get branch 'ct_st_type))
			   (and
			     (diana_node_accepts_attributep
			       branch 'ct_st_defining_block)
			     (diana_get branch
					'ct_st_defining_block))))))))
	   *add_to_symtab_list*)

      
      ;;Finally, return a pointer to the top of the restored Diana
      ;;structure -- this is under the new node name.
      
      (eval (car (last newbranchlist)))))


;;;(CT_ADA_LIBRARY_UNIT INTERNAL_REPRESENTATION):****************************
;;;Given a parameter list:
;;;(ct_ada_library_unit library_unit_name filename)
;;;restore the unit's LIBRARY_UNIT_NAME, PATHNAME, and DIANA instance
;;;variables; the Diana tree is returned.
				   ;;;;;;;;;;;;;;;;;;;;;;;
(ct_defmethod (ct_ada_library_unit internal_representation)
				   ;;;;;;;;;;;;;;;;;;;;;;;

	      (parameters)
   
   ;;Save the library unit name.
   
   (setq library_unit_name (second parameters))
   
   
   ;;If the diana branches haven't been loaded yet, load them from the file
   ;;named in the call (i.e., the third parameter).
   ;; check that this is a diasna file and it can run on tis release.
   
   (cond ((null diana_branches)
	  (let ((base 8.)(ibase 8.))
	    (load (third parameters) nil nil nil t));
	  (setq header *header*)
	  (cond ((not (consp header))
		 (ct_format
		   *userout*
		   (format
		     nil
		     "~%The file ~A does not appear to be a C*T ada internal file.~%"
			    (third parameters)))
		 (ct_format *listout*
			    (format nil
				    "~%The file ~A does not appear to be a C*T ada internal file.~%"
			    (third parameters)))
		 (setq *continue_inc_diana* nil)
		 (setq *not_wffp_diana* nil)
		 (*throw '*not_wffp_diana* *not_wffp_diana*)
		 nil)
		((equal *release* (string (second header)))
		 (setq pathname (third parameters))
		 (setq diana_branches *branches*))
		(t (ct_format
		     *userout*
		     (format nil
				      "~%The library file ~a was not created by this version of the C*T Ada interpreter.~%~
			      You must create a new library file from the original Ada source code."
			      (third parameters)))
		   (ct_format
		     *listout*
		     (format nil
				      "~%The library file ~a was not created by this version of the C*T Ada interpreter.~%~
			      You must create a new library file from the original Ada source code."
			      (third parameters)))
		 (setq *continue_inc_diana* nil)
		 (setq *not_wffp_diana* nil)
		 (*throw '*not_wffp_diana* *not_wffp_diana*)
		 nil)
		   )))
   
   ;;Instantiate the diana branches, save the resulting Diana code in DIANA,
   ;;and return the code.
   
   (setq diana (cond ((status feature debugging)
		      (ct_send self 'instantiate_diana_branches))
		     (t (car
			  (errset (ct_send self 'instantiate_diana_branches) nil)))))
   (cond ((null diana)
	  (ct_format *listout*
		     (format nil
			     "The contents of the library file ~a ~%~
				appear to have been corrupted.  You will probably need to create~%~
				a new library file from the original Ada source code."
 (third parameters))) 
	  (ct_format *userout*
		     (format nil "The contents of the library file ~a ~%~
				appear to have been corrupted.  You will probably need to create~%~
				a new library file from the original Ada source code."
 (third parameters)))
	  nil)
	 (t diana)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 


;;;BARE_FILE_NAME: *************************************************************
;;;Given a pathname, get just the bottom-level name of the file (i.e., without 
;;;any directory information.  In addition, replace any "."s with "_"s, so that
;;;the result can be interned without symbol-izing.
       ;;;;;;;;;;;;;;
(defun bare_file_name (pathname)
       ;;;;;;;;;;;;;;

  ;;Start at the end of the string and search backward for a ":" or a "/":
  ;;take all the characters that appear in the file name after that.
  ;;Also replace any "." with "_".  

  (loop with newname = nil
	for char in (reverse (list_of_chars pathname))
	until (memq char '(#/: #//))
	do
	(ct_push (cond ((equal char #/.)
			#/_)
		       (t char))
		 newname)
	finally
	(return #+ lispm
		(apply 'string-append newname)
		#+franz
		(get_pname (apply 'string-append newname)))))


(defun find_add_to_dumped (old)
    (assq old
	#+franz (arraycall t *already_dumped_nodes* (smalltemphash old))
	#+lispm (aref *already_dumped_nodes* (smalltemphash old))))

(defun add_already_dumped (old new)
    (let* ((haddr (smalltemphash old))
	   (hentry #+franz (arraycall t *already_dumped_nodes* haddr)
	           #+lispm (aref *already_dumped_nodes* haddr)))
	#+franz (set (arrayref *already_dumped_nodes* haddr)
		     (cons `(,old . ,new) hentry))
	#+lispm (aset (cons `(,old . ,new) hentry)
		      *already_dumped_nodes* haddr)))

(defun already_dumped_p (branch)
  (mapcan #'(lambda (arrayel)
	    (memq branch arrayel))
	#+franz (arraycall t *already_dumped_nodes*
			   (smalltemphash branch))
	#+lispm (aref *already_dumped_nodes*
		      (smalltemphash branch))))

;;;CONS_DIANA_SEGMENT: *************************************************
;;;Convert a given Diana graph into a list structure by passing its main branch
;;;to CONS_DIANA_SEGMENT_WORKER.  The meat of this function is to
;;;maintain the special variables used in the consing, and to return the
;;;(reversed) list.
       ;;;;;;;;;;;;;;;;;;
(defun cons_diana_segment (diana_graph)
       ;;;;;;;;;;;;;;;;;;

    (let ((*already_dumped_nodes* (small_temporary_hasharray))
	  (*nodelist* nil))
	 (cons_diana_segment_worker diana_graph)
	 (reverse *nodelist*)))


;;;CONS_DIANA_SEGMENT_WORKER: ******************************************
;;;For the passed Diana graph, replace embedded Diana nodes with their CT_IDs.
;;;The resulting lists are consed onto *NODELIST*, a special variable owned
;;;by CONS_DIANA_SEGMENT, and are suitable for writing to a file and
;;;being restored from that file.

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create_node_to_add_to_nodelist (dn )
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let ((nunod (diana_copy dn)))
    (diana_mapc
      #'(lambda (attr val)
	  (diana_put nunod (get_ct_id_if_diana_node val) attr))
      nunod)
    (diana_put nunod (diana_get dn 'ct_id) 'ct_id)
    ;;; if this is a dn_generic_param_s clobber its ct_existing_instantiations
    ;;; as this is an alist of diana_nodes ((((a.b)).c)...)
    (cond ((eq (diana_nodetype_get dn) 'dn_generic_param_s)
	   (diana_put nunod nil 'ct_existing_instantiations)))
    nunod))

       ;;;;;;;;;;;;;;;;;;;;;;;;;
(defun cons_diana_segment_worker (diana_graph)
       ;;;;;;;;;;;;;;;;;;;;;;;;;
    ;(break in-c-d-s-w-beg)
    (cond
       
       ;;If DIANA_GRAPH is empty or an atom, we're at the bottom of a branch:
       ;;return DIANA_GRAPH.
       
       ((or (null diana_graph) (symbolp diana_graph)) diana_graph)
       
       ;;If DIANA_GRAPH is a Diana node, create the list containing the node name

       ;;Is DIANA_GRAPH a Diana node?

       ((diana_nodep diana_graph) ;(break in-c-d-s-w-dinodep)
	(let ((ident (diana_get diana_graph 'ct_id)))

	;;Yes: Create a "stripped" version of this node, consisting of its
	;;Diana node type, NIL, and, for each attr-value pair, the attr and
	;;(a) the CT_ID(s) of its values if they are Diana nodes, or (b) the
	;;value itself if not.  Push this list onto *NODELIST*, which belongs
	;;to WRITE_DIANA_TO_FILE. However, if this is an already threaded node
	;;then we do not want to traverse its subtree or send it out to the
	;;the file, so transform this into an already_there_node. This
	;;means this node is part of the std env.

	(cond ((or #|(consp (diana_get diana_graph 'ct_threadp))|#  ;in stdenv
		    (and (diana_get diana_graph 'ct_threadp)
			 (boundp (diana_get diana_graph 'ct_id))))
		      (let ((newnode (diana_cons 'dn_already_in_there)))
		 (diana_put newnode ident 'ct_id)
		 (ct_push newnode *nodelist*)))
	      (t (ct_push
		   (create_node_to_add_to_nodelist diana_graph)
		   *nodelist*)))
        ;;;Now: has DIANA_GRAPH already been put onto *ALREADY_DUMPED_NODES*? 

	(cond ((not (already_dumped_p ident))
	       
	       
	       ;;No: push its name onto *ALREADY_DUMPED_NODES*...
	       
	       (add_already_dumped ident nil)
	       
	       ;;... and pass all attributes of DIANA_GRAPH that contain dumpable
	       ;;attributes back through CONS_DIANA_SEGMENT_WORKER to
	       ;;write any embedded Diana nodes.  Be careful NOT to follow any
	       ;;CT_CONT or CT_THREADP nodes, as these would lead to infinite
	       ;;recursion.  Other attributes can also be omitted -- like
	       ;;lexicals -- since it's certain that there will be no embedded
	       ;;nodes down those paths. Do not traverse the subtree if
	       ;; this is a dn_already_in_there node
   
	       (cond
		 ((not
		    (eq (diana_nodetype_get (car *nodelist*))
			'dn_already_in_there))
		  
		  ;(break in-c-d-s-w-traverse-the-node)
		  (diana_mapc
		    #'(lambda (attr val)
			(cond ((eq
				 (diana_nodetype_get (car *nodelist*))
				 attr)
			       val)
			      ((memq attr '(ct_cont ct_threadp ct_id
					 	      ct_bnl ct_pnl lx_srcpos
						      lx_symrep lx_comments
						      sm_pos lx_numrep
						      ct_generic_membership
						      ct_existing_instantiations))
			       val)
			      ((numberp val)
			       val)
			      (t (cons_diana_segment_worker val)))) 
		    diana_graph)))))))	  ; thats all for diana_nodep
	       
       
       ;;Otherwise, it's a list of at least one Diana node: print each of
       ;;them that haven't already been printed.
       
       ((diana_nodep (car diana_graph));(break in_diana_loop)
	(loop for branch in diana_graph
	      unless (already_dumped_p (diana_get branch 'ct_id))
	      do (cons_diana_segment_worker branch)))       
       ;;If (CAR DIANA_GRAPH) is not a Diana node, it must be a 'lexical item or
       ;;something': return DIANA_GRAPH.
       
       ((not (diana_nodep (car diana_graph))) diana_graph)
       (t ;(break in_loop)
	  (loop for branch in diana_graph
		unless (already_dumped_p (diana_get branch 'ct_id))
		do (cons_diana_segment_worker branch)))))


;;;GET_CT_ID_IF_DIANA_NODE: ****************************************************
;;;Return the CT_ID's for a Diana node or list of nodes.  If this is not a
;;;node, just return whatever was passed.
       ;;;;;;;;;;;;;;;;;;;;;;;
(defun get_ct_id_if_diana_node (branch)
       ;;;;;;;;;;;;;;;;;;;;;;;

    
    (cond
       
       
       ;;If BRANCH is empty or an atom, return it.
       
       ((or (null branch) 
	    (symbolp branch)
	    (numberp branch))
	branch)

       ;;If BRANCH is a single Diana node, return its CT_ID.  If no ID exists,
       ;;put one onto the branch via DIANA_CT_ID.
       
       ((diana_nodep branch) (diana_get branch 'ct_id))
       
       ;;If the first element in BRANCH is a diana node, then we recklessly
       ;;assume that they all are, and we collect (or generate) the CT_ID's
       ;;of each node.
       ;;This assumption may be unwarranted...     ++
       
       ((diana_nodep (car branch))
	(loop for b in branch collect (cond ((diana_nodep b)
					     (diana_get b 'ct_id)))))
       
       ;;Otherwise, BRANCH is some random list, like a lex_ident: Return
       ;;it.
       
       (t branch)))


;;;MAKE_NEW_NODE_NAME: ***************************************************
;;;Create a new node name for a diana branch; this name is
;;;currently the concatenation of the name of the file from which
;;;the diana_graph is being read, an underscore, a gensym to represent
;;;the input process, and the old gensym name.  The goal here is
;;;to keep multiple loadings of the same library distinct.
       ;;;;;;;;;;;;;;;;;;
(defun make_new_node_name (filename gensym)
       ;;;;;;;;;;;;;;;;;;

  (intern
    (string-downcase
      (string-append filename '_ (gensym 'r) '_ gensym))
    'user))


;;;READ_DIANA_BRANCHES_FROM_FILE: ********************************************
;;;Get the uninstantiated diana branches from a file; these will likely be 
;;;stored in a library unit's DIANA_BRANCHES instance variable.  The
;;;Translation into a functional diana tree is done by sending the library unit
;;;a INSTANTIATE_DIANA_BRANCHES message.
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun read_diana_branches_from_file (file)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (let ((ibase 8.)(base 8.))
    (with_open_infile (filedescr file)
		    #+lispm (ct_read filedescr); get rid of header
		    #+franz (let ((oldcase (status uctolc)))
			      (unwind-protect
				(progn (sstatus uctolc t)
				       (ct_read filedescr))
				(eval `(sstatus uctolc
						,oldcase)))); get rid of header
		    #+lispm (ct_read filedescr)
		    #+franz (let ((oldcase (status uctolc)))
			      (unwind-protect
				(progn (sstatus uctolc t)
				       (ct_read filedescr))
				(eval `(sstatus uctolc
						,oldcase)))))))


;;;RESTORE_DIANA_STRUCTURE: ************************************************
;;;Given the gensym'ed name of a Diana branch, replace all the references
;;;on the corresponding branch to other branches with the branches
;;;themselves.  Search recursively down embedded lists.
       ;;;;;;;;;;;;;;;;;;;;;;;
(defun restore_diana_structure (branch)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (let ((rbranch (symeval branch)))
    
  (diana_mapc
	      #'(lambda (attr val)
		  
	;(break in_the_restore_a_node)
	  ;;If attr is a skippable attribute, don't substitute a list
	  ;;structure (note that skipping CT_ID is critical here), but try 
	  ;;to replace the old gensym name with the new name.
	  
	  (cond ((eq attr 'ct_id)
		 ;(break)
		 ;;this needs to be a diana_put
		 (diana_put rbranch
			 (cond 
			       (val (cdr (find_new_node_name val)))
			       (t val))
			 attr))
		((member attr 
			 '( ct_bnl ct_pnl lx_srcpos
				 lx_symrep lx_comments))
		 ;(break)
		 ;;this needs to be a diana_put
		 (diana_put rbranch
			 val
			 attr))
		
		;;If (cadr node) is an ident on OLD_AND_NEW_NAMES, rplaca it
		;;with the node on the ident's property list, which has been
		;;fetched off OLD_AND_NEW_NAMES.

		((and (atom val)
		      (find_new_node_name val))
		 (diana_put rbranch
			 (symeval (cdr (find_new_node_name val))) attr))
		
		;;If (cadr node) is a list of idents, substitute them all. 
		;;For now, just check that the first element of the list is 
		;;an ident.
		
		((and (consp val)
		      (find_new_node_name (car val)))
		 ;(break)
		 (loop for item on val
		       do
		       ;(break in_loop)
		       (rplaca item 
			       (symeval
				 (cdr
				  (find_new_node_name (car item))))))
		 (diana_put rbranch val attr))
		
		;;Otherwise, don't do anything.
		
		(t nil)))
     rbranch)))


;;;New write_diana_to_file. Dispense with the temp file nonsense. Just dump
;;;the forms directly.
;;;This is better than the old way of writing things to a temp file and
;;;using the compiler. However, this version does a lot of cons'ing because
;;;it must build the list representation of the diana_graph to be dumped.
;;;Better approach would be to come up with a way to open a bin file and
;;;dump the forms one at a time. (not available without using functions
;;;internal to sys:dump-forms-to-file.) Better still would be to
;;;dispense with all the list structure and dump the diana nodes as
;;;the arrays they are but this requires rewriting the reconstruction
;;;code. --wab
(defun write_diana_to_file (diana_graph &optional (file (terminal_output)))
  (let ((nodelist (cons_diana_segment diana_graph)))
;    (setq *my-diana-graph* diana_graph)
    (sys:dump-forms-to-file
      file
      `((setq *header* '(Release ,*release* C*T diana internal file))
	(setq *branches*
	      ',(intern-symbols
		  (mapcar
		    #'(lambda (node)
			(diana_mapcar
			  #'(lambda (attr val)
			      (cond ((and (equal attr 'lx_symrep)
					  (eq (car val) 'lex_ident))
				     (string (implode (cadr val))))
				    ((equal attr 'ct_cont)
				     '*)
				    ((equal attr 'ct_nodetype)
				     (get val 'index_node))
				    ((equal val nil)
				     '*)
				    ((equal attr 'lx_srcpos)
				     '*)
				    ((equal attr 'ct_lisp_func)
				     val)
				    (t
				     val)))
			  node))
		    nodelist))))
      `(:package ,(#+Symbolics pkg-name #+LMI package-name package)))
    'write_diana_to_file))

;;;Go through the braches in the node list we will dump to the file and
;;;make sure all the symbols are interned.  Recurse down elements that
;;;are lists. --wab
(defun intern-symbols (branch-list)
  (map #'(lambda (branch-sublist &aux (element (first branch-sublist)))
	    (cond ((consp element)
		   (intern-symbols element))
		  ((and (symbolp element) (not (symbol-package element)))
		   (setf (first branch-sublist) (intern element)))))
       branch-list))

#|
;;;Testing code
(defun results (old new)
  (loop for i from 1
	for obranch in old
	for nbranch in new
	do (cond ((equal obranch nbranch)
		  (format t "~%~d Equal" i))
		 (t
		  (format t "~%~d Not equal~%     ~a~%     ~a" i obranch nbranch)))))


(defun tryit (fun)
  (funcall fun *my-diana-graph* "ctvax://tmp//temp.temp")
  (load "ctvax://tmp//temp.temp")
  (list *header* *branches*))

(defun tryitalso (file)
  (load file)
  (list *header* *branches*))

(defun find-branch (branches ct-id)
  (loop for branch in branches
	if (eq (first branch) ct-id)
	collect branch))

|#

;;;Old version
#|
;;;STUPID_PPRINT: **********************************************************
;;;Just prints each item in l on a separate line, indented one space in 
;;;front of the opening and closing parens.
       ;;;;;;;;;;;;;
(defun stupid_pprint (l &optional (fd (terminal_output)))
       ;;;;;;;;;;;;;

    (let ((ibase 8.)
	  (base 8.))
      (loop for item in l
	  initially (ct_princ "(setq *branches* '(" fd) (ct_terpri fd)
	  do
	  (ct_princ "(" fd)
	  (diana_mapc 
            #'(lambda (attr val)
		       (cond ((and (equal attr 'lx_symrep)
				   (eq (car val) 'lex_ident))
			      (ct_prin1 (ct_format nil (implode (cadr val))) fd))
			     ((equal attr 'ct_cont)
			      (ct_princ "*" fd))
			     ((equal attr 'ct_nodetype)
			      (ct_princ (get val 'index_node) fd))
			     ((equal val nil)
			      (ct_princ "*" fd))
			     ((equal attr 'lx_srcpos) (ct_princ "*" fd)
			      ;(ct_prin1 val fd)
			      )
			     ((equal attr 'ct_lisp_func) (ct_prin1 val fd))
			     (t (ct_princ val fd)))
		       (ct_princ " " fd))
	    item)
	  (ct_princ ")" fd)
	  (ct_terpri fd)
	  #+franz (ct_terpri fd)
	  finally (ct_princ ")))" fd))))


;;;WRITE_DIANA_TO_FILE: ***********************************************
;;;Write the named Diana diana_graph to the specified file; all the real work is 
;;;done by CONS_DIANA_SEGMENT.
       ;;;;;;;;;;;;;;;;;;;
(defun write_diana_to_file (diana_graph &optional (file (terminal_output)))
       ;;;;;;;;;;;;;;;;;;;

       
       (let ((nodelist nil)
	     (prinlevel nil)
	     (prinlength nil))
	    
	    ;;Convert the diana_graph to its external list representation; the
	    ;;list is consed up into NODELIST. 
	    
	    (setq nodelist (cons_diana_segment diana_graph))
	    ;(break look-at-nodelist)
	    ;;Print the list on either the terminal or a named file.
	    
	    (cond
	      ((equal file (terminal_output))
		   (ct_format file "(Release ~A C*T diana internal file)~%" *release*)
		   (stupid_pprint nodelist)
		   (ct_terpri))
	      (t
	       (let ((base 8. )(ibase 8.)
		     (temp_internal_output_file
		      (format nil "~actadaint~a.tmp" *temp_directory* (gensym))))
	       (when (db%probef temp_internal_output_file)
			 (deletef temp_internal_output_file)
			 (fs:expunge-directory *temp_directory*))
	       (with_open_outfile
		 (filedescr temp_internal_output_file)
		 (ct_format
		   filedescr
		   "(eval-when (compile load eval)~%(setq *header* '(Release ~A C*T diana internal file))~%" *release*)
		 (stupid_pprint nodelist filedescr)
		 (ct_terpri filedescr))
		 (compiler:compile-file temp_internal_output_file file)
		 (deletef temp_internal_output_file))
	       )
	      )
	    
	    'write_diana_to_file))

|#


;;;Testing functions and other junk...
       ;;;;;;;;;;;
(defun compile_ada (ct_load_name file)
       ;;;;;;;;;;;

  (adag ct_load_name)
  (write_diana_to_file *last_diana* file))

;;LGO needs to be rewritten to adapt to the library-unit focus...

(comment defun lgo (file)	       ;;won't compile right until RUN_DIANA
    				       ;;is an expr instead of a macro [unless
				       ;;you want to load the whole
				       ;;interpreter to get at RUN_DIANA...
  (setq *reloaded_diana* (read_diana_from_file file))
  (run_diana *reloaded_diana*))



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

#|

(adag 'goole)
(setq ld *last_diana*)
(setq goole (make_library_unit 'goole ld))
;(describe goole)
(ct_send goole 'external_representation)
(setq foo (ct_send goole 'internal_representation
		   (list goole 'goole (ct_send goole 'pathname))))
(setq bar (ct_send goole 'instantiate_diana_branches))

(eq foo bar)

|#