;;; -*- 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 ;;; ----------------------------------------------------------------------------------------- ;;; 03/20/89 WJB Do not initialize the server and create at build time; wait until selected. ;;; 03/29/89 WJB Patch 1.60; Change CREATE-INITIAL-SCREEN-CONFIGURATION to call initialize-screen-sizes. ;;; 03/02/89 WJB Patch 1.28; save the default root background pixmap in a special var so that ;;; change-window-attributes can restore it upon request. ;;; 01/04/89 LGO On reset, if font path is the default, don't zap the font-directory-cache. ;;; 10/27/88 DLS Remove references to the keyboard process, which is not needed anymore ;;; 10/21/88 WJB 1Make INITIALIZE-PROCESSES the last thing done in INITIALIZE-MONOCHROME-SERVER. * ;;; 9/12/88 LGO Initialize *installed-colormaps* in CREATE-INITIAL-SCREEN-CONFIGURATION ;;; 19*/107*/88 1LGO* 1Define a default root border-pixmap and define the correct background pixmap* ;;; 7/27/88 DAN Added initialization of FRAME-BUFFER-DESCRIPTOR.INV-GCONTEXT to ;;; CREATE-INITIAL-SCREEN-CONFIGURATION. ;;; 4/12/88 DAN Moved call to CREATE-INITIAL-SCREEN-CONFIGURATION inside ;;; INITIALIZE-MONOCHROME-SERVER. Inserted call to ;;; INITIALIZE-MONOCHROME-SERVER so it gets done by default. ;;; 4/12/88 TWE Put a call to SETUP-PREDEFINED-ATOMS in INITIALIZE-MONOCHROME-SERVER. ;;; 3/28/88 TWE Fixed up the initialization code. ;;; 3/25/88 TWE Initial creation. (defun RESET (&optional enable reset-trace-buffer) "2Reset and initialize the X11 server. This may unwedge if it is not working properly. Causes all open connections to loose. Leaves X11 disabled unless the the first parameter is non-nil.*" (kill-x) (when reset-trace-buffer (trace-buffer)) (when enable (initialize-monochrome-server)) (values)) (DEFUN KILL-X () "Kill off all X windows and X processes. Use this when you want to start off with a fresh new server." (flet ((substring-equal (a b) (string-equal a b :end1 (length b)))) (LOOP FOR PROCESS IN SI:ALL-PROCESSES DO (WHEN (MEMBER (SEND PROCESS :NAME) '("X Server" "X Dispatcher" "X Mouse") :TEST #'substring-equal) (SEND PROCESS :KILL))) (LOOP FOR WINDOW IN (FUNCALL TV:MAIN-SCREEN :INFERIORS) DO (WHEN (substring-equal (FUNCALL WINDOW :NAME) "X SERVER") (FUNCALL WINDOW :KILL))) ;; To make sure we really kill it off, we need to do this twice. (LOOP FOR PROCESS IN SI:ALL-PROCESSES DO (WHEN (MEMBER (string (SEND PROCESS :NAME)) '("X Server" "X Dispatcher" "X Mouse") :TEST #'substring-equal) (SEND PROCESS :KILL)))) (setq dispatcher-process nil mouse-process nil) ;; Don't try to close a connection when we have killed off the server. (when (and (find-package "XLIB") ;1; 2What a hack! What's this supposed to be doing, anyway? - LGO** (find-symbol "EXPLORER-SERVER" "XLIB")) (setf (symbol-value (find-symbol "EXPLORER-SERVER" "XLIB")) nil))) (DEFUN INITIALIZE-PROCESSES () (INITIALIZE-MOUSE-PROCESS) (INITIALIZE-DISPATCHER-PROCESS)) (DEFUN INITIALIZE-MONOCHROME-SERVER (&OPTIONAL &REST ARGS) "Top-level initialization function for the monochrome server." (CREATE-INITIAL-SCREEN-CONFIGURATION) ;; Reset the search path for fonts back to what it is initially. (unless (equal *font-default-search-path* *font-initial-search-path*) (set-server-font-paths *font-initial-search-path*)) (INITIALIZE-EXPLORER-CURSOR) (INITIALIZE-MONOCHROME-SERVER-DEVICES ARGS) (SETUP-PREDEFINED-ATOMS) (INITIALIZE-PROCESSES) (SERVER-RESET)) (DEFUN CREATE-INITIAL-SCREEN-CONFIGURATION () "Create the initial root and screen objects, and setup the other related data structures." (SETQ *GLOBALS* (X11:MAKE-GLOBAL-STATE)) (SETQ SCREEN-INFO (MAKE-SCREEN-INFO :NUM-SCREENS *MAX-SCREENS*)) (SETQ FRAME-BUFFER-DESCRIPTORS (MAKE-ARRAY *MAX-SCREENS* :ELEMENT-TYPE 'FRAME-BUFFER-DESCRIPTOR)) (setq *installed-colormaps* nil) (INITIALIZE-SCREEN-SIZES) (LOOP WITH SCREEN-ROOT-INSTANCE = NIL WITH WINDOW-ROOT-INSTANCE = NIL WITH TRAIT-INSTANCE = NIL WITH COLORMAP-OBJECT = NIL WITH SERVER-WINDOW = NIL FOR SCREEN FROM 0 BELOW *MAX-SCREENS* FOR SCREEN-ROOT IN *SCREEN-ROOTS* FOR WINDOW-ROOT IN *WINDOW-ROOTS* FOR COLORMAPS IN *SCREEN-COLORMAPS* FOR WHITE-PIXEL IN *SCREEN-WHITE-PIXELS* FOR BLACK-PIXEL IN *SCREEN-BLACK-PIXELS* FOR INPUT-EVENT IN *SCREEN-INPUT-EVENTS* FOR PIXEL-WIDTH IN *SCREEN-WIDTHS-IN-PIXELS* FOR PIXEL-HEIGHT IN *SCREEN-HEIGHTS-IN-PIXELS* FOR MILLIMETER-WIDTH IN *SCREEN-WIDTHS-IN-MILLIMETERS* FOR MILLIMETER-HEIGHT IN *SCREEN-HEIGHTS-IN-MILLIMETERS* FOR MAX-INSTALLED-MAPS IN *SCREEN-MAX-INSTALLED-MAPS* FOR MIN-INSTALLED-MAPS IN *SCREEN-MIN-INSTALLED-MAPS* FOR ROOT-VISUAL IN *SCREEN-ROOT-VISUALS* FOR BACKING-STORES IN *SCREEN-BACKING-STORES* FOR SAVE-UNDERS IN *SCREEN-SAVE-UNDERS* FOR ROOT-DEPTH IN *SCREEN-ROOT-DEPTHS* FOR SCREEN-ALLOWED-DEPTH IN *SCREEN-ALLOWED-DEPTHS* FOR ALLOWED-DEPTH = (NTH 0 SCREEN-ALLOWED-DEPTH) FOR VISUAL-TYPE-COUNT = (NTH 1 SCREEN-ALLOWED-DEPTH) FOR VISUAL-TYPES = (NTH 2 SCREEN-ALLOWED-DEPTH) DO (PROGN ;; The root is a window, which has a visual, which points to a screen. (SETQ TRAIT-INSTANCE (MAKE-DRAWABLE-TRAIT :DEPTH ROOT-DEPTH :VISUALS *SCREEN-ROOT-VISUALS* ;; We set this up later (look down a few lines). :SCREEN NIL)) (SETQ SCREEN-ROOT-INSTANCE (MAKE-SCREEN :MY-NUMBER SCREEN :ID SCREEN-ROOT :DEF-COLORMAP COLORMAPS :WHITE-PIXEL WHITE-PIXEL :BLACK-PIXEL BLACK-PIXEL :WIDTH PIXEL-WIDTH :HEIGHT PIXEL-HEIGHT :MM-WIDTH MILLIMETER-WIDTH :MM-HEIGHT MILLIMETER-HEIGHT :MIN-INSTALLED-CMAPS MAX-INSTALLED-MAPS :MAX-INSTALLED-CMAPS MIN-INSTALLED-MAPS :ROOT-VISUAL ROOT-VISUAL :BACKING-STORE-SUPPORT BACKING-STORES :SAVE-UNDER-SUPPORT SAVE-UNDERS :TRAITS (MAKE-ARRAY 1 :INITIAL-ELEMENT TRAIT-INSTANCE) :ROOT-DEPTH ROOT-DEPTH :ALLOWED-DEPTHS (LENGTH *SCREEN-ALLOWED-DEPTHS*) :NUM-DEPTHS (LENGTH *SCREEN-ALLOWED-DEPTHS*) :RGF 0 :GC-PER-DEPTH NIL :DEV-PRIVATE (PROGN (SETQ SERVER-WINDOW (FIND-FREE-X-SERVER-WINDOW)) (WHEN (NULL SERVER-WINDOW) (SETQ SERVER-WINDOW (MAKE-SERVER-WINDOW))) SERVER-WINDOW) :NUM-VISUALS VISUAL-TYPE-COUNT :VISUALS NIL)) (PUSH-END SCREEN-ROOT-INSTANCE (SCREEN-INFO.SCREENS SCREEN-INFO)) (SETF (DRAWABLE-TRAIT.SCREEN TRAIT-INSTANCE) SCREEN-ROOT-INSTANCE) (SETQ WINDOW-ROOT-INSTANCE (MAKE-WINDOW :ID WINDOW-ROOT :TYPE DRAW-WINDOW-RESOURCE-TYPE ;; For the moment, I assume that a trait is a list of ;; DRAWABLE-TRAITs. There is one1 *DRAWABLE-TRAIT for each depth ;; which is known about. Someday1 *(?) the real meaning of this ;; will be known. (TWE) :TRAIT TRAIT-INSTANCE :VISUAL ROOT-VISUAL :CLASS INPUT-OUTPUT :PARENT NIL :EVENT-MASKS NIL :ABSOLUTE-X-CORNER 0 :ABSOLUTE-Y-CORNER 0 :X 0 :Y 0 :WIDTH PIXEL-WIDTH :HEIGHT PIXEL-HEIGHT :BWIDTH 0 :CLIENT NIL :MAPPED-P T :REALIZED-P T ;; The root is fully visible. :OCCLUSION-STACK T)) (SETQ ROOT-BACKGROUND-PIXMAP (MAKE-PIXMAP :WIDTH 32 :HEIGHT 4 :TRAIT TRAIT-INSTANCE :CLIP-MASK NIL :ARRAY ROOT-BACKGROUND-PIXMAP-ARRAY :TYPE PIXMAP-RESOURCE-TYPE)) (SETF (WINDOW-BACKGROUND WINDOW-ROOT-INSTANCE) ROOT-BACKGROUND-PIXMAP) (SETF (window-border WINDOW-ROOT-INSTANCE) (MAKE-PIXMAP :WIDTH 1 :HEIGHT 1 :TRAIT TRAIT-INSTANCE :CLIP-MASK NIL :ARRAY (CREATE-PIXMAP-ARRAY 1 1 ROOT-DEPTH 0) :TYPE PIXMAP-RESOURCE-TYPE)) ;1; Start the root window out so that it only displays its background.* (X-BITBLT GX-COPY PIXEL-WIDTH PIXEL-HEIGHT (PIXMAP.ARRAY (WINDOW-BACKGROUND WINDOW-ROOT-INSTANCE)) 0 0 (DEVICE-PRIVATE-DRAWABLE SERVER-WINDOW) 0 0) (PUSH-END WINDOW-ROOT-INSTANCE (SCREEN-INFO.WINDOWS SCREEN-INFO)) ;; Set up the frame buffer descriptor for this screen (SETF (AREF FRAME-BUFFER-DESCRIPTORS SCREEN) (MAKE-FRAME-BUFFER-DESCRIPTOR ;; Need a scratch GC for cursor ;; operations. :GCONTEXT (CREATE-DEFAULT-GC 0 (SCREEN.DEV-PRIVATE SCREEN-ROOT-INSTANCE) WINDOW-ROOT-INSTANCE) :INV-GCONTEXT (CREATE-DEFAULT-GC 0 (SCREEN.DEV-PRIVATE SCREEN-ROOT-INSTANCE) WINDOW-ROOT-INSTANCE) :MAPPED T :PARENT T)) ;; Check to see if we have already done this initialization. (WHEN (NOT (TYPEP (CAR VISUAL-TYPES) 'VISUAL)) (IF (NULL VISUAL-TYPES) (SETQ VISUAL-TYPES (LIST (MAKE-VISUAL :VID ROOT-VISUAL :SCREEN SCREEN-ROOT :CLASS 0 :RED-MASK 1 :GREEN-MASK 1 :BLUE-MASK 1 :OFFSET-RED 0 :OFFSET-GREEN 0 :OFFSET-BLUE 0 :BITS-PER-RGB-VALUE 1 :COLORMAP-ENTRIES NIL))) ;;1ELSE* (SETQ VISUAL-TYPES (LOOP FOR (VISUAL-ID CLASS BITS-PER-RGB COLORMAP-ENTRIES RED-MASK GREEN-MASK BLUE-MASK) IN VISUAL-TYPES ;; The first visual is associated with the root, while ;; the other associations are left intact. FOR REAL-VISUAL-ID FIRST ROOT-VISUAL THEN VISUAL-ID FOR REAL-COLORMAP-ENTRIES FIRST NIL THEN COLORMAP-ENTRIES COLLECT (MAKE-VISUAL :VID REAL-VISUAL-ID :SCREEN SCREEN-ROOT :CLASS CLASS :RED-MASK RED-MASK :GREEN-MASK GREEN-MASK :BLUE-MASK BLUE-MASK ;; I don't know what these are ;; supposed to be yet. ;; Presumably they are the ;; offsets into the colormap, but ;; I'll set them to 0 for now. :OFFSET-RED 0 :OFFSET-GREEN 0 :OFFSET-BLUE 0 :BITS-PER-RGB-VALUE BITS-PER-RGB :COLORMAP-ENTRIES REAL-COLORMAP-ENTRIES)))) (SETF (NTH 2 SCREEN-ALLOWED-DEPTH) VISUAL-TYPES)) (SETQ COLORMAP-OBJECT (SIMPLY-CREATE-COLORMAP COLORMAPS WINDOW-ROOT-INSTANCE (FIRST VISUAL-TYPES))) (push colormap-object *installed-colormaps*) (SETF (WINDOW.COLORMAP WINDOW-ROOT-INSTANCE) COLORMAP-OBJECT) (SETF (VISUAL.COLORMAP-ENTRIES (FIRST VISUAL-TYPES)) (COLORMAP.ENTRIES COLORMAP-OBJECT))))) ;; This is now done during system key processing. ;;(INITIALIZE-MONOCHROME-SERVER)