;;; -*- Mode:Common-Lisp; Package:X11; Fonts:(MEDFNB HL12B HL12BI); Base:10 -*-

;;;			      RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(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) 1988 Texas Instruments Incorporated. All rights reserved.

;;;
;;; Change history:
;;;
;;;  Date      Author	Description
;;; -------------------------------------------------------------------------------------
;;; 12/14/88	LGO	Move all trace code to its own file.


(defvar *monochrome-server-trace* tv:initial-lisp-listener
  "Stream where trace output is written to.")

(defvar *monochrome-server-trace-enabled* nil
  "Flag to enable/disable the trace.")

(DEFPARAMETER *MONOCHROME-SERVER-EVENT-TRACE-ENABLED*  NIL
  "Used to enable/disable the trace for the event code.")

(DEFPARAMETER EVENT-FUNCTION-NESTING-LEVEL 0
  "Nesting level for event function calls.")

;1;*
;1; Server trace facility*
;1;*
(defvar server-trace-lock nil)

;1; When trace goes to an edit buffer, doing a single :string out is 3x faster than several short string out's*
;1; That's because the buffer-stream doesn't have to grow its line array each time.*
;1; Note: this array is automatically grown if necessary, but 2000 ought to do it.*
(defvar server-trace-vector (make-array 2000 :element-type 'string-char :fill-pointer 0))

(defmacro with-server-trace ((stream) &body body)
  `(when (and *monochrome-server-trace-enabled* *monochrome-server-trace*)
     ;1; Use a lock to keep trace from being fouled by multiple processes*
     (with-lock (server-trace-lock :whostate "Server Trace Lock")
       (setf (fill-pointer server-trace-vector) 0)
       (with-output-to-string (,stream server-trace-vector)
	 ,@body)
       (when (typep *monochrome-server-trace* 'w:sheet)
	 ;; Make sure that more processing is turned off.
	 (send *monochrome-server-trace* :set-more-p nil))
       (send *monochrome-server-trace* :string-out server-trace-vector))))

(defmacro server-trace (format-string &rest format-args)
  ;1; A macro, so arguments aren't evaluated when trace is disabled.*
  `(when *monochrome-server-trace-enabled*
     (server-trace-internal ,format-string ,@format-args)))

(defun server-trace-internal (format-string &rest format-args)
  (with-server-trace (stream)
    (apply #'format stream format-string format-args)))

(defun server-log (format-string &rest format-args)
  ;; Unconditionally write to the trace stream
  (let ((*monochrome-server-trace-enabled* t))
    (with-server-trace (stream)
      (apply #'format stream format-string format-args))))

(defun server-trace-fast (&rest values)
  "2Print VALUES, starting with a new-line, and inserting a space between each value, except when a value is a string.*"
  (with-server-trace (stream)
    (terpri *monochrome-server-trace*)
    (do ((values values (cdr values))
	 (value))
	((endp values))
      (setq value (car values))
      (block nospace
	(typecase value
	  (string (send stream :string-out value)
		  (return-from nospace))
	  (symbol (send stream :string-out (symbol-name value)))
	  (window (send stream :string-out "#<Window #x")
		  (let ((*print-base* 16.)) (princ (window.id value) stream))
		  (send stream :string-out " >"))
	  (pixmap (send stream :string-out "#<Pixmap #x")
		  (let ((*print-base* 16.)) (princ (pixmap.id value) stream))
		  (send stream :string-out " >"))
	  (gcontext (send stream :string-out "#<Gcontext #x")
		    (let ((*print-base* 16.)) (princ (gcontext.id value) stream))
		    (send stream :string-out " >"))
	  (otherwise (prin1 value stream)))
	(unless (stringp (second values))
	  (send stream :tyo #\space))))))

(defun print-padded-number (value width stream)
  ;1; Much faster than using format*
  (let ((value-width (loop for x = value then (floor x *print-base*)
			   count t until (< x *print-base*))))
    ;1; Print padding*
    (send stream :string-out "                " 0 (- width value-width))
    (princ value stream)))

(defconstant trace-line-length 124)

(defun server-trace-bytes (bytes start length &optional (label " Bytes: "))
  (with-server-trace (stream)
    (princ label stream)
    (let* ((pos (send  *monochrome-server-trace* :read-cursorpos :character))
	   (chars-per-long 13)
	   (longs-per-line (floor trace-line-length chars-per-long)))
      (loop for index from start below (+ start length)
	    for n upfrom (* 4 (ceiling pos chars-per-long))
	    with *print-base* = 16.
	    do (progn
		 (when (and (plusp n) (zerop (mod n 4)))
		   (if (zerop (mod n longs-per-line))
		       (terpri stream)
		     (write-char #\space stream)))
		 (print-padded-number (aref bytes index) 3 stream))))))

(defun server-trace-words (words start length &optional (label " Words: "))
  (with-server-trace (stream)
    (princ label stream)
    (let* ((pos (send  *monochrome-server-trace* :read-cursorpos :character))
	   (chars-per-long 11)
	   (longs-per-line (floor trace-line-length chars-per-long)))
      (loop for index from start below (+ start length)
	    for n upfrom (* 2 (ceiling pos chars-per-long))
	    with *print-base* = 16.
	    do (progn
		 (WHEN (and (plusp n) (zerop (mod n 2)))
		   (if (zerop (mod n longs-per-line))
		       (terpri stream)
		     (write-char #\space stream)))
		 (print-padded-number (aref words index) 5 stream))))))

(defun server-trace-longs (longs start length &optional (label " Longs: "))
  (with-server-trace (stream)
    (princ label stream)
    (let* ((pos (send  *monochrome-server-trace* :read-cursorpos :character))
	   (chars-per-long 9)
	   (longs-per-line (floor trace-line-length chars-per-long)))
      (loop for index from start below (+ start length)
	    for n upfrom (ceiling pos chars-per-long)
	    with *print-base* = 16.
	    do (progn
		 (when (and (plusp n) (zerop (mod n longs-per-line)))
		   (terpri stream))
		 (print-padded-number (aref longs index) 9 stream))))))

(zwei:define-indentation server-trace-value-mask (3 1))
(defun server-trace-value-mask (value-mask longs index vector)
  (with-server-trace (stream)
    (loop for i upfrom 0
	  for mask first value-mask then (ash mask -1)
	  while (plusp mask)
	  when (oddp mask) do
	  (princ " " stream)
	  (princ (aref vector i) stream)
	  (princ "=" stream)
	  (princ (aref longs index) stream)
	  (incf index))))

(defun server-backtrace (format-string &rest format-args)
  ;;1 Same as server-trace, but prints function backtrace*
  (when (and *monochrome-server-trace-enabled* *monochrome-server-trace*)
    (apply #'server-trace-internal format-string format-args)
    (format *monochrome-server-trace* "~%From ~{~<~%~1:; ~@[~a~]~>~^, ~}."
	    (backtrace 8))))

(DEFMACRO EVENT-TRACE (FORMAT-STRING &REST FORMAT-ARGS)
  "Use this to display trace messages for the event code."
  `(WHEN *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* 
     (SERVER-TRACE ,FORMAT-STRING ,@FORMAT-ARGS)))

(defmacro EVENT-TRACE-ENTERING (FUNCTION-NAME)
  `(WHEN *MONOCHROME-SERVER-EVENT-TRACE-ENABLED*
     (EVENT-TRACE-ENTERING-internal ',function-name)))

(defmacro EVENT-TRACE-LEAVING (FUNCTION-NAME)
  `(WHEN *MONOCHROME-SERVER-EVENT-TRACE-ENABLED*
     (EVENT-TRACE-LEAVING-internal ',function-name)))

(DEFUN EVENT-TRACE-ENTERING-internal (FUNCTION-NAME)
  (DECLARE (TYPE SIMPLE-STRING FUNCTION-NAME))
  (INCF EVENT-FUNCTION-NESTING-LEVEL)
  (SERVER-TRACE "~%~2D ~v@tEntering ~A"
		EVENT-FUNCTION-NESTING-LEVEL
		EVENT-FUNCTION-NESTING-LEVEL
		FUNCTION-NAME))

(DEFUN EVENT-TRACE-LEAVING-internal (FUNCTION-NAME)
  (DECLARE (TYPE SIMPLE-STRING FUNCTION-NAME))
  (SERVER-TRACE "~%~2D ~v@tLeaving  ~A"
		EVENT-FUNCTION-NESTING-LEVEL
		(max 0 EVENT-FUNCTION-NESTING-LEVEL)
		FUNCTION-NAME)
  (DECF EVENT-FUNCTION-NESTING-LEVEL)
  (WHEN (ZEROP EVENT-FUNCTION-NESTING-LEVEL)
    ;; When we get to the bottom, output a line separator.
    (SERVER-TRACE
      "~%-------------------------------------------------------------------------")))

;1;;*
;1;; Utility for getting debug backtrace info*
;1;;*
(DEFRESOURCE backtrace-sg ()
  :constructor (MAKE-STACK-GROUP "BackTrace") :initial-copies 0)

(DEFUN backtrace (depth &optional (STACK-GROUP current-stack-group))
  "2Return a list containg the function that called this one, etc to a depth of DEPTH.
 STACK-GROUP may be a stack-group or a process.*"2 *
  (WHEN (TYPEP stack-group 'si:process)
    (SETQ stack-group (PROCESS-STACK-GROUP stack-group)))
  (CHECK-TYPE stack-group si:stack-group)
  (USING-RESOURCE (backtrace-sg backtrace-sg)
    (STACK-GROUP-PRESET backtrace-sg #'(lambda (depth sg)
					 (STACK-GROUP-RETURN (backtrace-internal depth sg)))
			(+ depth 2) stack-group)
    (CDDR (FUNCALL backtrace-sg nil))))

(DEFUN backtrace-internal (depth sg)    
  (LOOP for i from 0 below depth
	with pdl = (si:sg-regular-pdl sg)
	for frame first #+elroy (si:sg-top-frame sg) #-elroy (si:sg-ap sg)
	          then (eh:sg-next-frame sg frame)
	for function = (AND frame (si:rp-function-word pdl frame))
	until (NULL function)
	collect (function-name function)))


(defun trace-buffer (&optional (name "X11-Trace"))
  (let ((buffer (zwei:find-buffer-named name t)))
    (when buffer ;1; If a buffer already there, kill it and make a new one*
      (zwei:kill-buffer buffer :no-save-p)))
  (let* ((*package* (find-package 'x11)) ;1; create buffer using the X11 package*
	 (buffer (zwei:find-buffer-named name t)))
    (setq *monochrome-server-trace*
	  (zwei:interval-stream buffer nil nil nil :no-undo-saving))))

(DEFUN SERVER-TRACE-ON ()
  (SETQ *MONOCHROME-SERVER-TRACE-ENABLED* T
        *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* NIL))

(DEFUN SERVER-EVENT-TRACE-ON ()
  (SETQ *MONOCHROME-SERVER-TRACE-ENABLED*       T
        *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* T
        EVENT-FUNCTION-NESTING-LEVEL            0))

(DEFUN SERVER-TRACE-OFF ()
  (SETQ *MONOCHROME-SERVER-TRACE-ENABLED* NIL
        *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* NIL))

(DEFUN SERVER-EVENT-TRACE-OFF ()
  (SETQ *MONOCHROME-SERVER-EVENT-TRACE-ENABLED* NIL))