;;; -*- 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) |#