From: Guillermo J. Rozas Date: Thu, 27 Aug 1992 06:30:02 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~9074 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=84fc18bb3fb6f342e68ea025c5e0508c1b1ed4b2;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/bios.scm b/v7/src/edwin/bios.scm new file mode 100644 index 000000000..03bf994be --- /dev/null +++ b/v7/src/edwin/bios.scm @@ -0,0 +1,193 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bios.scm,v 1.1 1992/08/27 06:30:02 jinx Exp $ + +Copyright (c) 1992 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; IBM-PC BIOS Screen Implementation +;;; package: (edwin console-screen) + +(declare (usual-integrations)) + +;;; NOTE: Currently this level knows nothing about BIOS highlights. +;;; It just passes down a boolean flag indicating whether to highlight, +;;; and the microcode sets up the attributes depending on the values +;;; of environment variables EDWIN_FOREGROUND and EDWIN_BACKGROUND. +;;; ** This is wrong ** +;;; The primitives should just get an attribute value, and this +;;; level should take care of mapping the boolean highlight value +;;; to the appropriate attribute. + +(define (make-bios-screen) + ;; What is the baud rate needed for? It's not even meaningful. + (let ((baud-rate (output-port/baud-rate console-output-port)) + (x-size (output-port/x-size console-output-port)) + (y-size (output-port/y-size console-output-port))) + (make-screen (cons (fix:-1+ y-size) (fix:-1+ x-size)) + bios-console-beep + bios-console-clear-line! + bios-console-clear-rectangle! + bios-console-clear-screen! + bios-console-discard! + bios-console-enter! + bios-console-exit! + bios-console-flush! + bios-console-modeline-event! + bios-console-discretionary-flush + bios-console-scroll-lines-down! + bios-console-scroll-lines-up! + bios-console-wrap-update! + bios-console-write-char! + bios-console-write-cursor! + bios-console-write-substring! + (fix:1+ (fix:quotient baud-rate 2400)) + x-size + y-size))) + +(define (bios-available?) + (and (implemented-primitive-procedure? bios:scroll-lines-up!) + (let ((term (get-environment-variable "TERM"))) + (and term + (string-ci=? term "ibm_pc_bios"))))) + +(define bios-display-type) + +(define (bios-initialize-package!) + (set! bios-display-type + (make-display-type 'IBM-PC-BIOS + false + bios-available? + make-bios-screen + (lambda (screen) + screen + (get-console-input-operations)) + with-console-grabbed + with-console-interrupts-enabled + with-console-interrupts-disabled)) + unspecific) + +;;;; Customized IBM-PC BIOS console operations + +(define-primitives + (bios:beep 0) + (bios:clear-line! 3) + (bios:clear-rectangle! 5) + (bios:clear-screen! 0) + (bios:discard! 0) + (bios:enter! 0) + (bios:exit! 0) + (bios:scroll-lines-up! 5) + (bios:scroll-lines-down! 5) + (bios:write-char! 2) + (bios:write-cursor! 2) + (bios:write-substring! 4)) + +(define (bios-console-discard! screen) + screen + (bios:discard!) + unspecific) + +(define (bios-console-enter! screen) + (bios:enter!) + unspecific) + +(define (bios-console-exit! screen) + (bios:exit!) + (bios-move-cursor screen 0 (fix:-1+ (screen-y-size screen)))) + +(define (bios-console-modeline-event! screen window type) + screen window type + unspecific) + +(define (bios-console-wrap-update! screen thunk) + screen + (thunk)) + +(define (bios-console-discretionary-flush screen) + screen + unspecific) + +(define (bios-console-beep screen) + screen + (bios:beep)) + +(define (bios-console-flush! screen) + screen + unspecific) + +(define-integrable (bios-move-cursor screen x y) + (bios:write-cursor! x y)) + +(define (bios-console-write-cursor! screen x y) + (bios-move-cursor screen x y)) + +(define (bios-console-write-char! screen x y char highlight) + (if (not (and (fix:= y (car (screen-state screen))) + (fix:= x (cdr (screen-state screen))))) + (begin + (bios-move-cursor screen x y) + (bios:write-char! char highlight)))) + +(define (bios-console-write-substring! screen x y string start end highlight) + (define (with-delta-and-end delta end) + (if (fix:< start end) + (begin + (bios-move-cursor screen x y) + (bios:write-substring! string start end highlight)))) + + (let ((delta (fix:- end start))) + (if (and (fix:= y (car (screen-state screen))) + (fix:= (fix:+ x delta) + (screen-x-size screen))) + (with-delta-and-end (fix:-1+ delta) (fix:-1+ end)) + (with-delta-and-end delta end)))) + +(define (bios-console-clear-line! screen x y first-unused-x) + (bios:clear-line! x y (fix:-1+ first-unused-x)) + (bios-move-cursor screen x y)) + +(define (bios-console-clear-screen! screen) + (bios:clear-screen!) + (bios-move-cursor screen 0 0)) + +(define (bios-console-clear-rectangle! screen xl xu yl yu highlight) + screen + (bios:clear-rectangle! xl xu yl yu highlight)) + +(define (bios-console-scroll-lines-down! screen xl xu yl yu amount) + screen + (bios:scroll-lines-down! xl (fix:-1+ xu) yl (fix:-1+ yu) amount) + 'CLEARED) + +(define (bios-console-scroll-lines-up! screen xl xu yl yu amount) + screen + (bios:scroll-lines-up! xl (fix:-1+ xu) yl (fix:-1+ yu) amount) + 'CLEARED) \ No newline at end of file