;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-

;;; Reason: Change to tv:show-font-map. Used a macro before defined in build.

;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 12/22/89 12:54:19 by MARKY,
;;; while running on LIBRA from band LODB
;;; With SYSTEM 6.23, VIRTUAL-MEMORY 6.2, EH 6.5, MAKE-SYSTEM 6.2, MICRONET 6.0, LOCAL-FILE 6.1,
;;;  BASIC-PATHNAME 6.2, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.6, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.1, DISK-LABEL 6.0, BASIC-FILE 6.6, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.14, TV 6.19, DATALINK 6.0, CHAOSNET 6.5, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.2,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.8,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.2, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.3, MAIL-READER 6.6, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.4, PROFILE 6.2, VISIDOC 6.5, TI-CLOS 6.26, CLEH 6.5, IP 3.56,
;;;  Experimental CLX 6.7, CLUE 6.41, X11M 6.16, Experimental BUG 11.17, MMON 6.2,
;;;  Experimental SC 2.0, Experimental CLIO 12.0, Experimental CONFORMANCE-CHECKER 2.0,
;;;   microcode 429, Band Name: REL6-mmon-11/15/89

;;; Was using zwei:current-font macro that is not loaded during build until after this is compiled

#!C
; From file SHEET.LISP#> WINDOW; Hotel:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; SHEET.#"


(DEFUN show-font-map (&optional (window *terminal-io*))
  "Show contents and other info for the font-map of sheet or screen WINDOW."
  (LET* ((font-map (SEND window :font-map))
	 (current-font-descriptor (FONT-MAP-CURRENT-FONT-NAME font-map))
	 (current-font-name (IF (NUMBERP current-font-descriptor)
				(aref font-map (FONT-MAP-CURRENT-FONT-NAME font-map))
				(font-evaluate current-font-descriptor))))
    (FORMAT t "~% Fill pointer       = ~2d." (array-leader font-map 0) )
    (FORMAT t "~% Font-map-font-list = ~s"   (array-leader font-map 1) )
    ;; describe current purpose fonts - if any
    (DOLIST (purpose (ARRAY-LEADER font-map 1))
      (WHEN (KEYWORDP purpose) (FORMAT t "~%~8@t Purpose ~s is currently ~s for w:default-screen"
				       Purpose
				       (tv:get-standard-font Purpose w:default-screen))))
    ;; Current-font is usually an index into font map. *ONLY*? is a symbol if
    ;; :set-current-font is passed in a T to OK-IF-NOT-IN-FONT-MAP arg. I don't think
    ;; this ever happens ?
    (IF (NUMBERP current-font-descriptor)
	(FORMAT t "~% Current-font :  Index  = ~2d.  Font = ~s" current-font-descriptor current-font-name)
	(FORMAT t "~% Current-font :  Font not in map = ~s" current-font-name))
    (dotimes (i (array-leader font-map 0))
      (FORMAT t "~%~2d : ~s" i (AREF font-map i)))))
))

#!C
; From file DEBUG.LISP#> WINDOW; Hotel:
#10R TV#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "TV"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; DEBUG.#"


;; may 12/22/89 Added indenting try: (do-operation-on-all-inferiors w:default-screen :name)
(DEFUN do-operation-on-all-inferiors (sheet operation &optional (indent 1))
  (declare (arglist sheet operation)) ;; hide indent from user
  (ASSERT sheet (sheet) "SHEET should not be NIL.")
  (format t "~%~@Vt ~s ~s" indent sheet (SEND sheet operation))
  (DOLIST (inf (SEND sheet :inferiors))
    (do-operation-on-all-inferiors inf operation (+ 2 indent))))
))