;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.45 1989/08/09 13:16:41 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.46 1989/08/12 08:31:05 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (make-autoloading-procedure library-name get-procedure)
(define entity
(make-entity (lambda arguments
- (load-library library-name)
+ ((ref-command load-library) library-name 'NO-WARN)
(let ((procedure (get-procedure)))
(set-entity-procedure! entity procedure)
(apply procedure (cdr arguments))))
(define (guarantee-command-loaded command)
(let ((procedure (command-procedure command)))
(if (autoloading-procedure? procedure)
- (load-library (autoloading-procedure/library-name procedure)))))
+ ((ref-command load-library)
+ (autoloading-procedure/library-name procedure)
+ 'NO-WARN))))
\f
;;;; Libraries
(hook)
(loop))))
(if entry (loop))))
-
-(define (load-library name)
- (if (not (library-loaded? name))
- (let ((entry (assq name known-libraries)))
- (if entry
- (%load-library entry)
- (error "LOAD-LIBRARY: Unknown library name" name)))))
-
-(define (%load-library library)
- (for-each (lambda (entry)
- (apply load-edwin-file entry))
- (cdr library))
- (if (not (memq (car library) loaded-libraries))
- (set! loaded-libraries (cons (car library) loaded-libraries)))
- (run-library-load-hooks! (car library)))
\f
;;;; Loading
-(define (load-edwin-file filename package #!optional purify?)
- (let ((pathname
- (merge-pathnames (->pathname filename) (edwin-binary-directory))))
- (temporary-message "Loading file \"" (pathname->string pathname) "\"")
- (let ((scode (fasload pathname true)))
- (if (or (default-object? purify?) purify?) (purify scode))
- (scode-eval-with-history scode (->environment package))))
- (append-message " -- done"))
-
-(define-command load-file
- "Load an Edwin binary file.
-An argument, if given, means purify the file too."
- "fLoad file\nP"
- (lambda (filename purify?)
- (load-edwin-file filename '(EDWIN) purify?)))
-
(define-command load-library
- "Load an Edwin library."
+ "Load the Edwin library NAME.
+Second arg FORCE? controls what happens if the library is already loaded:
+ 'NO-WARN means do nothing,
+ false means display a warning message in the minibuffer,
+ anything else means load it anyway.
+Second arg is prefix arg when called interactively."
(lambda ()
(list
(car
(map (lambda (library)
(cons (symbol->string (car library))
library))
- known-libraries)))))
- (lambda (name)
- (%load-library
- (or (assq name known-libraries)
- (editor-error "Unknown library name: " name)))))
\ No newline at end of file
+ known-libraries)))
+ (command-argument-standard-value)))
+ (lambda (name force?)
+ (let ((do-it
+ (let ((library
+ (or (assq name known-libraries)
+ (editor-error "Unknown library name: " name))))
+ (temporary-message "Loading " (car library))
+ (let ((directory (edwin-binary-directory)))
+ (for-each
+ (lambda (entry)
+ (load-edwin-file
+ (merge-pathnames (->pathname (car entry)) directory)
+ (cadr entry)
+ (or (null? (cddr entry)) (caddr entry))))
+ (cdr library)))
+ (if (not (memq (car library) loaded-libraries))
+ (set! loaded-libraries (cons (car library) loaded-libraries)))
+ (run-library-load-hooks! (car library))
+ (append-message " -- done"))))
+ (cond ((not (library-loaded? name))
+ (do-it))
+ ((not force?)
+ (temporary-message "Library already loaded: " name))
+ ((not (eq? force? 'NO-WARN))
+ (do-it))))))
+
+(define-command load-file
+ "Load the Edwin binary file FILENAME.
+Second arg PURIFY? means purify the file's contents after loading;
+ this is the prefix arg when called interactively."
+ "fLoad file\nP"
+ (lambda (filename purify?)
+ (temporary-message "Loading file \"" filename "\"")
+ (load-edwin-file filename '(EDWIN) purify?)
+ (append-message " -- done")))
+(define (load-edwin-file filename environment purify?)
+ (with-output-to-transcript-buffer
+ (lambda ()
+ (bind-condition-handler '() evaluation-error-handler
+ (lambda ()
+ (fluid-let ((load/suppress-loading-message? true))
+ (load filename environment edwin-syntax-table purify?)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.103 1989/08/11 10:51:43 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.104 1989/08/12 08:31:18 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(lambda ()
(set! edwin-finalization false)
(quit)
- (edwin)))
+ (edit)))
((ref-command suspend-edwin))))
(define-command suspend-edwin
(end (line-end (current-point) 0)))
(let ((com ((ref-variable comment-locator-hook) start)))
(if com
- (kill-string (horizontal-space-start (car com)) end)))))))
\ No newline at end of file
+ (kill-string (horizontal-space-start (car com)) end)))))))
+\f
+;;;; Useful Documentation
+
+(define-command define-command
+ "Scheme special form used to define commands:
+
+ (define-command NAME DOCUMENTATION INTERACTIVE-SPEC PROCEDURE)
+
+where:
+ NAME is a symbol;
+ DOCUMENTATION is a string;
+ INTERACTIVE-SPEC describes how to call PROCEDURE when the command is
+ invoked interactively (see below); and
+ PROCEDURE is a Scheme procedure that is called to perform the
+ command's actions.
+
+INTERACTIVE-SPEC and PROCEDURE are evaluated, the others aren't.
+
+INTERACTIVE-SPEC specifies a way of parsing arguments for interactive
+use of a command. For example, write
+ (define-command foo \"Doc string\" \"p\" (lambda (arg) ...use arg...))
+to make arg be the prefix numeric argument when foo is invoked.
+
+INTERACTIVE-SPEC is usually a string containing a code letter
+ followed by a prompt. (Some code letters do not use I/O to get
+ the argument and do not need prompts.) To prompt for multiple arguments,
+ give a code letter, its prompt, a newline, and another code letter, etc.
+If INTERACTIVE-SPEC is not a string, it is either a procedure or ().
+ If it's a procedure, then the procedure is invoked with no arguments,
+ and should return a list of arguments for the command.
+ Otherwise, if it's the empty list, the command gets no arguments.
+
+Code letters available are:
+b -- Name of existing buffer (string).
+B -- Name of buffer, possibly nonexistent (string).
+c -- Character.
+C -- Command name (symbol).
+d -- Value of point (editor-mark object). Does not do I/O.
+D -- Directory name (string).
+f -- Existing file name (string).
+F -- Possibly nonexistent file name (string).
+k -- Key sequence (list of chars).
+m -- Value of mark (editor-mark object). Does not do I/O.
+n -- Number read using minibuffer.
+N -- Prefix arg converted to number, or if none, do like code `n'.
+p -- Prefix arg converted to number, or 1 if no prefix. Does not do I/O.
+P -- Prefix arg converted to number, or #F if no prefix. Does not do I/O.
+r -- Region: current region (editor-region object). Does no I/O.
+s -- Any string.
+v -- Variable name (symbol).
+x -- Scheme expression read but not evaluated.
+X -- Scheme expression read and evaluated.
+In addition, if the first character of the string is '*' then an error is
+ signaled if the buffer is read-only.
+ This happens before reading any arguments."
+ ()
+ (lambda () (editor-error "DEFINE-COMMAND shouldn't be invoked")))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.135 1989/08/11 11:49:53 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.136 1989/08/12 08:31:27 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(let ((daemon (buffer-modification-daemon buffer)))
(add-group-insert-daemon! group daemon)
(add-group-delete-daemon! group daemon))
+ (add-group-clip-daemon! group (buffer-clip-daemon buffer))
(if (not (minibuffer? buffer))
(enable-group-undo! group))
(vector-set! buffer
(buffer-modeline-event! buffer 'BUFFER-MODIFIED)))
(vector-set! buffer buffer-index:auto-save-modified? true)
unspecific))
+
+(define (buffer-clip-daemon buffer)
+ (lambda (group start end)
+ group start end ;ignore
+ (buffer-modeline-event! buffer 'CLIPPING-CHANGED)))
+
(define-integrable (buffer-read-only? buffer)
(group-read-only? (buffer-group buffer)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.80 1989/08/11 16:17:44 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.81 1989/08/12 08:31:32 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
unspecific)
(define (top-level-command-reader initialization)
- (let loop ()
+ (let loop ((initialization initialization))
(with-keyboard-macro-disabled
(lambda ()
(intercept-^G-interrupts (lambda () unspecific)
(lambda ()
(command-reader initialization)))))
- (loop)))
+ (loop false)))
(define (command-reader #!optional initialization)
(define (command-reader-loop)
(define (%dispatch-on-command window command record?)
(set! *command* command)
(guarantee-command-loaded command)
- (let ((procedure (command-procedure command)))
+ (let ((point (window-point window))
+ (point-x (window-point-x window))
+ (procedure (command-procedure command)))
(let ((normal
(lambda ()
+ (set! *non-undo-count* 0)
+ (undo-boundary! point)
(apply procedure (interactive-arguments command record?)))))
- (if (or *executing-keyboard-macro?*
- (window-needs-redisplay? window)
- (command-argument-standard-value?))
- (begin
- (set! *non-undo-count* 0)
- (normal))
- (let ((point (window-point window))
- (point-x (window-point-x window)))
- (if (or (eq? procedure (ref-command self-insert-command))
- (and (eq? procedure (ref-command auto-fill-space))
- (not (auto-fill-break? point)))
- (command-argument-self-insert? procedure))
- (let ((char *command-char*))
- (if (let ((buffer (window-buffer window)))
- (and (buffer-auto-save-modified? buffer)
- (null? (cdr (buffer-windows buffer)))
- (line-end? point)
- (char-graphic? char)
- (< point-x (-1+ (window-x-size window)))))
- (begin
- (if (or (zero? *non-undo-count*)
- (>= *non-undo-count* 20))
- (begin
- (undo-boundary! point)
- (set! *non-undo-count* 0)))
- (set! *non-undo-count* (1+ *non-undo-count*))
- (window-direct-output-insert-char! window char))
- (region-insert-char! point char)))
- (begin
- (set! *non-undo-count* 0)
- (cond ((eq? procedure (ref-command forward-char))
- (if (and (not (group-end? point))
- (char-graphic? (mark-right-char point))
- (< point-x (- (window-x-size window) 2)))
- (window-direct-output-forward-char! window)
- (normal)))
- ((eq? procedure (ref-command backward-char))
- (if (and (not (group-start? point))
- (char-graphic? (mark-left-char point))
- (positive? point-x)
- (< point-x (-1+ (window-x-size window))))
- (window-direct-output-backward-char! window)
- (normal)))
- (else
- (if (not (typein-window? window))
- (undo-boundary! point))
- (normal))))))))))\f
+ (cond ((or *executing-keyboard-macro?*
+ (command-argument-standard-value?))
+ (set! *non-undo-count* 0)
+ (apply procedure (interactive-arguments command record?)))
+ ((window-needs-redisplay? window)
+ (normal))
+ ((eq? procedure (ref-command forward-char))
+ (if (and (not (group-end? point))
+ (char-graphic? (mark-right-char point))
+ (< point-x (- (window-x-size window) 2)))
+ (window-direct-output-forward-char! window)
+ (normal)))
+ ((eq? procedure (ref-command backward-char))
+ (if (and (not (group-start? point))
+ (char-graphic? (mark-left-char point))
+ (positive? point-x)
+ (< point-x (-1+ (window-x-size window))))
+ (window-direct-output-backward-char! window)
+ (normal)))
+ ((or (eq? procedure (ref-command self-insert-command))
+ (and (eq? procedure (ref-command auto-fill-space))
+ (not (auto-fill-break? point)))
+ (command-argument-self-insert? procedure))
+ (let ((char *command-char*))
+ (if (let ((buffer (window-buffer window)))
+ (and (buffer-auto-save-modified? buffer)
+ (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (char-graphic? char)
+ (< point-x (-1+ (window-x-size window)))))
+ (begin
+ (if (or (zero? *non-undo-count*)
+ (>= *non-undo-count* 20))
+ (begin
+ (set! *non-undo-count* 0)
+ (undo-boundary! point)))
+ (set! *non-undo-count* (1+ *non-undo-count*))
+ (window-direct-output-insert-char! window char))
+ (region-insert-char! point char))))
+ (else
+ (normal))))))
+\f
(define (interactive-arguments command record?)
(let ((specification (command-interactive-specification command))
(record-command-arguments
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.85 1989/08/09 13:17:02 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.86 1989/08/12 08:31:40 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(bufferset-rename-buffer (current-bufferset) buffer new-name))
(define (kill-buffer buffer)
- (if (buffer-visible? buffer)
- (let ((new-buffer
- (or (other-buffer buffer)
- (error "Buffer to be killed has no replacement" buffer))))
- (for-each (lambda (window)
- (set-window-buffer! window new-buffer false))
- (buffer-windows buffer)))) (bufferset-kill-buffer! (current-bufferset) buffer))
+ (let loop
+ ((windows (buffer-windows buffer))
+ (last-buffer false))
+ (if (not (null? windows))
+ (let ((new-buffer
+ (or (other-buffer buffer)
+ last-buffer
+ (error "Buffer to be killed has no replacement" buffer))))
+ (set-window-buffer! (car windows) new-buffer false)
+ (loop (cdr windows) new-buffer))))
+ (bufferset-kill-buffer! (current-bufferset) buffer))
\f
(define-integrable (select-buffer buffer)
(set-window-buffer! (current-window) buffer true))
'("bufinp"
"bufott"
"bufout"
- "comtab"
"class"
"clscon"
"clsmac"
+ "comtab"
"cterm"
+ "display"
"entity"
"grpops"
"image"
"strpad"
"strtab"
"utils"
- "xform"
- "xterm"
"winout"
- "winren")))
+ "winren"
+ "xform"
+ "xterm")))
(fluid-let ((sf/default-syntax-table
(access edwin-syntax-table (->environment '(EDWIN)))))
"curren"
"debug"
"debuge"
- "dired" "editor"
+ "dired"
+ "ed-ffi"
+ "editor"
"edtstr"
"evlcom"
"filcom"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.191 1989/08/11 16:17:58 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.192 1989/08/12 08:31:48 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define (edwin)
+(define (edit)
(if (not edwin-editor)
- (apply edwin-reset edwin-reset-args))
+ (apply create-editor create-editor-args))
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((editor-abort continuation)
(*auto-save-keystroke-count* 0))
(within-editor edwin-editor
(lambda ()
- (using-screen edwin-screen
+ (with-editor-interrupts
(lambda ()
- (with-editor-input-port edwin-input-port
+ (with-current-local-bindings!
(lambda ()
- (with-editor-interrupts
+ (bind-condition-handler '() internal-error-handler
(lambda ()
- (with-current-local-bindings!
- (lambda ()
- (bind-condition-handler '() internal-error-handler
- (lambda ()
- (dynamic-wind
- (lambda () (update-screens! true))
- (lambda ()
- (let ((message (cmdl-message/null)))
- (push-cmdl (lambda (cmdl)
- cmdl ;ignore
- (top-level-command-reader
- edwin-initialization)
- message)
- false
- message)))
- (lambda () unspecific)))))))))))))))))
+ (dynamic-wind
+ (lambda () (update-screens! true))
+ (lambda ()
+ (let ((message (cmdl-message/null)))
+ (push-cmdl (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader
+ edwin-initialization)
+ message)
+ false
+ message)))
+ (lambda () unspecific)))))))))))))
(if edwin-finalization (edwin-finalization))
unspecific)
-(define edwin-reset-args '())
+(define create-editor-args (list false))
(define editor-abort)
+(define edwin-editor false)
;; Set this before entering the editor to get something done after the
;; editor's dynamic environment is initialized, but before the command
;; reset and then reenter the editor.
(define edwin-finalization false)
\f
+(define (create-editor display-type . make-screen-args)
+ (reset-editor)
+ (initialize-typein!)
+ (initialize-typeout!)
+ (initialize-syntax-table!)
+ (initialize-command-reader!)
+ (if display-type
+ (set-editor-display-type! display-type)
+ (initialize-display-type!))
+ (set! edwin-editor
+ (let ((screen (apply make-editor-screen make-screen-args)))
+ (make-editor "Edwin" screen (make-editor-input-port screen))))
+ (set! edwin-initialization
+ (lambda ()
+ (set! edwin-initialization false)
+ (with-editor-interrupts-disabled standard-editor-initialization)))
+ unspecific)
+
+(define (reset-editor)
+ (without-interrupts
+ (lambda ()
+ (if edwin-editor
+ (begin
+ (screen-discard! (editor-screen edwin-editor))
+ (set! edwin-editor false)
+ unspecific)))))
+
+(define (standard-editor-initialization)
+ (if (not init-file-loaded?)
+ (begin
+ (let ((filename (os/init-file-name)))
+ (if (file-exists? filename)
+ (load-edwin-file filename '(EDWIN) true)))
+ (set! init-file-loaded? true)
+ unspecific))
+ (if (not (ref-variable inhibit-startup-message))
+ (let ((window (current-window)))
+ (with-output-to-mark (window-point window)
+ write-initial-buffer-greeting!)
+ (let ((buffer (window-buffer window)))
+ (set-window-start-mark! window (buffer-start buffer) false)
+ (buffer-not-modified! buffer)
+ (sit-for 120000)
+ (region-delete! (buffer-unclipped-region buffer))
+ (buffer-not-modified! buffer)))))
+
+(define inhibit-editor-init-file? false)
+(define init-file-loaded? false)
+
+(define-variable inhibit-startup-message
+ "*True inhibits the initial startup messages.
+This is for use in your personal init file, once you are familiar
+with the contents of the startup message."
+ false)
+
+(define (write-initial-buffer-greeting!)
+ (identify-world)
+ (write-string initial-buffer-greeting))
+
+(define initial-buffer-greeting
+ "
+
+;You are in an interaction window of the Edwin editor.
+;Type C-h for help. C-h m will describe some commands.
+
+")
+\f
;;;; Recursive Edit Levels
(define (within-editor editor thunk)
(fluid-let ((current-editor editor)
(recursive-edit-continuation false)
(recursive-edit-level 0))
- (thunk)))
+ (using-screen (current-screen)
+ (lambda ()
+ (with-editor-input-port (current-editor-input-port)
+ thunk)))))
+
(define (within-editor?)
(not (unassigned? current-editor)))
(define (enter-recursive-edit)
(define-structure (editor (constructor %make-editor))
(name false read-only true)
(screen false read-only true)
+ (input-port false read-only true)
(frame-window false read-only true)
(bufferset false read-only true)
(kill-ring false read-only true)
(char-history false read-only true)
(button-event false))
-(define (make-editor name screen)
+(define (make-editor name screen input-port)
(let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode)))
(let ((bufferset (make-bufferset initial-buffer)))
(let ((frame
(set-screen-window! screen frame)
(%make-editor name
screen
+ input-port
frame
bufferset
(make-ring 10)
(define-integrable (all-screens)
(list (current-screen)))
+
+(define-integrable (current-editor-input-port)
+ (editor-input-port current-editor))
+
(define-integrable (current-editor-frame)
(editor-frame-window current-editor))
;;; -*-Scheme-*-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.6 1989/08/09 13:17:13 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.7 1989/08/12 08:31:57 cph Exp $
;;; program to load package contents
;;; **** This program (unlike most .ldr files) is not generated by a program.
(load "buffer" environment)
(load "bufset" environment)
(load "undo" (->environment '(EDWIN UNDO)))
+ (load "display" (->environment '(EDWIN DISPLAY-TYPE)))
(load "screen" (->environment '(EDWIN SCREEN)))
(load "winren" (->environment '(EDWIN)))
(let ((environment (->environment '(EDWIN WINDOW))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.10 1989/08/11 11:50:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.11 1989/08/12 08:32:00 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
(export (edwin class-macros)
class-instance-transforms)
(export ()
- edwin-reset-args))
+ create-editor
+ create-editor-args
+ edit
+ inhibit-editor-init-file?
+ reset-editor))
(define-package (edwin class-macros)
(files "clsmac")
undo-record-deletion!
undo-record-insertion!))
+(define-package (edwin display-type)
+ (files "display")
+ (parent (edwin))
+ (export ()
+ editor-display-type
+ editor-display-types)
+ (export (edwin)
+ display-type?
+ initialize-display-type!
+ make-display-type
+ make-editor-input-port
+ make-editor-screen
+ set-editor-display-type!
+ with-editor-interrupts
+ with-editor-interrupts-disabled
+ with-editor-interrupts-enabled))
+
(define-package (edwin screen)
(files "screen")
(parent (edwin))
button3-up
button4-up
button5-up
- x-display)
+ x-display-type)
(export (edwin x-commands)
screen-xterm)
(initialization (initialize-package!)))
(define-package (edwin x-commands)
(files "xcom")
- (parent (edwin))
- (export (edwin)
- x-move-to-coordinates
- x-switch-to-window))
+ (parent (edwin)))
(define-package (edwin console-screen)
(files "cterm")
(parent (edwin))
(export (edwin)
- console-display)
+ console-display-type)
(initialization (initialize-package!)))
(define-package (edwin window)
"winmis")
(parent (edwin))
(export ()
- edwin-set-display!)
+ reset-editor-windows)
(export (edwin)
button-downify
button-upify
editor-frame-typein-window
editor-frame-window0
editor-frame-windows
- edwin-discard-state!
- edwin-display
- edwin-editor
- edwin-input-port
- edwin-reset
- edwin-reset-windows
- edwin-screen
initialize-buttons!
- make-display
make-editor-frame
set-window-point!
set-window-start-mark!
window-set-override-message!
window-setup-truncate-lines!
window-start-index
- window-y-center
- with-editor-interrupts
- with-editor-interrupts-enabled
- with-editor-interrupts-disabled)
+ window-y-center)
(export (edwin prompt)
clear-override-message!
frame-text-inferior
char-metafy
clear-message
command-prompt
- editor-input-port
initialize-typeout!
keyboard-active?
keyboard-peek-char
message-args->string
reset-command-prompt!
set-command-prompt!
- set-editor-input-port!
temporary-message
with-editor-input-port))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.16 1989/08/09 13:17:23 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.17 1989/08/12 08:32:04 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-variable enable-transcript-buffer
"If true, output from evaluation commands is recorded in transcript buffer."
- true)
+ false)
(define-variable transcript-buffer-name
"Name of evaluation transcript buffer.
"xEvaluate expression\nP"
(lambda (expression argument)
(editor-eval expression (evaluation-environment argument))))
-
+\f
(define-command set-environment
- "Sets the environment for the editor and any inferior REP loops."
+ "Make ENVIRONMENT the current evaluation environment."
"XSet environment"
+ (lambda (environment)
+ (set-variable! scheme-environment (->environment environment))))
+
+(define-command set-syntax-table
+ "Make SYNTAX-TABLE the current syntax table."
+ "XSet syntax table"
+ (lambda (syntax-table)
+ (set-variable! scheme-syntax-table syntax-table)))
+
+(define-command set-default-environment
+ "Make ENVIRONMENT the default evaluation environment."
+ "XSet default environment"
+ (lambda (environment)
+ (set-variable-default-value! (ref-variable-object scheme-environment)
+ (->environment environment))))
+
+(define-command set-default-syntax-table
+ "Make SYNTAX-TABLE the default syntax table."
+ "XSet default syntax table"
+ (lambda (syntax-table)
+ (set-variable-default-value! (ref-variable-object scheme-syntax-table)
+ syntax-table)))
+
+(define-command set-repl-environment
+ "Make ENVIRONMENT the environment of the nearest REP loop."
+ "XSet REPL environment"
(lambda (environment)
(set-repl/environment! (nearest-repl) (->environment environment))))
-(define-command set-syntactic-environment
- "Sets the current syntactic environment."
- "XSet syntactic environment"
- (lambda (syntactic-environment)
- (set-repl/syntax-table! (nearest-repl) syntactic-environment)))
+(define-command set-repl-syntax-table
+ "Make SYNTAX-TABLE the syntax table of the nearest REP loop."
+ "XSet REPL syntax table"
+ (lambda (syntax-table)
+ (set-repl/syntax-table! (nearest-repl) syntax-table)))
(define-command select-transcript-buffer
"Select the transcript buffer."
(loop (read)))))))))
(define (evaluation-environment argument)
- (if argument
- (if (environment? argument)
- argument
- (->environment
- (prompt-for-expression-value "Evaluate in environment")))
- (let ((environment (ref-variable scheme-environment)))
- (if (eq? 'DEFAULT environment)
- (nearest-repl/environment)
- (->environment environment)))))
-
-(define (evaluation-syntax-table)
- (or (ref-variable scheme-syntax-table)
- (nearest-repl/syntax-table)))
-
+ (let ((->environment
+ (lambda (object)
+ (bind-condition-handler '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (editor-error "Illegal environment: " object)))
+ (lambda ()
+ (->environment object))))))
+ (if argument
+ (if (environment? argument)
+ argument
+ (->environment
+ (prompt-for-expression-value "Evaluate in environment")))
+ (let ((environment (ref-variable scheme-environment)))
+ (if (eq? 'DEFAULT environment)
+ (nearest-repl/environment)
+ (->environment environment))))))
+
+(define (evaluation-syntax-table environment)
+ (let ((syntax-table (ref-variable scheme-syntax-table)))
+ (cond ((or (not syntax-table) (eq? 'DEFAULT syntax-table))
+ (nearest-repl/syntax-table))
+ ((scheme-syntax-table? syntax-table)
+ syntax-table)
+ ((and (symbol? syntax-table)
+ (not (lexical-unreferenceable? environment syntax-table))
+ (let ((syntax-table
+ (lexical-reference environment syntax-table)))
+ (and (scheme-syntax-table? syntax-table)
+ syntax-table))))
+ (else
+ (editor-error "Illegal syntax table: " syntax-table)))))
+
+(define scheme-syntax-table?
+ (access syntax-table? system-global-environment))
+\f
(define (editor-eval sexp environment)
(with-output-to-transcript-buffer
(lambda ()
value))))
(define (eval-with-history expression environment)
- (scode-eval-with-history (syntax expression (evaluation-syntax-table))
+ (scode-eval-with-history (syntax expression
+ (evaluation-syntax-table environment))
environment))
(define (scode-eval-with-history scode environment)
- (bind-condition-handler '()
- (lambda (condition)
- (and (not (condition/internal? condition))
- (error? condition)
- (begin
- (if (ref-variable debug-on-evaluation-error)
- (debug-scheme-error condition)
- (let ((string
- (with-output-to-string
- (lambda ()
- ((condition/reporter condition)
- condition
- (current-output-port))))))
- (if (and (not (string-find-next-char string #\newline))
- (< (string-column-length string 18) 80))
- (message "Evaluation error: " string)
- (begin
- (string->temporary-buffer string "*Error*")
- (message "Evaluation error")))))
- (%editor-error))))
+ (bind-condition-handler '() evaluation-error-handler
(lambda ()
(with-new-history
(lambda ()
(extended-scode-eval scode environment))))))
+
+(define (evaluation-error-handler condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (begin
+ (if (ref-variable debug-on-evaluation-error)
+ (debug-scheme-error condition)
+ (let ((string
+ (with-output-to-string
+ (lambda ()
+ ((condition/reporter condition)
+ condition
+ (current-output-port))))))
+ (if (and (not (string-find-next-char string #\newline))
+ (< (string-column-length string 18) 80))
+ (message "Evaluation error: " string)
+ (begin
+ (string->temporary-buffer string "*Error*")
+ (message "Evaluation error")))))
+ (%editor-error))))
\f
;;;; Transcript Buffer
(let ((value-message (lambda () (message value-string))))
(if (ref-variable enable-transcript-buffer)
(begin
- (fresh-lines 1) (write-string value-string)
+ (fresh-lines 1)
+ (write-char #\;)
+ (write-string value-string)
(fresh-lines 2)
(if (null? (buffer-windows (transcript-buffer)))
(value-message)))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.138 1989/08/11 10:54:26 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.139 1989/08/12 08:32:08 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(revert-buffer buffer true true))))
buffer)
(let ((buffer (new-buffer (pathname->buffer-name pathname))))
- (after-find-file
- buffer
- (catch-file-errors (lambda () true)
- (lambda ()
- (not (read-buffer buffer pathname)))))
+ (visit-file buffer pathname)
buffer))))))
-(define (after-find-file buffer error?)
- (let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
- (if (or (not pathname) (file-writable? pathname))
- (set-buffer-writeable! buffer)
- (set-buffer-read-only! buffer)))
- (let ((msg
- (cond ((not (buffer-read-only? buffer))
- (and error? "(New file)"))
- ((not error?)
- "File is write protected")
- ((file-attributes (buffer-pathname buffer))
- "File exists, but is read-protected.")
- ((file-attributes
- (pathname-directory-path (buffer-pathname buffer)))
- "File not found and directory write-protected")
- (else
- "File not found and directory doesn't exist"))))
- (if msg
- (message msg)))
- (setup-buffer-auto-save! buffer)
- (initialize-buffer! buffer))
-
-(define (pathname->buffer pathname)
- (or (list-search-positive (buffer-list)
- (lambda (buffer)
- (let ((pathname* (buffer-pathname buffer)))
- (and pathname*
- (pathname=? pathname pathname*)))))
- (let ((truename (pathname->input-truename pathname)))
- (and truename
- (list-search-positive (buffer-list)
- (lambda (buffer)
- (let ((pathname* (buffer-pathname buffer)))
- (and pathname*
- (or (pathname=? pathname pathname*)
- (pathname=? truename pathname*)
- (let ((truename* (buffer-truename buffer)))
- (and truename*
- (pathname=? truename truename*))))))))))))
-\f
(define-command find-file
"Visit a file in its own buffer.
If the file is already in some buffer, select that buffer.
(let ((buffer* (new-buffer "*dummy*")))
(do-it)
(kill-buffer buffer*)))))))
+\f
+(define-command revert-buffer
+ "Replace the buffer text with the text of the visited file on disk.
+This undoes all changes since the file was visited or saved.
+If latest auto-save file is more recent than the visited file,
+asks user whether to use that instead.
+Argument means don't offer to use auto-save file."
+ "P"
+ (lambda (argument)
+ (revert-buffer (current-buffer) argument false)))
+
+(define (revert-buffer buffer dont-use-auto-save? dont-confirm?)
+ (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD)))
+ (if method
+ (method buffer dont-use-auto-save? dont-confirm?)
+ (let ((pathname (buffer-pathname buffer)))
+ (cond ((not pathname)
+ (editor-error
+ "Buffer does not seem to be associated with any file"))
+ ((not (file-exists? pathname))
+ (editor-error "File "
+ (pathname->string pathname)
+ " no longer exists!"))
+ ((or dont-confirm?
+ (prompt-for-yes-or-no?
+ (string-append "Revert buffer from file "
+ (pathname->string pathname))))
+ (let ((where (mark-index (buffer-point buffer))))
+ (visit-file buffer pathname)
+ (set-buffer-point!
+ buffer
+ (mark+ (buffer-start buffer) where 'LIMIT)))))))))
(define-command toggle-read-only
"Change whether this buffer is visiting its file read-only."
set-buffer-writeable!)
buffer))))
\f
+(define (visit-file buffer pathname)
+ (let ((error?
+ (catch-file-errors (lambda () true)
+ (lambda ()
+ (not (read-buffer buffer pathname))))))
+ (let ((pathname (or (buffer-truename buffer) pathname)))
+ (if (file-writable? pathname)
+ (set-buffer-writeable! buffer)
+ (set-buffer-read-only! buffer))
+ (let ((msg
+ (cond ((not (buffer-read-only? buffer))
+ (and error? "(New file)"))
+ ((not error?)
+ "File is write protected")
+ ((file-attributes pathname)
+ "File exists, but is read-protected.")
+ ((file-attributes (pathname-directory-path pathname))
+ "File not found and directory write-protected")
+ (else
+ "File not found and directory doesn't exist"))))
+ (if msg
+ (message msg)))))
+ (setup-buffer-auto-save! buffer)
+ (initialize-buffer! buffer)
+ (let ((filename (os/find-file-initialization-filename pathname)))
+ (if filename
+ (let ((database (load-edwin-file filename '(EDWIN) false)))
+ (if (and (procedure? database)
+ (procedure-arity-valid? database 0))
+ (add-buffer-initialization! buffer database)
+ (message
+ "Ill-formed find-file initialization file: "
+ (os/pathname->display-string (->pathname filename))))))))
+
+(define (standard-scheme-find-file-initialization database)
+ ;; DATABASE -must- be a vector whose elements are all three element
+ ;; lists. The car of each element must be a string, and the
+ ;; elements must be sorted on those strings.
+ (lambda ()
+ (let ((entry
+ (let ((pathname (buffer-pathname (current-buffer))))
+ (and pathname
+ (equal? "scm" (pathname-type pathname))
+ (let ((name (pathname-name pathname)))
+ (and name
+ (vector-binary-search database
+ string<?
+ car
+ name)))))))
+ (if entry
+ (begin
+ (local-set-variable! scheme-environment (cadr entry))
+ (local-set-variable! scheme-syntax-table (caddr entry)))))))
+\f
(define (save-buffer buffer)
(if (buffer-modified? buffer)
(let ((exponent (command-argument-multiplier-only?)))
(buffer-modified! buffer))
(disable-buffer-auto-save! buffer)))
-(define (pathname->buffer-name pathname)
- (let ((name (pathname-name pathname)))
- (if name
- (pathname->string
- (make-pathname false false false
- name
- (pathname-type pathname)
- false))
- (let ((name
- (let ((directory (pathname-directory pathname)))
- (and (pair? directory)
- (car (last-pair directory))))))
- (if (string? name)
- name
- "*random*")))))
-
(define-command write-file
"Store buffer in specified file.
This file becomes the one being visited."
(lambda (filename)
(set-current-region! (insert-file (current-point) filename))))
\f
-(define-command revert-buffer
- "Replace the buffer text with the text of the visited file on disk.
-This undoes all changes since the file was visited or saved.
-If latest auto-save file is more recent than the visited file,
-asks user whether to use that instead.
-Argument means don't offer to use auto-save file."
- "P"
- (lambda (argument)
- (revert-buffer (current-buffer) argument false)))
-
-(define (revert-buffer buffer dont-use-auto-save? dont-confirm?)
- (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD)))
- (if method
- (method buffer dont-use-auto-save? dont-confirm?)
- (let ((pathname (buffer-pathname buffer)))
- (cond ((not pathname)
- (editor-error
- "Buffer does not seem to be associated with any file"))
- ((not (file-exists? pathname))
- (editor-error "File "
- (pathname->string pathname)
- " no longer exists!"))
- ((or dont-confirm?
- (prompt-for-yes-or-no?
- (string-append "Revert buffer from file "
- (pathname->string pathname))))
- (let ((where (mark-index (buffer-point buffer))))
- (read-buffer buffer pathname)
- (set-buffer-point!
- buffer
- (mark+ (buffer-start buffer) where 'LIMIT)))
- (after-find-file buffer false)))))))
-\f
(define-command copy-file
"Copy a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
\f
;;;; Printer Support
+#|
+
(define-command print-file
"Print a file on the local printer."
"fPrint File"
(lambda (region)
(print-region region)))
-#|
-
(define (print-region region)
(let ((temp (temporary-buffer "*Printout*")))
(region-insert! (buffer-point temp) region)
;;;; Prompting
(define (prompt-for-filename prompt default require-match?)
- (let ((default (pathname-directory-path default)))
+ (let ((default
+ (if default
+ (pathname-directory-path default)
+ (working-directory-pathname))))
(prompt-for-completed-string
prompt
- (pathname-directory-string default)
+ (os/pathname->display-string default)
'INSERTED-DEFAULT
(lambda (string if-unique if-not-unique if-not-found)
(define (loop directory filenames)
(and pathname-newest 'NEWEST)))
(define-integrable (prompt-string->pathname string)
- (string->pathname (os/trim-pathname-string string)))
\ No newline at end of file
+ (string->pathname (os/trim-pathname-string string)))
+
+(define (pathname->buffer-name pathname)
+ (let ((name (pathname-name pathname)))
+ (if name
+ (pathname->string
+ (make-pathname false false false
+ name (pathname-type pathname) false))
+ (let ((name
+ (let ((directory (pathname-directory pathname)))
+ (and (pair? directory)
+ (car (last-pair directory))))))
+ (if (string? name) name "*random*")))))
+
+(define (pathname->buffer pathname)
+ (or (list-search-positive (buffer-list)
+ (lambda (buffer)
+ (let ((pathname* (buffer-pathname buffer)))
+ (and pathname*
+ (pathname=? pathname pathname*)))))
+ (let ((truename (pathname->input-truename pathname)))
+ (and truename
+ (list-search-positive (buffer-list)
+ (lambda (buffer)
+ (let ((pathname* (buffer-pathname buffer)))
+ (and pathname*
+ (or (pathname=? pathname pathname*)
+ (pathname=? truename pathname*)
+ (let ((truename* (buffer-truename buffer)))
+ (and truename*
+ (pathname=? truename truename*))))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.89 1989/08/03 23:32:55 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.90 1989/08/12 08:32:15 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define-command help-prefix
"This is a prefix for more commands.
It reads another character (a subcommand) and dispatches on it."
- "cA C D I K L M T V W or C-h for more help"
+ "cA C F I K L M T V W or C-h for more help"
(lambda (char)
(dispatch-on-char
(current-comtabs)
that contain that substring.
C describe-key-briefly. Type a key sequence;
it prints the name of the command that sequence runs.
-D describe-command. Type a command name and get its documentation.
+F describe-command. Type a command name and get its documentation.
I info. The Info documentation reader.
K describe-key. Type a key sequence;
it prints the full documentation.
(let loop ()
(let ((char
(prompt-for-char
- "A C D I K L M T V W or space to scroll"))) (let ((test-for
+ "A C F I K L M T V W or space to scroll"))) (let ((test-for
(lambda (char*)
(char=? char (remap-alias-char char*)))))
(cond ((or (test-for #\C-h)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.80 1989/08/07 08:44:56 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.81 1989/08/12 08:32:19 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
\f
(define editor-input-port)
-(define (set-editor-input-port! port)
- (set! editor-input-port port))
(define (with-editor-input-port new-port thunk)
(fluid-let ((editor-input-port new-port))
(thunk)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.15 1989/08/11 11:50:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.16 1989/08/12 08:32:23 cph Exp $
Copyright (c) 1989 Massachusetts Institute of Technology
(declare (usual-integrations))
(package/system-loader "edwin" '() 'QUERY)
-(add-system! (make-system "Edwin" 3 15 '()))
\ No newline at end of file
+(add-system! (make-system "Edwin" 3 16 '()))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.120 1989/08/09 13:17:51 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.121 1989/08/12 08:32:28 cph Exp $
;;;
;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
(define-key 'fundamental '(#\c-c #\c-s) 'select-transcript-buffer)
(define-key 'fundamental '(#\c-h #\a) 'command-apropos)(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly)
-(define-key 'fundamental '(#\c-h #\d) 'describe-command)(define-key 'fundamental '(#\c-h #\i) 'info)
+(define-key 'fundamental '(#\c-h #\f) 'describe-command)
+(define-key 'fundamental '(#\c-h #\i) 'info)
(define-key 'fundamental '(#\c-h #\k) 'describe-key)
(define-key 'fundamental '(#\c-h #\l) 'view-lossage)
(define-key 'fundamental '(#\c-h #\m) 'describe-mode)
(let ((g<-e
(lambda (g e)
(local-assignment global g (lexical-reference edwin e)))))
- (g<-e 'edit 'edwin)
- (g<-e 'save-editor-files 'debug-save-files)
- (g<-e 'reset-editor 'edwin-discard-state!)
- (g<-e 'reset-editor-windows 'edwin-reset-windows)) (let ((e<-w
+ (g<-e 'save-editor-files 'debug-save-files))
+ (let ((e<-w
(lambda (e w)
(lexical-assignment edwin e (lexical-reference window w)))))
(e<-w 'window? 'buffer-frame?)
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.9 1989/08/09 13:18:11 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.10 1989/08/12 08:32:36 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(wrap (pathname-name-string pathname)
(pathname-directory-path pathname)))))
+(define (os/pathname->display-string pathname)
+ (let ((relative (pathname-relative? pathname (home-directory-pathname))))
+ (if relative
+ (string-append "~/" (pathname->string relative))
+ (pathname->string pathname))))
+
(define-variable backup-by-copying-when-linked
"*Non-false means use copying to create backups for files with multiple names.
This causes the alternate names to refer to the latest version as edited.
(sort pathnames
(lambda (x y)
(string<? (pathname-name-string x) (pathname-name-string y)))))
+
+(define (os/truncate-filename-for-modeline filename width)
+ (let ((length (string-length filename)))
+ (if (< 0 width length)
+ (let ((result
+ (substring
+ filename
+ (let ((index (- length width)))
+ (or (and (not (char=? #\/ (string-ref filename index)))
+ (substring-find-next-char filename index length
+ #\/))
+ (1+ index)))
+ length)))
+ (string-set! result 0 #\$)
+ result)
+ filename)))
\f
(define (os/directory-list directory)
(dynamic-wind
("txt" . text)
("y" . c))))
-(define (os/truncate-filename-for-modeline filename width)
- (let ((length (string-length filename)))
- (if (< 0 width length)
- (let ((result
- (substring
- filename
- (let ((index (- length width)))
- (or (and (not (char=? #\/ (string-ref filename index)))
- (substring-find-next-char filename index length
- #\/))
- (1+ index)))
- length)))
- (string-set! result 0 #\$)
- result)
- filename)))
\ No newline at end of file
+(define (os/init-file-name)
+ "~/.edwin")
+
+(define os/find-file-initialization-filename
+ (let ((name-path (string->pathname ".edwin-ffi")))
+ (lambda (pathname)
+ (or (and (equal? "scm" (pathname-type pathname))
+ (let ((pathname (pathname-new-version pathname "ffi")))
+ (and (file-exists? pathname)
+ pathname)))
+ (let ((pathname
+ (merge-pathnames name-path
+ (pathname-directory-path pathname))))
+ (and (file-exists? pathname)
+ pathname))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.17 1989/08/11 10:54:14 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.18 1989/08/12 08:32:42 cph Exp $
;;;
;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
(define (write-value value truncate?)
(if (undefined-value? value)
- (write-string ";No value")
+ (write-string "No value")
(begin
- (write-string ";Value: ") (if truncate?
+ (write-string "Value: ")
+ (if truncate?
(fluid-let ((*unparser-list-depth-limit* 5)
(*unparser-list-breadth-limit* 10))
(write value))
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.2 1989/08/11 11:50:55 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.3 1989/08/12 08:32:52 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
(x-window-x-size 1)
(x-window-y-size 1)
(x-window-set-size 3)
+ (x-window-set-position 3)
(x-window-map 1)
(x-window-unmap 1)
(x-window-beep 1)
(xterm-set-size xterm x-size y-size)))))
(define-command x-set-size
- "Set size of editor screen to (WIDTH, HEIGHT)."
- "nScreen width\nnScreen height"
+ "Set size of editor screen to WIDTH x HEIGHT."
+ "nScreen width (chars)\nnScreen height (chars)"
(lambda (width height)
(xterm-set-size (current-xterm) (max 2 width) (max 2 height))))
+
+(define-command x-set-position
+ "Set position of editor screen to (X,Y)."
+ "nX position (pixels)\nnY position (pixels)"
+ (lambda (x y)
+ (x-window-set-position (current-xterm) x y)))
+
(define-command x-set-border-width
"Set width of border to WIDTH."
"nSet border width"
;;; -*-Scheme-*-
;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.7 1989/06/21 10:43:20 cph Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.8 1989/08/12 08:32:56 cph Exp $
;;;
;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
;;;; Display description for X displays
-(define x-display)
+(define x-display-type)
(define x-display-data false)
(define (get-x-display)
unspecific)
(define (initialize-package!)
- (set! x-display
- (make-display get-x-display
- make-xterm-screen
- make-xterm-input-port
- with-editor-interrupts-from-x
- with-x-interrupts-enabled
- with-x-interrupts-disabled)) (initialize-buttons! 5)
+ (set! x-display-type
+ (make-display-type 'X
+ get-x-display
+ make-xterm-screen
+ make-xterm-input-port
+ with-editor-interrupts-from-x
+ with-x-interrupts-enabled
+ with-x-interrupts-disabled))
+ (initialize-buttons! 5)
(set! button1-down (button-downify 0))
(set! button2-down (button-downify 1))
(set! button3-down (button-downify 2))
projects / mit-scheme.git / commitdiff