;;; -*- Mode:Common-Lisp; Package:USER; Fonts:(MEDFNT HL12B HL12BI); Base:10 -*-
;===============================================================================
;
;   (c) Unpublished Copyright 1985 by Texas Instruments.  All rights reserved.
;
;===============================================================================

;;; Ï1LaMott's utility functionsÏ*

#|
BACKTRACE       Given a stack-group or process, return a stack trace
WHO-CALLS-ME	If FOO calls BAR and BAR calls WHO-CALLS-ME, then WHO-CALLS-ME returns FOO
PRINT-CALLERS	Print a histogram showing who called the functions calling WHO-CALLS-ME  
INCREMENT-HISTOGRAM
PRINT-HISTOGRAM General purpose histogram generation and reporting
KEYBOARD-INSERT Return a function which, when called, will put a
                string into the keyboard buffer.
BASE            Print the current base, or print arguments in base 8 10 and 16.
SET-PROCESS     Do apropos on process name and set priority and quantum
DESCRIBE-OPT    Describe the current compiler optimizations
AREA            Given a lisp object return what area its in.
UNROLL          Flatten a tree
SAVE-SYMBOL     Save a symbol and its value to an xfasl file
UNIVERSAL-STRING Like STRING, except it always works
STRING-TRIM-ALL Like STRING-TRIM, except removes ALL occurrences of characters

The following functions are useful for debugging:
WITH-MAR        Print a message when a variable is read or written
COMPARE         Like equalp, except prints what's different
C               Does (format nil "~:c" arg), except easier to type
PV              Macro takes local variables and prints their names and values
E               Do an FSIGNAL to get into the debugger
PAUSE           Pause displaying a message at the top of the screen
ACCEPT          Set a variable to a value read from the user at the top of the
                screen. 
SHOW            Bind *PRINT-ARRAY* to T around a PRINT - useful for looking
                at structures and arrays
PRINT-ARRAY     Pretty-prints multi-dimensional arrays (up to rank 3)

|#

;; Ï2FIND-WINDOWÏ*	Ï2Do apropos on window name.Ï* - moved to the APROPOS file.


(DEFMACRO with-mar ((thing &optional (mode :write) predicate &rest args) &body body)
  "Ï2Set an MAR break on THING. 
 Mode is :READ :WRITE or T for both.
 PREDICATE is a function to call when the mar is hit. Its called with the value being
 read or written, and ARGS.  When PREDICATE returns true, the error handler is invoked,
 otherwise a message is printed to *trace-output* (note that *trace-output* can be bound to
 si:null-stream of you don't want any output). Suggested predicates are MEMBER and friends,
 using :TEST or :TEST-NOT parameters.Ï*"
  (LET ((mar-size (CASE (CAR (MACROEXPAND-ALL `(LOCF ,thing)))
			;Ï1; If THING is a variable, set the whole structure THING points at.Ï*
			(VARIABLE-LOCATION `(%STRUCTURE-BOXED-SIZE ,thing))
			;Ï1; Otherwise, THING must be an array-element or someting, just check 1 word.Ï*
			(otherwise 1))))
    `(UNWIND-PROTECT
	 (PROGN
	   (SET-MAR (LOCF ,thing) ,mode ,mar-size)
	   (CONDITION-BIND ((sys:mar-break #'mar-condition-handler ,predicate ,@args))
	     (PROGN 'COMPILE . ,body)))
       (CLEAR-MAR))))

(DEFUN mar-condition-handler (condition predicate &rest args)
  (LET* ((object (SEND condition :object))
	 (offset (SEND condition :offset))
	 (value (SEND condition :value))
	 (direction (SEND condition :direction))
	 (functions  (MAPCAR #'FUNCTION-NAME (NTHCDR 5 (backtrace 9)))))
    (FORMAT *trace-output* "~&MAR break on ~:[read~;write~] of ~s ~:[from~;to~] ~s offset ~d in~{ ~a ~^<-~}"
	    direction value direction object offset functions)
    (WHEN (NOT (AND predicate (APPLY predicate value args)))
      (SEND condition :proceed :no-action))))


(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))
;	  while (OR (TYPEP function 'compiled-function) (TYPEP function ':STACK-GROUP))
	until (OR (NULL function))	   ; (TYPEP function ':STACK-GROUP))
;Ï1;Ï*	unless (eh:SG-FRAME-ACTIVE-P SG FRAME) do (FSIGNAL "This is not an active frame.")
	collect function))

(DEFMACRO increment-histogram (histo-list element-name &optional (amount 1))
  (LET ((element (GENSYM))
	(histo histo-list))
    (ONCE-ONLY (histo-list element-name amount)
      `(LET* ((,element (assoc ,element-name ,histo-list :test #'eq))
	      (default-cons-area working-storage-area))
	 (IF ,element
	     (SETF (CDR ,element) (+ (CDR ,element) ,amount))
	   (SETF ,histo (CONS (CONS ,element-name ,amount) ,histo-list))
	   ,amount)))))

(DEFUN print-histogram (histo &key (ignore-list t) print-translate
			(threshold 0.5) (STREAM *standard-output*)
			total)
  "Ï2Print histogram HISTO.
 IGNORE-LIST is a list of histogram entries to ignore, NIL to prevent copying the histogram.
   When NIL, the sorted histogram is returned.
 PRINT-TRANSLATE is a function of one argument used to translate histogram item names.
 THRESHOLD is used to restrict printing of insignificant items.  Items whose percentage
     of the total is less than or equal to THRESHOLD aren't printed.
 STREAM the stream to print on.
 TOTAL is the sum of all the histogram entries.  This is usually calculated for you.Ï*"
  (LET ((sub-total 0) (sub-percent 100.)
	(histo-copy histo))
    ;Ï1; When IGNORE-LIST, copy the histogram, because SORT is destructiveÏ*
    (WHEN ignore-list
      (SETQ histo-copy
	    (LOOP for h in histo
		  with ignores = (AND (LISTP ignore-list) ignore-list)
		  unless (MEMBER (CAR H) IGNORES :TEST #'EQ)
		  collect h)))
    ;Ï1; Sort the histogramÏ*
    (SETQ histo-copy (SORT histo-copy #'(lambda (a b) (> (CDR a) (CDR b)))))
    ;Ï1; Find the sumÏ*
    (UNLESS total
      (SETQ total 0)
      (DOLIST (h histo-copy) (INCF total (CDR h))))
    (WHEN (PLUSP total) ;Ï1; Avoid division by zeroÏ*
      ;Ï1; Print a line for each histogram entryÏ*
      (DOLIST (h histo-copy)
	(LET* ((COUNT (CDR h))
	       (percent (/ (ROUND (* count 1000.) total) 10.0)))
	  (WHEN (<= percent threshold) (RETURN))
	  (INCF sub-total count)
	  (FORMAT stream "~&~4f% ~:5d  " percent count)
	  (If print-translate
	      (LET ((PRINT (FUNCALL print-translate (CAR h))))
		(WHEN print (PRIN1 print stream)))
	    (PRIN1 (CAR h) stream))))
      (SETQ sub-percent (/ (ROUND (* sub-total 1000.) total) 10.0)))
    ;Ï1; Report the totalÏ*
    (FORMAT stream "~&~4f% ~5:d reported out of a grand total of ~:d"
	    sub-percent sub-total total)
    ;Ï1; Return the sorted histogram when IGNORE-LIST is NILÏ*
    (IF ignore-list (VALUES) histo-copy)))

(defun merge-histograms (&rest histograms &aux result)
  (dolist (histogram histograms)
    (loop for (name . count) in histogram
	  do (increment-histogram result name count)))
  result)

(DEFVAR *who-callers* nil)

(DEFUN who-calls-me (&optional name)
  "Ï2Keep track of who calls the routine this macro is in.  See PRINT-CALLERS.
Returns Who called me, and the current number of times.
Use the optional NAME property when calling this from a method or internal function.Ï*"
  (LET* ((callers (backtrace 3))
	 (who-called-me (SECOND callers))
	 (who-called-name (OR name (FUNCTION-NAME who-called-me)))
	 (who-who-called-me (THIRD callers)))
    (WHEN (LISTP who-called-name) (SETQ who-called-name (SECOND who-called-name))) ;Ï1; Fake itÏ*
    (PUSHNEW who-called-name *who-callers*)
    (VALUES who-who-called-me
	    (increment-histogram (GET who-called-name 'callers) who-who-called-me))))

(DEFUN print-callers (&optional function)
  "Ï2Print the callers of FUNCTION.  IF FUNCTION is not specified, print the callers for
 all functions that have executed WHO-CALLS-MEÏ*"
  (IF function 
      (print-histogram (GET function 'callers) :print-translate #'FUNCTION-NAME)
    (DOLIST (f *who-callers*)
      (WHEN f
	(FORMAT t "~2%~s" f)
	(print-callers f))))
  (VALUES))

(DEFUN KEYBOARD-INSERT (INSERT-STRING)
  "Ï2Return a function which, when called, will put that string into the keyboard buffer.Ï*"
  (LET ((STRING INSERT-STRING))
    #'(LAMBDA (&REST IGNORE)
        (WHEN TV:SELECTED-WINDOW
          (SEND TV:SELECTED-WINDOW :FORCE-KBD-INPUT STRING))
        NIL)))

(defun base (&rest numbers)
  "Ï2Print NUMBERS in bases 8 10 and 1×6.  With no arguments, print the current BASE and IBASE.Ï*"
  (if (not numbers)
      (format t "~&*read-base* ~d  *print-base* ~d" *read-base* *print-base*)
      (when (consp (car numbers))
	 (setq numbers (car numbers)))
      (dolist (n numbers)
	(let ((*print-base* 16.))		  ;Symbolics doesn't have ~x
	  (format t "~&#o~o ~d #x~a" n n n)))))

(DEFUN set-process (&rest options &aux (process si:current-process) quantum priority report)
  "Ï2Set process quantum and/or priority.
:process is a process or the name of one.  It defaults to the current process.
:quantum qq  Sets the process quantum to qq
:priority nn  Sets the priority to pp
:background sets low quantum and priority.
:foreground sets normal quantum and priority.
:report prints the process name priority and quantum.Ï*"
  (DECLARE (ARGLIST &key (process si:current-process) quantum priority &flag background foreground report))
  (unless (keywordp (first options))
    (setq process (or (pop options) si:current-process)))
  (KEYWORD-EXTRACT options var (process quantum priority) (report)
    (:background (SETQ quantum 20. priority -15.))
    (:foreground (SETQ quantum 60. priority 0.)))
  (UNLESS (TYPEP process 'si:process)
    (LOOP for (p) in si:active-processes
	  when (SEARCH (THE STRING (STRING process)) (THE LIST (si:process-name p)))
	  do (RETURN (SETQ process p))
	  finally (FERROR "~s isn't a process or the name of one" process)))
  (WHEN quantum (SEND process :set-quantum quantum))
  (WHEN priority (SEND process :set-priority priority))
  (WHEN report (FORMAT t "~%~a  Priority: ~d, Quantum: ~d"
		       (SEND process :name) (SEND process :priority) (SEND process :quantum)))
  process)

(DEFUN describe-opt ()
  "Ï2Describe compiler optimizationsÏ*"
  (describe-defstruct compiler::optimize-switch 'compiler::optimize-switches))

(DEFUN area (object)
  "Ï1Get the area name for an objectÏ*"
  (LET ((name (si:%AREA-NUMBER object)))
    (IF name (AREA-NAME name))))

(DEFUN region (object)
  "Ï2Describe the regionÏ1 for an objectÏ*Ï*"
  (LET ((name (si:%region-NUMBER object)))
    (IF name (si:describe-region name))
    name))

(DEFUN UNROLL (LST)
  "Ï1Return LST with 'all parens' removed, i. e., completely flattened.Ï*"
  (COND ((NULL LST) NIL)
        ((ATOM LST) (LIST LST))
        (T (APPEND (UNROLL (CAR LST)) (UNROLL (CDR LST))))))

(DEFUN compare (a b &optional &special silentp)
  "Ï1Print the differences between A and BÏ*"
  (LABELS ((compare-internal (n a b)
			     (SETQ a (IF (LOCATION-BOUNDP a) (CAR a) 'unbound))
			     (SETQ b (IF (LOCATION-BOUNDP b) (CAR b) 'unbound))
			     (compare-internal-value n a b))
	   
	   (compare-internal-value (n a b)
				   (DECLARE (SPECIAL silentp))
				   (UNLESS (OR (EQUAL a b) (compare a b t))
				     (IF silentp (THROW 'NEQ nil)
				       (FORMAT t "~%~a:~20t ~s~%~20t ~s" n a b)))))
    
    (CATCH 'NEQ
      (COND ((AND (EQ (TYPE-OF a) (TYPE-OF b)))
	     (COND ((EQ (DATA-TYPE a) 'dtp-instance)
		    (LOOP with fl = (TYPE-OF a)
			  for name in (si:flavor-all-instance-variables fl)
			  for i from 1 below (si:flavor-instance-size fl)
			  DO (compare-internal name (si:%instance-loc a i) (si:%instance-loc b i))))
		   ((TYPEP a 'array)
		    (WHEN (ARRAY-HAS-LEADER-P a)
		      (LOOP for i from 0 below (ARRAY-LEADER-LENGTH a)
			    DO (compare-internal (LIST :leader i) (AP-LEADER a i) (AP-LEADER b i))))
		    (CASE (array-rank a)
			  (1 (LOOP for i from 0 below (ARRAY-ACTIVE-LENGTH a)
				   DO (compare-internal-value i (AREF a i) (AREF b i))))
			  (2 (LOOP for i from 0 below (ARRAY-DIMENSION a 0)
				   DO (LOOP for j from 0 below (ARRAY-DIMENSION a 1)
					    DO (compare-internal-value
						 (LIST i j) (AREF a i j) (AREF b i j)))))
			  (3 (LOOP for i from 0 below (ARRAY-DIMENSION a 0)
				   DO (LOOP for j from 0 below (ARRAY-DIMENSION a 1)
					    DO (LOOP for k from 0 below (ARRAY-DIMENSION a 2)
						     DO (compare-internal-value
							  (LIST i j k) (AREF a i j k) (AREF b i j k))))))
			  (otherwise (FORMAT t "can't compare arrays of rank greater than 3"))))
		   ((LISTP a)
		    (LOOP for i on a
			  for j on b
			  for n upfrom 0
			  DO (compare-internal-value n (CAR i) (CAR j))
			  (UNLESS (AND (CONSP (CDR i)) (CONSP (CDR j)))
			    (RETURN (compare-internal-value (1+ n) (CDR i) (CDR j))))))		 
		   (t (UNLESS (EQUAL a b)
			(IF silentp (THROW 'NEQ nil)
			  (FORMAT t "~%~s NEQ ~s" a b) t))))
	     t)
	    (t (UNLESS silentp (FORMAT t "~%Items not the same type")))))))
			   

(defmacro save-symbol (symbol file-name)
  `(dump-forms-to-file ,FILE-NAME '((setq ,symbol ',(SYMBOL-VALUE symbol)))))


(DEFUN universal-string (x)
  "Convert X to a string.Ï2  Like STRING, execpt this always works.Ï*"
  (TYPECASE X
    (STRING X)
    (SYMBOL (SYMBOL-NAME X))
    ;; this kludginess is due to the fact that (typep x 'string-char) loses on fixnums
    ;; and that string-char-p blows out on non-character non-fixnums
    ((AND (OR FIXNUM CHARACTER)
	  (SATISFIES STRING-CHAR-P))
     (VALUES (MAKE-ARRAY 1 ':TYPE 'ART-STRING ':INITIAL-VALUE X)))
    (INSTANCE
     (SEND X ':SEND-IF-HANDLES ':STRING-FOR-PRINTING))
    (T (FORMAT nil "~a" x))))

(DEFUN c (char)
  "Ï1Return a character name given a numberÏ*"
  (IF (ATOM char)
      (FORMAT nil "~:c" char)
    (LOOP for c in char collecting (c c))))

; Ï1This is useful for printing debug variablesÏ*
(export 'ticl:pv 'ticl)
(DEFMACRO pv (&rest variables)
  "Ï2Print VARIABLES to DEBUG-IO.Ï*"
  `(format *debug-io* "~%;;~@{~<~%;;~1:; ~@[~a~] ~s~>~^,~2,10t~}."
	   ,@(loop for variable in variables nconc
		   `(',(UNLESS (CONSTANTP variable) variable) ,variable))))

(DEFSUBST e (&rest parms)
  "Ï1Handy debugging function to get into the error handler printing parmsÏ*"
  (fsignal "User forced error~{~%~s~}" parms))

(defun mouse-string (string &rest args)
  "Format STRING with ARGS in the mouse documentation line."
  (tv:PROCESS-WHO-LINE-DOCUMENTATION-LIST
    tv:who-line-screen `(:documentation ,(if args (apply #'format nil string args) string))))

(defun pause (&optional string &rest vars &aux (stream *query-io*) c)
  "Ï1Pause displaying format string with Ï*\"Ï1Hit any key to continueÏ*\"Ï1 appendedÏ*"
  (multiple-value-bind (cx cy) (send stream ':read-cursorpos)
    (send stream ':home-cursor)
    (send stream ':clear-eol)
    (setq string (format nil "~@[~a~%~]Hit any key to continue:" string))
    (APPLY #'format stream string vars)
    (setq c (READ-CHAR stream))
    (send stream ':set-cursorpos cx cy))
  c)

(DEFMACRO value-or-nil (variable)
  "Ï2Returns VARIABLE if its bound, else NIL.Ï*"
  (CHECK-TYPE variable :symbol)
  `(AND (variable-boundp ,variable) ,variable))

(defmacro accept (value &optional string &rest vars)
  "Ï2Set VALUE to a value read from the user.  Displays prompt STRING at the top of the window.Ï*"
  (if string
      `(setq ,value (acceptf (value-or-nil ,value) ,string . ,vars))
    `(setq ,value (acceptf (value-or-nil ,value) ,(format nil "Enter new ~a:" value)))))

(defun acceptf (default &optional string &rest vars &aux (stream *query-io*) result)
  "Ï1Read a value & return it.  Displays prompt string at top of windowÏ*"
  (multiple-value-bind (cx cy) (send stream ':read-cursorpos)
    (send stream ':home-cursor)
    (send stream ':clear-eol)
    (setq string (format nil "~:[Enter value:~*~;~a~] (default ~s) " string string default))
    (UNWIND-PROTECT
	(setq result
	      (SEND stream ':rubout-handler
		    `((:prompt ,(APPLY #'format nil string vars)))
		    #'(lambda (stream default)
			(LET ((ch (SEND stream ':tyi)))
			  (SEND stream ':untyi ch)
			  (IF (EQL ch #\return)
			      default
			    (READ-FOR-TOP-LEVEL stream ""))))
		    stream default))
      (send stream ':home-cursor)
      (send stream ':clear-eol)
      (send stream ':set-cursorpos cx cy)))
  result)

(DEFUN string-trim-all (char-set STRING)
  "Ï1Remove all characters in CHAR-SET from STRINGÏ*"
  (DO ((i 0 (1+ i))
       (j 0)
       (l (LENGTH STRING))
       (new-string (STRING-APPEND STRING))
       ch)
      ((>= i l) (ADJUST-ARRAY new-string j))
    (WHEN (NOT (MEMBER (SETQ CH (AREF STRING I)) CHAR-SET :TEST #'EQ))
      (SETF (AREF NEW-STRING J) CH)  
      (INCF j))))

(export 'ticl:show 'ticl)
(defun show (what &optional stream)
  "Ï2Print WHAT with *print-array* bound to TÏ*"
  (LET ((*print-array* t))
    (print what stream)))

(DEFUN print-array (ARRAY &optional (stream *standard-output*))
  (LET ((rank #+3600(ARRAY-#-DIMS array) #-3600(array-rank array))
	(nchar 0)
	(length 0)
	(line-length (SEND stream ':size-in-characters)))
    (COND ((= rank 1)
	   (LOOP for element being the array-elements of ARRAY
		 for len = (LENGTH (FORMAT nil "~a  " element))
		 do
		 (setq nchar (max nchar len))
		 (INCF LENGTH len))
	   (COND ((< LENGTH line-length)
		  (SEND stream ':fresh-line)
		  (LOOP for element being the array-elements of ARRAY using (index i) doing
			(FORMAT STREAM "~a, "element)))
		 (t (LOOP with num-ele-per-line = (/ (- line-length 6) nchar) AND n = 999
			  for element being the array-elements of ARRAY using (index i) doing
			  (WHEN (> n num-ele-per-line)
			    (FORMAT STREAM "~&~4d: " i)
			    (SETQ n 1))
			  (FORMAT STREAM "~va"nchar element)
			  (INCF n)))))
	  ((= rank 2)
	   (LOOP for row from 0 below (ARRAY-DIMENSION array 0) doing	Ï1   Ï*;Ï1loop over rowsÏ*
		 (FORMAT STREAM "~%Row ~4d:  " row)
		 (LOOP for column from 0 below (ARRAY-DIMENSION array 1) doing	;Ï1loop over columnsÏ*
		       (FORMAT STREAM " ~a" (AREF ARRAY row column)))))		 
	  (t (FORMAT STREAM "PRINT-ARRAY doesn't handle arrays of rank ~a" rank)))))

