265 lines
9.6 KiB
Common Lisp
265 lines
9.6 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pwindows.s
|
||
|
||
; Last Revision: 10-Oct-85 1500ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985 (c) Texas Instruments ;
|
||
; ;
|
||
; John Jensen ;
|
||
; ;
|
||
; Window Manipulation Routines ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
|
||
;;; MAKE-WINDOW returns a "default" window object with the following
|
||
;;; attributes:
|
||
;;;
|
||
;;; Upper Left Hand Corner = 0,0
|
||
;;; Size (Lines, Columns) = 25,80 or 30,80 (the entire screen)
|
||
;;; Cursor Position = 0,0
|
||
;;; Text Color = White (on IBM, high intensity white)
|
||
;;; Border Color (if bordered) = Green (on IBM, low intensity green)
|
||
;;; Transcript Recording = Enabled
|
||
|
||
(define make-window ; MAKE-WINDOW
|
||
(lambda args
|
||
(let ((label (car args))
|
||
(bordered? (cadr args)))
|
||
(if (or (null? label) (string? label))
|
||
(let ((window (%make-window label)))
|
||
(when bordered?
|
||
(%reify-port! window 6 (if (eqv? pcs-machine-type 1)
|
||
#b00001100 ; TIPC green
|
||
#b00001010))) ; IBM green
|
||
window)
|
||
(begin
|
||
(%error-invalid-operand 'MAKE-WINDOW label)
|
||
'())))))
|
||
|
||
|
||
;;; WINDOW-CLEAR erases the data portion of a window (writes blanks using
|
||
;;; the current text attributes) and positions the cursor in position
|
||
;;; 0,0 (the upper left hand corner of the window). If the window is
|
||
;;; bordered, the border is re-drawn by this operation. This operation
|
||
;;; more properly may be considered a "window-initialize" operation.
|
||
|
||
(define WINDOW-CLEAR ; WINDOW-CLEAR
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(%clear-window window)
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-CLEAR window)
|
||
'()))))
|
||
|
||
|
||
;;; The "delete-window" function completely erases the area of the CRT which
|
||
;;; is covered by a given window, including the borders. This function
|
||
;;; accomplishes the erasing of the borders by expanding the dimensions
|
||
;;; of the window (temporarily) so that the borders are included in the
|
||
;;; data portion of the window; setting the border attribute to "no
|
||
;;; border"; and issuing a "%clear-window" operation to clear the text
|
||
;;; portion of the (temporarily) expanded window. After clearing the
|
||
;;; window and border, the original attributes of the window are
|
||
;;; restored.
|
||
;;;
|
||
;;; Note: when expanding the size of the window to account for the
|
||
;;; right and bottom borders, this routine takes advantage of the fact
|
||
;;; that %reify-port will not allow a window's boundaries to be set
|
||
;;; to be larger than the physical device size. Therefore, no check
|
||
;;; is performed to see if the right and bottom borders are off the
|
||
;;; screen.
|
||
|
||
(define WINDOW-DELETE ; DELETE-WINDOW
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(if (eqv? (%reify-port window 6) -1)
|
||
(%clear-window window) ; if not bordered, just do a %clear-window
|
||
(let ((ul-line (%reify-port window 2)) ; save current attributes
|
||
(ul-col (%reify-port window 3)) ; for later restoration
|
||
(n-lines (%reify-port window 4))
|
||
(n-cols (%reify-port window 5))
|
||
(b-attrib (%reify-port window 6))
|
||
(t-lines '())
|
||
(t-cols '()))
|
||
(begin
|
||
(when (> ul-line 0)
|
||
(begin ; increase window size to include top border
|
||
(%reify-port! window 2 (-1+ ul-line))
|
||
(%reify-port! window 4 (1+ n-lines))))
|
||
(when (> ul-col 0)
|
||
(begin ; increase window size to include left border
|
||
(%reify-port! window 3 (-1+ ul-col))
|
||
(%reify-port! window 5 (1+ n-cols))))
|
||
(set! t-lines (%reify-port window 4)) ; get new window size
|
||
(set! t-cols (%reify-port window 5))
|
||
(%reify-port! window 4 (1+ t-lines)) ; include bottom border
|
||
(%reify-port! window 5 (1+ t-cols)) ; include right border
|
||
(%reify-port! window 6 -1) ; indicate no border
|
||
(%clear-window window)
|
||
(%reify-port! window 2 ul-line) ; restore the original
|
||
(%reify-port! window 3 ul-col) ; attributes to the user's
|
||
(%reify-port! window 4 n-lines) ; window
|
||
(%reify-port! window 5 n-cols)
|
||
(%reify-port! window 6 b-attrib))))
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-DELETE window)
|
||
'()))))
|
||
|
||
|
||
;;; WINDOW-GET-POSITION conses the coordinates of the upper left hand
|
||
;;; position of a window into a pair as: (line . column)
|
||
|
||
(define WINDOW-GET-POSITION ; WINDOW-GET-POSITION
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(cons (%reify-port window 2) (%reify-port window 3))
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-GET-POSITION window)
|
||
'()))))
|
||
|
||
|
||
;;; WINDOW-GET-SIZE conses the number of lines and columns in a window
|
||
;;; (excluding the border columns, if any) into a pair as:
|
||
;;; (lines . columns)
|
||
|
||
(define WINDOW-GET-SIZE ; WINDOW-GET-SIZE
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(cons (%reify-port window 4) (%reify-port window 5))
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-GET-SIZE window)
|
||
'()))))
|
||
|
||
|
||
;;; WINDOW-GET-CURSOR conses the line and column number of the current
|
||
;;; cursor position into a pair as: (line . column)
|
||
|
||
(define WINDOW-GET-CURSOR ; WINDOW-GET-CURSOR
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(cons (%reify-port window 0) (%reify-port window 1))
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-GET-CURSOR window)
|
||
'()))))
|
||
|
||
|
||
;;; The following routines modify the position, size, and cursor position
|
||
;;; of a window by side effecting the appropriate fields in a window
|
||
;;; object. An argument value of '() indicates that a particular
|
||
;;; field's value is to remain unchanged.
|
||
|
||
(define WINDOW-SET-POSITION!)
|
||
(define WINDOW-SET-SIZE!)
|
||
(define WINDOW-SET-CURSOR!)
|
||
(letrec ((chk-and-set
|
||
(lambda (window line column instruction-name L C)
|
||
(cond
|
||
((not (or (window? window) (null? window)))
|
||
(error (string-append "Invalid Window Argument to "
|
||
(symbol->string instruction-name))
|
||
window))
|
||
((and line
|
||
(or (not (integer? line))
|
||
(negative? line)))
|
||
(error (string-append "Invalid Line Number to "
|
||
(symbol->string instruction-name))
|
||
line))
|
||
((and column
|
||
(or (not (integer? column))
|
||
(negative? column)))
|
||
(error (string-append "Invalid Column Number to "
|
||
(symbol->string instruction-name))
|
||
column))
|
||
(else
|
||
(when line (%reify-port! window L line))
|
||
(when column (%reify-port! window C column))
|
||
window)))))
|
||
(set! WINDOW-SET-POSITION! ; WINDOW-SET-POSITION!
|
||
(lambda (window ul-line ul-col)
|
||
(chk-and-set window ul-line ul-col
|
||
'WINDOW-SET-POSITION! 2 3)))
|
||
(set! WINDOW-SET-SIZE! ; WINDOW-SET-SIZE!
|
||
(lambda (window n-lines n-cols)
|
||
(chk-and-set window n-lines n-cols
|
||
'WINDOW-SET-SIZE! 4 5)))
|
||
(set! WINDOW-SET-CURSOR! ; WINDOW-SET-CURSOR!
|
||
(lambda (window cur-line cur-col)
|
||
(chk-and-set window cur-line cur-col
|
||
'WINDOW-SET-CURSOR! 0 1))))
|
||
|
||
|
||
;;; Pop-Up window manipulation.
|
||
;;;
|
||
;;; "WINDOW-POPUP" preserves the data on the screen which will be
|
||
;;; covered by the pop-up window, initializes the window, and
|
||
;;; returns the pop-up window object to the caller.
|
||
;;;
|
||
;;; "WINDOW-POPUP-DELETE" restores the region of the CRT covered by a
|
||
;;; window created "WINDOW-POPUP" to its state prior to the
|
||
;;; pop-up window's appearance.
|
||
|
||
(define WINDOW-POPUP)
|
||
(define WINDOW-POPUP-DELETE)
|
||
(let ((pop-up-list '()))
|
||
(begin
|
||
(set! WINDOW-POPUP ; WINDOW-POPUP
|
||
(lambda (window)
|
||
(if (or (window? window) (null? window))
|
||
(begin
|
||
(set! pop-up-list
|
||
(cons (cons window (window-save-contents window)) pop-up-list))
|
||
(window-delete window)
|
||
(%clear-window window)
|
||
window)
|
||
(begin
|
||
(%error-invalid-operand 'WINDOW-POPUP window)
|
||
'()))))
|
||
(set! WINDOW-POPUP-DELETE ; WINDOW-POPUP-DELETE
|
||
(lambda (window)
|
||
(let ((saved-data (assq window pop-up-list)))
|
||
(when (not (null? saved-data))
|
||
(window-restore-contents window (cdr saved-data))
|
||
(set! pop-up-list (delq! saved-data pop-up-list))
|
||
window)))) ))
|
||
|
||
|
||
;;; The following routines get and set window attributes which are not
|
||
;;; modifiable by any of the above routines. It is necessary to explicitly
|
||
;;; name the attribute you wish to examine/modify.
|
||
|
||
(define WINDOW-GET-ATTRIBUTE)
|
||
(define WINDOW-SET-ATTRIBUTE!)
|
||
(letrec ((attr-list '((border-attributes . 6)
|
||
(text-attributes . 7)
|
||
(window-flags . 8)))
|
||
(check-and-map-args
|
||
(lambda (window attribute)
|
||
(if (or (window? window) (null? window))
|
||
(cdr (assq attribute attr-list))
|
||
#!FALSE))))
|
||
(set! WINDOW-GET-ATTRIBUTE
|
||
(lambda (window attribute)
|
||
(let ((mapped-attribute (check-and-map-args window attribute)))
|
||
(if mapped-attribute
|
||
(%reify-port window mapped-attribute)
|
||
(begin
|
||
(%error-invalid-operand-list 'WINDOW-GET-ATTRIBUTE
|
||
window attribute)
|
||
'())))))
|
||
(set! WINDOW-SET-ATTRIBUTE!
|
||
(lambda (window attribute value)
|
||
(let ((mapped-attribute (check-and-map-args window attribute)))
|
||
(if (and mapped-attribute
|
||
(integer? value)
|
||
(< value #x3fff)
|
||
(> value #x-3fff))
|
||
(%reify-port! window mapped-attribute value)
|
||
(begin
|
||
(%error-invalid-operand-list 'WINDOW-SET-ATTRIBUTE!
|
||
window attribute value)
|
||
'()))))))
|
||
|