;;; -*- Mode: Common-Lisp; Package: PRINTER; Base: 10.; Patch-File: T -*- ;;; Reason: Fix resource deallocation of 'screen-image-bit-array for REMOTE bitmap printing. ;;; 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 05/30/90 12:53:55 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.32, X11M 6.16, Experimental BUG 11.17, MMON 6.2, ;;; microcode 429, Band Name: REL6-mmon-11/15/89 ;;;; Add deallocation of 'screen-image-bit-array resource when errors or REMOTE printing occurs. ;;;; NOTE: adding resource to si:*resources-without-memory* will take care of deallocation ;;;; problems, but the code is fixed below for completeness. ;; may 06/11/90 ;(progn ; (without-interrupts ; (let ((name 'printer::screen-image-bit-array)) ; (pushnew name si:*resources-without-memory*) ; (progn ;; taken from si:clear-resources-without-memory ; (setf (get name 'si:no-memory) t) ; (when (si:get-resource-structure name) ; (si:clear-resource name nil nil))) ; ))) #!C ; From file REQUESTS.LISP#> PRINTER; Hotel: #10R PRINTER#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "PRINTER")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: PRINTER; REQUESTS.#" (DEFMETHOD (ARRAY-PRINT-REQUEST :HANDLE-REMOTE-REQUEST) (PRINTER-HOST) "Printer is on a remote host. Copy the screen image into a temporary file and send its file request to the print server for remote printer." (COND ((NOT *ALLOW-SENDING-OF-REMOTE-PRINT-REQUESTS*) (deallocate-resource 'screen-image-bit-array bitmap-array) ;; may 05/30/90 (NOTIFY-USER-AT-HOST (FORMAT () "Spooling of ~A to printer ~A on ~A not allowed" SCREEN-NAME (CAR PRINT-DEVICE) (GET PRINT-DEVICE :HOST)) SENDER-HOST)) ((AND (TYPEP BITMAP-ARRAY 'ARRAY) (EQ (ARRAY-TYPE BITMAP-ARRAY) 'ART-1B)) (NOTIFY-USER-AT-HOST (FORMAT () "Spooling ~A print request to printer ~A on ~A" SCREEN-NAME (CAR PRINT-DEVICE) (GET PRINT-DEVICE :HOST)) SENDER-HOST) (unwind-protect ;; may 05/30/90 (LET ((TEMP-FILE (SEND SELF :COPY-ARRAY-INTO-TEMP-FILE)) FILE-REQUEST) (UNLESS (ERRORP TEMP-FILE) (SETQ FILE-REQUEST (MAKE-INSTANCE 'FILE-PRINT-REQUEST :PRINT-DEVICE PRINT-DEVICE :FILE-NAME TEMP-FILE :HEADER-NAME SCREEN-NAME :HEADER HEADER :USER-NAME USER-NAME :SENDER-HOST SENDER-HOST :COPIES COPIES :LINES () :DELETE-AFTER T )) (SEND FILE-REQUEST :SEND-REMOTE-PRINT-FILE-REQUEST PRINTER-HOST))) (deallocate-resource 'screen-image-bit-array bitmap-array))) ;; may 05/30/90 (T (NOTIFY-USER-AT-HOST (FORMAT () "~A not a bit array in print request queue entry: ~A" BITMAP-ARRAY SELF) SENDER-HOST)))) )) #!C ; From file SCREEN-IMAGE.LISP#> PRINTER; Hotel: #10R PRINTER#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "PRINTER")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: PRINTER; SCREEN-IMAGE.#" (DEFUN QUEUE-SCREEN-BITMAP (WINDOW-NAME WIDTH HEIGHT FROM-X FROM-Y BLINKERP PRINTER-NAME PRINTER-DEFAULTS &AUX SAVE-ARRAY) "Enqueue a print request for the specified portion of the screen." ;;ab 9/27/88. Assumes ZAP-SCREEN-AND-WHOLINE has already been called once by our caller so that *FULL-SCREEN-ARRAY* is ;;The right size on entry. (DECLARE (SPECIAL *FULL-SCREEN-ARRAY*)) ;; Create a separate array for this request, clear it, and ;; then save relevant portion of image in it... (SETQ SAVE-ARRAY (ALLOCATE-RESOURCE 'SCREEN-IMAGE-BIT-ARRAY WIDTH HEIGHT)) (BITBLT W::ALU-SETZ (array-dimension SAVE-ARRAY 1) (array-dimension SAVE-ARRAY 0) SAVE-ARRAY 0 0 SAVE-ARRAY 0 0) ;; If no blinkers requested, get the screen-and-who-line again, this time sans blinkers... (WHEN (NOT BLINKERP) ;;Turn blinkers off, suspend interrupts while we... (W:PREPARE-SHEET (W:DEFAULT-SCREEN) ;; Grab the screen without blinkers... (BITBLT-masked W:ALU-SETA (W:SHEET-WIDTH W:DEFAULT-SCREEN) ;; may 06/30/89 (W:SHEET-HEIGHT W:DEFAULT-SCREEN) (W:SHEET-SCREEN-ARRAY W:DEFAULT-SCREEN) 0 0 *FULL-SCREEN-ARRAY* 0 0)) ;; Now get the who-line screen, too... ; (bitblt w:alu-seta ; (w:sheet-width w:who-line-screen) ; (w:sheet-height w:who-line-screen) ; (w:sheet-screen-array w:who-line-screen) 0 0 ; *Full-Screen-Array* 0 (w:sheet-height w:default-screen)) ) ;; Save the requested portion of the screen in the SAVE-ARRAY... (if (typep *full-screen-array* '(array bit)) (BITBLT W:ALU-SETA WIDTH HEIGHT *FULL-SCREEN-ARRAY* FROM-X FROM-Y SAVE-ARRAY 0 0) (progn (bitblt-masked W:ALU-SETA WIDTH HEIGHT *FULL-SCREEN-ARRAY* FROM-X FROM-Y SAVE-ARRAY 0 0 ;; may 06/27/89 (tv:sheet-plane-mask w:default-screen) t) ;; may 06/27/89 (translate-color-array *full-screen-array* save-array (tv:sheet-foreground-color w:default-screen) (tv:sheet-background-color w:default-screen) from-x from-y 0 0 (+ from-x height -1)(+ from-y width -1) ))) ;; If printer options are OK, queue this array-print request... (FS:FORCE-USER-TO-LOGIN) (MULTIPLE-VALUE-BIND (PRINTER-OPTIONS-OK ERROR-MESSAGE) (CHECK-PRINTER-OPTIONS PRINTER-NAME) (COND (PRINTER-OPTIONS-OK (APPLY #'INSERT-ARRAY-IN-QUEUE WINDOW-NAME PRINTER-NAME SAVE-ARRAY WIDTH HEIGHT 0 0 :USER USER-ID PRINTER-DEFAULTS) ) (T (deallocate-resource 'screen-image-bit-array save-array) ;; may 05/30/90 (W::MOUSE-CONFIRM (FORMAT () "Error: ~A" ERROR-MESSAGE) "Click mouse here to confirm."))))) ))