;;;  -*- Mode:Common-Lisp; Package:ZWEI; Base:8 -*-

;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;;
;;;  The commands in this file are not supported by TI because they don't
;;;  work properly.  They may be repaired in the future, but don't bet on it.
;;;
;;;  From comc:

(DEFCOM COM-MAKE-CORRESPONDENCE
   "Make a correspondence table for this function.
The correspondence table maps between links in the list structure
of the function and positions in the text in the buffer.
This command is not currently supported by TI, and is probably broken."
   ()
   (CONDITION-CASE (ERROR)
      (FUNCTION-CORRESPONDENCE-1 (SECTION-NODE-NAME (LINE-NODE (BP-LINE (POINT)))) (POINT)
       *INTERVAL*)
      (DEFINITION-NOT-SEXP (BARF ERROR)))
   DIS-NONE) 

;; Correspondences


(DEFSIGNAL DEFINITION-NOT-UNIQUE FERROR (FUNCTION-SPEC)
   "Signaled by FUNCTION-CORRESPONDENCE when ZWEI can't tell which
text definition to make the correspondence with.") 


(DEFUN FUNCTION-CORRESPONDENCE (FUNCTION-SPEC)
  "Given a function spec, make a correspondence from its definition to its text.
The function spec better have an interpreted definition.
If there is not a unique definition section for the function spec,
an error is signaled with condition name ZWEI:DEFINITION-NOT-UNIQUE.
The command M-X Make Correspondence can be used to tell ZWEI which
definition to prefer."
  (MULTIPLE-VALUE-BIND (BP BUFFER)
    (DEFINITION-TEXT-LOCATION-1 FUNCTION-SPEC)
    (IF BP
      (FUNCTION-CORRESPONDENCE-1 FUNCTION-SPEC BP BUFFER)
      (FERROR 'DEFINITION-NOT-UNIQUE "There is more than one definition of ~S." FUNCTION-SPEC)))) 


(DEFUN FUNCTION-CORRESPONDENCE-1 (FUNCTION BP BUFFER)
  (LET* ((LINE (CAR BP))
	 (INT (DEFUN-INTERVAL (CREATE-BP LINE 0) 1 () ()))
	 (DEFINITION (FDEFINITION (SI:UNENCAPSULATE-FUNCTION-SPEC FUNCTION)))
	 NEWSEXP
	 TEM
	 (CORRESPONDENCE (SI:FUNCTION-SPEC-GET FUNCTION 'ZMACS-CORRESPONDENCE)))
    (COND
      ((OR (ATOM DEFINITION) (AND (EQ (CAR DEFINITION) 'MACRO) (ATOM (CDR DEFINITION))))
       (FERROR 'DEFINITION-NOT-SEXP "The definition of ~S is not an s-expression." FUNCTION)))
    (SI:FUNCTION-SPEC-PUTPROP FUNCTION
			      (CONS BUFFER
				    (SECTION-NODE-DEFUN-LINE
				     (LINE-NODE (BP-LINE (INTERVAL-FIRST-BP INT)))))
			      'ZMACS-CHOSEN-DEFINITION)
    (COND
      ((OR (NULL CORRESPONDENCE) (NEQ (CAR CORRESPONDENCE) DEFINITION)
	  (> (INTERVAL-REAL-TICK INT) (CADDR CORRESPONDENCE)))
       ;; Read in the text.  Get a new sexp for the function,
       ;; together with a correspondence between it and the text.
       (MULTIPLE-VALUE-SETQ (NEWSEXP CORRESPONDENCE)
	 (ESTABLISH-CORRESPONDENCE DEFINITION BUFFER INT))
       (SETQ TEM (MEMBER NEWSEXP CORRESPONDENCE :TEST #'EQ)) (AND TEM (RPLACA TEM DEFINITION))
       (SETQ NEWSEXP (CDDR NEWSEXP));Flush DEFUN or DEFMETHOD, and fn name.
       (SETQ DEFINITION (SI::LAMBDA-EXP-ARGS-AND-BODY DEFINITION))
       ;; Now the new sexp should look like the definition.
       ;; Move the correspondence to the definition.
       (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE NEWSEXP DEFINITION)
       (SI:FUNCTION-SPEC-PUTPROP FUNCTION CORRESPONDENCE 'ZMACS-CORRESPONDENCE)))
    CORRESPONDENCE)) 


(DEFUN ESTABLISH-CORRESPONDENCE (DEFINITION BUFFER BP1 &OPTIONAL BP2 IN-ORDER-P)
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (LET ((STREAM (INTERVAL-STREAM BP1 BP2 T))
	(SI:XR-CORRESPONDENCE-FLAG T)
	SI:XR-CORRESPONDENCE)
    (VALUES (READ STREAM T)
	    `(,DEFINITION ,BUFFER ,(NODE-TICK BUFFER) ,BP1 ,BP2 ,@SI:XR-CORRESPONDENCE)))) 


(DEFUN INTERVAL-REAL-TICK (BP1 &OPTIONAL BP2 IN-ORDER-P)
  "Return the latest tick at which any line in an interval was modified.
Pass either an interval or a pair of BPs."
  (GET-INTERVAL BP1 BP2 IN-ORDER-P)
  (DO ((LINE (BP-LINE BP1) (LINE-NEXT LINE))
       (FIRST-LINE (BP-LINE BP1))
       (MAX-TICK 0)
       (LIMIT (BP-LINE BP2)))
      (NIL)
    (SETQ MAX-TICK
	  (MAX MAX-TICK (LINE-TICK LINE)
	       (OR
		(AND (NEQ LINE FIRST-LINE)
		   (GETF (LINE-PLIST LINE) 'PRECEDING-LINES-DELETED-TICK))
		0)))
    (IF (EQ LINE LIMIT)
      (RETURN MAX-TICK)))) 

;; Given a correspondence from the sexp TEMPDEF, matches up TEMPDEF
;; and REALDEF and clobbers the correspondence to be from REALDEF instead.
;; FUNCTION is just for error messages.  
;; We throw to TRANSFER-CORRESPONDENCE-LOSSAGE if the two sexps don't match.

(DEFUN TRANSFER-CORRESPONDENCE (FUNCTION CORRESPONDENCE TEMPDEF REALDEF)
  (LET ((TEM (MEMBER TEMPDEF CORRESPONDENCE :TEST #'EQ)))
    (AND TEM (RPLACA TEM REALDEF)))
  ;; In the real definition, some displacing macros may have gone off.
  (AND (EQ (CAR REALDEF) 'SI::DISPLACED) (SETQ REALDEF (CADR REALDEF)))
  (OR (= (LENGTH TEMPDEF) (LENGTH REALDEF)) (THROW 'TRANSFER-CORRESPONDENCE-LOSSAGE
						   ()))
  (DO ((TD TEMPDEF (CDR TD))
       (RD REALDEF (CDR RD)))
      ((NULL TD))
    (AND (COND
	   ((ATOM (CAR TD)) (NOT (EQUAL (CAR TD) (CAR RD))))
	   (T (ATOM (CAR RD))))
       (THROW 'TRANSFER-CORRESPONDENCE-LOSSAGE
	      ()))
    (OR (ATOM (CAR TD)) (TRANSFER-CORRESPONDENCE FUNCTION CORRESPONDENCE (CAR TD) (CAR RD))))) 
