From: Chris Hanson Date: Tue, 23 Jan 2018 02:33:59 +0000 (-0800) Subject: Eliminate long-obsolete starbase support. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~318 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c1165b63a1b6cde9b613e0d8b222aff1520e74a0;p=mit-scheme.git Eliminate long-obsolete starbase support. --- diff --git a/src/runtime/ed-ffi.scm b/src/runtime/ed-ffi.scm index ad7e1ecb9..81a2a3b50 100644 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@ -148,7 +148,6 @@ USA. ("socket" (runtime socket)) ("srfi-1" (runtime srfi-1)) ("stack-sample" (runtime stack-sampler)) - ("starbase" (runtime starbase-graphics)) ("stream" (runtime stream)) ("string" (runtime string)) ("stringio" (runtime string-i/o-port)) diff --git a/src/runtime/make.scm b/src/runtime/make.scm index a7f65ab1f..9b67f97ea 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -552,7 +552,6 @@ USA. ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. - (OPTIONAL (RUNTIME STARBASE-GRAPHICS)) (OPTIONAL (RUNTIME X-GRAPHICS)) ;; Emacs -- last because it installs hooks everywhere which must be initted. (RUNTIME EMACS-INTERFACE) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index cb7b10add..e2ae82dc7 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4315,7 +4315,6 @@ USA. x-graphics/set-mouse-color x-graphics/set-mouse-shape x-graphics/set-window-name - x-graphics/starbase-filename x-graphics/visual-info x-graphics/window-id x-graphics/withdraw-window @@ -4347,15 +4346,6 @@ USA. x-visual-info/visual-id) (initialization (initialize-package!))) -(define-package (runtime starbase-graphics) - (file-case os-type - ((unix) "starbase") - (else)) - (parent (runtime)) - (export () - starbase-graphics-device-type) - (initialization (initialize-package!))) - (define-package (runtime state-space) (files "wind") (parent (runtime)) diff --git a/src/runtime/starbase.scm b/src/runtime/starbase.scm deleted file mode 100644 index 044c2fb87..000000000 --- a/src/runtime/starbase.scm +++ /dev/null @@ -1,256 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, - 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, - 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, - 2017 Massachusetts Institute of Technology - -This file is part of MIT/GNU Scheme. - -MIT/GNU Scheme is free software; you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation; either version 2 of the License, or (at -your option) any later version. - -MIT/GNU Scheme is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. - -You should have received a copy of the GNU General Public License -along with MIT/GNU Scheme; if not, write to the Free Software -Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, -USA. - -|# - -;;;; Starbase Graphics Interface -;;; package: (runtime starbase-graphics) - -(declare (usual-integrations)) - -(define-primitives - (starbase-open-device 2) - (starbase-close-device 1) - (starbase-flush 1) - (starbase-clear 1) - (starbase-move-cursor 3) - (starbase-drag-cursor 3) - (starbase-draw-line 5) - (starbase-draw-point 3) - (starbase-set-line-style 2) - (starbase-set-drawing-mode 2) - (starbase-device-coordinates 1) - (starbase-set-vdc-extent 5) - (starbase-reset-clip-rectangle 1) - (starbase-set-clip-rectangle 5) - (starbase-draw-text 4) - (starbase-set-text-height 2) - (starbase-set-text-aspect 2) - (starbase-set-text-slant 2) - (starbase-set-text-rotation 2) - (starbase-color-map-size 1) - (starbase-define-color 5) - (starbase-set-line-color 2) - (starbase-write-image-file 3)) - -(define (initialize-package!) - (set! starbase-graphics-device-type - (make-graphics-device-type - 'STARBASE - `((available? ,operation/available?) - (clear ,operation/clear) - (close ,operation/close) - (color-map-size ,operation/color-map-size) - (coordinate-limits ,operation/coordinate-limits) - (define-color ,operation/define-color) - (device-coordinate-limits ,operation/device-coordinate-limits) - (drag-cursor ,operation/drag-cursor) - (draw-line ,operation/draw-line) - (draw-point ,operation/draw-point) - (draw-text ,operation/draw-text) - (flush ,operation/flush) - (move-cursor ,operation/move-cursor) - (open ,operation/open) - (reset-clip-rectangle ,operation/reset-clip-rectangle) - (set-clip-rectangle ,operation/set-clip-rectangle) - (set-coordinate-limits ,operation/set-coordinate-limits) - (set-drawing-mode ,operation/set-drawing-mode) - (set-line-color ,operation/set-line-color) - (set-line-style ,operation/set-line-style) - (set-text-aspect ,operation/set-text-aspect) - (set-text-height ,operation/set-text-height) - (set-text-rotation ,operation/set-text-rotation) - (set-text-slant ,operation/set-text-slant) - (text-aspect ,operation/text-aspect) - (text-height ,operation/text-height) - (text-rotation ,operation/text-rotation) - (text-slant ,operation/text-slant) - (write-image-file ,operation/write-image-file)))) - unspecific) - -(define starbase-graphics-device-type) - -(define-structure (starbase-graphics-descriptor - (conc-name starbase-graphics-descriptor/) - (constructor make-starbase-descriptor (identifier))) - (identifier #f read-only #t) - x-left - y-bottom - x-right - y-top - text-height - text-aspect - text-slant - text-rotation) - -(define (starbase-device/identifier device) - (starbase-graphics-descriptor/identifier - (graphics-device/descriptor device))) - -(define-syntax define-accessors-and-mutators - (sc-macro-transformer - (lambda (form environment) - (let ((name (cadr form))) - `(BEGIN - (DEFINE (,(symbol 'STARBASE-DEVICE/ name) DEVICE) - (,(close-syntax - (symbol 'STARBASE-GRAPHICS-DESCRIPTOR/ name) - environment) - (GRAPHICS-DEVICE/DESCRIPTOR DEVICE))) - (DEFINE - (,(symbol 'SET-STARBASE-DEVICE/ name '!) DEVICE VALUE) - (,(close-syntax - (symbol 'SET-STARBASE-GRAPHICS-DESCRIPTOR/ name '!) - environment) - (GRAPHICS-DEVICE/DESCRIPTOR DEVICE) - VALUE))))))) - -(define-accessors-and-mutators x-left) -(define-accessors-and-mutators y-bottom) -(define-accessors-and-mutators x-right) -(define-accessors-and-mutators y-top) -(define-accessors-and-mutators text-height) -(define-accessors-and-mutators text-aspect) -(define-accessors-and-mutators text-slant) -(define-accessors-and-mutators text-rotation) - -(define (operation/available?) - (implemented-primitive-procedure? (ucode-primitive starbase-open-device 2))) - -(define (operation/open descriptor->device device-name driver-name) - (let ((identifier (starbase-open-device device-name driver-name))) - (and identifier - (let ((descriptor (make-starbase-descriptor identifier))) - (operation/set-coordinate-limits descriptor -1 -1 1 1) - (operation/set-text-height descriptor 0.1) - (operation/set-text-aspect descriptor 1) - (operation/set-text-slant descriptor 0) - (operation/set-text-rotation descriptor 0) - (descriptor->device descriptor))))) - -(define (operation/close device) - (starbase-close-device (starbase-device/identifier device))) - -(define (operation/flush device) - (starbase-flush (starbase-device/identifier device))) - -(define (operation/device-coordinate-limits device) - (let ((limits - (starbase-device-coordinates - (starbase-device/identifier device)))) - (values (vector-ref limits 0) - (vector-ref limits 1) - (vector-ref limits 2) - (vector-ref limits 3)))) - -(define (operation/coordinate-limits device) - (values (starbase-device/x-left device) - (starbase-device/y-bottom device) - (starbase-device/x-right device) - (starbase-device/y-top device))) - -(define (operation/set-coordinate-limits device x-left y-bottom x-right y-top) - (starbase-set-vdc-extent (starbase-device/identifier device) - x-left y-bottom x-right y-top) - (set-starbase-device/x-left! device x-left) - (set-starbase-device/y-bottom! device y-bottom) - (set-starbase-device/x-right! device x-right) - (set-starbase-device/y-top! device y-top)) - -(define (operation/reset-clip-rectangle device) - (starbase-reset-clip-rectangle (starbase-device/identifier device))) - -(define (operation/set-clip-rectangle device x-left y-bottom x-right y-top) - (starbase-set-clip-rectangle (starbase-device/identifier device) - x-left y-bottom x-right y-top)) - -(define (operation/set-drawing-mode device drawing-mode) - (starbase-set-drawing-mode (starbase-device/identifier device) drawing-mode)) - -(define (operation/set-line-style device line-style) - (starbase-set-line-style (starbase-device/identifier device) line-style)) - -(define (operation/clear device) - (starbase-clear (starbase-device/identifier device))) - -(define (operation/draw-point device x y) - (starbase-draw-point (starbase-device/identifier device) x y)) - -(define (operation/move-cursor device x y) - (starbase-move-cursor (starbase-device/identifier device) x y)) - -(define (operation/drag-cursor device x y) - (starbase-drag-cursor (starbase-device/identifier device) x y)) - -(define (operation/draw-line device x-start y-start x-end y-end) - (starbase-draw-line (starbase-device/identifier device) - x-start y-start x-end y-end)) - -(define (operation/draw-text device x y text) - (starbase-draw-text (starbase-device/identifier device) x y text)) - -;;; Custom Operations - -(define (operation/write-image-file device filename invert?) - (starbase-write-image-file (starbase-device/identifier device) - (->namestring (merge-pathnames filename)) - invert?)) - -(define (operation/text-height device) - (starbase-device/text-height device)) - -(define (operation/text-aspect device) - (starbase-device/text-aspect device)) - -(define (operation/text-slant device) - (starbase-device/text-slant device)) - -(define (operation/text-rotation device) - (starbase-device/text-rotation device)) - -(define (operation/set-text-height device height) - (starbase-set-text-height (starbase-device/identifier device) height) - (set-starbase-device/text-height! device height)) - -(define (operation/set-text-aspect device aspect) - (starbase-set-text-aspect (starbase-device/identifier device) aspect) - (set-starbase-device/text-aspect! device aspect)) - -(define (operation/set-text-slant device slant) - (starbase-set-text-slant (starbase-device/identifier device) slant) - (set-starbase-device/text-slant! device slant)) - -(define (operation/set-text-rotation device rotation) - (starbase-set-text-rotation (starbase-device/identifier device) rotation) - (set-starbase-device/text-rotation! device rotation)) - -(define (operation/color-map-size device) - (starbase-color-map-size (starbase-device/identifier device))) - -(define (operation/define-color device color-index red green blue) - (starbase-define-color (starbase-device/identifier device) - color-index red green blue)) - -(define (operation/set-line-color device color-index) - (starbase-set-line-color (starbase-device/identifier device) color-index)) \ No newline at end of file diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm index d9e4bffb6..a7817aa5d 100644 --- a/src/runtime/x11graph.scm +++ b/src/runtime/x11graph.scm @@ -63,7 +63,6 @@ USA. (x-window-set-name 2) (x-window-set-position 3) (x-window-set-size 3) - (x-window-starbase-filename 1) (x-window-visual 1) (x-window-withdraw 1) (x-window-x-size 1) @@ -199,7 +198,6 @@ USA. (set-mouse-color ,x-graphics/set-mouse-color) (set-mouse-shape ,x-graphics/set-mouse-shape) (set-window-name ,x-graphics/set-window-name) - (starbase-filename ,x-graphics/starbase-filename) (visual-info ,x-graphics/visual-info) (withdraw-window ,x-graphics/withdraw-window)))) (set! display-finalizer @@ -724,9 +722,6 @@ USA. (x-display-get-default (x-graphics-device/xd device) resource-name class-name)) -(define (x-graphics/starbase-filename device) - (x-window-starbase-filename (x-graphics-device/xw device))) - (define (x-graphics/window-id device) (x-window-id (x-graphics-device/xw device))) diff --git a/src/x11/make.scm b/src/x11/make.scm index e565d66d3..979328e74 100644 --- a/src/x11/make.scm +++ b/src/x11/make.scm @@ -48,7 +48,6 @@ Load the X11 option. |# x-window-set-name x-window-set-position x-window-set-size - ;; x-window-starbase-filename No such primitive! x-window-visual x-window-withdraw x-window-x-size diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm index 71ab59a78..69c574501 100644 --- a/src/x11/x11-device.scm +++ b/src/x11/x11-device.scm @@ -103,7 +103,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set-mouse-color ,x-graphics/set-mouse-color) (set-mouse-shape ,x-graphics/set-mouse-shape) (set-window-name ,x-graphics/set-window-name) - (starbase-filename ,x-graphics/starbase-filename) (visual-info ,x-graphics/visual-info) (withdraw-window ,x-graphics/withdraw-window)))) (set! display-finalizer @@ -628,13 +627,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (x-display-get-default (x-graphics-device/xd device) resource-name class-name)) -(define (x-graphics/starbase-filename device) - (x-window-starbase-filename (x-graphics-device/xw device))) - -(define (x-window-starbase-filename window) - window - (error "Unimplemented.")) - (define (x-graphics/window-id device) (x-window-id (x-graphics-device/xw device))) diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg index c67e3ae6b..d3e4e3eae 100644 --- a/src/x11/x11.pkg +++ b/src/x11/x11.pkg @@ -265,7 +265,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. x-graphics/set-mouse-color x-graphics/set-mouse-shape x-graphics/set-window-name - x-graphics/starbase-filename x-graphics/visual-info x-graphics/window-id x-graphics/withdraw-window