From aa5eb64d84960959c481d57de35957b73ac3ad1e Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 27 Oct 1987 18:00:24 +0000 Subject: [PATCH] initial revision --- v7/src/edwin/argred.scm | 309 +++++++++++++++ v7/src/edwin/autold.scm | 466 ++++++++++++++++++++++ v7/src/edwin/autosv.scm | 127 ++++++ v7/src/edwin/basic.scm | 329 +++++++++++++++ v7/src/edwin/bufcom.scm | 218 ++++++++++ v7/src/edwin/buffer.scm | 417 +++++++++++++++++++ v7/src/edwin/buffrm.scm | 268 +++++++++++++ v7/src/edwin/bufmnu.scm | 347 ++++++++++++++++ v7/src/edwin/bufset.scm | 111 ++++++ v7/src/edwin/bufwfs.scm | 213 ++++++++++ v7/src/edwin/bufwin.scm | 481 ++++++++++++++++++++++ v7/src/edwin/bufwiu.scm | 382 ++++++++++++++++++ v7/src/edwin/bufwmc.scm | 164 ++++++++ v7/src/edwin/c-mode.scm | 478 ++++++++++++++++++++++ v7/src/edwin/calias.scm | 99 +++++ v7/src/edwin/class.scm | 327 +++++++++++++++ v7/src/edwin/comman.scm | 108 +++++ v7/src/edwin/comred.scm | 234 +++++++++++ v7/src/edwin/comtab.scm | 212 ++++++++++ v7/src/edwin/comwin.scm | 705 +++++++++++++++++++++++++++++++++ v7/src/edwin/curren.scm | 358 +++++++++++++++++ v7/src/edwin/debuge.scm | 132 ++++++ v7/src/edwin/dired.scm | 420 ++++++++++++++++++++ v7/src/edwin/editor.scm | 212 ++++++++++ v7/src/edwin/edtfrm.scm | 109 +++++ v7/src/edwin/evlcom.scm | 269 +++++++++++++ v7/src/edwin/filcom.scm | 434 ++++++++++++++++++++ v7/src/edwin/fileio.scm | 305 ++++++++++++++ v7/src/edwin/fill.scm | 211 ++++++++++ v7/src/edwin/hlpcom.scm | 381 ++++++++++++++++++ v7/src/edwin/image.scm | 299 ++++++++++++++ v7/src/edwin/info.scm | 658 ++++++++++++++++++++++++++++++ v7/src/edwin/input.scm | 276 +++++++++++++ v7/src/edwin/intmod.scm | 194 +++++++++ v7/src/edwin/keymap.scm | 94 +++++ v7/src/edwin/kilcom.scm | 352 ++++++++++++++++ v7/src/edwin/kmacro.scm | 258 ++++++++++++ v7/src/edwin/lincom.scm | 418 +++++++++++++++++++ v7/src/edwin/linden.scm | 367 +++++++++++++++++ v7/src/edwin/lspcom.scm | 232 +++++++++++ v7/src/edwin/macros.scm | 206 ++++++++++ v7/src/edwin/midas.scm | 83 ++++ v7/src/edwin/modefs.scm | 333 ++++++++++++++++ v7/src/edwin/modes.scm | 82 ++++ v7/src/edwin/modwin.scm | 150 +++++++ v7/src/edwin/motcom.scm | 179 +++++++++ v7/src/edwin/motion.scm | 249 ++++++++++++ v7/src/edwin/nvector.scm | 55 +++ v7/src/edwin/pasmod.scm | 174 ++++++++ v7/src/edwin/prompt.scm | 501 +++++++++++++++++++++++ v7/src/edwin/reccom.scm | 140 +++++++ v7/src/edwin/regcom.scm | 205 ++++++++++ v7/src/edwin/regexp.scm | 334 ++++++++++++++++ v7/src/edwin/regops.scm | 404 +++++++++++++++++++ v7/src/edwin/replaz.scm | 251 ++++++++++++ v7/src/edwin/ring.scm | 112 ++++++ v7/src/edwin/schmod.scm | 207 ++++++++++ v7/src/edwin/screen.scm | 234 +++++++++++ v7/src/edwin/search.scm | 366 +++++++++++++++++ v7/src/edwin/sercom.scm | 496 +++++++++++++++++++++++ v7/src/edwin/simple.scm | 198 +++++++++ v7/src/edwin/strpad.scm | 110 +++++ v7/src/edwin/strtab.scm | 262 ++++++++++++ v7/src/edwin/struct.scm | 404 +++++++++++++++++++ v7/src/edwin/syntax.scm | 430 ++++++++++++++++++++ v7/src/edwin/tagutl.scm | 314 +++++++++++++++ v7/src/edwin/texcom.scm | 213 ++++++++++ v7/src/edwin/things.scm | 316 +++++++++++++++ v7/src/edwin/tparse.scm | 279 +++++++++++++ v7/src/edwin/tximod.scm | 83 ++++ v7/src/edwin/undo.scm | 423 ++++++++++++++++++++ v7/src/edwin/utils.scm | 101 +++++ v7/src/edwin/utlwin.scm | 335 ++++++++++++++++ v7/src/edwin/wincom.scm | 444 +++++++++++++++++++++ v7/src/edwin/window.scm | 452 +++++++++++++++++++++ v7/src/edwin/xform.scm | 177 +++++++++ v7/src/runtime/rgxcmp.scm | 815 ++++++++++++++++++++++++++++++++++++++ 77 files changed, 22091 insertions(+) create mode 100644 v7/src/edwin/argred.scm create mode 100644 v7/src/edwin/autold.scm create mode 100644 v7/src/edwin/autosv.scm create mode 100644 v7/src/edwin/basic.scm create mode 100644 v7/src/edwin/bufcom.scm create mode 100644 v7/src/edwin/buffer.scm create mode 100644 v7/src/edwin/buffrm.scm create mode 100644 v7/src/edwin/bufmnu.scm create mode 100644 v7/src/edwin/bufset.scm create mode 100644 v7/src/edwin/bufwfs.scm create mode 100644 v7/src/edwin/bufwin.scm create mode 100644 v7/src/edwin/bufwiu.scm create mode 100644 v7/src/edwin/bufwmc.scm create mode 100644 v7/src/edwin/c-mode.scm create mode 100644 v7/src/edwin/calias.scm create mode 100644 v7/src/edwin/class.scm create mode 100644 v7/src/edwin/comman.scm create mode 100644 v7/src/edwin/comred.scm create mode 100644 v7/src/edwin/comtab.scm create mode 100644 v7/src/edwin/comwin.scm create mode 100644 v7/src/edwin/curren.scm create mode 100644 v7/src/edwin/debuge.scm create mode 100644 v7/src/edwin/dired.scm create mode 100644 v7/src/edwin/editor.scm create mode 100644 v7/src/edwin/edtfrm.scm create mode 100644 v7/src/edwin/evlcom.scm create mode 100644 v7/src/edwin/filcom.scm create mode 100644 v7/src/edwin/fileio.scm create mode 100644 v7/src/edwin/fill.scm create mode 100644 v7/src/edwin/hlpcom.scm create mode 100644 v7/src/edwin/image.scm create mode 100644 v7/src/edwin/info.scm create mode 100644 v7/src/edwin/input.scm create mode 100644 v7/src/edwin/intmod.scm create mode 100644 v7/src/edwin/keymap.scm create mode 100644 v7/src/edwin/kilcom.scm create mode 100644 v7/src/edwin/kmacro.scm create mode 100644 v7/src/edwin/lincom.scm create mode 100644 v7/src/edwin/linden.scm create mode 100644 v7/src/edwin/lspcom.scm create mode 100644 v7/src/edwin/macros.scm create mode 100644 v7/src/edwin/midas.scm create mode 100644 v7/src/edwin/modefs.scm create mode 100644 v7/src/edwin/modes.scm create mode 100644 v7/src/edwin/modwin.scm create mode 100644 v7/src/edwin/motcom.scm create mode 100644 v7/src/edwin/motion.scm create mode 100644 v7/src/edwin/nvector.scm create mode 100644 v7/src/edwin/pasmod.scm create mode 100644 v7/src/edwin/prompt.scm create mode 100644 v7/src/edwin/reccom.scm create mode 100644 v7/src/edwin/regcom.scm create mode 100644 v7/src/edwin/regexp.scm create mode 100644 v7/src/edwin/regops.scm create mode 100644 v7/src/edwin/replaz.scm create mode 100644 v7/src/edwin/ring.scm create mode 100644 v7/src/edwin/schmod.scm create mode 100644 v7/src/edwin/screen.scm create mode 100644 v7/src/edwin/search.scm create mode 100644 v7/src/edwin/sercom.scm create mode 100644 v7/src/edwin/simple.scm create mode 100644 v7/src/edwin/strpad.scm create mode 100644 v7/src/edwin/strtab.scm create mode 100644 v7/src/edwin/struct.scm create mode 100644 v7/src/edwin/syntax.scm create mode 100644 v7/src/edwin/tagutl.scm create mode 100644 v7/src/edwin/texcom.scm create mode 100644 v7/src/edwin/things.scm create mode 100644 v7/src/edwin/tparse.scm create mode 100644 v7/src/edwin/tximod.scm create mode 100644 v7/src/edwin/undo.scm create mode 100644 v7/src/edwin/utils.scm create mode 100644 v7/src/edwin/utlwin.scm create mode 100644 v7/src/edwin/wincom.scm create mode 100644 v7/src/edwin/window.scm create mode 100644 v7/src/edwin/xform.scm create mode 100644 v7/src/runtime/rgxcmp.scm diff --git a/v7/src/edwin/argred.scm b/v7/src/edwin/argred.scm new file mode 100644 index 000000000..3fc174e8a --- /dev/null +++ b/v7/src/edwin/argred.scm @@ -0,0 +1,309 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Command Argument Reader + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +;;;; Description +;;; +;;; 1. The reader keeps track of: +;;; +;;; [] The MAGNITUDE of the argument. If there are no digits, the +;;; magnitude is false. +;;; [] The SIGN of the argument. +;;; [] The MULTIPLIER-EXPONENT, which is the number of C-U's typed. +;;; [] Whether or not "Autoargument mode" is in effect. In autoarg +;;; mode, ordinary digits are interpreted as part of the argument; +;;; normally they are self-inserting. +;;; +;;; 2. It has the following (alterable) parameters: +;;; +;;; [] RADIX, which is between 2 and 36 inclusive. (default: 10) +;;; [] MULTIPLIER-BASE, a non-negative integer. (default: 4) +;;; +;;; 3. From these, it can compute: +;;; +;;; [] VALUE = (* MAGNITUDE MULTIPLIER-EXPONENT MULTIPLIER-BASE). +;;; If the magnitude is false, then the value is too. + +(define with-command-argument-reader) +(define reset-command-argument-reader!) +(define command-argument-beginning?) +(define command-argument-multiplier-exponent) +(define command-argument-multiplier-only?) +(define command-argument-negative-only?) +(define command-argument-negative?) +(define command-argument-prompt) +(define command-argument-value) +(define command-argument-standard-value) +(define command-argument-self-insert?) + +(define command-argument-package + (make-environment + +;;;; Commands + +(define-command ("^R Universal Argument" argument) + "Increments the argument multiplier and enters Autoarg mode. +In Autoarg mode, - negates the numeric argument, and the +digits 0, ..., 9 accumulate it." + (command-argument-increment-multiplier-exponent!) + (enter-autoargument-mode!) + (update-argument-prompt!) + (read-and-dispatch-on-char)) + +(define-command ("^R Argument Digit" argument) + "Sets the numeric argument for the next command. +Several such digits typed consecutively accumulate in the radix +specified by the variable COMMAND-ARGUMENT-RADIX (normally 10) to form +the argument. This command should *only* be placed on a character +which is a digit (modulo control/meta bits)." + (command-argument-accumulate-digit! (char-base (current-command-char))) + (update-argument-prompt!) + (read-and-dispatch-on-char)) + +(define-command ("^R Negative Argument" argument) + "Negates the numeric argument for the next command. +If no argument has yet been given, the argument defaults to -1." + (command-argument-negate!) + (update-argument-prompt!) + (read-and-dispatch-on-char)) + +(set! command-argument-self-insert? +(named-lambda (command-argument-self-insert? procedure) + (and (not *autoargument-mode?*) + (or (eq? procedure ^r-autoargument-digit-command) + (and (eq? procedure ^r-auto-negative-argument-command) + (command-argument-beginning?)))))) + +(define-command ("^R Autoargument Digit" argument) + "In Autoargument mode, sets numeric argument to the next command. +Otherwise, the digit inserts itself. This just dispatches to either +Argument Digit or Insert Self, depending on the mode." + ((if (autoargument-mode?) + ^r-argument-digit-command + ^r-insert-self-command) + argument)) + +(define-command ("^R Auto Negative Argument" argument) + "In Autoargument mode, sets numeric sign to the next command. +Otherwise, the character inserts itself. This just dispatches to either +Negative Argument or Insert Self, depending on the mode." + ((if (and *autoargument-mode?* (command-argument-beginning?)) + ^r-negative-argument-command + ^r-insert-self-command) + argument)) + +(define-command ("^R Autoargument" argument) + "Used to start a command argument and enter Autoargument mode. +This should only be placed on digits or -, with or without control +or meta bits." + (let ((char (char-base (current-command-char)))) + (if (eq? char #\-) + (if (command-argument-beginning?) + (begin (enter-autoargument-mode!) + (^r-negative-argument-command argument)) + (insert-chars char argument)) + (begin (enter-autoargument-mode!) + (^r-argument-digit-command argument))))) + +;;;; Primitives + +(set! with-command-argument-reader +(named-lambda (with-command-argument-reader thunk) + (fluid-let ((*magnitude*) + (*negative?*) + (*multiplier-exponent*) + (*autoargument-mode?*) + (*previous-prompt*)) + (thunk)))) + +(set! reset-command-argument-reader! +(named-lambda (reset-command-argument-reader!) + ;; Call this at the beginning of a command cycle. + (set! *magnitude* false) + (set! *negative?* false) + (set! *multiplier-exponent* 0) + (set! *autoargument-mode?* false) + (set! *previous-prompt* ""))) + +(set! command-argument-prompt +(named-lambda (command-argument-prompt) + (or *previous-prompt* (%command-argument-prompt)))) + +(define *previous-prompt*) + +(define (update-argument-prompt!) + (let ((prompt (%command-argument-prompt))) + (set! *previous-prompt* prompt) + (set-command-prompt! prompt))) + +(define (%command-argument-prompt) + (if (and (not *magnitude*) + (if (autoargument-mode?) + (and (not *negative?*) + (= *multiplier-exponent* 1)) + *negative?*)) + (xchar->name (current-command-char)) + (let ((prefix (if (autoargument-mode?) "Autoarg" "Arg")) + (value (command-argument-value))) + (cond (value (string-append-separated prefix (write-to-string value))) + (*negative?* (string-append-separated prefix "-")) + (else ""))))) + +;;;; Argument Number + +(define *magnitude*) +(define *radix*) +(define *negative?*) + +(define (command-argument-accumulate-digit! digit-char) + (set! *multiplier-exponent* 0) + (let ((digit (or (char->digit digit-char *radix*) + (error "Not a valid digit" digit-char)))) + (set! *magnitude* + (if (not *magnitude*) + digit + (+ digit (* *radix* *magnitude*)))))) + +(define (set-command-argument-radix! n) + (if (not (and (integer? n) (<= 2 n 36))) + (error "Radix must be an integer between 2 and 36, inclusive" n)) + (set! *radix* n)) + +(define (command-argument-negate!) + (set! *multiplier-exponent* 0) + (set! *negative?* (not *negative?*))) + +(define (command-argument-magnitude) + *magnitude*) + +(define (command-argument-radix) + *radix*) + +(set! command-argument-negative? +(named-lambda (command-argument-negative?) + *negative?*)) + +;; **** Kludge **** +(set-command-argument-radix! 10) + +;;;; Argument Multiplier + +(define *multiplier-exponent*) +(define *multiplier-base*) + +(define (command-argument-increment-multiplier-exponent!) + (set! *magnitude* false) + (set! *negative?* false) + (set! *multiplier-exponent* (1+ *multiplier-exponent*))) + +(set! command-argument-multiplier-exponent +(named-lambda (command-argument-multiplier-exponent) + *multiplier-exponent*)) + +(define (command-argument-multiplier-base) + *multiplier-base*) + +(define (set-command-argument-multiplier-base! n) + (if (not (and (integer? n) (not (negative? n)))) + (error "Multiplier Base" n "must be a non-negative integer.")) + (set! *multiplier-base* n)) + +;; **** Kludge **** +(set-command-argument-multiplier-base! 4) + +;;;; Autoargument Mode + +(define *autoargument-mode?*) + +(define (enter-autoargument-mode!) + (set! *autoargument-mode?* true)) + +(define (autoargument-mode?) + *autoargument-mode?*) + +;;;; Value + +(set! command-argument-standard-value +(named-lambda (command-argument-standard-value) + (or (command-argument-value) + (and *negative?* -1)))) + +(set! command-argument-value +(named-lambda (command-argument-value) + ;; This returns the numeric value of the argument, or false if none. + (cond (*magnitude* + (* (if *negative?* (- *magnitude*) *magnitude*) + (expt *multiplier-base* *multiplier-exponent*))) + ((not (zero? *multiplier-exponent*)) + (if *negative?* + (- (expt *multiplier-base* *multiplier-exponent*)) + (expt *multiplier-base* *multiplier-exponent*))) + (else false)))) + +(set! command-argument-multiplier-only? +(named-lambda (command-argument-multiplier-only?) + (and (not *magnitude*) + (not (zero? *multiplier-exponent*)) + *multiplier-exponent*))) + +(set! command-argument-negative-only? +(named-lambda (command-argument-negative-only?) + (and (not *magnitude*) + (zero? *multiplier-exponent*) + *negative?*))) + +(set! command-argument-beginning? +(named-lambda (command-argument-beginning?) + (and (not *magnitude*) + (not *negative?*) + (< *multiplier-exponent* 2)))) + +;;; end COMMAND-ARGUMENT-PACKAGE +)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access command-argument-package edwin-package) +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm new file mode 100644 index 000000000..8dadfe9ef --- /dev/null +++ b/v7/src/edwin/autold.scm @@ -0,0 +1,466 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Autoloads for Edwin + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +;;;; Definitions + +(define (define-autoload-major-mode name super-mode-name library-name + description) + (define mode + (make-mode name #!TRUE + (if super-mode-name + (mode-comtabs (name->mode super-mode-name)) + '()) + description + (lambda arguments + (load-library library-name) + (apply (mode-initialization mode) arguments)))) + mode) + +(define (define-autoload-minor-mode name library-name description) + (define mode + (make-mode name #!FALSE '() + description + (lambda arguments + (load-library library-name) + (apply (mode-initialization mode) arguments)))) + mode) + +(define (autoloading-mode? mode) + (or (autoloading-procedure? (mode-initialization mode) + define-autoload-major-mode) + (autoloading-procedure? (mode-initialization mode) + define-autoload-minor-mode))) + +(define (define-autoload-command name library-name description) + (define command + (make-command name description + (lambda arguments + (load-library library-name) + (apply (command-procedure command) arguments)))) + command) + +(define (autoloading-command? command) + (autoloading-procedure? (command-procedure command) + define-autoload-command)) + +(define (define-autoload-procedure package name library-name) + (local-assignment package name + (lambda arguments + (load-library library-name) + (apply (lexical-reference package name) arguments)))) + +(define (autoloading-procedure? procedure parent) + (and (compound-procedure? procedure) + (let ((environment (procedure-environment procedure))) + (and (environment? environment) + (eq? (environment-procedure environment) parent) + (access library-name environment))))) + +;;;; Libraries + +(define loaded-libraries + '()) + +(define (library-loaded? name) + (memq name loaded-libraries)) + +(define library-load-hooks + '()) + +(define (add-library-load-hook! name hook) + (if (library-loaded? name) + (hook) + (let ((entry (assq name library-load-hooks))) + (if entry + (append! entry (list hook)) + (set! library-load-hooks + (cons (list name hook) + library-load-hooks)))))) + +(define (run-library-load-hooks! name) + (let ((entry (assq name library-load-hooks))) + (define (loop) + (if (null? (cdr entry)) + (set! library-load-hooks (delq! entry library-load-hooks)) + (let ((hook (cadr entry))) + (set-cdr! entry (cddr entry)) + (hook) + (loop)))) + (if entry (loop)))) + +(define (load-library name) + (if (not (library-loaded? name)) + (let ((entry (assq name (access :libraries edwin-system)))) + (if entry + (%load-library entry) + (error "LOAD-LIBRARY: Unknown library name" name))))) + +(define (%load-library library) + (apply load-edwin-file (cdr library)) + (if (not (memq (car library) loaded-libraries)) + (set! loaded-libraries (cons (car library) loaded-libraries))) + (run-library-load-hooks! (car library))) + +;;;; Loading + +(define load-edwin-file) +(let () + +(define binary-fasload + (make-primitive-procedure 'BINARY-FASLOAD)) + +(set! load-edwin-file +(named-lambda (load-edwin-file filename purify? package) + (let ((filename (canonicalize-input-filename filename))) + (temporary-message "Loading file '" filename "'") + (let ((scode (binary-fasload filename))) + (append-message " -- done") + (if purify? + (begin (temporary-message "Purify...") + (purify scode (eq? purify? 'PURE)))) + (temporary-message "Evaluate...") + (scode-eval scode package))) + (temporary-message "Done"))) + +) + +(define-variable "Load File Default" + "Pathname given as default for \\[Load File]." + (string->pathname "EDB:FOO.BIN.0")) + +(define-command ("Load File" argument) + "Load an Edwin binary file. +An argument, if given, means purify the file too." + (let ((pathname (prompt-for-pathname "Load File" + (ref-variable "Load File Default")))) + (set-variable! "Load File Default" pathname) + (load-edwin-file pathname argument edwin-package))) + +(define-command ("Load Library" argument) + "Load an Edwin library." + (%load-library + (prompt-for-alist-value "Load Library" + (map (lambda (library) + (cons (symbol->string (car library)) + library)) + (access :libraries edwin-system))))) + +;;;; Various Libraries + +(define-variable "Info Enable Edit" + "If true, the \\[^R Info Edit] command in Info can edit the current node." + #!FALSE) + +(define-variable "Info Enable Active Nodes" + "If true, allows Info to execute Scheme code associated with nodes. +The Scheme code is executed when the node is selected." + #!TRUE) + +(define-variable "Info Directory" + "Default directory pathname for Info documentation files." + "SDOC:DIR.INFO.0") + +(define-variable "Info Previous Search" + "Default search string for Info \\[^R Info Search] command to search for." + #!FALSE) + +(define-variable "Info Tag Table Start" "") +(define-variable "Info Tag Table End" "") + +(define-autoload-command "Info" 'INFO + "Create a buffer for Info, the documentation browser program.") + +(define-variable "List Directory Unpacked" + "If not false, \\[List Directory] puts one file on each line. +Normally it packs many onto a line. +This has no effect if \\[List Directory] is invoked with an argument." + #!FALSE) + +(define-autoload-command "Dired" 'DIRED + "Edit a directory. You type the directory name.") + +(define-autoload-command "Dired Other Window" 'DIRED + "Edit a directory in another window. You type the directory name.") + +(define-autoload-command "List Directory" 'DIRED + "Generate a directory listing.") + +(define-autoload-command "Kill Rectangle" 'RECTANGLE-COMMANDS + "Delete rectangle with corners at point and mark; save as last killed one.") + +(define-autoload-command "Delete Rectangle" 'RECTANGLE-COMMANDS + "Delete (don't save) text in rectangle with point and mark as corners. +The same range of columns is deleted in each line +starting with the line where the region begins +and ending with the line where the region ends.") + +(define-autoload-command "Open Rectangle" 'RECTANGLE-COMMANDS + "Blank out rectangle with corners at point and mark, shifting text right. +The text previously in the region is not overwritten by the blanks, +but instead winds up to the right of the rectangle.") + +(define-autoload-command "Clear Rectangle" 'RECTANGLE-COMMANDS + "Blank out rectangle with corners at point and mark. +The text previously in the region is overwritten by the blanks.") + +(define-autoload-command "Yank Rectangle" 'RECTANGLE-COMMANDS + "Yank the last killed rectangle with upper left corner at point.") + +(define-autoload-procedure rectangle-package 'delete-rectangle + 'RECTANGLE-COMMANDS) + +(define-autoload-procedure rectangle-package 'yank-rectangle + 'RECTANGLE-COMMANDS) + +(define-autoload-command "Make Command Summary" 'COMMAND-SUMMARY + "Make a summary of current key bindings in the buffer *Summary*. +Previous contents of that buffer are killed first.") + +;;;; Tags Package + +(define-variable "Tags Table Pathname" + "Pathname of current tags table." + false) + +(define-autoload-command "Visit Tags Table" 'TAGS + "Tell tags commands to use a given tags table file.") + +(define-autoload-command "Find Tag" 'TAGS + "Find tag (in current tags table) whose name contains a given string. + Selects the buffer that the tag is contained in +and puts point at its definition. + With argument, searches for the next tag in the tags table that matches +the string used in the previous Find Tag.") + +(define-autoload-command "Find Tag Other Window" 'TAGS + "Like \\[Find Tag], but selects buffer in another window.") + +(define-autoload-command "Generate Tags Table" 'TAGS + "Generate a tags table from a files list of Scheme files. + A files list is a file containing only strings which are file names. + The generated tags table has the same name as the files list, except that +the file type is TAG.") + +(define-autoload-command "Tags Search" 'TAGS + "Search through all files listed in tag table for a given string. +Stops when a match is found. +To continue searching for next match, use command \\[Tags Loop Continue].") + +(define-autoload-command "RE Tags Search" 'TAGS + "Search through all files listed in tag table for a given regexp. +Stops when a match is found. +To continue searching for next match, use command \\[Tags Loop Continue].") + +(define-autoload-command "Tags Query Replace" 'TAGS + "Query replace a given string with another one though all files listed +in tag table. If you exit (C-G or Altmode), you can resume the query +replace with the command \\[Tags Loop Continue].") + +(define-autoload-command "Tags Loop Continue" 'TAGS + "Continue last \\[Tags Search] or \\[Tags Query Replace] command.") + +;;;; Debug Library + +(define-variable "Continuation Browser Student Walk" + "If true, changes \\[^R Continuation Browser Forward] and +\\[^R Continuation Browser Backward] to only walk through reductions +of subproblem 0." + #!FALSE) + +(define (debugger-scheme-error-hook environment message irritant + substitute-environment?) + (fluid-let ((processing-error? #!TRUE)) + (if (within-typein-edit + (lambda () + (let ((window (current-window))) + (define (loop) + (let ((char (char-upcase (keyboard-read-char)))) + (cond ((or (char=? #\Y char) + (char=? #\Space char)) + (insert-string "Yes" (window-point window)) + (window-direct-update! window #!FALSE) + #!TRUE) + ((or (char=? #\N char) + (char=? #\Rubout char)) + (insert-string "No" (window-point window)) + (window-direct-update! window #!FALSE) + #!FALSE) + (else + (beep) + (loop))))) + (with-output-to-mark-truncating (window-point window) + (- (window-x-size window) 15) + (lambda () + (write-string message) + (if (not (eq? irritant *the-non-printing-object*)) + (begin (write-char #\Space) + (write irritant))))) + (insert-string " -- Debug? " (window-point window)) + (beep) + (loop)))) + (begin (load-library 'DEBUG) + ((access start-debugger debugger-package))) + (abort-current-command)))) + +(define-variable "& Scheme Error Hook" + "The error hook to use for handling Scheme errors." + debugger-scheme-error-hook) + +;;;; Major Mode Libraries + +(define-autoload-major-mode "Midas" "Fundamental" 'MIDAS-MODE + "Major mode for editing assembly code.") + +(define-autoload-command "Midas Mode" 'MIDAS-MODE + "Enter Midas mode.") + +(define-variable "Midas Mode Hook" + "If not false, a thunk to call when entering Midas mode." + #!FALSE) + +(define-autoload-major-mode "Pascal" "Fundamental" 'PASCAL-MODE + "Major mode specialized for editing Pascal code.") + +(define-autoload-command "Pascal Mode" 'PASCAL-MODE + "Enter Pascal mode.") + +(define-variable "Pascal Mode Hook" + "If not false, a thunk to call when entering Pascal mode." + #!FALSE) + +(define-variable "Pascal Shift Increment" + "Indentation increment for Pascal Shift commands." + 2) + +(define-variable "Pascal Indentation Keywords" + "These keywords cause the lines below them to be indented to the right. +This must be a regular expression, or #!FALSE to disable the option." + #!FALSE) + +(define-autoload-major-mode "Texinfo" "Text" 'TEXINFO-MODE + "Major mode for editing texinfo files. +These are files that are input for TeX and also to be turned +into Info files by \\[Texinfo Format Buffer]. +These files must be written in a very restricted and +modified version of TeX input format.") + +(define-autoload-command "Texinfo Mode" 'TEXINFO-MODE + "Make the current mode be Texinfo mode.") + +(define-variable "Texinfo Mode Hook" + "A procedure to be called when Texinfo mode is entered, or false." + #!FALSE) + +(define-autoload-major-mode "C" "Fundamental" 'C-MODE + "Major mode for editing C code. +Expression and list commands understand all C brackets. +Tab indents for C code. +Comments are delimited with /* ... */. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. +The characters { } ; : correct indentation when typed. + +Variables controlling indentation style: + C Auto Newline + Non-false means automatically newline before and after braces, + and after colons and semicolons, inserted in C code. + C Indent Level + Indentation of C statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + C Continued Statement Offset + Extra indentation given to a substatement, such as the + then-clause of an if or body of a while. + C Brace Offset + Extra indentation for line if it starts with an open brace. + C Brace Imaginary Offset + An open brace following other text is treated as if it were + this far to the right of the start of its line. + C Argdecl Indent + Indentation level of declarations of C function arguments. + C Label Offset + Extra indentation for line that is a label, or case or default.") + +(define-autoload-command "C Mode" 'C-MODE + "Enter C mode.") + +(define-variable "C Mode Hook" + "If not false, a thunk to call when entering C mode." + #!FALSE) + +(define-variable "C Indent Level" + "Indentation of C statements with respect to containing block." + 2) + +(define-variable "C Brace Offset" + "Extra indentation for braces, compared with other text in same context." + 0) + +(define-variable "C Brace Imaginary Offset" + "Imagined indentation of a C open brace that actually follows a statement." + 0) + +(define-variable "C Argdecl Indent" + "Indentation level of declarations of C function arguments." + 5) + +(define-variable "C Label Offset" + "Offset of C label lines and case statements relative to usual indentation." + -2) + +(define-variable "C Continued Statement Offset" + "Extra indent for lines not starting new statements." + 2) + +(define-variable "C Auto Newline" + "Non-false means automatically newline before and after braces, +and after colons and semicolons, inserted in C code." + #!FALSE) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/autosv.scm b/v7/src/edwin/autosv.scm new file mode 100644 index 000000000..35dd5ac4e --- /dev/null +++ b/v7/src/edwin/autosv.scm @@ -0,0 +1,127 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Auto Save + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-variable "Auto Save Visited File" + "If not false, auto save into the visited file." + #!FALSE) + +(define-variable "Auto Save Default" + "If not false, auto save all visited files." + #!TRUE) + +(define-variable "Auto Save Interval" + "The number of keystrokes between auto saves." + 300) + +(define-variable "Delete Auto Save Files" + "If not false, delete auto save files when normal saves happen." + #!FALSE) + +(define-command ("Auto Save Mode" argument) + "Toggle Auto Save mode. +With argument, turn Auto Save mode on iff argument is positive." + (let ((buffer (current-buffer))) + (if (if argument + (positive? argument) + (not (buffer-auto-save-pathname buffer))) + (begin (enable-buffer-auto-save! buffer) + (temporary-message "Auto Save enabled")) + (begin (disable-buffer-auto-save! buffer) + (temporary-message "Auto Save disabled"))))) + +(define (setup-buffer-auto-save! buffer) + (if (ref-variable "Auto Save Default") + (enable-buffer-auto-save! buffer) + (disable-buffer-auto-save! buffer))) + +(define (enable-buffer-auto-save! buffer) + (define (set-to-string dirpath string) + ;; **** Crock **** + (if (> (string-length string) 15) (set-string-length! string 15)) + (set-buffer-auto-save-pathname! + buffer + (merge-pathnames dirpath + (string->pathname (string-append "&" string))))) + (let ((pathname (buffer-pathname buffer))) + (cond ((not pathname) + (set-to-string (working-directory-pathname) + (string-append "%" (buffer-name buffer)))) + ((ref-variable "Auto Save Visited File") + (set-buffer-auto-save-pathname! buffer pathname)) + (else + (set-to-string + (pathname-extract pathname 'DEVICE 'DIRECTORY) + (pathname->string (pathname-extract pathname 'NAME 'TYPE))))))) + +(define (disable-buffer-auto-save! buffer) + (set-buffer-auto-save-pathname! buffer #!FALSE)) + +(define *auto-save-keystroke-count*) + +(define (do-auto-save) + (let ((buffers + (list-transform-positive (buffer-list) + (lambda (buffer) + (and (buffer-auto-save-pathname buffer) + (buffer-auto-save-modified? buffer) + (<= (* 10 (buffer-save-length buffer)) + (* 13 (buffer-length buffer)))))))) + (if (not (null? buffers)) + (begin (temporary-message "Auto saving...") + (for-each auto-save-buffer buffers) + (clear-message)))) + (set! *auto-save-keystroke-count* 0)) + +(define (auto-save-buffer buffer) + (region->file (buffer-unclipped-region buffer) + (buffer-auto-save-pathname buffer)) + (set-buffer-save-length! buffer) + (set-buffer-auto-saved! buffer)) + +(define (delete-auto-save-file! buffer) + (if (and (ref-variable "Delete Auto Save Files") + (buffer-auto-save-pathname buffer) + (file-exists? (buffer-auto-save-pathname buffer))) + (delete-file (buffer-auto-save-pathname buffer)))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm new file mode 100644 index 000000000..732d9d99d --- /dev/null +++ b/v7/src/edwin/basic.scm @@ -0,0 +1,329 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Basic Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("^R Bad Command" argument) + "This command is used to capture undefined keys. +It is usually called directly by the command lookup +procedure when it fails to find a command." + (editor-error "Undefined command: " (xchar->name (current-command-char)))) + +(define-command ("^R Insert Self" (argument 1)) + "Insert the character used to invoke this. +With an argument, insert the character that many times." + (insert-chars (current-command-char) argument)) + +(define-command ("^R Quoted Insert" (argument 1)) + "Reads a character and inserts it." + (define (read-char) + (let ((char (keyboard-read-char))) + (set-command-prompt! (string-append (command-prompt) (char->name char))) + char)) + + (define (read-digit) + (or (char->digit (read-char) 8) + (editor-error "Not an octal digit"))) + + (set-command-prompt! "Quote Character: ") + (insert-chars (let ((char (read-char))) + (let ((digit (char->digit char 4))) + (if digit + (ascii->char + (let ((digit2 (read-digit))) + (let ((digit3 (read-digit))) + (+ (* (+ (* digit 8) digit2) 8) digit3)))) + char))) + argument)) + +(define-command ("^R Open Line" (argument 1)) + "Insert a newline after point. +Differs from ordinary insertion in that point remains +before the inserted characters. +With an argument, inserts several newlines." + (let ((m* (mark-right-inserting (current-point)))) + (insert-newlines argument) + (set-current-point! m*))) + +(define (xchar->name char) + (if (pair? char) + (chars->name char) + (char->name char))) + +(define (chars->name chars) + (if (null? chars) + "" + (string-append-separated (char->name (car chars)) + (chars->name (cdr chars))))) + +(define (string-append-separated x y) + (cond ((string-null? x) y) + ((string-null? y) x) + (else (string-append x " " y)))) + +(define (editor-error . strings) + (if (not (null? strings)) (apply temporary-message strings)) + (beep) + (abort-current-command)) + +(define (editor-failure . strings) + (cond ((not (null? strings)) (apply temporary-message strings)) + (*defining-keyboard-macro?* (clear-message))) + (beep) + (keyboard-macro-disable)) + +(define (not-implemented) + (editor-error "Not yet implemented")) + +(define-command ("^R Prefix Control" argument) + "Sets Control-bit of following character. +This command followed by an = is equivalent to a Control-=." + (read-extension-char "C-" char-controlify)) + +(define-command ("^R Prefix Meta" argument) + "Sets Meta-bit of following character. +Turns a following A into a Meta-A. +If the Metizer character is Altmode, it turns ^A +into Control-Meta-A. Otherwise, it turns ^A into plain Meta-A." + (read-extension-char "M-" + (if (let ((char (current-command-char))) + (and (char? char) + (char=? #\Altmode char))) + char-metafy + (lambda (char) + (char-metafy (char-base char)))))) + +(define-command ("^R Prefix Control-Meta" argument) + "Sets Control- and Meta-bits of following character. +Turns a following A (or C-A) into a Control-Meta-A." + (read-extension-char "C-M-" char-control-metafy)) + +(define execute-extended-chars? + true) + +(define extension-commands + (list (name->command "^R Prefix Control") + (name->command "^R Prefix Meta") + (name->command "^R Prefix Control-Meta"))) + +(define (read-extension-char prefix-string modifier) + (if execute-extended-chars? + (set-command-prompt-prefix! prefix-string)) + (let ((char (modifier (keyboard-read-char)))) + (if execute-extended-chars? + (dispatch-on-char (current-comtab) char) + char))) + +(define (set-command-prompt-prefix! prefix-string) + (set-command-prompt! + (string-append-separated (command-argument-prompt) + prefix-string))) + +(define-command ("^R Prefix Character" argument) + "This is a prefix for more commands. +It reads another character (a subcommand) and dispatches on it." + (let ((prefix-char (current-command-char))) + (set-command-prompt-prefix! (string-append (xchar->name prefix-char) " ")) + (dispatch-on-char (current-comtab) + ((if (pair? prefix-char) append cons) + prefix-char + (list (keyboard-read-char)))))) + +(define-command ("^R Extended Command" argument) + "Read an extended command from the terminal with completion. +This command reads the name of a function, with completion. Then the +function is called. Completion is done as the function name is typed +For more information type the HELP key while entering the name." + (dispatch-on-command (prompt-for-command "Extended Command"))) + +(define-command ("^R Return to Superior" argument) + "Go back to Scheme's superior job. +With argument, saves visited file first." + (if argument (^r-save-file-command)) + (quit) + (update-alpha-window! true)) + +(define-command ("^R Scheme" argument) + "Stop Edwin and return to Scheme." + (editor-abort *the-non-printing-object*)) + +(define-command ("^R Exit" argument) + "Exit normally from a subsystem of a level of editing. +At top level, exit from Edwin like \\[^R Return to Superior]." + (exit-recursive-edit 'EXIT)) + +(define-command ("Abort Recursive Edit" argument) + "Abnormal exit from recursive editing command. +The recursive edit is exited and the command that invoked it is aborted. +For a normal exit, you should use \\[^R Exit], NOT this command." + (exit-recursive-edit 'ABORT)) + +(define-command ("^R Narrow Bounds to Region" argument) + "Restrict editing in current buffer to text between point and mark. +Use \\[^R Widen Bounds] to undo the effects of this command." + (region-clip! (current-region))) + +(define-command ("^R Widen Bounds" argument) + "Remove restrictions from current buffer. +Allows full text to be seen and edited." + (buffer-widen! (current-buffer))) + +(define-command ("Set Key" argument) + "Define a key binding from the keyboard. +Prompts for a command and a key, and sets the key's binding. +The key is bound in Fundamental Mode." + (let ((command (prompt-for-command "Command"))) + (let ((key (prompt-for-key (string-append "Put \"" + (command-name command) + "\" on key") + (mode-comtabs fundamental-mode)))) + (if (prompt-for-confirmation? "Go ahead") + (define-key "Fundamental" key (command-name command)))))) + +;;;; Comment Commands + +(define-variable "Comment Column" + "Column to indent right-margin comments to." + 32) + +(define-variable "Comment Locator Hook" + "Procedure to find a comment, or false if no comment syntax defined. +The procedure is passed a mark, and should return false if it cannot +find a comment, or a pair of marks. The car should be the start of +the comment, and the cdr should be the end of the comment's starter." + false) + +(define-variable "Comment Indent Hook" + "Procedure to compute desired indentation for a comment. +The procedure is passed the start mark of the comment +and should return the column to indent the comment to." + false) + +(define-variable "Comment Start" + "String to insert to start a new comment." + "") + +(define-variable "Comment End" + "String to insert to end a new comment. +This should be a null string if comments are terminated by Newline." + "") + +(define-command ("^R Set Comment Column" argument) + "Set the comment column based on point. +With no arg, set the comment column to the current column. +With just minus as an arg, kill any comment on this line. +Otherwise, set the comment column to the argument." + (cond ((command-argument-negative-only?) + (^r-kill-comment-command)) + (else + (set! comment-column (or argument (current-column))) + (message "Comment column set to " (write-to-string comment-column))))) + +(define-command ("^R Indent for Comment" argument) + "Indent this line's comment to comment column, or insert an empty comment." + (if (not (ref-variable "Comment Locator Hook")) + (editor-error "No comment syntax defined") + (let ((start (line-start (current-point) 0)) + (end (line-end (current-point) 0))) + (let ((com ((ref-variable "Comment Locator Hook") start))) + (set-current-point! (if com (car com) end)) + (if com (mark-permanent! (cdr com))) + (let ((indent ((ref-variable "Comment Indent Hook") + (current-point)))) + (maybe-change-column indent) + (if com + (set-current-point! (cdr com)) + (begin (insert-string (ref-variable "Comment Start")) + (insert-comment-end)))))))) + +(define-variable "Comment Multi Line" + "If true, means \\[^R Indent New Comment Line] should continue same comment +on new line, with no new terminator or starter." + false) + +(define-command ("^R Indent New Comment Line" argument) + "Break line at point and indent, continuing comment if presently within one." + (define (if-not-in-comment) + (if (ref-variable "Fill Prefix") + (insert-string (ref-variable "Fill Prefix")) + (^r-indent-according-to-mode-command))) + (delete-horizontal-space) + (insert-newlines 1) + (if (ref-variable "Comment Locator Hook") + (let ((com ((ref-variable "Comment Locator Hook") + (line-start (current-point) -1)))) + (if com + (let ((start-column (mark-column (car com))) + (end-column (mark-column (cdr com))) + (comment-start (extract-string (car com) (cdr com)))) + (if (ref-variable "Comment Multi Line") + (maybe-change-column end-column) + (begin (insert-string (ref-variable "Comment End") + (line-end (current-point) -1)) + (maybe-change-column start-column) + (insert-string comment-start))) + (if (line-end? (current-point)) + (insert-comment-end))) + (if-not-in-comment))) + (if-not-in-comment))) + +(define (insert-comment-end) + (let ((point (mark-right-inserting (current-point)))) + (insert-string (ref-variable "Comment End")) + (set-current-point! point))) + +(define-command ("^R Kill Comment" argument) + "Kill the comment on this line, if any." + (if (not (ref-variable "Comment Locator Hook")) + (editor-error "No comment syntax defined") + (let ((start (line-start (current-point) 0)) + (end (line-end (current-point) 0))) + (let ((com ((ref-variable "Comment Locator Hook") start))) + (if com + (kill-string (horizontal-space-start (car com)) end)))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/bufcom.scm b/v7/src/edwin/bufcom.scm new file mode 100644 index 000000000..339cef5df --- /dev/null +++ b/v7/src/edwin/bufcom.scm @@ -0,0 +1,218 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("^R Buffer Not Modified" argument) + "Pretend that this buffer hasn't been altered." + (buffer-not-modified! (current-buffer))) + +(define-command ("Select Buffer" argument) + "Select buffer with specified name. +If the variable Select Buffer Create is true, +specifying a non-existent buffer will cause it to be created." + (select-buffer (prompt-for-select-buffer "Select Buffer"))) + +(define-command ("Select Buffer Other Window" argument) + "Select buffer in another window." + (select-buffer-other-window + (prompt-for-select-buffer "Select Buffer Other Window"))) + +(define-variable "Select Buffer Create" + "If true, buffer selection commands may create new buffers." + true) + +(define (prompt-for-select-buffer prompt) + ((if (ref-variable "Select Buffer Create") + prompt-for-buffer prompt-for-existing-buffer) + prompt (previous-buffer))) + +(define-command ("Create Buffer" argument) + "Create a new buffer with a given name, and select it." + (let ((buffer (new-buffer (prompt-for-string "Create Buffer" false)))) + (set-buffer-major-mode! buffer (ref-variable "Editor Default Mode")) + (select-buffer buffer))) + +(define-command ("Insert Buffer" argument) + "Insert the contents of a specified buffer at point." + (let ((point (mark-right-inserting (current-point)))) + (region-insert-string! + point + (region->string + (buffer-region (prompt-for-existing-buffer "Insert Buffer" false)))) + (push-current-mark! (current-point)) + (set-current-point! point))) + +(define-command ("^R Twiddle Buffers" argument) + "Select previous buffer." + (let ((buffer (previous-buffer))) + (if buffer + (select-buffer buffer) + (editor-error "No previous buffer to select")))) + +(define-command ("Bury Current Buffer" argument) + "Deselect the current buffer, putting it at the end of the buffer list." + (let ((buffer (current-buffer)) + (previous (previous-buffer))) + (if previous + (begin (select-buffer previous) + (bury-buffer buffer))))) + +(define-command ("Kill Buffer" argument) + "Kill the buffer with specified name. +Does a completing read of the buffer name in the echo area. +If the buffer has changes in it, we offer to write it out." + (kill-buffer-interactive + (prompt-for-existing-buffer "Kill Buffer" (current-buffer)))) + +(define (kill-buffer-interactive buffer) + (if (not (other-buffer buffer)) (editor-error "Only one buffer")) + (save-buffer-changes buffer) + (kill-buffer buffer)) + +(define-command ("Kill Some Buffers" argument) + "For each buffer, ask whether to kill it." + (kill-some-buffers true)) + +(define (kill-some-buffers prompt?) + (for-each (lambda (buffer) + (if (and (not (minibuffer? buffer)) + (or (not prompt?) + (prompt-for-confirmation? + (string-append "Kill buffer '" + (buffer-name buffer) + "'")))) + (if (other-buffer buffer) + (kill-buffer-interactive buffer) + (let ((dummy (new-buffer "*Dummy*"))) + (kill-buffer-interactive buffer) + (set-buffer-major-mode! + (create-buffer initial-buffer-name) + (ref-variable "Editor Default Mode")) + (kill-buffer dummy))))) + (buffer-list))) + +(define-command ("Rename Buffer" argument) + "Change the name of the current buffer. +Reads the new name in the echo area." + (let ((buffer (current-buffer))) + (let ((name + (prompt-for-string "Rename Buffer" + (let ((pathname (buffer-pathname buffer))) + (and pathname + (pathname->buffer-name pathname)))))) + (if (find-buffer name) + (editor-error "Buffer named " name " already exists")) + (rename-buffer buffer name)))) + +(define-command ("Normal Mode" argument) + "Reset mode and local variable bindings to their default values. +Just like what happens when the file is first visited." + (initialize-buffer! (current-buffer))) + +(define (save-buffer-changes buffer) + (if (and (buffer-pathname buffer) + (buffer-modified? buffer) + (buffer-writeable? buffer) + (prompt-for-yes-or-no? + (string-append "Buffer " + (buffer-name buffer) + " contains changes. Write them out"))) + (write-buffer-interactive buffer))) + +(define (new-buffer name) + (define (search-loop n) + (let ((new-name (string-append name "<" (write-to-string n) ">"))) + (if (find-buffer new-name) + (search-loop (1+ n)) + new-name))) + (create-buffer (let ((buffer (find-buffer name))) + (if buffer + (search-loop 2) + name)))) +(define (with-output-to-temporary-buffer name thunk) + (let ((buffer (temporary-buffer name))) + (with-output-to-mark (buffer-point buffer) thunk) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (pop-up-buffer buffer false))) + +(define (temporary-buffer name) + (let ((buffer (find-or-create-buffer name))) + (buffer-reset! buffer) + buffer)) + +(define (prompt-for-buffer prompt default-buffer) + (let ((name (prompt-for-buffer-name prompt default-buffer))) + (or (find-buffer name) + (let ((buffer (create-buffer name))) + (set-buffer-major-mode! buffer (ref-variable "Editor Default Mode")) + (temporary-message "(New Buffer)") + buffer)))) + +(define (prompt-for-buffer-name prompt default-buffer) + (prompt-for-completed-string prompt + (and default-buffer + (buffer-name default-buffer)) + (if default-buffer + 'VISIBLE-DEFAULT + 'NO-DEFAULT) + (buffer-names) + 'PERMISSIVE-COMPLETION)) + +(define (prompt-for-existing-buffer prompt default-buffer) + (find-buffer + (prompt-for-completed-string prompt + (and default-buffer + (buffer-name default-buffer)) + (if default-buffer + 'VISIBLE-DEFAULT + 'NO-DEFAULT) + (buffer-names) + 'STRICT-COMPLETION))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm new file mode 100644 index 000000000..8d870097b --- /dev/null +++ b/v7/src/edwin/buffer.scm @@ -0,0 +1,417 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Abstraction + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-named-structure "Buffer" + name + group + mark-ring + modes + comtabs + windows + cursor-y + pathname + truename + writeable? + alist + local-bindings + initializations + auto-save-pathname + auto-save-modified? + save-length) + +(define-variable "Mark Ring Maximum" + "The maximum number of entries to keep in the mark ring." + 16) + +(define-variable "Buffer Creation Hook" + "If not false, a procedure to call when a new buffer is created. +The procedure is passed the new buffer as its argument. +The buffer is guaranteed to be deselected at that time." + #!FALSE) + +(define-unparser %buffer-tag + (lambda (buffer) + (write-string "Buffer ") + (write (buffer-name buffer)))) + +(define (make-buffer name #!optional mode) + (if (unassigned? mode) (set! mode fundamental-mode)) + (let ((group (region-group (string->region "")))) + (let ((buffer (%make-buffer))) + (vector-set! buffer buffer-index:name name) + (vector-set! buffer buffer-index:group group) + (let ((daemon (buffer-modification-daemon buffer))) + (add-group-insert-daemon! group daemon) + (add-group-delete-daemon! group daemon)) + (if (not (minibuffer? buffer)) + (enable-group-undo! group)) + (vector-set! buffer buffer-index:mark-ring + (make-ring (ref-variable "Mark Ring Maximum"))) + (ring-push! (buffer-mark-ring buffer) (group-start-mark group)) + (vector-set! buffer buffer-index:modes (list mode)) + (vector-set! buffer buffer-index:comtabs (mode-comtabs mode)) + (vector-set! buffer buffer-index:windows '()) + (vector-set! buffer buffer-index:cursor-y #!FALSE) + (vector-set! buffer buffer-index:pathname #!FALSE) + (vector-set! buffer buffer-index:truename #!FALSE) + (vector-set! buffer buffer-index:writeable? #!TRUE) + (vector-set! buffer buffer-index:alist '()) + (vector-set! buffer buffer-index:local-bindings '()) + (vector-set! buffer buffer-index:initializations + (list (mode-initialization mode))) + (vector-set! buffer buffer-index:auto-save-pathname #!FALSE) + (vector-set! buffer buffer-index:auto-save-modified? #!FALSE) + (vector-set! buffer buffer-index:save-length 0) + (if (ref-variable "Buffer Creation Hook") + ((ref-variable "Buffer Creation Hook") buffer)) + buffer))) + +(define (buffer-reset! buffer) + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + (buffer-not-modified! buffer) + (let ((group (buffer-group buffer))) + (if (group-undo-data group) + (undo-done! (group-point group)))) + (buffer-widen! buffer) + (set-buffer-major-mode! buffer (buffer-major-mode buffer)) + (without-interrupts + (lambda () + (vector-set! buffer buffer-index:pathname #!FALSE) + (vector-set! buffer buffer-index:truename #!FALSE) + (buffer-modeline-event! buffer 'BUFFER-PATHNAME) + (vector-set! buffer buffer-index:auto-save-pathname #!FALSE) + (vector-set! buffer buffer-index:auto-save-modified? #!FALSE) + (vector-set! buffer buffer-index:save-length 0)))) + +(define (set-buffer-name! buffer name) + (vector-set! buffer buffer-index:name name) + (buffer-modeline-event! buffer 'BUFFER-NAME)) + +(define (set-buffer-pathname! buffer pathname) + (vector-set! buffer buffer-index:pathname pathname) + (buffer-modeline-event! buffer 'BUFFER-PATHNAME)) + +(define (set-buffer-truename! buffer truename) + (vector-set! buffer buffer-index:truename truename) + (buffer-modeline-event! buffer 'BUFFER-TRUENAME)) + +(define-integrable (set-buffer-auto-save-pathname! buffer pathname) + (vector-set! buffer buffer-index:auto-save-pathname pathname)) + +(define-integrable (set-buffer-auto-saved! buffer) + (vector-set! buffer buffer-index:auto-save-modified? #!FALSE)) + +(define-integrable (set-buffer-save-length! buffer) + (vector-set! buffer buffer-index:save-length (buffer-length buffer))) + +(define-integrable (set-buffer-comtabs! buffer comtabs) + (vector-set! buffer buffer-index:comtabs comtabs)) + +(define-integrable (buffer-point buffer) + (group-point (buffer-group buffer))) + +(define-integrable (%set-buffer-point! buffer mark) + (set-group-point! (buffer-group buffer) mark)) + +(define (minibuffer? buffer) + (char=? (string-ref (buffer-name buffer) 0) #\Space)) + +(define-integrable (buffer-region buffer) + (group-region (buffer-group buffer))) + +(define-integrable (buffer-unclipped-region buffer) + (group-unclipped-region (buffer-group buffer))) + +(define-integrable (buffer-widen! buffer) + (group-un-clip! (buffer-group buffer))) + +(define-integrable (buffer-length buffer) + (group-length (buffer-group buffer))) + +(define-integrable (buffer-start buffer) + (group-start-mark (buffer-group buffer))) + +(define-integrable (buffer-end buffer) + (group-end-mark (buffer-group buffer))) + +(define (add-buffer-window! buffer window) + (vector-set! buffer buffer-index:windows + (cons window (vector-ref buffer buffer-index:windows)))) + +(define (remove-buffer-window! buffer window) + (vector-set! buffer buffer-index:windows + (delq! window (vector-ref buffer buffer-index:windows)))) + +(define-integrable (set-buffer-cursor-y! buffer cursor-y) + (vector-set! buffer buffer-index:cursor-y cursor-y)) + +(define-integrable (buffer-visible? buffer) + (not (null? (buffer-windows buffer)))) + +(define (buffer-get buffer key) + (let ((entry (assq key (vector-ref buffer buffer-index:alist)))) + (and entry (cdr entry)))) + +(define (buffer-put! buffer key value) + (let ((entry (assq key (vector-ref buffer buffer-index:alist)))) + (if entry + (set-cdr! entry value) + (vector-set! buffer buffer-index:alist + (cons (cons key value) + (vector-ref buffer buffer-index:alist)))))) + +(define (buffer-remove! buffer key) + (vector-set! buffer buffer-index:alist + (del-assq! key + (vector-ref buffer buffer-index:alist)))) + +(define-integrable (reset-buffer-alist! buffer) + (vector-set! buffer buffer-index:alist '())) + +;;;; Modification Flags + +(define-integrable (buffer-modified? buffer) + (group-modified? (buffer-group buffer))) + +(define-integrable (buffer-not-modified! buffer) + (set-buffer-modified! buffer #!FALSE)) + +(define-integrable (buffer-modified! buffer) + (set-buffer-modified! buffer #!TRUE)) + +(define (set-buffer-modified! buffer sense) + (set-group-modified! (buffer-group buffer) sense) + (vector-set! buffer buffer-index:auto-save-modified? sense) + (buffer-modeline-event! buffer 'BUFFER-MODIFIED)) + +;; Open coded for speed. +(define ((buffer-modification-daemon buffer) group start end) + (if (not (group-modified? group)) + (begin (set-group-modified! group #!TRUE) + (buffer-modeline-event! buffer 'BUFFER-MODIFIED))) + (vector-set! buffer buffer-index:auto-save-modified? #!TRUE)) + +(define-integrable (buffer-read-only? buffer) + (group-read-only? (buffer-group buffer))) + +(define (set-buffer-writeable! buffer) + (set-group-writeable! (buffer-group buffer)) + (vector-set! buffer buffer-index:writeable? #!TRUE) + (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE)) + +(define (set-buffer-file-read-only! buffer) + (set-group-writeable! (buffer-group buffer)) + (vector-set! buffer buffer-index:writeable? #!FALSE) + (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE)) + +(define (set-buffer-read-only! buffer) + (set-group-read-only! (buffer-group buffer)) + (vector-set! buffer buffer-index:writeable? #!FALSE) + (buffer-modeline-event! buffer 'BUFFER-MODIFIABLE)) + +(define (with-read-only-defeated mark thunk) + (let ((group (mark-group mark))) + (define read-only?) + (dynamic-wind (lambda () + (set! read-only? (group-read-only? group)) + (if read-only? + (set-group-writeable! group))) + thunk + (lambda () + (if read-only? + (set-group-read-only! group)))))) + +;;;; Modeline Interface + +(define (buffer-modeline-event! buffer type) + (define (loop windows) + (if (not (null? windows)) + (begin (window-modeline-event! (car windows) type) + (loop (cdr windows))))) + (loop (buffer-windows buffer))) + +(define (buffer-display-name buffer) + (let ((name (buffer-name buffer)) + (pathname (buffer-pathname buffer))) + (define (display-string name*) + (define (append-version version) + (string-append name* " (" (write-to-string version) ")")) + (string-append + (if (pathname-version pathname) + (let ((truename (buffer-truename buffer))) + (if (not truename) + (append-version + (let ((version (pathname-version pathname))) + (if (integer? version) version 0))) + (let ((version (pathname-version truename))) + (if version (append-version version) name*)))) + name*) + " " + (pathname->string (pathname-extract pathname 'DEVICE 'DIRECTORY)))) + (if (not pathname) + name + (let ((name* (pathname->buffer-name pathname))) + (if (or (string-ci=? name name*) + (let ((i (string-match-forward-ci name name*))) + (and i + (= i (string-length name*)) + (char=? (string-ref name i) #\<)))) + (display-string name) + (string-append name " [" (display-string name*) "]")))))) + +;;;; Local Bindings + +(define (make-local-binding! name #!optional new-value) + (without-interrupts + (lambda () + (let ((buffer (current-buffer)) + (value (lexical-assignment edwin-package name (set! new-value)))) + (let ((bindings (buffer-local-bindings buffer))) + (let ((binding (assq name bindings))) + (if (not binding) + (vector-set! buffer buffer-index:local-bindings + (cons (cons name value) bindings))))))))) + +(define (unmake-local-binding! name) + (without-interrupts + (lambda () + (let ((buffer (current-buffer))) + (let ((bindings (buffer-local-bindings buffer))) + (let ((binding (assq name bindings))) + (if binding + (begin (lexical-assignment edwin-package name (cdr binding)) + (vector-set! buffer buffer-index:local-bindings + (delq! binding bindings)))))))))) + +(define (undo-local-bindings!) + (without-interrupts + (lambda () + (let ((buffer (current-buffer))) + (for-each (lambda (binding) + (lexical-assignment edwin-package + (car binding) + (cdr binding))) + (buffer-local-bindings buffer)) + (vector-set! buffer buffer-index:local-bindings '()))))) + +(define (%wind-local-bindings! buffer) + ;; Assumes that interrupts are disabled and that BUFFER is selected. + (for-each (lambda (binding) + (set-cdr! binding + (lexical-assignment edwin-package + (car binding) + (cdr binding)))) + (buffer-local-bindings buffer))) +;;;; Modes + +(define-integrable (buffer-major-mode buffer) + (car (buffer-modes buffer))) + +(define (set-buffer-major-mode! buffer mode) + (if (not (mode-major? mode)) (error "Not a major mode" mode)) + (without-interrupts + (lambda () + (let ((modes (buffer-modes buffer))) + (set-car! modes mode) + (set-cdr! modes '())) + (set-buffer-comtabs! buffer (mode-comtabs mode)) + (vector-set! buffer buffer-index:alist '()) + (buffer-modeline-event! buffer 'BUFFER-MODES) + (vector-set! buffer buffer-index:initializations '()) + (add-buffer-initialization! buffer undo-local-bindings!) + (add-buffer-initialization! buffer (mode-initialization mode))))) + +(define (buffer-minor-mode? buffer mode) + (if (mode-major? mode) (error "Not a minor mode" mode)) + (memq mode (buffer-modes buffer))) + +(define (enable-buffer-minor-mode! buffer mode) + (if (mode-major? mode) (error "Not a minor mode" mode)) + (without-interrupts + (lambda () + (let ((modes (buffer-modes buffer))) + (if (not (memq mode (cdr modes))) + (begin (set-cdr! modes (append! (cdr modes) (list mode))) + (set-buffer-comtabs! buffer + (cons (mode-comtab mode) + (buffer-comtabs buffer))) + (buffer-modeline-event! buffer 'BUFFER-MODES) + (add-buffer-initialization! buffer + (mode-initialization mode)))))))) + +(define (disable-buffer-minor-mode! buffer mode) + (if (mode-major? mode) (error "Not a minor mode" mode)) + (without-interrupts + (lambda () + (let ((modes (buffer-modes buffer))) + (if (memq mode (cdr modes)) + (begin (set-cdr! modes (delq! mode (cdr modes))) + (set-buffer-comtabs! buffer + (delq! (mode-comtab mode) + (buffer-comtabs buffer))) + (buffer-modeline-event! buffer 'BUFFER-MODES))))))) + +(define (add-buffer-initialization! buffer thunk) + (if (eq? buffer (current-buffer)) + (thunk) + (vector-set! buffer buffer-index:initializations + (append! (buffer-initializations buffer) (list thunk))))) + +(define (perform-buffer-initializations! buffer) + ;; Assumes that BUFFER is selected. + (define (loop) + (let ((thunks (buffer-initializations buffer))) + (if (not (null? thunks)) + (begin (vector-set! buffer buffer-index:initializations + (cdr thunks)) + ((car thunks)) + (loop))))) + (loop)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm new file mode 100644 index 000000000..1679c35de --- /dev/null +++ b/v7/src/edwin/buffrm.scm @@ -0,0 +1,268 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Frames + +(declare (usual-integrations) + (integrate-external "edb:comwin.bin.0")) +(using-syntax class-syntax-table + +(define-class buffer-frame combination-leaf-window + (text-inferior border-inferior modeline-inferior last-select-time)) + +(define (buffer-frame? object) + (object-of-class? buffer-frame object)) + +(define (make-buffer-frame superior new-buffer modeline?) + (let ((frame (=> superior :make-inferior buffer-frame))) + (initial-buffer! (frame-text-inferior frame) new-buffer) + (initial-modeline! frame modeline?) + frame)) + +(define-method buffer-frame (:make-leaf frame) + (let ((frame* (=> superior :make-inferior buffer-frame))) + (initial-buffer! (frame-text-inferior frame*) (window-buffer frame)) + (initial-modeline! frame* modeline-inferior) + frame*)) + +(define-method buffer-frame (:initialize! frame window*) + (usual=> frame :initialize! window*) + (set! text-inferior (make-inferior frame buffer-window)) + (set! border-inferior (make-inferior frame vertical-border-window)) + (set! last-select-time 0)) + +;;; **** Kludge: The text-inferior will generate modeline events, so +;;; if the modeline gets redisplayed first it will be left with its +;;; redisplay-flag set but its superior's redisplay-flag cleared. + +(define-procedure buffer-frame (initial-modeline! frame modeline?) + (if modeline? + (begin (set! modeline-inferior (make-inferior frame modeline-window)) + (set! inferiors + (append! (delq! modeline-inferior inferiors) + (list modeline-inferior)))) + (set! modeline-inferior #!FALSE))) + +(define-procedure buffer-frame (window-cursor frame) + (%window-cursor (inferior-window text-inferior))) + +(declare (integrate frame-text-inferior)) +(define-procedure buffer-frame (frame-text-inferior frame) + (declare (integrate frame)) + (inferior-window text-inferior)) + +(define-procedure buffer-frame (frame-modeline-inferior frame) + (and modeline-inferior + (inferior-window modeline-inferior))) + +(define-procedure buffer-frame (window-modeline-event! frame type) + (if modeline-inferior + (=> (inferior-window modeline-inferior) :event! type))) + +(define-procedure buffer-frame (window-select-time frame) + last-select-time) + +(define-procedure buffer-frame (set-window-select-time! frame time) + (set! last-select-time time)) + +(define-procedure buffer-frame (set-buffer-frame-size! window x y) + (usual=> window :set-size! x y) + (if (window-has-right-neighbor? window) + (let ((x* (- x (inferior-x-size border-inferior)))) + (set-inferior-start! border-inferior x* 0) + (set-inferior-y-size! border-inferior y) + (set! x x*)) + (set-inferior-start! border-inferior #!FALSE #!FALSE)) + (if modeline-inferior + (let ((y* (- y (inferior-y-size modeline-inferior)))) + (set-inferior-start! modeline-inferior 0 y*) + (set-inferior-x-size! modeline-inferior x) + (set! y y*))) + (set-inferior-start! text-inferior 0 0) + (set-inferior-size! text-inferior x y)) + +(define-method buffer-frame :set-size! + set-buffer-frame-size!) + +(define-method buffer-frame (:set-x-size! window x) + (set-buffer-frame-size! window x y-size)) + +(define-method buffer-frame (:set-y-size! window y) + (set-buffer-frame-size! window x-size y)) + +(define-method buffer-frame (:minimum-x-size window) + (if (window-has-right-neighbor? window) + (+ (ref-variable "Window Minimum Width") + (inferior-x-size border-inferior)) + (ref-variable "Window Minimum Width"))) + +(define-method buffer-frame (:minimum-y-size window) + (if modeline-inferior + (+ (ref-variable "Window Minimum Height") + (inferior-y-size modeline-inferior)) + (ref-variable "Window Minimum Height"))) + +;;;; External Entries + +(define (window-buffer frame) + (%window-buffer (frame-text-inferior frame))) + +(define (set-window-buffer! frame buffer) + (if (and (string-ci=? (buffer-name buffer) "Bluffer") + (null? (buffer-windows buffer))) + (buffer-reset! buffer)) + (%set-window-buffer! (frame-text-inferior frame) buffer)) + +(define (window-point frame) + (%window-point (frame-text-inferior frame))) + +(define (set-window-point! frame point) + (let ((window (frame-text-inferior frame))) + (%set-window-point! window (clip-mark-to-display window point)))) + +(define (window-redraw! frame #!optional preserve-point?) + (if (unassigned? preserve-point?) (set! preserve-point? #!FALSE)) + (let ((window (frame-text-inferior frame))) + (%window-redraw! window + (if preserve-point? + (%window-point-y window) + (%window-y-center window))))) + +(define (window-direct-update! frame display-style) + (%window-direct-update! (frame-text-inferior frame) display-style)) + +(define-procedure buffer-frame (window-needs-redisplay? frame) + (car (inferior-redisplay-flags text-inferior))) + +(define (direct-output-insert-char! frame char) + (%direct-output-insert-char! (frame-text-inferior frame) char)) + +(define (direct-output-insert-newline! frame) + (%direct-output-insert-newline! (frame-text-inferior frame))) + +(define (direct-output-insert-substring! frame string start end) + (%direct-output-insert-substring! (frame-text-inferior frame) + string start end)) + +(define (direct-output-forward-character! frame) + (%direct-output-forward-character! (frame-text-inferior frame))) + +(define (direct-output-backward-character! frame) + (%direct-output-backward-character! (frame-text-inferior frame))) + +(define (window-scroll-y-absolute! frame y-point) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-scroll-y-absolute! window y-point))) + +(define (window-scroll-y-relative! frame delta) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-scroll-y-relative! window delta))) + +(define (window-y-center frame) + (%window-y-center (frame-text-inferior frame))) + +(define (window-start-mark frame) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-start-mark window))) + +(define (set-window-start-mark! frame mark force?) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%set-window-start-mark! window + (clip-mark-to-display window mark) + force?))) + +(define (window-end-mark frame) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-end-mark window))) +(define (window-mark-visible? frame mark) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-mark-visible? window mark))) + +(define (buffer-frame-x-size frame) + (window-x-size (frame-text-inferior frame))) + +(define (buffer-frame-y-size frame) + (window-y-size (frame-text-inferior frame))) + +(define (window-mark->x frame mark) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-mark->x window (clip-mark-to-display window mark)))) + +(define (window-mark->y frame mark) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-mark->y window (clip-mark-to-display window mark)))) + +(define (window-mark->coordinates frame mark) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-mark->coordinates window (clip-mark-to-display window mark)))) + +(define (window-point-x frame) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-point-x window))) + +(define (window-point-y frame) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-point-y window))) + +(define (window-point-coordinates frame) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-point-coordinates window))) + +(define (window-coordinates->mark frame x y) + (let ((window (frame-text-inferior frame))) + (maybe-recompute-image! window) + (%window-coordinates->mark window x y))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/bufmnu.scm b/v7/src/edwin/bufmnu.scm new file mode 100644 index 000000000..c23b894a6 --- /dev/null +++ b/v7/src/edwin/bufmnu.scm @@ -0,0 +1,347 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Menu + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-variable "Buffer Menu Kill on Quit" + "If not false, kill the *Buffer-List* buffer when leaving it." + #!FALSE) + +(define buffer-menu-package + (make-environment + +(define-command ("List Buffers" argument) + "Display a list of names of existing buffers." + (pop-up-buffer (update-buffer-list) #!FALSE)) + +(define-command ("Buffer Menu" argument) + "Display a list of names of existing buffers." + (pop-up-buffer (update-buffer-list) #!TRUE) + (message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help.")) + +(define (update-buffer-list) + (let ((buffer (temporary-buffer "*Buffer-List*"))) + (set-buffer-major-mode! buffer buffer-menu-mode) + (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-buffer-menu) + (fill-buffer-menu! buffer) + buffer)) + +(define (revert-buffer-menu argument) + (let ((buffer (current-buffer))) + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + (fill-buffer-menu! buffer))) + +(define (fill-buffer-menu! buffer) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-string list-buffers-header) + (let ((current (current-buffer))) + (for-each (lambda (buffer) + (if (not (minibuffer? buffer)) (begin + (write-string + (list-buffers-format + (if (eq? buffer current) "." " ") + (if (buffer-modified? buffer) "*" " ") + (if (buffer-writeable? buffer) " " "%") + (buffer-name buffer) + (write-to-string + (group-length (buffer-group buffer))) + (mode-name (buffer-major-mode buffer)) + (let ((truename (buffer-truename buffer))) + (if truename (pathname->string truename) "")))) + (newline)))) + (buffer-list))))) + (set-buffer-point! buffer (line-start (buffer-start buffer) 2)) + (set-buffer-read-only! buffer)) + +(define-major-mode "Buffer-Menu" "Fundamental" + "Major mode for editing a list of buffers. +Each line describes a buffer in the editor. +M -- mark buffer to be displayed. +Q -- select buffer of line point is in. +1 -- select that buffer in full-screen window. +2 -- select that buffer in one window, + together with buffer selected before this one in another window. +F -- select buffer of line point is in, + leaving *Buffer-List* as the previous buffer. +O -- like F, but select buffer in another window. +~ -- clear modified-flag of that buffer. +S -- mark that buffer to be saved. +D or K or C-D or C-K -- mark that buffer to be killed. +X -- kill or save marked buffers. +U -- remove all kinds of marks from the current line. +Rubout -- move up a line and remove marks. +Space -- move down a line. +C-] -- abort Buffer-Menu edit, killing *Buffer-List*." + ((mode-initialization fundamental-mode))) + +(define-key "Buffer-Menu" #\M "^R Buffer Menu Mark") +(define-key "Buffer-Menu" #\Q "^R Buffer Menu Quit") +(define-key "Buffer-Menu" #\1 "^R Buffer Menu 1 Window") +(define-key "Buffer-Menu" #\2 "^R Buffer Menu 2 Window") +(define-key "Buffer-Menu" #\F "^R Buffer Menu Find") +(define-key "Buffer-Menu" #\O "^R Buffer Menu Find Other Window") +(define-key "Buffer-Menu" #\~ "^R Buffer Menu Not Modified") +(define-key "Buffer-Menu" #\S "^R Buffer Menu Save") +(define-key "Buffer-Menu" #\D "^R Buffer Menu Kill") +(define-key "Buffer-Menu" #\K "^R Buffer Menu Kill") +(define-key "Buffer-Menu" #\C-D "^R Buffer Menu Kill") +(define-key "Buffer-Menu" #\C-K "^R Buffer Menu Kill") +(define-key "Buffer-Menu" #\X "^R Buffer Menu Execute") +(define-key "Buffer-Menu" #\U "^R Buffer Menu Unmark") +(define-key "Buffer-Menu" #\Rubout "^R Buffer Menu Backup Unmark") +(define-key "Buffer-Menu" #\Space "^R Buffer Menu Next") +(define-key "Buffer-Menu" #\C-\] "^R Buffer Menu Abort") +(define-key "Buffer-Menu" #\? "Describe Mode") + +(define-command ("^R Buffer Menu Mark" (argument 1)) + "Mark buffer on this line for being displayed by \\[^R Buffer Menu Quit] command." + (set-multiple-marks! 0 #\> argument)) + +(define-command ("^R Buffer Menu Quit" argument) + "Select this line's buffer; also display buffers marked with >. +You can mark buffers with the \\[^R Buffer Menu Mark] command." + (let ((lstart (current-lstart)) + (window (current-window))) + (let ((menu (window-buffer window)) + (buffer (buffer-menu-buffer lstart)) + (others (map buffer-menu-buffer (find-buffers-marked 0 #\>)))) + (if (and (ref-variable "Preserve Window Arrangement") + (null? others)) + (buffer-menu-select menu buffer #!FALSE) + (begin + (delete-other-windows window) + (buffer-menu-select menu buffer (memq menu others)) + (let ((height (max (quotient (1+ (window-y-size window)) + (1+ (length others))) + (1+ (ref-variable "Window Minimum Height"))))) + (define (loop window buffers) + (let ((new (window-split-vertically! window height))) + (if new + (begin (set-window-buffer! new (car buffers)) + (loop new (cdr buffers)))))) + (loop window others)))))) + (clear-message)) + +(define-command ("^R Buffer Menu 1 Window" argument) + "Select this line's buffer, alone, in full screen." + (let ((window (current-window))) + (delete-other-windows window) + (buffer-menu-select (window-buffer window) + (buffer-menu-buffer (current-lstart)) + #!FALSE)) + (clear-message)) + +(define-command ("^R Buffer Menu 2 Window" argument) + "Select this line's buffer, with previous buffer in second window." + (buffer-menu-select (window-buffer (current-window)) + (buffer-menu-buffer (current-lstart)) + #!FALSE) + (fluid-let (((ref-variable "Pop Up Windows") #!TRUE)) + (pop-up-buffer (previous-buffer))) + (clear-message)) + +(define-command ("^R Buffer Menu Find" argument) + "Select this line's buffer." + (buffer-menu-find select-buffer)) + +(define-command ("^R Buffer Menu Find Other Window" argument) + "Select this line's buffer in another window." + (buffer-menu-find select-buffer-other-window)) + +(define (buffer-menu-find select-buffer) + (let ((buffer (buffer-menu-buffer (current-lstart)))) + (if (not (eq? (current-buffer) buffer)) + (select-buffer buffer))) + (clear-message)) + +(define-command ("^R Buffer Menu Not Modified" argument) + "Mark buffer on this line as unmodified (no changes to save)." + (buffer-not-modified! (buffer-menu-buffer (current-lstart))) + (let ((lstart (current-lstart))) + (if (char=? #\* (buffer-menu-mark lstart 1)) + (set-buffer-menu-mark! lstart 1 #\Space)))) + +(define-command ("^R Buffer Menu Save" (argument 1)) + "Mark buffer on this line to be saved by X command." + (set-multiple-marks! 1 #\S argument)) + +(define-command ("^R Buffer Menu Kill" (argument 1)) + "Mark buffer on this line to be killed by X command." + (set-multiple-marks! 0 #\K argument)) + +(define-command ("^R Buffer Menu Execute" argument) + "Save and/or Kill buffers marked with \\[^R Buffer Menu Save] or \\[^R Buffer Menu Kill]." + (buffer-menu-save-and-kill!)) + +(define-command ("^R Buffer Menu Unmark" argument) + "Remove all marks from this line." + (let ((lstart (mark-right-inserting (current-lstart)))) + (let ((buffer (buffer-menu-buffer lstart))) + (set-buffer-menu-mark! lstart 0 #\Space) + (set-buffer-menu-mark! lstart 1 + (if (buffer-modified? buffer) #\* #\Space)))) + (set-current-point! (next-lstart))) + +(define-command ("^R Buffer Menu Backup Unmark" argument) + "Remove all marks from the previous line." + (set-current-point! (previous-lstart)) + (^r-buffer-menu-unmark-command) + (set-current-point! (previous-lstart))) + +(define-command ("^R Buffer Menu Next" (argument 1)) + "Move down to the next line." + (set-current-point! (line-start (current-point) argument 'BEEP))) + +(define-command ("^R Buffer Menu Abort" argument) + "Abort buffer menu edit." + (kill-buffer-interactive (current-buffer)) + (clear-message)) + +(define (buffer-menu-select menu buffer needed?) + (select-buffer buffer) + (if (not (or (eq? menu buffer) needed?)) + (if (ref-variable "Buffer Menu Kill on Quit") + (kill-buffer-interactive menu) + (bury-buffer menu)))) + +(define (buffer-menu-save-and-kill!) + (for-each buffer-menu-save! (find-buffers-marked 1 #\S)) + (for-each buffer-menu-kill! (find-buffers-marked 0 #\K))) + +(define (buffer-menu-save! lstart) + (save-file (buffer-menu-buffer lstart)) + (set-buffer-menu-mark! lstart 1 #\Space)) + +(define (buffer-menu-kill! lstart) + (define (erase-line) + (with-read-only-defeated lstart + (lambda () + (delete-string lstart (line-start lstart 1))))) + (let ((buffer (find-buffer (buffer-menu-buffer-name lstart)))) + (cond ((not buffer) (erase-line)) + ((not (eq? buffer (current-buffer))) + (kill-buffer-interactive buffer) + (erase-line))))) + +(define (buffer-menu-buffer lstart) + (let ((name (buffer-menu-buffer-name lstart))) + (or (find-buffer name) + (editor-error "No buffer named '" name "'")))) + +(define (buffer-menu-buffer-name lstart) + (guarantee-buffer-line lstart) + (buffer-line-name lstart)) + +(define (current-lstart) + (line-start (current-point) 0)) + +(define (next-lstart) + (line-start (current-point) 1)) + +(define (previous-lstart) + (line-start (current-point) -1)) + +(define (set-multiple-marks! column char n) + (dotimes n + (lambda (i) + (set-buffer-menu-mark! (current-lstart) column char) + (set-current-point! (next-lstart))))) + +(define (guarantee-buffer-line lstart) + (if (not (buffer-line? lstart)) + (editor-error "No buffer on this line"))) + +(define (buffer-line? lstart) + (and (mark>= lstart (line-start (group-start lstart) 2)) + (not (mark= lstart (line-end lstart 0))))) + +(define (buffer-line-name lstart) + (let ((start (mark+ lstart 4))) + (char-search-forward #\Space start (line-end start 0)) + (extract-string start (re-match-start 0)))) + +(define (buffer-menu-mark lstart column) + (guarantee-buffer-line lstart) + (mark-right-char (mark+ lstart column))) + +(define (set-buffer-menu-mark! lstart column char) + (guarantee-buffer-line lstart) + (let ((m (mark+ lstart column))) + (with-read-only-defeated m + (lambda () + (delete-right-char m) + (region-insert-char! m char))))) + +(define (list-buffers-format k m r buffer size mode file) + (let ((buffer (pad-on-right-to buffer 12))) + (let ((size (pad-on-right-to size + (- 5 (max 0 (- (string-length buffer) 12)))))) + (let ((mode (pad-on-right-to mode + (- 12 (max 0 (- (+ (string-length buffer) + (string-length size)) + 17)))))) + (string-append k m r " " buffer " " size " " mode " " file))))) + +(define list-buffers-header + (string-append + (list-buffers-format " " "M" "R" "Buffer" "Size" "Mode" "File") " +" + (list-buffers-format " " "-" "-" "------" "----" "----" "----") " +")) + +(define (find-buffers-marked column char) + (define (loop lstart) + (let ((next (line-start lstart 1))) + (cond ((not next) '()) + ((char=? (mark-right-char (mark+ lstart column)) char) + (cons (mark-permanent! lstart) (loop next))) + (else (loop next))))) + (loop (line-start (buffer-start (current-buffer)) 2))) + +;;; end BUFFER-MENU-PACKAGE +))) + +;;; Edwin Variables: +;;; Scheme Environment: (access buffer-menu-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/bufset.scm b/v7/src/edwin/bufset.scm new file mode 100644 index 000000000..84f6c1b64 --- /dev/null +++ b/v7/src/edwin/bufset.scm @@ -0,0 +1,111 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Set Abstraction + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-named-structure "Bufferset" + buffer-list + names) + +(define (make-bufferset initial-buffer) + (let ((bufferset (%make-bufferset)) + (names (make-string-table))) + (string-table-put! names (buffer-name initial-buffer) initial-buffer) + (vector-set! bufferset bufferset-index:buffer-list (list initial-buffer)) + (vector-set! bufferset bufferset-index:names names) + bufferset)) + +(define (bufferset-select-buffer! bufferset buffer) + (if (memq buffer (bufferset-buffer-list bufferset)) + (vector-set! bufferset bufferset-index:buffer-list + (cons buffer + (delq! buffer (bufferset-buffer-list bufferset)))))) + +(define (bufferset-bury-buffer! bufferset buffer) + (if (memq buffer (bufferset-buffer-list bufferset)) + (vector-set! bufferset bufferset-index:buffer-list + (append! (delq! buffer (bufferset-buffer-list bufferset)) + (list buffer))))) + +(define (bufferset-guarantee-buffer! bufferset buffer) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (begin (string-table-put! (bufferset-names bufferset) + (buffer-name buffer) + buffer) + (vector-set! bufferset bufferset-index:buffer-list + (append! (bufferset-buffer-list bufferset) + (list buffer)))))) + +(define (bufferset-find-buffer bufferset name) + (string-table-get (bufferset-names bufferset) name)) + +(define (bufferset-create-buffer bufferset name) + (if (bufferset-find-buffer bufferset name) + (error "Attempt to re-create buffer" name)) + (let ((buffer (make-buffer name))) + (string-table-put! (bufferset-names bufferset) name buffer) + (vector-set! bufferset bufferset-index:buffer-list + (append! (bufferset-buffer-list bufferset) + (list buffer))) + buffer)) + +(define (bufferset-find-or-create-buffer bufferset name) + (or (bufferset-find-buffer bufferset name) + (bufferset-create-buffer bufferset name))) + +(define (bufferset-kill-buffer! bufferset buffer) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (error "Attempt to kill unknown buffer" buffer)) + (vector-set! bufferset bufferset-index:buffer-list + (delq! buffer (bufferset-buffer-list bufferset))) + (string-table-remove! (bufferset-names bufferset) (buffer-name buffer))) + +(define (bufferset-rename-buffer bufferset buffer new-name) + (if (not (memq buffer (bufferset-buffer-list bufferset))) + (error "Attempt to rename unknown buffer" buffer)) + (if (bufferset-find-buffer bufferset new-name) + (error "Attempt to rename buffer to existing buffer name" new-name)) + (let ((names (bufferset-names bufferset))) + (string-table-remove! names (buffer-name buffer)) + (set-buffer-name! buffer new-name) + (string-table-put! names new-name buffer))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm new file mode 100644 index 000000000..2091c78e0 --- /dev/null +++ b/v7/src/edwin/bufwfs.scm @@ -0,0 +1,213 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Windows: Fill and Scroll + +(declare (usual-integrations) + (integrate-external "edb:bufwin.bin.0")) +(using-syntax class-syntax-table + +;;;; Fill + +(define-procedure buffer-window (fill-top! window inferiors start fill-bottom?) + ;; INFERIORS is assumed to be not '(), and START is the start index + ;; of the first inferior in that list. FILL-BOTTOM?, if true, means + ;; try to fill the bottom of INFERIORS after filling the top. + + (let ((group (buffer-group buffer))) + (define (loop y-start start inferiors) + (cond ((<= y-start 0) + (if fill-bottom? (do-bottom! inferiors start)) + (set-line-inferiors! window inferiors start)) + ((group-start-index? group start) + (set-line-inferiors! window + (scroll-lines-up! window inferiors 0 start) + start)) + (else + (let ((end (-1+ start))) + (let ((start (line-start-index group end))) + (let ((inferior (make-line-inferior window start end))) + (let ((y-start (- y-start (inferior-y-size inferior)))) + (set-inferior-start! inferior 0 y-start) + (loop y-start start (cons inferior inferiors))))))))) + + (define (do-bottom! inferiors start) + (if (null? (cdr inferiors)) + (set-cdr! inferiors + (fill-bottom window + (inferior-y-end (car inferiors)) + (line-end-index group start))) + (do-bottom! (cdr inferiors) + (+ start (line-inferior-length inferiors))))) + + (loop (inferior-y-start (car inferiors)) start inferiors))) + +(define-procedure buffer-window (fill-bottom window y-end end-index) + ;; Generates a list of inferiors which will be appended to a list + ;; ending in Y-END and END-INDEX. + + (let ((group (buffer-group buffer))) + (define (loop y-start end) + (if (or (>= y-start y-size) + (group-end-index? group end)) + '() + (let ((start (1+ end))) + (let ((end (line-end-index group start))) + (let ((inferior (make-line-inferior window start end))) + (set-inferior-start! inferior 0 y-start) + (cons inferior (loop (inferior-y-end inferior) end))))))) + (loop y-end end-index))) + +(define-procedure buffer-window (fill-middle! window y-end end-index + tail tail-start-index) + ;; Generates a list of inferiors which will be appended to a list + ;; ending in Y-END and END-INDEX. TAIL will be appended to the + ;; generated list if it is visible, and scrolled up or down as + ;; needed. TAIL-START-INDEX says where TAIL begins. It is assumed + ;; that (> TAIL-START-INDEX END-INDEX), and that TAIL is non-'(). + + (let ((group (buffer-group buffer))) + (define (loop y-end end) + (let ((start (1+ end))) + (cond ((= start tail-start-index) + (let ((old-y-end (inferior-y-start (car tail)))) + (cond ((> y-end old-y-end) + (scroll-lines-down! window tail y-end)) + ((< y-end old-y-end) + (scroll-lines-up! window tail y-end start)) + (else tail)))) + ((>= y-end y-size) '()) + (else + (let ((end (line-end-index group start))) + (let ((inferior (make-line-inferior window start end))) + (set-inferior-start! inferior 0 y-end) + (cons inferior + (loop (inferior-y-end inferior) end)))))))) + (loop y-end end-index))) + +;;;; Scroll + +(define (%set-window-start-mark! window mark force?) + (let ((start-y (%window-mark->y window mark))) + (and (or force? + (let ((point-y (- (%window-point-y window) start-y))) + (and (not (negative? point-y)) + (< point-y (window-y-size window))))) + (begin (%window-scroll-y-relative! window start-y) + #!TRUE)))) + +(define-procedure buffer-window (%window-scroll-y-absolute! window y-point) + (%window-scroll-y-relative! window (- (%window-point-y window) y-point))) + +(define-procedure buffer-window (%window-scroll-y-relative! window y-delta) + (define-procedure buffer-window (scrolled-point-offscreen window) + (let ((y (if (positive? y-delta) 0 (-1+ (window-y-size window))))) + (%set-buffer-point! buffer (%window-coordinates->mark window 0 y)) + (set! point (buffer-point buffer)) + (set-inferior-start! cursor-inferior 0 y) + (set-buffer-cursor-y! buffer y) + (set! point-moved? #!FALSE) + (window-modeline-event! superior 'WINDOW-SCROLLED))) + + (cond ((negative? y-delta) + (let ((y-start (- (inferior-y-start (car line-inferiors)) y-delta))) + (if (< y-start y-size) + (fill-top! window + (scroll-lines-down! window line-inferiors y-start) + (mark-index start-line-mark) + #!FALSE) + (redraw-at! window + (or (%window-coordinates->mark window 0 y-delta) + (buffer-start buffer)))))) + ((positive? y-delta) + (let ((inferiors (y->inferiors window y-delta))) + (if inferiors + (let ((start (inferiors->index window inferiors))) + (set-line-inferiors! + window + (scroll-lines-up! window + inferiors + (- (inferior-y-start (car inferiors)) + y-delta) + start) + start)) + (redraw-at! window + (or (%window-coordinates->mark window 0 y-delta) + (buffer-end buffer))))))) + (everything-changed! window scrolled-point-offscreen)) + +(define-procedure buffer-window (redraw-at! window mark) + (%set-buffer-point! buffer mark) + (set! point (buffer-point buffer)) + (redraw-screen! window 0)) + +(define-procedure buffer-window (scroll-lines-down! window inferiors y-start) + (define (loop inferiors y-start) + (if (or (null? inferiors) + (>= y-start y-size)) + '() + (begin (set-inferior-start! (car inferiors) 0 y-start) + (cons (car inferiors) + (loop (cdr inferiors) + (inferior-y-end (car inferiors))))))) + (loop inferiors y-start)) + +(define-procedure buffer-window + (scroll-lines-up! window inferiors y-start start-index) + (define (loop inferiors y-start start-index) + (set-inferior-start! (car inferiors) 0 y-start) + (cons (car inferiors) + (if (null? (cdr inferiors)) + (fill-bottom window + (inferior-y-end (car inferiors)) + (line-end-index (buffer-group buffer) start-index)) + (let ((y-start (inferior-y-end (car inferiors)))) + (if (>= y-start y-size) + '() + (loop (cdr inferiors) + y-start + (+ start-index + (line-inferior-length inferiors)))))))) + (loop inferiors y-start start-index)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm new file mode 100644 index 000000000..32c0f9a11 --- /dev/null +++ b/v7/src/edwin/bufwin.scm @@ -0,0 +1,481 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Windows: Base + +(declare (usual-integrations) + (integrate-external "edb:linwin.bin.0")) +(using-syntax class-syntax-table + +(define-class buffer-window vanilla-window + (buffer point changes-daemon clip-daemon + cursor-inferior blank-inferior + line-inferiors last-line-inferior + start-line-mark start-mark end-mark end-line-mark + start-changes-mark end-changes-mark point-moved? + start-clip-mark end-clip-mark + saved-screen saved-x-start saved-y-start + saved-xl saved-xu saved-yl saved-yu + override-inferior)) + +(define-method buffer-window (:initialize! window window*) + (usual=> window :initialize! window*) + (set! cursor-inferior (make-inferior window cursor-window)) + (set! blank-inferior (make-inferior window blank-window)) + (set! changes-daemon (make-changes-daemon window)) + (set! clip-daemon (make-clip-daemon window)) + (set! override-inferior #!FALSE)) + +(define-method buffer-window (:kill! window) + (delete-window-buffer! window) + (usual=> window :kill!)) + +(define-method buffer-window (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (set! saved-screen screen) + (set! saved-x-start x-start) (set! saved-y-start y-start) + (set! saved-xl xl) (set! saved-xu xu) (set! saved-yl yl) (set! saved-yu yu) + (update-buffer-window! window screen x-start y-start + xl xu yl yu display-style)) + +(define-procedure buffer-window (set-buffer-window-size! window x y) + (set! saved-screen #!FALSE) + (%window-redraw! window + (let ((old-y y-size)) + (usual=> window :set-size! x y) + ;; Preserve point y unless it is offscreen now. + (or (and old-y + (let ((y (inferior-y-start cursor-inferior))) + (and (< y y-size) y))) + (let ((y (buffer-cursor-y buffer))) + (and y (< y y-size) y)))))) + +(define-method buffer-window :set-size! + set-buffer-window-size!) + +(define-method buffer-window (:set-x-size! window x) + (set-buffer-window-size! window x y-size)) + +(define-method buffer-window (:set-y-size! window y) + (set-buffer-window-size! window x-size y)) + +;;;; Group Operations + +;;; These are identical to the operations of the same name used +;;; elsewhere in the editor, except that they clip at the display clip +;;; limits rather than the text clip limits. + +(declare (integrate group-start-index group-end-index + group-start-index? group-end-index?)) + +(define (group-start-index group) + (declare (integrate group)) + (mark-index (group-display-start group))) + +(define (group-end-index group) + (declare (integrate group)) + (mark-index (group-display-end group))) + +(define (group-start-index? group index) + (declare (integrate group index)) + (<= index (group-start-index group))) + +(define (group-end-index? group index) + (declare (integrate group index)) + (>= index (group-end-index group))) + +(define (line-start-index group index) + (or (%find-previous-newline group index (group-start-index group)) + (group-start-index group))) + +(define (line-end-index group index) + (or (%find-next-newline group index (group-end-index group)) + (group-end-index group))) + +(define (line-start-index? group index) + (or (group-start-index? group index) + (char=? (group-left-char group index) char:newline))) + +(define (line-end-index? group index) + (or (group-end-index? group index) + (char=? (group-right-char group index) char:newline))) + +(define-procedure buffer-window (clip-mark-to-display window mark) + (if (not (mark? mark)) + (error "Argument not a mark" mark)) + (if (not (mark~ point mark)) + (error "Mark not within displayed buffer" mark)) + (let ((group (mark-group mark)) + (index (mark-index mark))) + (cond ((group-start-index? group index) (group-display-start group)) + ((group-end-index? group index) (group-display-end group)) + (else mark)))) + +;;;; Buffer and Point + +(define-procedure buffer-window (%window-buffer window) + buffer) + +(define-procedure buffer-window (%set-window-buffer! window new-buffer) + (if (not (buffer? new-buffer)) (error "Argument not a buffer" new-buffer)) + (delete-window-buffer! window) + (initial-buffer! window new-buffer) + (window-modeline-event! superior 'NEW-BUFFER) + (%window-redraw! window + (let ((y (buffer-cursor-y buffer))) + (and y (< y y-size) y)))) + +(define-procedure buffer-window (initial-buffer! window new-buffer) + (set! buffer new-buffer) + (add-buffer-window! buffer superior) + (let ((group (buffer-group buffer))) + (add-group-delete-daemon! group changes-daemon) + (add-group-insert-daemon! group changes-daemon) + (add-group-clip-daemon! group clip-daemon) + (let ((point (mark-index (buffer-point buffer))) + (start (group-start-index group)) + (end (group-end-index group))) + (cond ((< point start) + (%set-buffer-point! buffer (make-mark group start))) + ((> point end) + (%set-buffer-point! buffer (make-mark group end)))))) + (set! point (buffer-point buffer))) + +(define-procedure buffer-window (delete-window-buffer! window) + (let ((group (buffer-group buffer))) + (remove-group-delete-daemon! group changes-daemon) + (remove-group-insert-daemon! group changes-daemon) + (remove-group-clip-daemon! group clip-daemon)) + (remove-buffer-window! buffer superior)) + +(define-procedure buffer-window (%window-point window) + point) + +(define-procedure buffer-window (%set-window-point! window mark) + (%set-buffer-point! buffer mark) + (set! point (buffer-point buffer)) + (set! point-moved? #!TRUE) + (setup-redisplay-flags! redisplay-flags)) + +(define-procedure buffer-window (%window-cursor window) + (inferior-window cursor-inferior)) + +(define-method buffer-window (:salvage! window) + (%set-buffer-point! buffer + (make-mark (buffer-group buffer) + (group-start-index (buffer-group buffer)))) + (set! point (buffer-point buffer)) + (window-modeline-event! superior 'SALVAGE) + (%window-redraw! window #!FALSE)) + +;;;; Override Message + +;;; This is used to display messages over the typein window. + +(define-procedure buffer-window (set-override-message! window message) + (if (not override-inferior) + (begin (set! override-inferior (make-inferior window line-window)) + (set! inferiors (list override-inferior blank-inferior)) + (set-inferior-start! override-inferior 0 0))) + (set-line-window-string! (inferior-window override-inferior) message) + (set-blank-inferior-start! window (inferior-y-end override-inferior))) + +(define-procedure buffer-window (clear-override-message! window) + (if override-inferior + (begin (set! override-inferior #!FALSE) + (set! inferiors + (cons* cursor-inferior blank-inferior line-inferiors)) + (blank-inferior-changed! window) + (for-each inferior-needs-redisplay! inferiors)))) + +(define-procedure buffer-window (home-cursor! window) + (screen-write-cursor! saved-screen saved-x-start saved-y-start)) + +;;;; Inferiors + +(define-procedure buffer-window (make-line-inferior window start end) + (let ((inferior (make-inferior window line-window))) + (set-line-window-string! (inferior-window inferior) + (group-extract-string (buffer-group buffer) + start end)) + inferior)) + +(declare (integrate first-line-inferior line-inferior-length + blank-inferior-changed! set-blank-inferior-start! + set-line-inferiors!)) + +(define-procedure buffer-window (first-line-inferior window) + (declare (integrate window)) + (car line-inferiors)) + +(define (line-inferior-length inferiors) + (declare (integrate inferiors)) + (1+ (line-window-length (inferior-window (car inferiors))))) + +(define-procedure buffer-window (blank-inferior-changed! window) + (declare (integrate window)) + (if (not override-inferior) + (set-blank-inferior-start! window (inferior-y-end last-line-inferior)))) + +(define-procedure buffer-window (set-blank-inferior-start! window y-end) + (declare (integrate window)) + (if (< y-end y-size) + (begin (set-inferior-size! blank-inferior x-size (- y-size y-end)) + (set-inferior-start! blank-inferior 0 y-end)) + (set-inferior-start! blank-inferior #!FALSE #!FALSE))) + +(define-procedure buffer-window (set-line-inferiors! window inferiors start) + (declare (integrate window inferiors start)) + (set! line-inferiors inferiors) + (set! start-line-mark + (%make-permanent-mark (buffer-group buffer) start #!FALSE))) + +(define-procedure buffer-window (line-inferiors-changed! window) + (define (loop inferiors start) + (if (null? (cdr inferiors)) + (begin (set! last-line-inferior (car inferiors)) + (set! end-line-mark + (let ((group (buffer-group buffer))) + (%make-permanent-mark group + (line-end-index group start) + #!TRUE)))) + (loop (cdr inferiors) + (+ start (line-inferior-length inferiors))))) + (loop line-inferiors (mark-index start-line-mark)) + (if (not override-inferior) + (set! inferiors (cons* cursor-inferior blank-inferior line-inferiors)))) + +(define-procedure buffer-window (y->inferiors window y) + (define (loop previous-inferiors inferiors) + (cond ((< y (inferior-y-start (car inferiors))) previous-inferiors) + ((null? (cdr inferiors)) + (and (< y (inferior-y-end (car inferiors))) + inferiors)) + (else (loop inferiors (cdr inferiors))))) + (loop #!FALSE line-inferiors)) + +(define-procedure buffer-window (index->inferiors window index) + ;; Assumes that (>= INDEX (MARK-INDEX START-LINE-MARK)). + (define (loop inferiors start) + (let ((new-start (+ start (line-inferior-length inferiors)))) + (if (< index new-start) + inferiors + (and (not (null? (cdr inferiors))) + (loop (cdr inferiors) new-start))))) + (loop line-inferiors (mark-index start-line-mark))) + +(define-procedure buffer-window (inferiors->index window inferiors) + ;; Assumes that INFERIORS is a tail of LINE-INFERIORS. + (define (loop inferiors* start) + (if (eq? inferiors inferiors*) + start + (loop (cdr inferiors*) + (+ start (line-inferior-length inferiors*))))) + (loop line-inferiors (mark-index start-line-mark))) + +(define-procedure buffer-window (y->inferiors&index window y receiver) + ;; This is used for scrolling. + (define (loop inferiors start previous-inferiors previous-start) + (cond ((< y (inferior-y-start (car inferiors))) + (receiver previous-inferiors previous-start)) + ((null? (cdr inferiors)) + (and (< y (inferior-y-end (car inferiors))) + (receiver inferiors start))) + (else + (loop (cdr inferiors) (+ start (line-inferior-length inferiors)) + inferiors start)))) + (loop line-inferiors (mark-index start-line-mark) + #!FALSE #!FALSE)) + +(define-procedure buffer-window (start-changes-inferiors window) + ;; Assumes that (MARK<= START-LINE-MARK START-CHANGES-MARK). + ;; Guarantees to return non-'() result. + (or (index->inferiors window (mark-index start-changes-mark)) + (error "Can't find START-CHANGES"))) + +(define-procedure buffer-window (end-changes-inferiors window) + ;; Assumes that (MARK<= END-CHANGES-MARK END-LINE-MARK). + ;; Guarantees to return non-'() result. + (let ((group (buffer-group buffer)) + (index (mark-index end-changes-mark))) + (define (loop inferiors not-found) + (if (null? inferiors) + (not-found (mark-index end-line-mark)) + (loop (cdr inferiors) + (lambda (end) + (let ((new-end (- end (line-inferior-length inferiors)))) + (if (< new-end index) + inferiors + (not-found new-end))))))) + (loop line-inferiors + (lambda (end) + (error "Can't find END-CHANGES"))))) + +;;;; Changes + +(define-procedure buffer-window (update-cursor! window if-not-visible) + (if (%window-mark-visible? window point) + (let ((coordinates (%window-mark->coordinates window point))) + (set-inferior-position! cursor-inferior coordinates) + (set-buffer-cursor-y! buffer (cdr coordinates)) + (set! point-moved? #!FALSE) + (window-modeline-event! superior 'CURSOR-MOVED)) + (if-not-visible window))) + +(define-procedure buffer-window (maybe-recenter! window) + (if (zero? (ref-variable "Cursor Centering Threshold")) + (%window-redraw! window (%window-y-center window)) + (if (< (mark-index point) (mark-index start-mark)) + (let ((limit (%window-coordinates->index + window + 0 (- (ref-variable "Cursor Centering Threshold"))))) + (if (or (not limit) + (>= (mark-index point) limit)) + (%window-scroll-y-relative! window (%window-point-y window)) + (%window-redraw! window (%window-y-center window)))) + (let ((limit (%window-coordinates->index + window + 0 (+ (window-y-size window) + (ref-variable "Cursor Centering Threshold"))))) + (if (or (not limit) + (< (mark-index point) limit)) + (%window-scroll-y-relative! window + (- (%window-point-y window) + (-1+ (window-y-size window)))) + (%window-redraw! window (%window-y-center window))))))) + +(define-procedure buffer-window (%window-redraw! window y) + (cond ((not y) (set! y (%window-y-center window))) + ((or (< y 0) (>= y y-size)) + (error "Attempt to scroll point off window" y))) + (redraw-screen! window y) + (everything-changed! window + (lambda (w) + (error "%WINDOW-REDRAW! left point offscreen -- get a wizard" w)))) + +(define-procedure buffer-window (redraw-screen! window y) + (let ((group (mark-group point)) + (index (mark-index point))) + (let ((start (line-start-index group index))) + (let ((inferior (make-line-inferior window + start + (line-end-index group index)))) + (set-inferior-start! + inferior + 0 + (- y (string-base:index->y (inferior-window inferior) + (- index start)))) + (fill-top! window (list inferior) start #!TRUE))))) + +(define-procedure buffer-window (everything-changed! window if-not-visible) + (no-outstanding-changes! window) + (line-inferiors-changed! window) + (blank-inferior-changed! window) + (start-mark-changed! window) + (end-mark-changed! window) + (update-cursor! window if-not-visible)) + +(define-procedure buffer-window (maybe-marks-changed! window inferiors y-end) + (no-outstanding-changes! window) + (if (and (eq? inferiors line-inferiors) + (negative? (inferior-y-start (car inferiors)))) + (start-mark-changed! window)) + (if (and (null? (cdr inferiors)) + (> y-end y-size)) + (end-mark-changed! window)) + (update-cursor! window maybe-recenter!)) + +(define-procedure buffer-window (no-outstanding-changes! window) + (set! start-changes-mark #!FALSE) + (set! end-changes-mark #!FALSE) + (set! start-clip-mark #!FALSE) + (set! end-clip-mark #!FALSE)) + +(define-procedure buffer-window (start-mark-changed! window) + (set! start-mark + (%make-permanent-mark + (buffer-group buffer) + (+ (mark-index start-line-mark) + (let ((inferior (first-line-inferior window))) + (string-base:coordinates->index + (inferior-window inferior) + 0 + (- (inferior-y-start inferior))))) + #!FALSE)) + (window-modeline-event! superior 'START-MARK-CHANGED!)) + +(define-procedure buffer-window (end-mark-changed! window) + (set! end-mark + (let ((group (buffer-group buffer))) + (%make-permanent-mark + group + (+ (line-start-index group (mark-index end-line-mark)) + (string-base:coordinates->index + (inferior-window last-line-inferior) + (-1+ x-size) + (-1+ (- (min y-size (inferior-y-end last-line-inferior)) + (inferior-y-start last-line-inferior))))) + #!TRUE))) + (window-modeline-event! superior 'END-MARK-CHANGED!)) + +(declare (integrate %window-start-mark %window-end-mark %window-mark-visible?)) + +(define-procedure buffer-window (%window-start-mark window) + (declare (integrate window)) + start-mark) + +(define-procedure buffer-window (%window-end-mark window) + (declare (integrate window)) + end-mark) + +(define-procedure buffer-window (%window-mark-visible? window mark) + (declare (integrate window mark)) + (and (mark<= start-mark mark) + (mark<= mark end-mark))) + +(define-procedure buffer-window (%window-y-center window) + (let ((qr (integer-divide (* y-size cursor-centering-point) 100))) + (if (< (integer-divide-remainder qr) 50) + (integer-divide-quotient qr) + (1+ (integer-divide-quotient qr))))) + +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm new file mode 100644 index 000000000..eca0cd958 --- /dev/null +++ b/v7/src/edwin/bufwiu.scm @@ -0,0 +1,382 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Windows: Image Update + +(declare (usual-integrations) + (integrate-external "edb:bufwin.bin.0")) +(using-syntax class-syntax-table + +;;;; Insert/Delete/Clip + +;;; It is assumed that the insert daemon is called after the insertion +;;; has been performed, and the delete daemon before the deletion has +;;; been performed. It is also assumed that interrupts are disabled. + +(define-procedure buffer-window ((make-changes-daemon window) group start end) + (cond (start-changes-mark + (cond ((< start (mark-index start-changes-mark)) + (set! start-changes-mark + (%make-permanent-mark group start #!FALSE))) + ((> end (mark-index end-changes-mark)) + (set! end-changes-mark + (%make-permanent-mark group end #!TRUE))))) + (else + (set! start-changes-mark (%make-permanent-mark group start #!FALSE)) + (set! end-changes-mark (%make-permanent-mark group end #!TRUE)))) + (if (and (>= end (mark-index start-line-mark)) + (<= start (mark-index end-mark))) + (setup-redisplay-flags! redisplay-flags))) + +;;; It is assumed that the clip daemon is called before the clipping +;;; has been performed, so that we can get the old clipping limits. + +(define-procedure buffer-window ((make-clip-daemon window) group start end) + (if (not start-clip-mark) + (begin (set! start-clip-mark (group-display-start group)) + (set! end-clip-mark (group-display-end group)))) + (let ((window-start (mark-index start-line-mark)) + (window-end (mark-index end-mark))) + (if (or (> start window-start) + (< end window-end) + (and (< start window-start) + (= window-start (mark-index start-clip-mark))) + (and (> end window-end) + (= window-end (mark-index end-clip-mark)))) + (setup-redisplay-flags! redisplay-flags)))) + +(define (update-buffer-window! window screen x-start y-start + xl xu yl yu display-style) + ;; The primary update entry. + (recompute-image! window) + (update-inferiors! window screen x-start y-start xl xu yl yu display-style)) + +(define-procedure buffer-window (maybe-recompute-image! window) + ;; Used to guarantee everything updated before certain operations. + (if (car redisplay-flags) + (recompute-image! window))) + +(define-procedure buffer-window (recompute-image! window) + (without-interrupts + (lambda () + (%recompute-image! window)))) + +(define-procedure buffer-window (%recompute-image! window) + (let ((group (mark-group start-mark)) + (start-line (mark-index start-line-mark)) + (start (mark-index start-mark)) + (end (mark-index end-mark)) + (point-index (mark-index point))) + (if start-clip-mark + (let ((new-clip-start (group-start-index group)) + (new-clip-end (group-end-index group))) + (cond ((< point-index new-clip-start) + (%set-buffer-point! buffer (group-display-start group)) + (set! point (buffer-point buffer))) + ((> point-index new-clip-end) + (%set-buffer-point! buffer (group-display-end group)) + (set! point (buffer-point buffer)))) + (cond ((> new-clip-start start-line) + (%window-redraw! window #!FALSE)) + ((or (< new-clip-end end) + (and (< new-clip-start start-line) + (= start-line (mark-index start-clip-mark))) + (and (> new-clip-end end) + (= end (mark-index end-clip-mark)))) + (%window-redraw! + window + (and (not start-changes-mark) + (>= point-index start) + (<= point-index end) + (%window-point-y window)))) + (else + (set! start-clip-mark #!FALSE) + (set! end-clip-mark #!FALSE))))) + (if start-changes-mark + (let ((start-changes (mark-index start-changes-mark)) + (end-changes (mark-index end-changes-mark))) + (if (and (>= end-changes start-line) + (<= start-changes end)) + (cond ((<= start-changes start) + (cond ((< end-changes end) + (recompute-image!:top-changed window)) + (else + (%window-redraw! window #!FALSE)))) + ((>= end-changes end) + (recompute-image!:bottom-changed window)) + (else + (recompute-image!:middle-changed window))) + (begin (set! start-changes-mark #!FALSE) + (set! end-changes-mark #!FALSE)))))) + (if point-moved? + (update-cursor! window maybe-recenter!))) + +(define-procedure buffer-window (recompute-image!:top-changed window) + (let ((inferiors (end-changes-inferiors window)) + (group (mark-group end-changes-mark)) + (index (mark-index end-changes-mark))) + (let ((start-index (line-start-index group index))) + (set-line-window-string! + (inferior-window (car inferiors)) + (group-extract-string group start-index (line-end-index group index))) + (fill-top! window inferiors start-index #!TRUE))) + (everything-changed! window maybe-recenter!)) + +(define-procedure buffer-window (recompute-image!:bottom-changed window) + (let ((inferiors (start-changes-inferiors window)) + (group (mark-group start-changes-mark)) + (index (mark-index start-changes-mark))) + (let ((end-index (line-end-index group index))) + (set-line-window-string! + (inferior-window (car inferiors)) + (group-extract-string group + (line-start-index group index) + end-index)) + (set-cdr! inferiors + (fill-bottom window + (inferior-y-end (car inferiors)) + end-index)))) + (everything-changed! window maybe-recenter!)) + +(define-procedure buffer-window (recompute-image!:middle-changed window) + (let ((start-inferiors (start-changes-inferiors window)) + (end-inferiors (end-changes-inferiors window)) + (group (buffer-group buffer)) + (start-index (mark-index start-changes-mark)) + (end-index (mark-index end-changes-mark))) + (let ((start-start (line-start-index group start-index)) + (start-end (line-end-index group start-index)) + (end-start (line-start-index group end-index)) + (end-end (line-end-index group end-index))) + (if (eq? start-inferiors end-inferiors) + (if (= start-start end-start) + +;;; In this case, the changed region was a single line before the +;;; changes, and is still a single line now. All we need do is redraw +;;; the line and then scroll the rest up or down if the y-size of the +;;; line has been changed. +(let ((y-end (inferior-y-end (car start-inferiors)))) + (set-line-window-string! (inferior-window (car start-inferiors)) + (group-extract-string group start-start start-end)) + (let ((y-end* (inferior-y-end (car start-inferiors)))) + (if (= y-end y-end*) + (maybe-marks-changed! window start-inferiors y-end*) + (begin (set-cdr! + start-inferiors + (cond ((< y-end y-end*) + (scroll-lines-down! window + (cdr start-inferiors) + y-end*)) + ((not (null? (cdr start-inferiors))) + (scroll-lines-up! window + (cdr start-inferiors) + y-end* + (1+ start-end))) + (else + (fill-bottom window y-end* start-end)))) + (everything-changed! window maybe-recenter!))))) + +;;; Here, the changed region used to be a single line, and now is +;;; several, so we need to insert a bunch of new lines. +(begin + (set-line-window-string! (inferior-window (car start-inferiors)) + (group-extract-string group start-start start-end)) + (set-cdr! start-inferiors + (if (null? (cdr start-inferiors)) + (fill-bottom window + (inferior-y-end (car start-inferiors)) + start-end) + (fill-middle! window + (inferior-y-end (car start-inferiors)) + start-end + (cdr start-inferiors) + (1+ end-end)))) + (everything-changed! window maybe-recenter!)) + +) +(if (= start-start end-start) + +;;; The changed region used to be multiple lines and is now just one. +;;; We must scroll the bottom of the screen up to fill in. +(begin + (set-line-window-string! (inferior-window (car start-inferiors)) + (group-extract-string group start-start start-end)) + (set-cdr! start-inferiors + (if (null? (cdr end-inferiors)) + (fill-bottom window + (inferior-y-end (car start-inferiors)) + start-end) + (scroll-lines-up! window + (cdr end-inferiors) + (inferior-y-end (car start-inferiors)) + (1+ start-end)))) + (everything-changed! window maybe-recenter!)) + +;;; The most general case, we must refill the center of the screen. +(begin + (set-line-window-string! (inferior-window (car start-inferiors)) + (group-extract-string group + start-start start-end)) + (let ((old-y-end (inferior-y-end (car end-inferiors)))) + (set-line-window-string! (inferior-window (car end-inferiors)) + (group-extract-string group + end-start end-end)) + (let ((y-end (inferior-y-end (car end-inferiors))) + (tail (cdr end-inferiors))) + (cond ((> y-end old-y-end) + (set-cdr! end-inferiors (scroll-lines-down! window tail y-end))) + ((< y-end old-y-end) + (set-cdr! end-inferiors + (scroll-lines-up! window tail y-end (1+ end-end))))))) + (set-cdr! start-inferiors + (fill-middle! window + (inferior-y-end (car start-inferiors)) + start-end + end-inferiors + end-start)) + (everything-changed! window maybe-recenter!)) + +))))) + +;;;; Direct Update/Output Support + +;;; The direct output procedures are hairy and should be used only +;;; under restricted conditions. In particular, the cursor may not be +;;; at the right margin (for insert and forward) or the left margin +;;; (for backward), and the character being inserted must be an +;;; ordinary graphic character. For insert, the buffer must be +;;; modifiable, and the modeline must already show that it has been +;;; modified. None of the procedures may be used if the window needs +;;; redisplay. + +(define-procedure buffer-window (%window-direct-update! window display-style) + (if (not saved-screen) + (error "Window needs normal redisplay -- can't direct update" window)) + (and (update-buffer-window! window saved-screen saved-x-start saved-y-start + saved-xl saved-xu saved-yl saved-yu + display-style) + (begin (set-car! redisplay-flags #!FALSE) + #!TRUE))) + +(define-procedure buffer-window (%window-needs-redisplay? window) + (car redisplay-flags)) + +(define-procedure buffer-window (%direct-output-forward-character! window) + (without-interrupts + (lambda () + (%set-buffer-point! buffer (mark1+ point)) + (set! point (buffer-point buffer)) + (let ((x-start (1+ (inferior-x-start cursor-inferior))) + (y-start (inferior-y-start cursor-inferior))) + (screen-write-cursor! saved-screen + (+ saved-x-start x-start) + (+ saved-y-start y-start)) + (%set-inferior-x-start! cursor-inferior x-start))))) + +(define-procedure buffer-window (%direct-output-backward-character! window) + (without-interrupts + (lambda () + (%set-buffer-point! buffer (mark-1+ point)) + (set! point (buffer-point buffer)) + (let ((x-start (-1+ (inferior-x-start cursor-inferior))) + (y-start (inferior-y-start cursor-inferior))) + (screen-write-cursor! saved-screen + (+ saved-x-start x-start) + (+ saved-y-start y-start)) + (%set-inferior-x-start! cursor-inferior x-start))))) + +(define-procedure buffer-window (%direct-output-insert-char! window char) + (without-interrupts + (lambda () + (let ((x-start (inferior-x-start cursor-inferior)) + (y-start (inferior-y-start cursor-inferior))) + (let ((x (+ saved-x-start x-start)) + (y (+ saved-y-start y-start))) + (screen-write-char! saved-screen x y char) + (screen-write-cursor! saved-screen (1+ x) y)) + (line-window-direct-output-insert-char! + (inferior-window (car (y->inferiors window y-start))) + x-start + char) + (%set-inferior-x-start! cursor-inferior (1+ x-start)))))) + +(define-procedure buffer-window (%direct-output-insert-newline! window) + (without-interrupts + (lambda () + (let ((y-start (1+ (inferior-y-start cursor-inferior)))) + (let ((inferior (make-inferior window line-window))) + (%set-inferior-x-start! inferior 0) + (%set-inferior-y-start! inferior y-start) + (set-cdr! (last-pair line-inferiors) (list inferior)) + (set! last-line-inferior inferior) + (line-window-direct-output-insert-newline! + (inferior-window inferior))) + (let ((y-end (1+ y-start))) + (if (< y-end y-size) + (begin (%set-inferior-y-size! blank-inferior (- y-size y-end)) + (%set-inferior-y-start! blank-inferior y-end)) + (begin (%set-inferior-x-start! blank-inferior #!FALSE) + (%set-inferior-y-start! blank-inferior #!FALSE)))) + (%set-inferior-x-start! cursor-inferior 0) + (%set-inferior-y-start! cursor-inferior y-start) + (screen-write-cursor! saved-screen + saved-x-start + (+ saved-y-start y-start)))))) + +(define-procedure buffer-window + (%direct-output-insert-substring! window string start end) + (without-interrupts + (lambda () + (let ((x-start (inferior-x-start cursor-inferior)) + (y-start (inferior-y-start cursor-inferior)) + (length (- end start))) + (let ((x (+ saved-x-start x-start)) + (y (+ saved-y-start y-start))) + (screen-write-substring! saved-screen x y string start end) + (screen-write-cursor! saved-screen (+ x length) y)) + (line-window-direct-output-insert-substring! + (inferior-window (car (y->inferiors window y-start))) + x-start string start end) + (%set-inferior-x-start! cursor-inferior (+ x-start length)))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm new file mode 100644 index 000000000..edacfe62d --- /dev/null +++ b/v7/src/edwin/bufwmc.scm @@ -0,0 +1,164 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Buffer Windows: Mark <-> Coordinate Maps + +(declare (usual-integrations) + (integrate-external "edb:bufwin.bin.0")) +(using-syntax class-syntax-table + +(define-procedure buffer-window (%window-mark->x window mark) + (car (%window-mark->coordinates window mark))) + +(define-procedure buffer-window (%window-mark->y window mark) + (cdr (%window-mark->coordinates window mark))) + +(define-procedure buffer-window (%window-point-x window) + (car (%window-mark->coordinates window point))) + +(define-procedure buffer-window (%window-point-y window) + (cdr (%window-mark->coordinates window point))) + +(define-procedure buffer-window (%window-point-coordinates window) + (%window-mark->coordinates window point)) + +(declare (integrate %window-mark->coordinates)) + +(define-procedure buffer-window (%window-mark->coordinates window mark) + (declare (integrate window mark)) + (%window-index->coordinates window (mark-index mark))) + +(define-procedure buffer-window (%window-coordinates->mark window x y) + (let ((index (%window-coordinates->index window x y))) + (and index (make-mark (buffer-group buffer) index)))) + +(define-procedure buffer-window (%window-index->coordinates window index) + (let ((group (buffer-group buffer))) + (define (search-upwards end y-end) + (let ((start (line-start-index group end))) + (let ((columns (group-column-length group start end 0))) + (let ((y-start (- y-end (column->y-size columns x-size)))) + (if (<= start index) + (done start columns y-start) + (search-upwards (-1+ start) y-start)))))) + + (define (search-downwards start y-start) + (let ((end (line-end-index group start))) + (let ((columns (group-column-length group start end 0))) + (if (<= index end) + (done start columns y-start) + (search-downwards (1+ end) + (+ y-start + (column->y-size columns x-size))))))) + + (declare (integrate done)) + + (define (done start columns y-start) + (declare (integrate start columns y-start)) + (let ((xy + (column->coordinates columns + x-size + (group-column-length group start index 0)))) + (cons (car xy) (+ (cdr xy) y-start)))) + + (let ((start (mark-index start-line-mark)) + (end (mark-index end-line-mark))) + (cond ((< index start) + (search-upwards (-1+ start) + (inferior-y-start (first-line-inferior window)))) + ((> index end) + (search-downwards (1+ end) + (inferior-y-end last-line-inferior))) + (else + (let ((start (line-start-index group index))) + (done start + (group-column-length group start + (line-end-index group index) 0) + (inferior-y-start + (car (index->inferiors window index)))))))))) + +(define-procedure buffer-window (%window-coordinates->index window x y) + (let ((group (buffer-group buffer))) + (define (search-upwards start y-end) + (and (not (group-start-index? group start)) + (let ((end (-1+ start))) + (let ((start (line-start-index group end))) + (let ((y-start (- y-end (y-delta start end)))) + (if (<= y-start y) + (done start end y-start) + (search-upwards start y-start))))))) + + (define (search-downwards end y-start) + (and (not (group-end-index? group end)) + (let ((start (1+ end))) + (let ((end (line-end-index group start))) + (let ((y-end (+ y-start (y-delta start end)))) + (if (< y y-end) + (done start end y-start) + (search-downwards end y-end))))))) + + (declare (integrate y-delta done)) + + (define (y-delta start end) + (declare (integrate start end)) + (column->y-size (group-column-length group start end 0) x-size)) + + (define (done start end y-start) + (declare (integrate start end y-start)) + (group-column->index group start end 0 + (coordinates->column x (- y y-start) x-size))) + + (let ((start (inferior-y-start (first-line-inferior window))) + (end (inferior-y-end last-line-inferior))) + (cond ((< y start) + (search-upwards (mark-index start-line-mark) start)) + ((>= y end) + (search-downwards (mark-index end-line-mark) end)) + (else + (y->inferiors&index window y + (lambda (inferiors index) + (done index + (line-end-index group index) + (inferior-y-start (car inferiors)))))))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/c-mode.scm b/v7/src/edwin/c-mode.scm new file mode 100644 index 000000000..1f05a6511 --- /dev/null +++ b/v7/src/edwin/c-mode.scm @@ -0,0 +1,478 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; C Mode (from GNU Emacs) + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("C Mode" argument) + "Enter C mode." + (set-current-major-mode! c-mode)) + +(define-major-mode "C" "Fundamental" + "Major mode for editing C code. +Expression and list commands understand all C brackets. +Tab indents for C code. +Comments are delimited with /* ... */. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. +The characters { } ; : correct indentation when typed. + +Variables controlling indentation style: + C Auto Newline + Non-false means automatically newline before and after braces, + and after colons and semicolons, inserted in C code. + C Indent Level + Indentation of C statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + C Continued Statement Offset + Extra indentation given to a substatement, such as the + then-clause of an if or body of a while. + C Brace Offset + Extra indentation for line if it starts with an open brace. + C Brace Imaginary Offset + An open brace following other text is treated as if it were + this far to the right of the start of its line. + C Argdecl Indent + Indentation level of declarations of C function arguments. + C Label Offset + Extra indentation for line that is a label, or case or default." + + (local-set-variable! "Syntax Table" c-mode:syntax-table) + (local-set-variable! "Syntax Ignore Comments Backwards" #!TRUE) + (local-set-variable! "Paragraph Start" "^$") + (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start")) + (local-set-variable! "Indent Line Procedure" c-indent-line-command) + (local-set-variable! "Require Final Newline" #!TRUE) + (local-set-variable! "Comment Locator Hook" c-mode:comment-locate) + (local-set-variable! "Comment Indent Hook" c-mode:comment-indent) + (local-set-variable! "Comment Start" "/* ") + (local-set-variable! "Comment End" " */") + (local-set-variable! "Comment Column" 32) + (if (ref-variable "C Mode Hook") ((ref-variable "C Mode Hook")))) + +(define-variable "C Mode Hook" + "If not false, a thunk to call when entering C mode." + #!FALSE) + +(define-key "C" #\Linefeed "Reindent then Newline and Indent") +(define-key "C" #\{ "Electric C Brace") +(define-key "C" #\} "Electric C Brace") +(define-key "C" #\; "Electric C Semi") +(define-key "C" #\: "Electric C Terminator") +(define-key "C" #\C-M-H "Mark C Function") +(define-key "C" #\C-M-Q "C Indent Expression") +(define-key "C" #\Rubout "^R Backward Delete Hacking Tabs") +(define-key "C" #\Tab "C Indent Line") + +(define c-mode:syntax-table (make-syntax-table)) +(modify-syntax-entry! c-mode:syntax-table #\\ "\\") +(modify-syntax-entry! c-mode:syntax-table #\/ ". 14") +(modify-syntax-entry! c-mode:syntax-table #\* ". 23") +(modify-syntax-entry! c-mode:syntax-table #\+ ".") +(modify-syntax-entry! c-mode:syntax-table #\- ".") +(modify-syntax-entry! c-mode:syntax-table #\= ".") +(modify-syntax-entry! c-mode:syntax-table #\% ".") +(modify-syntax-entry! c-mode:syntax-table #\< ".") +(modify-syntax-entry! c-mode:syntax-table #\> ".") +(modify-syntax-entry! c-mode:syntax-table #\' "\"") + +(define (c-mode:comment-locate start) + (and (re-search-forward "/\\*[ \t]*" start (line-end start 0)) + (cons (re-match-start 0) (re-match-end 0)))) + +(define (c-mode:comment-indent start) + (if (re-match-forward "^/\\*" start (line-end start 0)) + 0 + (max (1+ (mark-column (horizontal-space-start start))) + (ref-variable "Comment Column")))) + +(define-command ("Electric C Brace" argument) + "Insert character and correct line's indentation." + (let ((point (current-point))) + (if (and (not argument) + (line-end? point) + (or (line-blank? point) + (and (ref-variable "C Auto Newline") + (begin (c-indent-line-command #!FALSE) + (insert-newline) + #!TRUE)))) + (begin (^r-insert-self-command #!FALSE) + (c-indent-line-command #!FALSE) + (if (ref-variable "C Auto Newline") + (begin (insert-newline) + (c-indent-line-command #!FALSE)))) + (^r-insert-self-command argument)))) + +(define-command ("Electric C Semi" argument) + "Insert character and correct line's indentation." + (if (ref-variable "C Auto Newline") + (electric-c-terminator-command argument) + (^r-insert-self-command argument))) + +(define-command ("Electric C Terminator" argument) + "Insert character and correct line's indentation." + (let ((point (current-point))) + (if (and (not argument) + (line-end? point) + (not (let ((mark (indentation-end point))) + (or (char-match-forward #\# mark) + (let ((state (parse-partial-sexp mark point))) + (or (parse-state-in-string? state) + (parse-state-in-comment? state) + (parse-state-quoted? state))))))) + (begin (^r-insert-self-command #!FALSE) + (c-indent-line-command #!FALSE) + (if (and (ref-variable "C Auto Newline") + (not ((access inside-parens? c-indentation-package) + point))) + (begin (insert-newline) + (c-indent-line-command #!FALSE)))) + (^r-insert-self-command argument)))) + +(define-command ("Mark C Procedure" argument) + "Put mark at end of C procedure, point at beginning." + (push-current-mark! (current-point)) + (let ((end (forward-definition-end (current-point) 1 'LIMIT))) + (push-current-mark! end) + (set-current-point! + (backward-paragraph (backward-definition-start end 1 'LIMIT) 1 'LIMIT)))) + +(define-command ("C Indent Line" argument) + "Indent current line as C code. +Argument means shift any additional lines of grouping +rigidly with this line." + (let ((start (line-start (current-point) 0))) + (let ((indentation + ((access indent-line:indentation c-indentation-package) start))) + (let ((shift-amount (- indentation (mark-indentation start)))) + (cond ((not (zero? shift-amount)) + (change-indentation indentation start) + (if argument + ((access indent-code-rigidly lisp-indentation-package) + start (forward-sexp start 1 'ERROR) shift-amount "#"))) + ((within-indentation? (current-point)) + (set-current-point! (indentation-end (current-point))))))))) + +(define-command ("C Indent Expression" argument) + "Indent each line of the C grouping following point." + ((access indent-expression c-indentation-package) (current-point))) + +(define c-indentation-package + (make-environment + +(define (indent-line start) + (maybe-change-indentation (indent-line:indentation start) start)) + +(define (indent-line:indentation start) + (fluid-let (((ref-variable "Case Fold Search") #!FALSE)) + (let ((indentation (calculate-indentation start #!FALSE))) + (cond ((not indentation) (mark-indentation start)) + ((eq? indentation #!TRUE) + ;; Inside a comment; indentation of line depends on + ;; whether or not it starts with a *. + (mark-column + (let ((end (whitespace-start start (group-start start)))) + (let ((iend (indentation-end end))) + (let ((comstart (re-search-forward "/\\*[ \t]*" iend end))) + (cond ((not comstart) iend) + ((re-match-forward "[ \t]*\\*" start) + (mark1+ (re-match-start 0))) + (else comstart))))))) + ((char-match-forward #\# start) 0) + (else + (indent-line:adjust-indentation (horizontal-space-end start) + indentation)))))) + +(define (indent-line:adjust-indentation start indentation) + (cond ((or (re-match-forward "case\\b" start) + (and (re-match-forward "[A-Za-z]" start) + (char-match-forward #\: (forward-one-sexp start)))) + (max 1 (+ indentation (ref-variable "C Label Offset")))) + ((re-match-forward "else\\b" start) + (mark-indentation + (backward-to-start-of-if start + (backward-one-definition-start start)))) + ((char-match-forward #\} start) + (- indentation (ref-variable "C Indent Level"))) + ((char-match-forward #\{ start) + (+ indentation (ref-variable "C Brace Offset"))) + (else indentation))) + +(define (calculate-indentation mark parse-start) + (let ((gstart (group-start mark)) + (gend (group-end mark)) + (indent-point (line-start mark 0))) + (define (find-outer-container start) + (let ((state (parse-partial-sexp start indent-point 0))) + (if (mark= (parse-state-location state) indent-point) + state + (find-outer-container (parse-state-location state))))) + (let ((state + (find-outer-container (or parse-start + (backward-one-definition-start mark) + gstart)))) + (if (or (parse-state-in-string? state) + (parse-state-in-comment? state)) + ;; Return boolean if line should not be changed. + (not (not (parse-state-in-comment? state))) + (let ((container (parse-state-containing-sexp state))) + (cond ((not container) + ;; Line is at top level. Discriminate between + ;; procedure definition and other cases. + (if (re-match-forward "[ \t]*{" indent-point) + 0 + ;; May be data definition, or may be function + ;; argument declaration. Indent like the + ;; previous top level line unless that ends + ;; in a closeparen without semicolon, in + ;; which case this line is the first argument + ;; decl. + (let ((mark + (backward-to-noncomment indent-point + (or parse-start + gstart)))) + (if (char-match-backward #\) mark) + (ref-variable "C Argdecl Indent") + (mark-indentation mark))))) + ((char-match-forward #\{ container) + (calculate-indentation:statement indent-point container)) + (else + ;; Line is expression, not statement: indent to just + ;; after the surrounding open. + (mark-column (mark1+ container))))))))) + +(define (calculate-indentation:statement indent-point container) + (let ((mark (backward-to-noncomment indent-point container))) + (if (and mark + (re-match-forward "[^,;:{}]" (mark-1+ mark))) + ;; This line is continuation of preceding line's statement; + ;; indent C Continued Statement Offset more than the previous + ;; line of the statement. + (+ (ref-variable "C Continued Statement Offset") + (mark-column (backward-to-start-of-continued-exp mark container))) + (let ((mark (skip-comments&labels (mark1+ container) indent-point))) + (if (not mark) + ;; If this is first statement after open brace, indent + ;; it relative to line brace is on. For open brace in + ;; column zero, don't let statement start there too. If + ;; C Indent Level is zero, use C Brace Offset + C + ;; Continued Statement Offset instead. For open-braces + ;; not the first thing in a line, add in C Brace + ;; Imaginary Offset. + (+ (if (and (line-start? container) + (zero? (ref-variable "C Indent Level"))) + (+ (ref-variable "C Brace Offset") + (ref-variable "C Continued Statement Offset")) + (ref-variable "C Indent Level")) + (+ (if (within-indentation? container) + 0 + (ref-variable "C Brace Imaginary Offset")) + (mark-indentation container))) + ;; Otherwise, indent under that first statement. + (mark-column mark)))))) + +(define (skip-comments&labels start end) + (define (phi1 mark) + (cond ((mark= mark end) #!FALSE) + ((char-match-forward #\# mark) + (phi2 (line-start mark 1))) + ((match-forward "/*" mark) + (phi2 (search-forward "*/" mark end))) + ((re-match-forward "case[ \t\n]\\|[a-zA-Z0-9_$]*:" mark) + (phi2 (char-search-forward #\: mark end))) + (else mark))) + + (define (phi2 mark) + (and mark + (phi1 (whitespace-end mark end)))) + + (phi1 (whitespace-end start end))) + +(define (whitespace-start start end) + (skip-chars-backward " \t\n" start end)) + +(define (whitespace-end start end) + (skip-chars-forward " \t\n" start end)) + +(define (inside-parens? mark) + (let ((container (backward-up-one-list mark))) + (and container + (mark>= container (backward-one-definition-start mark)) + (char-match-forward #\( container)))) + +(define (backward-to-noncomment start end) + (define (loop start) + (let ((mark (whitespace-start start end))) + (if (match-backward "*/" mark) + (and (search-backward "/*" (re-match-start 0) end) + (loop (re-match-start 0))) + (let ((mark* (indentation-end mark))) + (cond ((not (char-match-forward #\# mark*)) mark) + ((mark<= mark* end) mark*) + (else (loop mark*))))))) + (loop start)) + +(define (backward-to-start-of-continued-exp start end) + (let ((mark + (line-start (if (char-match-backward #\) start) + (backward-one-sexp start) + start) + 0))) + (horizontal-space-end (if (mark<= mark end) (mark1+ end) mark)))) + +(define (backward-to-start-of-if start end) + (define (phi2 mark if-level) + (define (phi1 if-level) + (if (zero? if-level) + mark + (phi2 (backward-sexp mark 1 'LIMIT) if-level))) + (cond ((re-match-forward "else\\b" mark) + (phi1 (1+ if-level))) + ((re-match-forward "if\\b" mark) + (phi1 (-1+ if-level))) + ((mark>= mark end) + (phi1 if-level)) + (else end))) + (phi2 (backward-sexp start 1 'LIMIT) 1)) + +(define (indent-expression expression-start) + (fluid-let (((ref-variable "Case Fold Search") #!FALSE)) + (let ((end (mark-left-inserting (line-start (forward-sexp expression-start + 1 'ERROR) + 0)))) + (define (loop start indent-stack contain-stack last-depth) + (next-line-start start #!FALSE + (lambda (start state) + (let ((depth-delta (- (parse-state-depth state) last-depth))) + (let ((indent-stack (adjust-stack depth-delta indent-stack)) + (contain-stack (adjust-stack depth-delta contain-stack))) + (if (not (car contain-stack)) + (set-car! contain-stack + (or (parse-state-containing-sexp state) + (backward-one-sexp start)))) + (if (not (line-blank? start)) + (indent-line start indent-stack contain-stack)) + (if (not (mark= start end)) + (loop start indent-stack contain-stack + (parse-state-depth state)))))))) + + (define (next-line-start start state receiver) + (define (loop start state) + (let ((start* (line-start start 1))) + (let ((state* + (parse-partial-sexp start start* #!FALSE #!FALSE state))) + (if (and state (parse-state-in-comment? state)) + (indent-line start)) + (cond ((mark= start* end) + (receiver start* state*)) + ((parse-state-in-comment? state*) + (if (not (and state (parse-state-in-comment? state))) + (if (re-search-forward "/\\*[ \t]*" start start*) + (c-mode:comment-indent (re-match-start 0)) + (error "C-Indent-Expression: Missing comment"))) + (loop start* state*)) + ((parse-state-in-string? state*) + (loop start* state*)) + (else + (receiver start* state*)))))) + (loop start state)) + + (define (indent-line start indent-stack contain-stack) + (let ((indentation + (indent-line:adjust-indentation + start + (if (car indent-stack) + (if (char-match-forward #\{ (car contain-stack)) + ;; Line is at statement level. Is it a new + ;; statement? Is it an else? Find last + ;; non-comment character before this line. + (let ((mark + (backward-to-noncomment + start expression-start))) + (cond ((not (memv (extract-previous-char mark) + '(#!FALSE #\. #\; #\} #\:))) + (+ (ref-variable + "C Continued Statement Offset") + (mark-column + (backward-to-start-of-continued-exp + mark (car contain-stack))))) + ((re-match-forward "else\\b" start) + (mark-indentation + (backward-to-start-of-if mark + expression-start))) + (else (car indent-stack)))) + (car indent-stack)) + (let ((indentation (calculate-indentation start #!FALSE))) + (set-car! indent-stack indentation) + indentation))))) + (if (not (or (= indentation (mark-indentation start)) + (re-match-forward "[ \t]*#" start))) + (change-indentation indentation start)))) + + (loop expression-start + (list #!FALSE) + (list expression-start) + 0)))) + +(define (adjust-stack depth-delta indent-stack) + (cond ((zero? depth-delta) indent-stack) + ((positive? depth-delta) (up-stack depth-delta indent-stack)) + (else (down-stack depth-delta indent-stack)))) + +(define (down-stack n stack) + (if (= -1 n) + (cdr stack) + (down-stack (1+ n) (cdr stack)))) + +(define (up-stack n stack) + (if (= 1 n) + (cons #!FALSE stack) + (up-stack (-1+ n) (cons #!FALSE stack)))) + +;;; end C-INDENTATION-PACKAGE +)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm new file mode 100644 index 000000000..35b6b7c63 --- /dev/null +++ b/v7/src/edwin/calias.scm @@ -0,0 +1,99 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Alias Characters + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define alias-characters '()) + +(define (remap-alias-char char) + (let ((entry (assq char alias-characters))) + (if entry + (remap-alias-char (cdr entry)) + char))) + +(define (define-alias-char char char*) + (let ((entry (assq char alias-characters))) + (if entry + (set-cdr! entry char*) + (set! alias-characters (cons (cons char char*) alias-characters))))) + +(define (undefine-alias-char char) + (set! alias-characters (del-assq! char alias-characters))) + +(define-alias-char #\C-h #\Backspace) +(define-alias-char #\C-H #\Backspace) +(define-alias-char #\C-i #\Tab) +(define-alias-char #\C-I #\Tab) +(define-alias-char #\C-j #\Linefeed) +(define-alias-char #\C-J #\Linefeed) +(define-alias-char #\C-l #\Page) +(define-alias-char #\C-L #\Page) +(define-alias-char #\C-m #\Return) +(define-alias-char #\C-M #\Return) +(define-alias-char #\C-[ #\Altmode) + +(define-alias-char #\C-M-h #\M-Backspace) +(define-alias-char #\C-M-H #\M-Backspace) +(define-alias-char #\C-M-i #\M-Tab) +(define-alias-char #\C-M-I #\M-Tab) +(define-alias-char #\C-M-j #\M-Linefeed) +(define-alias-char #\C-M-J #\M-Linefeed) +(define-alias-char #\C-M-l #\M-Page) +(define-alias-char #\C-M-L #\M-Page) +(define-alias-char #\C-M-m #\M-Return) +(define-alias-char #\C-M-M #\M-Return) +(define-alias-char #\C-M-[ #\M-Altmode) + +;;; These are definitions for the HP 9000 model 237. +;;; They should probably be isolated somehow, but there is no clear way. +(define-alias-char #\S-S #\Rubout) ;Home +(define-alias-char #\S-R #\Linefeed) ;Select + +;;; These are definitions for the HP 9000 model 236. +(define-alias-char #\S-U #\Altmode) ;Run +(define-alias-char #\S-V #\Linefeed) ;Continue +(define-alias-char #\S-W #\Altmode) ;Execute + +;;; end USING-SYNTAX +) +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/class.scm b/v7/src/edwin/class.scm new file mode 100644 index 000000000..c10922081 --- /dev/null +++ b/v7/src/edwin/class.scm @@ -0,0 +1,327 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Class/Object System + +(declare (usual-integrations)) + +;;; ****************************************************************** +;;; This software is intended for use in the Edwin window system only. +;;; Don't think about using it for anything else, since it is not, and +;;; likely will not ever, be supported as a part of the Scheme system. +;;; ****************************************************************** + +(define class-syntax-table + (make-syntax-table edwin-syntax-table)) + +(define class-macros + (make-environment + +(define ((scode-macro-spreader transform) expression) + (apply transform (cdr expression))) + +(syntax-table-define class-syntax-table 'DEFINE-CLASS + (macro (name superclass variables) + (guarantee-symbol "Class name" name) + (if (not (null? superclass)) + (guarantee-symbol "Class name" superclass)) + ;; Compile-time definition. + (make-class name + (if (null? superclass) #!FALSE (name->class superclass)) + variables) + ;; Load-time definition. + `(DEFINE ,name + (MAKE-CLASS ',name + ,(if (null? superclass) '#!FALSE superclass) + ',variables)))) + +(syntax-table-define class-syntax-table 'DEFINE-METHOD + (scode-macro-spreader + (lambda (class bvl . body) + (syntax-class-definition class bvl body + (lambda (name expression) + (make-method-definition class name expression)))))) + +(syntax-table-define class-syntax-table 'DEFINE-PROCEDURE + (scode-macro-spreader + (lambda (class bvl . body) + (syntax-class-definition class bvl body + (lambda (name expression) + (make-definition name expression)))))) + +(syntax-table-define class-syntax-table 'WITH-INSTANCE-VARIABLES + (scode-macro-spreader + (lambda (class self . body) + (guarantee-symbol "Self name" self) + (syntax-class-expression class self body)))) + +(syntax-table-define class-syntax-table '=> + (macro (object operation . arguments) + (guarantee-symbol "Operation name" operation) + (if (symbol? object) + `((ACCESS ,operation (OBJECT-METHODS ,object)) ,object ,@arguments) + (let ((obname (string->uninterned-symbol "object"))) + `(LET ((,obname ,object)) + ((ACCESS ,operation (OBJECT-METHODS ,obname)) ,obname + ,@arguments)))))) + +(syntax-table-define class-syntax-table 'USUAL=> + (macro (object operation . arguments) + (guarantee-symbol "Operation name" operation) + (if (not *class-name*) + (error "Not inside class expression: USUAL=>" operation)) + `((ACCESS ,operation (CLASS-METHODS (CLASS-SUPERCLASS ,*class-name*))) + ,object ,@arguments))) + +(define (syntax-class-definition class bvl body receiver) + (parse-definition bvl body + (lambda (name expression) + (receiver bvl (syntax expression))) + (lambda (bvl body) + (let ((operation (car bvl)) + (self (cadr bvl))) + (guarantee-symbol "Operation name" operation) + (guarantee-symbol "Self name" self) + (receiver operation + (syntax-class-expression class self + `((NAMED-LAMBDA ,bvl ,@body)))))))) + +(define (parse-definition bvl body simple compound) + (define (loop bvl body) + (if (pair? (car bvl)) + (loop (car bvl) + `((LAMBDA ,(cdr bvl) ,@body))) + (compound bvl body))) + (if (symbol? bvl) + (begin (if (not (null? (cdr body))) + (error "Multiple forms in definition body" body)) + (simple bvl (car body))) + (loop bvl body))) + +(define *class-name* #!FALSE) + +(define (syntax-class-expression class-name self expression) + (guarantee-symbol "Class name" class-name) + (fluid-let ((*class-name* class-name)) + (transform-instance-variables + (class-instance-transforms (name->class class-name)) + self + (syntax* expression)))) + +(define (make-method-definition class operation expression) + (make-comb (make-variable 'CLASS-METHOD-DEFINE) (make-variable class) operation expression)) + +(define (make-comb operator . operands) + (make-combination operator operands)) + +(define (guarantee-symbol s x) + (if (not (symbol? x)) + (error (string-append s " must be a symbol") x))) + +;;; end CLASS-MACROS +)) + +(define make-class) +(define class?) +(define name->class) +(let () + +(set! make-class +(named-lambda (make-class name superclass variables) + (let ((class (and (not (lexical-unreferenceable? class-descriptors name)) + (lexical-reference class-descriptors name))) + (object-size (if superclass + (+ (length variables) (class-object-size superclass)) + (1+ (length variables)))) + (transforms (make-instance-transforms superclass variables))) + (if (and class (eq? (class-superclass class) superclass)) + (begin (with-output-to-port console-output-port + (lambda () + (newline) (write-string "Warning! Redefining class ") + (write name))) + (vector-set! class 3 object-size) + (vector-set! class 4 transforms) + class) + (let ((class + (vector class-tag name superclass object-size transforms + ;; **** MAKE-PACKAGE used here because + ;; MAKE-ENVIRONMENT is being flushed by the + ;; cross-syntaxer for no good reason. + (if superclass + (in-package (class-methods superclass) + (make-package methods ())) + ;; **** Because IN-PACKAGE NULL-ENVIRONMENT broken. + (make-package methods () + ((access system-environment-remove-parent! + environment-package) + (the-environment))))))) + ((access add-unparser-special-object! unparser-package) + class object-unparser) + (local-assignment class-descriptors name class) + class))))) + +(set! class? +(named-lambda (class? x) + (and (vector? x) + (not (zero? (vector-length x))) + (eq? class-tag (vector-ref x 0))))) + +(set! name->class +(named-lambda (name->class name) + (lexical-reference class-descriptors name))) + +(define class-tag "Class") + +(define (make-instance-transforms superclass variables) + (define (generate variables n tail) + (if (null? variables) + tail + (cons (cons (car variables) n) + (generate (cdr variables) (1+ n) tail)))) + (if superclass + (generate variables + (class-object-size superclass) + (class-instance-transforms superclass)) + (generate variables 1 '()))) + +((access add-unparser-special-object! unparser-package) + class-tag + (lambda (class) + (write-string "#[Class ") + (write (class-name class)) + (write-string "]"))) + +(define (object-unparser object) + (let ((methods (object-methods object))) + (if (lexical-unreferenceable? methods ':print-object) + (begin (write-string "#[") + (write (class-name (object-class object))) + (write-string " ") + (write (primitive-datum object)) + (write-string "]")) + ((lexical-reference methods ':print-object) object)))) + +(define class-descriptors + (make-package class-descriptors () + ((access system-environment-remove-parent! environment-package) + (the-environment)))) + +) + +(declare (integrate class-name class-superclass class-object-size + class-instance-transforms class-methods + class-method usual-method)) + +(define (class-name class) + (declare (integrate class)) + (vector-ref class 1)) + +(define (class-superclass class) + (declare (integrate class)) + (vector-ref class 2)) + +(define (class-object-size class) + (declare (integrate class)) + (vector-ref class 3)) + +(define (class-instance-transforms class) + (declare (integrate class)) + (vector-ref class 4)) + +(define (class-methods class) + (declare (integrate class)) + (vector-ref class 5)) + +(define (class-method class name) + (declare (integrate class name)) + (lexical-reference (class-methods class) name)) + +(define (class-method-define class name method) + (local-assignment (class-methods class) name method)) + +(define (usual-method class name) + (declare (integrate class name)) + (class-method (class-superclass class) name)) + +(define (subclass? class class*) + (define (loop class) + (and class + (or (eq? class class*) + (loop (class-superclass class))))) + (or (eq? class class*) + (loop (class-superclass class)))) + +(declare (integrate object-class object-methods object-method)) + +(define (make-object class) + (if (not (class? class)) (error "MAKE-OBJECT: Not a class" class)) + (let ((object (vector-cons (class-object-size class) #!FALSE))) + (vector-set! object 0 class) + object)) + +(define (object? object) + (and (vector? object) + (not (zero? (vector-length object))) + (class? (vector-ref object 0)))) + +(define (object-of-class? class object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? class (vector-ref object 0)))) + +(define (object-class object) + (declare (integrate object)) + (vector-ref object 0)) + +(define (object-methods object) + (declare (integrate object)) + (class-methods (object-class object))) + +(define (object-method object name) + (declare (integrate object name)) + (class-method (object-class object) name)) + +(define (send object operation . args) + (apply (object-method object operation) object args)) + +(define (send-if-handles object operation . args) + (let ((methods (object-methods object))) + (and (not (lexical-unreferenceable? methods operation)) + (apply (lexical-reference methods operation) object args)))) + +(define (send-usual class object operation . args) + (apply (usual-method class operation) object args)) \ No newline at end of file diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm new file mode 100644 index 000000000..aa09edd69 --- /dev/null +++ b/v7/src/edwin/comman.scm @@ -0,0 +1,108 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Commands and Variables + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-named-structure "Command" + name + description + procedure) + +(define (make-command name description procedure) + (let ((command + (or (string-table-get editor-commands name) + (let ((command (%make-command))) + (string-table-put! editor-commands name command) + command)))) + (vector-set! command command-index:name name) + (vector-set! command command-index:description description) + (vector-set! command command-index:procedure procedure) + command)) + +(define editor-commands + (make-string-table 500)) + +(define-unparser %command-tag + (lambda (command) + (write-string "Command ") + (write (command-name command)))) + +(define (name->command name) + (or (string-table-get editor-commands name) + (make-command name "" + (lambda (#!optional argument) + (editor-error "Undefined command: \"" name "\""))))) + +(define-named-structure "Variable" + name + description + symbol) + +(define (make-variable name description symbol) + (let ((variable + (or (string-table-get editor-variables name) + (let ((variable (%make-variable))) + (string-table-put! editor-variables name variable) + variable)))) + (vector-set! variable variable-index:name name) + (vector-set! variable variable-index:description description) + (vector-set! variable variable-index:symbol symbol) + variable)) + +(define editor-variables + (make-string-table 50)) + +(define-unparser %variable-tag + (lambda (variable) + (write-string "Variable ") + (write (variable-name variable)))) + +(define (name->variable name) + (or (string-table-get editor-variables name) + (make-variable name "" 'UNASSIGNED-VARIABLE))) + +(define (variable-ref variable) + (lexical-reference edwin-package (variable-symbol variable))) + +(define (variable-set! variable #!optional value) + (lexical-assignment edwin-package (variable-symbol variable) (set! value))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm new file mode 100644 index 000000000..4aa9176db --- /dev/null +++ b/v7/src/edwin/comred.scm @@ -0,0 +1,234 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Command Reader + +(declare (usual-integrations) + (integrate-external "edb:curren.bin.0")) +(using-syntax (access edwin-syntax-table edwin-package) + +(define (top-level-command-reader) + (fluid-let ((*auto-save-keystroke-count* 0)) + (define (^G-loop) + (with-keyboard-macro-disabled + (lambda () + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((*^G-interrupt-continuation* continuation)) + (command-reader)))))) + (^G-loop)) + (^G-loop))) + +(define command-reader) +(define execute-char) +(define execute-command) +(define read-and-dispatch-on-char) +(define dispatch-on-char) +(define dispatch-on-command) +(define abort-current-command) +(define current-command-char) +(define current-command) +(define set-command-message!) +(define command-message-receive) + +(define command-reader-package + (make-environment + +(define *command-continuation*) ;Continuation of current command +(define *command-char*) ;Character read to find current command +(define *command*) ;The current command +(define *command-message*) ;Message from last command +(define *next-message*) ;Message to next command +(define *non-undo-count*) ;# of self-inserts since last undo boundary + +(let () + +(set! command-reader +(named-lambda (command-reader) + (fluid-let ((*command-message*) + (*non-undo-count* 0)) + (with-command-argument-reader command-reader-loop)))) + +(define (command-reader-loop) + (let ((value + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((*command-continuation* continuation) + (*command-char*) + (*command*) + (*next-message* false)) + (start-next-command)))))) + (if (not (eq? value 'ABORT)) (value))) + (command-reader-loop)) + +(define (start-next-command) + (reset-command-state!) + (let ((window (current-window)) + (char (keyboard-read-char))) + (set! *command-char* char) + (set-command-prompt! (char->name char)) + (%dispatch-on-command + window + (comtab-entry (buffer-comtabs (window-buffer window)) char))) + (start-next-command)) + +) + +(define (reset-command-state!) + (reset-command-argument-reader!) + (reset-command-prompt!) + (set! *command-message* *next-message*) + (set! *next-message* false) + (if *defining-keyboard-macro?* (keyboard-macro-finalize-chars))) + +;;; The procedures for executing commands come in two flavors. The +;;; difference is that the EXECUTE-foo procedures reset the command +;;; state first, while the DISPATCH-ON-foo procedures do not. The +;;; latter should only be used by "prefix" commands such as C-X or +;;; C-3, since they want arguments, messages, etc. to be passed on. + +(set! execute-char +(named-lambda (execute-char comtab char) + (reset-command-state!) + (dispatch-on-char comtab char))) + +(set! execute-command +(named-lambda (execute-command command) + (reset-command-state!) + (dispatch-on-command command))) + +(set! read-and-dispatch-on-char +(named-lambda (read-and-dispatch-on-char) + (dispatch-on-char (current-comtab) (keyboard-read-char)))) + +(set! dispatch-on-char +(named-lambda (dispatch-on-char comtab char) + (set! *command-char* char) + (set-command-prompt! + (string-append-separated (command-argument-prompt) + (xchar->name char))) + (dispatch-on-command (comtab-entry comtab char)))) + +(set! dispatch-on-command +(named-lambda (dispatch-on-command command) + (%dispatch-on-command (current-window) command))) + +(define (%dispatch-on-command window command) + (set! *command* command) + (let ((procedure (command-procedure command)) + (argument (command-argument-standard-value))) + (if (or argument + *executing-keyboard-macro?* + (window-needs-redisplay? window)) + (begin (set! *non-undo-count* 0) + (procedure argument)) + (cond ((or (eq? procedure ^r-insert-self-command) + (and (eq? procedure ^r-auto-fill-space-command) + (not (auto-fill-break? (current-point)))) + (command-argument-self-insert? procedure)) + (let ((point (window-point window))) + (if (and (buffer-auto-save-modified? (window-buffer window)) + (null? (cdr (buffer-windows (window-buffer window)))) + (line-end? point) + (char-graphic? *command-char*) + (< (window-point-x window) + (-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 + *command-char*)) + (region-insert-char! point *command-char*)))) + ((eq? procedure ^r-forward-character-command) + (let ((point (window-point window))) + (if (and (not (group-end? point)) + (char-graphic? (mark-right-char point)) + (< (window-point-x window) + (- (window-x-size window) 2))) + (window-direct-output-forward-char! window) + (procedure argument)))) + ((eq? procedure ^r-backward-character-command) + (let ((point (window-point window))) + (if (and (not (group-start? point)) + (char-graphic? (mark-left-char point)) + (positive? (window-point-x window))) + (window-direct-output-backward-char! window) + (procedure argument)))) + (else + (if (not (typein-window? window)) + (undo-boundary! (window-point window))) + (set! *non-undo-count* 0) + (procedure argument)))))) + +(set! abort-current-command +(named-lambda (abort-current-command #!optional value) + (if (unassigned? value) (set! value 'ABORT)) + (keyboard-macro-disable) + (*command-continuation* value))) + +(set! current-command-char +(named-lambda (current-command-char) + *command-char*)) + +(set! current-command +(named-lambda (current-command) + *command*)) + +(set! set-command-message! +(named-lambda (set-command-message! tag . arguments) + (set! *next-message* (cons tag arguments)))) + +(set! command-message-receive +(named-lambda (command-message-receive tag if-received if-not-received) + (if (and *command-message* + (eq? (car *command-message*) tag)) + (apply if-received (cdr *command-message*)) + (if-not-received)))) + +;;; end COMMAND-READER-PACKAGE +)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access command-reader-package edwin-package) +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/comtab.scm b/v7/src/edwin/comtab.scm new file mode 100644 index 000000000..f0df81fd1 --- /dev/null +++ b/v7/src/edwin/comtab.scm @@ -0,0 +1,212 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Command Tables + +(declare (usual-integrations)) + +(define make-comtab) +(define comtab?) +(define comtab-entry) +(define prefix-char-list?) +(define comtab-key-bindings) +(define define-key) +(define define-prefix-key) +(define define-default-key) + +(define comtab-package + (make-environment + +(set! make-comtab +(named-lambda (make-comtab) + (vector comtab-tag (cons '() '())))) + +(set! comtab? +(named-lambda (comtab? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? comtab-tag (vector-ref object 0))))) + +(define comtab-tag "Comtab") +(define (comtab-dispatch-alists comtab) (vector-ref comtab 1)) + +(define-unparser comtab-tag + (lambda (comtab) + (write-string "Comtab ") + (write (primitive-datum comtab)))) + +(define (remap-char char) + (char-upcase (remap-alias-char char))) + +(define (set-comtab-entry! alists char command) + (let ((char (remap-char char))) + (let ((entry (assq char (cdr alists)))) + (if entry + (set-cdr! entry command) + (set-cdr! alists (cons (cons char command) (cdr alists))))))) + +(define (make-prefix-char! alists char alists*) + (let ((char (remap-char char))) + (let ((entry (assq char (car alists)))) + (if entry + (set-cdr! entry alists*) + (set-car! alists (cons (cons char alists*) (car alists))))))) + +(define (comtab-lookup-prefix comtabs char receiver #!optional if-undefined) + (define (loop char->alist chars) + (let ((entry (assq (remap-char (car chars)) char->alist))) + (if entry + (if (null? (cddr chars)) + (receiver (cdr entry) (cadr chars)) + (loop (cadr entry) (cdr chars))) + (if (unassigned? if-undefined) + (error "Not a prefix character" (car chars)) + (if-undefined))))) + (cond ((char? char) + (receiver (comtab-dispatch-alists (car comtabs)) char)) + ((pair? char) + (if (null? (cdr char)) + (receiver (comtab-dispatch-alists (car comtabs)) (car char)) + (loop (car (comtab-dispatch-alists (car comtabs))) char))) + (else + (error "Unrecognizable character" char)))) + +(set! comtab-entry +(named-lambda (comtab-entry comtabs xchar) + (define (continue) + (cond ((null? (cdr comtabs)) bad-command) + ((comtab? (cadr comtabs)) (comtab-entry (cdr comtabs) xchar)) + (else (cadr comtabs)))) + (comtab-lookup-prefix comtabs xchar + (lambda (alists char) + (let ((entry (assq (remap-char char) (cdr alists)))) + (if entry + (cdr entry) + (continue)))) + continue))) + +(define bad-command + (name->command "^R Bad Command")) + +(set! prefix-char-list? +(named-lambda (prefix-char-list? comtabs chars) + (define (loop char->alist chars) + (or (null? chars) + (let ((entry (assq (remap-char (car chars)) char->alist))) + (if entry + (loop (cadr entry) (cdr chars)) + (and (not (null? (cdr comtabs))) + (comtab? (cadr comtabs)) + (prefix-char-list? (cdr comtabs) chars)))))) + (loop (car (comtab-dispatch-alists (car comtabs))) chars))) + +(set! define-key +(named-lambda (define-key mode-name char command-name) + (let ((comtabs (mode-comtabs (name->mode mode-name))) + (command (name->command command-name))) + (cond ((or (char? char) (pair? char)) + (%define-key comtabs char command)) + ((char-set? char) + (for-each (lambda (char) (%define-key comtabs char command)) + (char-set-members char))) + (else (error "DEFINE-KEY: Not a character" char)))) + char)) + +(define (%define-key comtabs xchar command) + (comtab-lookup-prefix comtabs xchar + (lambda (alists char) + (set-comtab-entry! alists char command)))) + +(set! define-prefix-key +(named-lambda (define-prefix-key mode-name char command-name) + (let ((comtabs (mode-comtabs (name->mode mode-name))) + (command (name->command command-name))) + (cond ((or (char? char) (pair? char)) + (comtab-lookup-prefix comtabs char + (lambda (alists char) + (set-comtab-entry! alists char command) + (make-prefix-char! alists char (cons '() '()))))) + (else (error "DEFINE-PREFIX-KEY: Not a character" char)))) + char)) + +(set! define-default-key +(named-lambda (define-default-key mode-name command-name) + (let ((comtabs (mode-comtabs (name->mode mode-name)))) + (if (not (or (null? (cdr comtabs)) (command? (cadr comtabs)))) + (error "Can't define default key for this mode" mode-name)) + (set-cdr! comtabs (list (name->command command-name)))) 'DEFAULT-KEY)) + +(set! comtab-key-bindings +(named-lambda (comtab-key-bindings comtabs command) + (define (search-comtabs comtabs) + (let ((bindings + (search-comtab '() (comtab-dispatch-alists (car comtabs))))) + (if (and (not (null? (cdr comtabs))) + (comtab? (cadr comtabs))) + (append! bindings (search-comtabs (cdr comtabs))) + bindings))) + + (define (search-comtab prefix dispatch-alists) + (define (search-prefix-map alist) + (if (null? alist) + (map (lambda (char) (append prefix (list char))) + (search-command-map (cdr dispatch-alists))) + (append! (search-comtab (append prefix (list (caar alist))) + (cdar alist)) + (search-prefix-map (cdr alist))))) + + (define (search-command-map alist) + (cond ((null? alist) '()) + ((eq? command (cdar alist)) + (cons (caar alist) (search-command-map (cdr alist)))) + (else + (search-command-map (cdr alist))))) + + (search-prefix-map (car dispatch-alists))) + + ;; Filter out shadowed bindings. + (list-transform-positive (search-comtabs comtabs) + (lambda (xchar) + (eq? command (comtab-entry comtabs xchar)))))) + +;;; end COMTAB-PACKAGE +)) + +;;; Edwin Variables: +;;; Scheme Environment: (access comtab-package edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/comwin.scm b/v7/src/edwin/comwin.scm new file mode 100644 index 000000000..22f00f9fa --- /dev/null +++ b/v7/src/edwin/comwin.scm @@ -0,0 +1,705 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Combination Windows + +(declare (usual-integrations) + (integrate-external "edb:window.bin.0")) +(using-syntax class-syntax-table + +;;; Combination windows are used to split a window into vertically or +;;; horizontally divided areas. That window's initial superior must +;;; support the :NEW-ROOT-WINDOW! operation, but is otherwise not +;;; constrained. + +;;; (=> WINDOW :NEW-ROOT-WINDOW! WINDOW*) + +;;; This is called whenever the root is changed. It need not do +;;; anything at all, but it is useful to keep track of the root. + +;;; What happens is that the initial window may be split horizontally +;;; or vertically, as many times as desired. The combination windows +;;; organize those splits into a tree. The leaves of the tree are not +;;; combination windows, but are created from one of the other leaves +;;; by the :MAKE-LEAF operation. Of course, the initial window is a +;;; leaf window too. + +;;; If there is just one leaf window in the tree, then it is the root +;;; window also. Otherwise, the root is a combination window. + +;;; The leaf windows must be subclasses of COMBINATION-LEAF-WINDOW, +;;; and they must support these operations: + +;;; (=> WINDOW :MAKE-LEAF) + +;;; Make a new leaf which can be placed next to WINDOW. For example, +;;; if WINDOW is a buffer window, the new window should also be a +;;; buffer window, visiting the same buffer, and sharing the same +;;; superior. + +;;; (=> WINDOW :MINIMUM-X-SIZE) +;;; (=> WINDOW :MINIMUM-Y-SIZE) + +;;; These define how small the window is allowed to be. Since the +;;; combination window operations change the sizes of leaf windows, +;;; they need some idea of how small the leaves are allowed to get. +;;; So, no window will ever be set to a size that is below its minimum +;;; -- it will be deleted from the heirarchy instead. + +;;; The values of these operations may depend on the window's position +;;; in the heirarchy, i.e. the SUPERIOR, NEXT-WINDOW, and +;;; PREVIOUS-WINDOW. These are carefully arranged in the target +;;; configuration before the operations are invoked. This is intended +;;; to allow the leaves to have different minimums when there are +;;; optional borders which depend on their placement. + +;;; Under no circumstances should the :MINIMUM-SIZE depend on the +;;; current size of a leaf window. + +(define window+) +(define window-) +(define window1+) +(define window-1+) +(define window0) +(define window-has-no-neighbors?) +(define window-has-horizontal-neighbor?) +(define window-has-vertical-neighbor?) +(define window-has-right-neighbor?) +(define window-has-left-neighbor?) +(define window-has-up-neighbor?) +(define window-has-down-neighbor?) +(define window-split-horizontally!) +(define window-split-vertically!) +(define window-delete!) +(define window-grow-horizontally!) +(define window-grow-vertically!) + +(define-class combination-leaf-window vanilla-window + (next-window previous-window)) + +(define combination-package + (make-environment + +(declare (integrate window-next set-window-next! + window-previous set-window-previous!)) + +(define-procedure combination-leaf-window (window-next window) + (declare (integrate window)) + next-window) + +(define-procedure combination-leaf-window (set-window-next! window window*) + (declare (integrate window window*)) + (set! next-window window*)) + +(define-procedure combination-leaf-window (window-previous window) + (declare (integrate window)) + previous-window) + +(define-procedure combination-leaf-window (set-window-previous! window window*) + (declare (integrate window window*)) + (set! previous-window window*)) + +(define (link-windows! previous next) + (set-window-previous! next previous) + (set-window-next! previous next)) + +(define-class combination-window combination-leaf-window + (vertical? child)) + +(declare (integrate combination-vertical? set-combination-vertical! + combination-child combination? leaf? check-leaf-window)) + +(define-procedure combination-window (combination-vertical? window) + (declare (integrate window)) + vertical?) + +(define-procedure combination-window (set-combination-vertical! window v) + (declare (integrate window v)) + (set! vertical? v)) + +(define-procedure combination-window (combination-child window) + (declare (integrate window)) + child) + +(define-procedure combination-window (set-combination-child! window window*) + (set! child window*) + (set-window-previous! window* #!FALSE)) + +(define (combination? window) + (declare (integrate window)) + (object-of-class? combination-window window)) + +(define (leaf? window) + (declare (integrate window)) + (and (object? window) + (subclass? (object-class window) combination-leaf-window) + (not (eq? (object-class window) combination-window)))) + +(define (check-leaf-window window name) + (declare (integrate window name)) + (if (not (leaf? window)) + (error "Not a leaf window" name window))) + +;;;; Leaf Ordering + +(set! window+ +(named-lambda (window+ leaf n) + (check-leaf-window leaf 'WINDOW+) + (cond ((positive? n) (%window+ leaf n)) + ((negative? n) (%window- leaf (- n))) + (else leaf)))) + +(set! window- +(named-lambda (window- leaf n) + (check-leaf-window leaf 'WINDOW-) + (cond ((positive? n) (%window- leaf n)) + ((negative? n) (%window+ leaf (- n))) + (else leaf)))) + +(define (%window+ leaf n) + (if (= n 1) + (%window1+ leaf) + (%window+ (%window1+ leaf) (-1+ n)))) + +(define (%window- leaf n) + (if (= n 1) + (%window-1+ leaf) + (%window- (%window-1+ leaf) (-1+ n)))) + +(set! window1+ +(named-lambda (window1+ leaf) + (check-leaf-window leaf 'WINDOW1+) + (%window1+ leaf))) + +(set! window-1+ +(named-lambda (window-1+ leaf) + (check-leaf-window leaf 'WINDOW-1+) + (%window-1+ leaf))) + +(set! window0 +(named-lambda (window0 window) + (if (not (and (object? window) + (subclass? (object-class window) combination-leaf-window))) + (error "WINDOW0: Window neither combination nor leaf" window)) + (window-leftmost-leaf (window-root window)))) + +(define (%window1+ leaf) + (window-leftmost-leaf + (or (window-next leaf) + (if (combination? (window-superior leaf)) + (find-window-with-next (window-superior leaf)) + leaf)))) + +(define (%window-1+ leaf) + (window-rightmost-leaf + (or (window-previous leaf) + (if (combination? (window-superior leaf)) + (find-window-with-previous (window-superior leaf)) + leaf)))) + +(define (find-window-with-next combination) + (or (window-next combination) + (if (combination? (window-superior combination)) + (find-window-with-next (window-superior combination)) + combination))) + +(define (find-window-with-previous combination) + (or (window-previous combination) + (if (combination? (window-superior combination)) + (find-window-with-previous (window-superior combination)) + combination))) + +(define (window-first window) + (if (window-previous window) + (window-first (window-previous window)) + window)) + +(define (window-last window) + (if (window-next window) + (window-last (window-next window)) + window)) + +(define (window-root window) + (if (combination? (window-superior window)) + (window-root (window-superior window)) + window)) + +(define (window-leftmost-leaf window) + (if (combination? window) + (window-leftmost-leaf (combination-child window)) + window)) + +(define (window-rightmost-leaf window) + (if (combination? window) + (window-rightmost-leaf (window-last (combination-child window))) + window)) + +(set! window-has-no-neighbors? +(named-lambda (window-has-no-neighbors? leaf) + (check-leaf-window leaf 'WINDOW-HAS-NO-NEIGHBORS?) + (not (combination? (window-superior leaf))))) + +(set! window-has-horizontal-neighbor? +(named-lambda (window-has-horizontal-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-HORIZONTAL-NEIGHBOR?) + (%window-has-horizontal-neighbor? leaf))) + +(define (%window-has-horizontal-neighbor? window) + (and (combination? (window-superior window)) + (or (not (combination-vertical? (window-superior window))) + (%window-has-horizontal-neighbor? (window-superior window))))) + +(set! window-has-vertical-neighbor? +(named-lambda (window-has-vertical-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-VERTICAL-NEIGHBOR?) + (%window-has-vertical-neighbor? leaf))) + +(define (%window-has-vertical-neighbor? window) + (and (combination? (window-superior window)) + (or (combination-vertical? (window-superior window)) + (%window-has-vertical-neighbor? (window-superior window))))) + +(set! window-has-right-neighbor? +(named-lambda (window-has-right-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-RIGHT-NEIGHBOR?) + (%window-has-right-neighbor? leaf))) + +(define (%window-has-right-neighbor? window) + (and (combination? (window-superior window)) + (or (and (not (combination-vertical? (window-superior window))) + (window-next window)) + (%window-has-right-neighbor? (window-superior window))))) + +(set! window-has-left-neighbor? +(named-lambda (window-has-left-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-LEFT-NEIGHBOR?) + (%window-has-left-neighbor? leaf))) + +(define (%window-has-left-neighbor? window) + (and (combination? (window-superior window)) + (or (and (not (combination-vertical? (window-superior window))) + (window-previous window)) + (%window-has-left-neighbor? (window-superior window))))) + +(set! window-has-up-neighbor? +(named-lambda (window-has-up-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-UP-NEIGHBOR?) + (%window-has-up-neighbor? leaf))) + +(define (%window-has-up-neighbor? window) + (and (combination? (window-superior window)) + (or (and (combination-vertical? (window-superior window)) + (window-next window)) + (%window-has-up-neighbor? (window-superior window))))) + +(set! window-has-down-neighbor? +(named-lambda (window-has-down-neighbor? leaf) + (check-leaf-window leaf 'WINDOW-HAS-DOWN-NEIGHBOR?) + (%window-has-down-neighbor? leaf))) + +(define (%window-has-down-neighbor? window) + (and (combination? (window-superior window)) + (or (and (combination-vertical? (window-superior window)) + (window-next window)) + (%window-has-down-neighbor? (window-superior window))))) + +;;;; Creation + +(set! window-split-horizontally! +(named-lambda (window-split-horizontally! leaf #!optional n) + (check-leaf-window leaf 'WINDOW-SPLIT-HORIZONTALLY!) + (if (or (unassigned? n) (not n)) + (set! n (quotient (window-x-size leaf) 2))) + (let ((x (window-x-size leaf)) + (y (window-y-size leaf))) + (let ((n* (- x n))) + (let ((new (allocate-leaf! leaf #!FALSE))) + (let ((combination (window-superior leaf))) + (inferior-start (window-inferior combination leaf) + (lambda (x y) + (set-inferior-start! (window-inferior combination new) + (+ x n) y)))) + (if (or (< n (=> leaf :minimum-x-size)) + (< n* (=> new :minimum-x-size))) + (begin (deallocate-leaf! new) + #!FALSE) + (begin (=> leaf :set-x-size! n) + (=> new :set-size! n* y) + new))))))) + +(set! window-split-vertically! +(named-lambda (window-split-vertically! leaf #!optional n) + (check-leaf-window leaf 'WINDOW-SPLIT-VERTICALLY!) + (if (or (unassigned? n) (not n)) + (set! n (quotient (window-y-size leaf) 2))) + (let ((x (window-x-size leaf)) + (y (window-y-size leaf))) + (let ((n* (- y n))) + (let ((new (allocate-leaf! leaf #!TRUE))) + (let ((combination (window-superior leaf))) + (inferior-start (window-inferior combination leaf) + (lambda (x y) + (set-inferior-start! (window-inferior combination new) + x (+ y n))))) + (if (or (< n (=> leaf :minimum-y-size)) + (< n* (=> new :minimum-y-size))) + (begin (deallocate-leaf! new) + #!FALSE) + (begin (=> leaf :set-y-size! n) + (=> new :set-size! x n*) + new))))))) + +(define (allocate-leaf! leaf v) + (let ((superior (window-superior leaf))) + (if (or (not (combination? superior)) + (not (eq? v (combination-vertical? superior)))) + (let ((combination (=> superior :make-inferior combination-window))) + (=> superior :set-inferior-position! combination + (=> superior :inferior-position leaf)) + (set-combination-vertical! combination v) + (window-replace! leaf combination) + (set-combination-child! combination leaf) + (set-window-next! leaf #!FALSE) + (=> superior :delete-inferior! leaf) + (add-inferior! combination leaf) + (set-inferior-start! (window-inferior combination leaf) 0 0) + (set-window-size! combination + (window-x-size leaf) + (window-y-size leaf))))) + (let ((new (=> leaf :make-leaf))) + (set-window-next! new (window-next leaf)) + (if (window-next leaf) (set-window-previous! (window-next leaf) new)) + (link-windows! leaf new) + new)) + +(define (deallocate-leaf! leaf) + (unlink-leaf! leaf) + (maybe-delete-combination! (window-superior leaf))) + +;;;; Deletion + +(set! window-delete! +(named-lambda (window-delete! leaf) + (check-leaf-window leaf 'WINDOW-DELETE!) + (let ((superior (window-superior leaf))) + (define (adjust-size! window) + (if (combination-vertical? superior) + (=> window :set-y-size! + (+ (window-y-size window) (window-y-size leaf))) + (=> window :set-x-size! + (+ (window-x-size window) (window-x-size leaf))))) + + (if (not (combination? superior)) + (error "Attempt to delete top window")) + (unlink-leaf! leaf) + (let ((value + (cond ((window-next leaf) + (adjust-size! (window-next leaf)) + (let ((inferior + (window-inferior superior (window-next leaf)))) + (if (combination-vertical? superior) + (set-inferior-y-start! inferior + (- (inferior-y-start inferior) + (window-y-size leaf))) + (set-inferior-x-start! inferior + (- (inferior-x-start inferior) + (window-x-size leaf))))) + (window-next leaf)) + ((window-previous leaf) + (adjust-size! (window-previous leaf)) + (window-previous leaf)) + (else + (error "Combination with single child -- WINDOW-DELETE!" + superior))))) + (maybe-delete-combination! superior) + value)))) + +(define (unlink-leaf! leaf) + (let ((combination (window-superior leaf)) + (next (window-next leaf)) + (previous (window-previous leaf))) + (delete-inferior! combination leaf) + (=> leaf :kill!) + (if previous + (set-window-next! previous next) + (set-combination-child! combination next)) + (if next + (set-window-previous! next previous)))) + +(define (maybe-delete-combination! combination) + (let ((child (combination-child combination))) + (if (not (window-next child)) + (begin (delete-inferior! combination child) + (=> (window-superior combination) :replace-inferior! + combination child) + (window-replace! combination child))))) + +(define-procedure combination-leaf-window (window-replace! old new) + (cond ((not (combination? superior)) + (=> superior :new-root-window! new)) + ((and (combination? new) + (eq? (combination-vertical? superior) + (combination-vertical? new))) + (let ((first (combination-child new))) + (inferior-start (window-inferior superior new) + (lambda (xs ys) + (define (loop window) + (add-inferior! superior window) + (inferior-start (window-inferior new window) + (lambda (x y) + (set-inferior-start! (window-inferior superior window) + (+ xs x) (+ ys y)))) + (if (window-next window) + (loop (window-next window)))) + (delete-inferior! superior new) + (loop first))) + (if next-window + (link-windows! (window-last first) next-window)) + (if previous-window + (link-windows! previous-window first) + (set-combination-child! superior first)))) + (else + (if next-window + (link-windows! new next-window)) + (if previous-window + (link-windows! previous-window new) + (set-combination-child! superior new))))) + +;;;; Sizing + +(define (window-grow! leaf delta + v size min-size + set-c-size! set-w-size! + start set-start!) + (check-leaf-window leaf 'WINDOW-GROW!) + (let ((combination (window-superior leaf))) + (define (loop) + (if (not (combination? combination)) + (error "No siblings of this window" leaf)) + (if (not (eq? v (combination-vertical? combination))) + (begin (set! leaf combination) + (set! combination (window-superior combination)) + (loop)))) + (loop) + (let ((new-size (+ (size leaf) delta)) + (next (window-next leaf)) + (previous (window-previous leaf))) + (if (> new-size (size combination)) + (begin (set! new-size (size combination)) + (set! delta (- new-size (size leaf))))) + (cond ((< new-size (min-size leaf)) + (window-delete! leaf)) + ((and next (>= (- (size next) delta) (min-size next))) + (let ((inferior (window-inferior combination next))) + (set-start! inferior (+ (start inferior) delta))) + (set-w-size! next (- (size next) delta)) + (set-w-size! leaf new-size)) + ((and previous + (>= (- (size previous) delta) (min-size previous))) + (let ((inferior (window-inferior combination leaf))) + (set-start! inferior (- (start inferior) delta))) + (set-w-size! previous (- (size previous) delta)) + (set-w-size! leaf new-size)) + (else + (scale-combination-inferiors! combination + (- (size combination) new-size) + leaf v size min-size + set-c-size! set-w-size! + set-start!) + ;; Scaling may have deleted all other inferiors. + ;; If so, leaf has replaced combination. + (set-w-size! leaf + (if (eq? combination (window-superior leaf)) + new-size + (size combination)))))))) + +(set! window-grow-horizontally! +(named-lambda (window-grow-horizontally! leaf delta) + (window-grow! leaf delta #!FALSE + window-x-size window-min-x-size + set-window-x-size! send-window-x-size! + inferior-x-start set-inferior-x-start!))) + +(set! window-grow-vertically! +(named-lambda (window-grow-vertically! leaf delta) + (window-grow! leaf delta #!TRUE + window-y-size window-min-y-size + set-window-y-size! send-window-y-size! + inferior-y-start set-inferior-y-start!))) + +(define (scale-combination-inferiors-x! combination x except) + (scale-combination-inferiors! combination x except #!FALSE + window-x-size window-min-x-size + set-window-x-size! send-window-x-size! + set-inferior-x-start!)) + +(define (scale-combination-inferiors-y! combination y except) + (scale-combination-inferiors! combination y except #!TRUE + window-y-size window-min-y-size + set-window-y-size! send-window-y-size! + set-inferior-y-start!)) + +(define (window-min-x-size window) + (=> window :minimum-x-size)) + +(define (send-window-x-size! window x) + (=> window :set-x-size! x)) + +(define (window-min-y-size window) + (=> window :minimum-y-size)) + +(define (send-window-y-size! window y) + (=> window :set-y-size! y)) + +(define-method combination-window (:minimum-x-size combination) + (=> (window-leftmost-leaf combination) :minimum-x-size)) + +(define-method combination-window (:minimum-y-size combination) + (=> (window-leftmost-leaf combination) :minimum-y-size)) + +(define (set-combination-x-size! combination x) + (scale-combination-inferiors-x! combination x #!FALSE) + (set-window-x-size! combination x)) + +(define (set-combination-y-size! combination y) + (scale-combination-inferiors-y! combination y #!FALSE) + (set-window-y-size! combination y)) + +(define (set-combination-size! combination x y) + (scale-combination-inferiors-x! combination x #!FALSE) + (scale-combination-inferiors-y! combination y #!FALSE) + (set-window-size! combination x y)) + +(define-method combination-window :set-x-size! set-combination-x-size!) +(define-method combination-window :set-y-size! set-combination-y-size!) +(define-method combination-window :set-size! set-combination-size!) + +(define (scale-combination-inferiors! combination new-room except + v size min-size + set-c-size! set-w-size! + set-start!) + ;; Change all of the inferiors of COMBINATION (except EXCEPT) to + ;; use NEW-ROOM's worth of space. EXCEPT, if given, should not be + ;; changed in size, but should be moved if its neighbors change. + ;; It is assumed that EXCEPT is given only for case where the + ;; combination's VERTICAL? flag is the same as V. + + ;; General strategy: + ;; If the window is growing, we can simply change the sizes of the + ;; inferiors. However, if it is shrinking, we must be more careful + ;; because some or all of the inferiors can be deleted. So in that + ;; case, before any sizes are changed, we find those inferiors that + ;; will be deleted and delete them. If we delete all of the + ;; inferiors, then we are done: this window has also been deleted. + ;; Otherwise, we can then perform all of the changes, knowing that + ;; no window will grow too small. + + (let ((c-size (size combination)) + (same? (eq? (combination-vertical? combination) v)) + (child (combination-child combination))) + (let ((old-room (if (and same? except) (- c-size (size except)) c-size))) + + (define (diff-start) + (diff-loop child)) + + (define (diff-loop window) + (set-w-size! window new-room) + (if (window-next window) + (diff-loop (window-next window)))) + + (define (diff-deletions) + (for-each window-delete! (diff-collect child)) + (if (not (null? (window-inferiors combination))) (diff-start))) + + (define (diff-collect window) + (let ((deletions + (if (window-next window) + (diff-collect (window-next window)) + '()))) + (if (< new-room (min-size window)) + (cons window deletions) + deletions))) + + (define (same-start) + (same-loop child 0 old-room new-room)) + + (define (same-loop window start old-room new-room) + (set-start! (window-inferior combination window) start) + (cond ((eq? window except) + (if (window-next window) + (same-loop (window-next window) start old-room new-room))) + ((not (window-next window)) + (set-w-size! window new-room)) + (else + (let ((old-s (size window))) + (let ((new-s (truncate (* old-s (/ new-room old-room))))) + (set-w-size! window new-s) + (same-loop (window-next window) + (+ start new-s) + (- old-room old-s) + (- new-room new-s))))))) + + (define (same-deletions) + (for-each window-delete! (same-collect child old-room new-room)) + (if (not (null? (window-inferiors combination))) (same-start))) + + (define (same-collect window old-room new-room) + (cond ((eq? window except) + (if (window-next window) + (same-collect (window-next window) old-room new-room) + '())) + ((not (window-next window)) + (if (< new-room (min-size window)) + (list window) + '())) + (else + (let ((old-s (size window))) + (let ((new-s (truncate (* old-s (/ new-room old-room))))) + (let ((deletions (same-collect (window-next window) + (- old-room old-s) + (- new-room new-s)))) + (if (< new-s (min-size window)) + (cons window deletions) + deletions))))))) + + (cond ((< old-room new-room) + ((if same? same-start diff-start))) + ((> old-room new-room) + ((if same? same-deletions diff-deletions))))))) + +;;; end COMBINATION-PACKAGE +))) \ No newline at end of file diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm new file mode 100644 index 000000000..6f3c52ec3 --- /dev/null +++ b/v7/src/edwin/curren.scm @@ -0,0 +1,358 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Current State + +(declare (usual-integrations) + (integrate-external "edb:editor.bin.0") + (integrate-external "edb:buffer.bin.0") + (integrate-external "edb:bufset.bin.0")) +(using-syntax edwin-syntax-table + +;;;; Windows + +(define (current-window) + ((access editor-frame-selected-window window-package) (current-frame))) + +(define (window0) + ((access editor-frame-window0 window-package) (current-frame))) + +(define (typein-window) + ((access editor-frame-typein-window window-package) (current-frame))) + +(define (typein-window? window) + (eq? window (typein-window))) + +(define (select-window window) + (without-interrupts + (lambda () + (exit-buffer (current-buffer)) + ((access editor-frame-select-window! window-package) + (current-frame) + window) + (enter-buffer (window-buffer window))))) + +(define (select-cursor window) + ((access editor-frame-select-cursor! window-package) (current-frame) window)) + +(define ((window-buffer-setter enter-buffer exit-buffer) window buffer) + (without-interrupts + (lambda () + (let ((current (current-window))) + (if (eq? window current) + (begin (exit-buffer (window-buffer current)) + ((access set-window-buffer! window-package) window buffer) + (enter-buffer buffer)) + ((access set-window-buffer! window-package) window buffer)))))) + +(define (window-list) + (let ((window0 (window0))) + (define (loop window) + (if (eq? window window0) + (list window) + (cons window (loop (window1+ window))))) + (loop (window1+ window0)))) + +(define (window-visible? window) + (or (typein-window? window) + (let ((window0 (window0))) + (define (loop window*) + (or (eq? window window*) + (and (not (eq? window* window0)) + (loop (window1+ window*))))) + (loop (window1+ window0))))) + +(define other-window + (let () + (define (+loop n window) + (if (zero? n) + window + (+loop (-1+ n) + (if (typein-window? window) + (window0) + (let ((window (window1+ window))) + (if (and (within-typein-edit?) + (eq? window (window0))) + (typein-window) + window)))))) + (define (-loop n window) + (if (zero? n) + window + (-loop (1+ n) + (if (and (within-typein-edit?) + (eq? window (window0))) + (typein-window) + (window-1+ (if (typein-window? window) + (window0) + window)))))) + (named-lambda (other-window #!optional n) + (if (or (unassigned? n) (not n)) (set! n 1)) + (cond ((positive? n) (+loop n (current-window))) + ((negative? n) (-loop n (current-window))) + (else (current-window)))))) + +(define (window-delete! window) + (if (typein-window? window) + (editor-error "Attempt to delete the typein window")) + (if (window-has-no-neighbors? window) + (editor-error "Attempt to delete only window")) + (if (eq? window (current-window)) + (begin (select-window (window1+ window)) + (select-window ((access window-delete! window-package) window))) + ((access window-delete! window-package) window))) + +(define (window-grow-horizontally! window n) + (if (typein-window? window) + (editor-error "Can't grow the typein window")) + (if (not (window-has-horizontal-neighbor? window)) + (editor-error "Can't grow this window horizontally")) + ((access window-grow-horizontally! window-package) window n)) + +(define (window-grow-vertically! window n) + (if (typein-window? window) + (editor-error "Can't grow the typein window")) + (if (not (window-has-vertical-neighbor? window)) + (editor-error "Can't grow this window vertically")) + ((access window-grow-vertically! window-package) window n)) + +;;;; Buffers + +(define-integrable (buffer-list) + (list-copy (bufferset-buffer-list (current-bufferset)))) + +(define-integrable (buffer-alive? buffer) + (memq buffer (bufferset-buffer-list (current-bufferset)))) + +(define-integrable (buffer-names) + (bufferset-names (current-bufferset))) + +(define-integrable (current-buffer) + (window-buffer (current-window))) + +(define-integrable (previous-buffer) + (other-buffer (current-buffer))) + +(define-integrable (select-buffer buffer) + (set-window-buffer! (current-window) buffer)) + +(define-integrable (select-buffer-no-record buffer) + (set-window-buffer-no-record! (current-window) buffer)) + +(define-integrable (select-buffer-in-window buffer window) + (set-window-buffer! window buffer)) + +(define (select-buffer-other-window buffer) + (define (expose-buffer window) + (select-window window) + (select-buffer buffer)) + + (let ((window (current-window))) + (if (window-has-no-neighbors? window) + (expose-buffer (window-split-vertically! window #!FALSE)) + (let ((window* (get-buffer-window buffer))) + (if (and window* (not (eq? window window*))) + (begin (set-window-point! window* (buffer-point buffer)) + (select-window window*)) + (expose-buffer (window1+ window))))))) + +(define (bury-buffer buffer) + (bufferset-bury-buffer! (current-bufferset) buffer)) + +(define (enter-buffer buffer) + (bufferset-select-buffer! (current-bufferset) buffer) + (%wind-local-bindings! buffer) + (perform-buffer-initializations! buffer)) + +(define (exit-buffer buffer) + (bufferset-select-buffer! (current-bufferset) buffer) + (%wind-local-bindings! buffer)) + +(define set-window-buffer! + (window-buffer-setter enter-buffer exit-buffer)) + +(define (enter-buffer-no-record buffer) + (%wind-local-bindings! buffer) + (perform-buffer-initializations! buffer)) + +(define (exit-buffer-no-record buffer) + (%wind-local-bindings! buffer)) + +(define set-window-buffer-no-record! + (window-buffer-setter enter-buffer-no-record exit-buffer-no-record)) + +(define (with-selected-buffer buffer thunk) + (define (switch) + (let ((new-buffer (set! buffer (current-buffer)))) + (if (buffer-alive? new-buffer) + (select-buffer new-buffer)))) + (dynamic-wind switch thunk switch)) + +(define (other-buffer buffer) + (define (loop less-preferred buffers) + (cond ((null? buffers) + less-preferred) + ((or (eq? buffer (car buffers)) + (minibuffer? (car buffers))) + (loop less-preferred (cdr buffers))) + ((buffer-visible? (car buffers)) + (loop (or less-preferred (car buffers)) (cdr buffers))) + (else + (car buffers)))) + (loop #!FALSE (buffer-list))) + +(define-integrable (find-buffer name) + (bufferset-find-buffer (current-bufferset) name)) + +(define-integrable (create-buffer name) + (bufferset-create-buffer (current-bufferset) name)) + +(define-integrable (find-or-create-buffer name) + (bufferset-find-or-create-buffer (current-bufferset) 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)) + (buffer-windows buffer)))) (bufferset-kill-buffer! (current-bufferset) buffer)) + +(define-integrable (rename-buffer buffer new-name) + (bufferset-rename-buffer (current-bufferset) buffer new-name)) + +;;;; Point + +(define-integrable (current-point) + (window-point (current-window))) + +(define-integrable (set-current-point! mark) + (set-window-point! (current-window) mark)) + +(define (set-buffer-point! buffer mark) + (if (buffer-visible? buffer) + (for-each (lambda (window) + (set-window-point! window mark)) + (buffer-windows buffer)) + (%set-buffer-point! buffer mark))) + +(define (with-current-point point thunk) + (define (switch) + (set-current-point! (set! point (current-point)))) + (dynamic-wind switch thunk switch)) + +;;;; Mark and Region + +(define-integrable (current-mark) + (buffer-mark (current-buffer))) + +(define (buffer-mark buffer) + (let ((ring (buffer-mark-ring buffer))) + (if (ring-empty? ring) (editor-error)) + (ring-ref ring 0))) + +(define (set-current-mark! mark) + (if (not (mark? mark)) (error "New mark not a mark" mark)) + (set-buffer-mark! (current-buffer) mark)) + +(define (set-buffer-mark! buffer mark) + (ring-set! (buffer-mark-ring buffer) + 0 + (mark-right-inserting mark))) + +(define-variable "Auto Push Point Notification" + "Message to display when point is pushed on the mark ring, or false." + "Mark Set") + +(define (push-current-mark! mark) + (if (not (mark? mark)) (error "New mark not a mark" mark)) + (push-buffer-mark! (current-buffer) mark) + (if (and (ref-variable "Auto Push Point Notification") + (not *executing-keyboard-macro?*) + (not (typein-window? (current-window)))) + (temporary-message (ref-variable "Auto Push Point Notification")))) + +(define (push-buffer-mark! buffer mark) + (ring-push! (buffer-mark-ring buffer) + (mark-right-inserting mark))) + +(define-integrable (pop-current-mark!) + (pop-buffer-mark! (current-buffer))) + +(define (pop-buffer-mark! buffer) + (ring-pop! (buffer-mark-ring buffer))) + +(define-integrable (current-region) + (make-region (current-point) (current-mark))) + +(define (set-current-region! region) + (set-current-point! (region-start region)) + (push-current-mark! (region-end region))) + +(define (set-current-region-reversed! region) + (push-current-mark! (region-start region)) + (set-current-point! (region-end region))) + +;;;; Modes and Comtabs + +(define-integrable (current-modes) + (buffer-modes (current-buffer))) + +(define-integrable (current-major-mode) + (buffer-major-mode (current-buffer))) +(define-integrable (current-comtab) ;**** misnamed, should be plural. + (buffer-comtabs (current-buffer))) + +(define (set-current-major-mode! mode) + (set-buffer-major-mode! (current-buffer) mode)) + +(define (current-minor-mode? mode) + (buffer-minor-mode? (current-buffer) mode)) + +(define (enable-current-minor-mode! mode) + (enable-buffer-minor-mode! (current-buffer) mode)) + +(define (disable-current-minor-mode! mode) + (disable-buffer-minor-mode! (current-buffer) mode)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm new file mode 100644 index 000000000..50fbca46f --- /dev/null +++ b/v7/src/edwin/debuge.scm @@ -0,0 +1,132 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Debugging Stuff + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define (debug-save-files) + (for-each debug-save-buffer + (bufferset-buffer-list + (vector-ref edwin-editor editor-index:bufferset)))) + +(define (debug-save-buffer buffer) + (if (and (buffer-modified? buffer) + (buffer-writeable? buffer)) + (let ((pathname + (let ((pathname (buffer-pathname buffer))) + (cond ((not pathname) + (and (y-or-n? "Save buffer " + (buffer-name buffer) + " (Y or N)? ") + (begin (newline) + (write-string "Filename: ") + (string->pathname (read-line))))) + ((integer? (pathname-version pathname)) + (pathname-new-version pathname 'NEWEST)) + (else pathname))))) + (if pathname + (let ((truename (pathname->output-truename pathname))) + (let ((filename (pathname->string truename))) + (if (or (not (file-exists? filename)) + (y-or-n? "File '" + (pathname->string pathname) + "' exists. Write anyway (Y or N)? ")) + (begin (newline) + (write-string "Writing file '") + (write-string filename) + (write-string "'") + (region->file (buffer-region buffer) filename) + (write-string " -- done") + (set-buffer-pathname! buffer pathname) + (set-buffer-truename! buffer truename) + (buffer-not-modified! buffer))))))))) + +(define-command ("Redraw Alpha Window" argument) + "Redraws the entire alpha window from scratch." + (update-alpha-window! #!TRUE)) + +(define-command ("Debug Show Rings" argument) "" + (message "Mark Ring: " + (write-to-string (ring-size (buffer-mark-ring (current-buffer)))) + "; Kill Ring: " + (write-to-string (ring-size (current-kill-ring))))) + +(define-command ("Debug Count Marks" argument) "" + (count-marks-group (buffer-group (current-buffer)) + (lambda (n-existing n-gced) + (message "Existing: " (write-to-string n-existing) + "; GCed: " (write-to-string n-gced))))) + +(define (count-marks-group group receiver) + (define (loop marks receiver) + (if (null? marks) + (receiver 0 0) + (loop (cdr marks) + (lambda (n-existing n-gced) + (if (object-unhash (car marks)) + (receiver (1+ n-existing) n-gced) + (receiver n-existing (1+ n-gced))))))) + (loop (group-marks group) receiver)) + +(define (po object) + (for-each (lambda (entry) + (format "~%~o: ~40@o" + (car entry) + (vector-ref object (cdr entry)))) + (class-instance-transforms (object-class object)))) + +(define (instance-ref object name) + (let ((entry (assq name (class-instance-transforms (object-class object))))) + (if entry + (vector-ref object (cdr entry)) + (error "Not a valid instance-variable name" name)))) + +(define (instance-set! object name value) + (let ((entry (assq name (class-instance-transforms (object-class object))))) + (if entry + (vector-set! object (cdr entry) value) + (error "Not a valid instance-variable name" name)))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm new file mode 100644 index 000000000..4a223cc85 --- /dev/null +++ b/v7/src/edwin/dired.scm @@ -0,0 +1,420 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Directory Editor + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Dired" argument) + "Edit a directory. You type the directory name." + (select-buffer (make-dired-buffer "Dired"))) + +(define-command ("Dired Other Window" argument) + "Edit a directory in another window. You type the directory name." + (select-buffer-other-window (make-dired-buffer "Dired Other Window"))) + +(define (make-dired-buffer prompt) + (let ((pathname + (prompt-for-pathname prompt + (pathname-directory-path + (or (buffer-pathname (current-buffer)) + (working-directory-pathname)))))) + (let ((buffer (get-dired-buffer pathname))) + (set-buffer-major-mode! buffer dired-mode) + (set-buffer-truename! buffer pathname) + (buffer-put! buffer 'REVERT-BUFFER-METHOD revert-dired-buffer) + (fill-dired-buffer! buffer) + buffer))) + +(define (get-dired-buffer pathname) + (or (list-search-positive (buffer-list) + (lambda (buffer) + (and (eq? dired-mode (buffer-major-mode buffer)) + (pathname=? pathname (buffer-truename buffer))))) + (new-buffer (pathname->string pathname)))) + +(define (revert-dired-buffer argument) + (fill-dired-buffer! (current-buffer))) + +(define (fill-dired-buffer! buffer) + (set-buffer-writeable! buffer) + (region-delete! (buffer-region buffer)) + (let ((pathname (buffer-truename buffer))) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-string "Directory ") + (write-string (pathname->string pathname)) + (newline) + (newline) + (for-each (lambda (element) (apply write-dired-line element)) + (generate-dired-elements pathname))))) + (buffer-not-modified! buffer) + (set-buffer-read-only! buffer) + (add-buffer-initialization! buffer + (lambda () + (set-current-point! (line-start (buffer-start (current-buffer)) 2))))) + +(define-major-mode "Dired" "Fundamental" + "Major mode for editing a list of files. +Each line describes a file in the directory. +F -- visit the file on the current line. +D -- mark that file to be killed. +U -- remove all marks from the current line. +Rubout -- back up a line and remove marks. +Space -- move down one line. +X -- kill marked files. +Q -- quit, killing marked files. + This is like \\[^R Dired Execute] followed by \\[Kill Buffer]. +C-] -- abort Dired; this is like \\[Kill Buffer] on this buffer." + ((mode-initialization fundamental-mode)) + (local-set-variable! "Case Fold Search" #!TRUE) + (local-set-variable! "Cursor Centering Threshold" 0) + (local-set-variable! "Cursor Centering Point" 10)) + +(define-key "Dired" #\F "^R Dired Find File") +(define-key "Dired" #\O "^R Dired Find File Other Window") +(define-key "Dired" #\D "^R Dired Kill") +(define-key "Dired" #\K "^R Dired Kill") +(define-key "Dired" #\C-D "^R Dired Kill") +(define-key "Dired" #\C-K "^R Dired Kill") +(define-key "Dired" #\U "^R Dired Unmark") +(define-key "Dired" #\Rubout "^R Dired Backup Unmark") +(define-key "Dired" #\Space "^R Dired Next") +(define-key "Dired" #\X "^R Dired Execute") +(define-key "Dired" #\Q "^R Dired Quit") +(define-key "Dired" #\C-\] "^R Dired Abort") +(define-key "Dired" #\? "^R Dired Summary") + +(define-command ("^R Dired Find File" argument) + "Read the current file into a buffer." + (find-file (dired-current-pathname))) + +(define-command ("^R Dired Find File Other Window" argument) + "Read the current file into a buffer in another window." + (find-file-other-window (dired-current-pathname))) + +(define-command ("^R Dired Kill" (argument 1)) + "Mark the current file to be killed." + (dired-mark #\D argument)) + +(define-command ("^R Dired Unmark" (argument 1)) + "Cancel the kill requested for the current file." + (dired-mark #\Space argument)) + +(define-command ("^R Dired Backup Unmark" (argument 1)) + "Cancel the kill requested for the file on the previous line." + (set-current-point! (line-start (current-point) -1 'ERROR)) + (dired-mark #\Space argument) + (set-current-point! (line-start (current-point) -1 'ERROR))) + +(define-command ("^R Dired Next" (argument 1)) + "Move down to the next line." + (set-current-point! (line-start (current-point) argument 'BEEP))) + +(define-command ("^R Dired Execute" argument) + "Kill all marked files." + (dired-kill-files)) + +(define-command ("^R Dired Quit" argument) + "Exit Dired, offering to kill any files first." + (dired-kill-files) + (kill-buffer-interactive (current-buffer))) + +(define-command ("^R Dired Abort" argument) + "Exit Dired." + (kill-buffer-interactive (current-buffer))) + +(define-command ("^R Dired Summary" argument) + "Summarize the Dired commands in the typein window." + (message "d-elete, u-ndelete, x-ecute, q-uit, f-ind, o-ther window")) + +(define (write-dired-line pathname lsize last-date last-time) + (write-string + (string-append " " + (pad-on-right-to (pathname-name-string pathname) 16) + (pad-on-left-to (write-to-string lsize) 9) + (pad-on-left-to last-date 10) + (pad-on-left-to last-time 9))) + (newline)) + +(define (dired-current-pathname) + (let ((lstart (line-start (current-point) 0))) + (guarantee-dired-filename-line lstart) + (dired-pathname lstart))) + +(define (guarantee-dired-filename-line lstart) + (if (not (dired-filename-line? lstart)) + (editor-error "No file on this line"))) + +(define (dired-filename-line? lstart) + (let ((lend (line-end lstart 0))) + (and (not (mark= lstart lend)) + (not (match-forward "Directory" lstart))))) + +(define (dired-pathname lstart) + (merge-pathnames (pathname-directory-path (buffer-truename (current-buffer))) + (string->pathname (dired-filename lstart)))) + +(define (dired-filename lstart) + (let ((start (mark+ lstart 2))) + (char-search-forward #\Space start (line-end start 0)) + (extract-string start (re-match-start 0)))) + +(define (dired-mark char n) + (with-read-only-defeated (current-point) + (lambda () + (dotimes n + (lambda (i) + (let ((lstart (line-start (current-point) 0))) + (guarantee-dired-filename-line lstart) + (delete-right-char lstart) + (insert-chars char 1 lstart) + (set-current-point! (line-start lstart 1)))))))) + +(define (dired-kill-files) + (let ((filenames (dired-killable-filenames))) + (if (not (null? filenames)) + (let ((buffer (temporary-buffer " *Deletions*"))) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-strings-densely + (map (lambda (filename) + (pathname-name-string (car filename))) + filenames)))) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (set-buffer-read-only! buffer) + (if (with-selected-buffer buffer + (lambda () + (prompt-for-yes-or-no? "Delete these files"))) + (for-each dired-kill-file! filenames)) + (kill-buffer buffer))))) + +(define (dired-killable-filenames) + (define (loop start) + (let ((next (line-start start 1))) + (if next + (let ((rest (loop next))) + (if (char=? #\D (mark-right-char start)) + (cons (cons (dired-pathname start) (mark-permanent! start)) + rest) + rest)) + '()))) + (loop (line-start (buffer-start (current-buffer)) 1))) + +(define (dired-kill-file! filename) + (if (file-exists? (car filename)) + (delete-file (car filename))) + (with-read-only-defeated (cdr filename) + (lambda () + (delete-string (cdr filename) (mark1+ (line-end (cdr filename) 0)))))) + +;;;; List Directory + +(define-command ("List Directory" argument) + "Generate a directory listing." + (let ((pathname + (prompt-for-pathname "List Directory" + (pathname-directory-path + (or (buffer-pathname (current-buffer)) + (working-directory-pathname)))))) + (let ((elements (generate-dired-elements pathname)) + (directory (pathname->string pathname))) + (with-output-to-temporary-buffer "*Directory*" + (lambda () + (write-string "Directory ") + (write-string directory) + (newline) + (newline) + (cond (argument + (for-each (lambda (element) (apply write-dired-line element)) + elements)) + ((ref-variable "List Directory Unpacked") + (for-each (lambda (element) + (write-string + (pathname-name-string (car element))) + (newline)) + elements)) + (else + (write-strings-densely + (map (lambda (element) + (pathname-name-string (car element))) + elements))))))))) + +(define generate-dired-elements) +(let () + +(define open-catalog (make-primitive-procedure 'OPEN-CATALOG)) +(define close-catalog (make-primitive-procedure 'CLOSE-CATALOG)) +(define next-file (make-primitive-procedure 'NEXT-FILE)) +(define next-file-matching (make-primitive-procedure 'NEXT-FILE-MATCHING)) +(define cat-name (make-primitive-procedure 'CAT-NAME)) +(define cat-kind (make-primitive-procedure 'CAT-KIND)) +(define cat-psize (make-primitive-procedure 'CAT-PSIZE)) +(define cat-lsize (make-primitive-procedure 'CAT-LSIZE)) +(define cat-info (make-primitive-procedure 'CAT-INFO)) +(define cat-block (make-primitive-procedure 'CAT-BLOCK)) +(define cat-create-date (make-primitive-procedure 'CAT-CREATE-DATE)) +(define cat-create-time (make-primitive-procedure 'CAT-CREATE-TIME)) +(define cat-last-date (make-primitive-procedure 'CAT-LAST-DATE)) +(define cat-last-time (make-primitive-procedure 'CAT-LAST-TIME)) + +;; **** The number 16 is used here because that is the longest filename +;; allowed in any of the file systems: LIF, UCSD, or SRM. + +(set! generate-dired-elements +(named-lambda (generate-dired-elements pathname) + (if (eq? (pathname-version pathname) 'NEWEST) + (extract-newest + (get-dired-elements (pathname-new-version pathname 'WILD))) + (extract-elements (get-dired-elements pathname))))) + +(define (get-dired-elements pathname) + (let ((dir-path (pathname-directory-path pathname)) + (name-path (pathname-name-path pathname))) + (let ((dir-string (pathname->string dir-path)) + (name-string (pathname->string name-path))) + (define (loop) + (if (next-file-matching name-string) + (let ((name (string-allocate 16)) + (lsize (cat-lsize)) + (last-date (string-allocate 9)) + (last-time (string-allocate 8))) + (cat-name name) + (cat-last-date last-date) + (cat-last-time last-time) + (cons (list (merge-pathnames dir-path (string->pathname name)) + lsize last-date last-time) + (loop))) + (begin (close-catalog) + '()))) + (temporary-message "Reading directory '" dir-string "'") + (open-catalog dir-string) + (let ((elements (loop))) + (append-message " -- done") + (sort-dired-elements elements))))) + +(define (sort-dired-elements elements) + (let ((name-alist '())) + (for-each (lambda (element) + (let ((name (pathname-name (car element))) + (type (pathname-type (car element))) + (version (pathname-version (car element)))) + (let ((name-entry (ass-name name name-alist))) + (if (not name-entry) + (set! name-alist + (cons (list name + (list type + (cons version element))) + name-alist)) + (let ((type-entry (ass-type type (cdr name-entry)))) + (if (not type-entry) + (set-cdr! name-entry + (cons (list type + (cons version element)) + (cdr name-entry))) + (set-cdr! type-entry + (cons (cons version element) + (cdr type-entry))))))))) + elements) + (for-each (lambda (name-entry) + (for-each (lambda (type-entry) + (set-cdr! type-entry + (sort (cdr type-entry) car-version y-size 24) (set! typein-y-size 2)) + (make-editor "Edwin" the-alpha-window 0 0 + (if restrict-editor-x-size + (min restrict-editor-x-size x-size) + x-size) + y-size))) + (within-editor edwin-editor + (lambda () + (add-buffer-initialization! (current-buffer) + (lambda () + (with-output-to-mark (current-point) + (lambda () + (identify-world) + (write-string " + +;You are in an interaction window of the Edwin editor. +;Type C-H for help. C-H M will describe some useful commands."))) + (insert-interaction-prompt) + (set-window-start-mark! (current-window) + (buffer-start (current-buffer)) + #!FALSE))))) + *the-non-printing-object*)) + +(set! edwin-reset-windows +(named-lambda (edwin-reset-windows) + (send the-alpha-window ':salvage!))) + +) + +(define (edwin) + (if (or (unassigned? edwin-editor) + (not edwin-editor)) + (edwin-reset)) + (with-keyboard-interrupt-dispatch-table + editor-keyboard-interrupt-dispatch-table + (lambda () + (with-editor-interrupts-enabled + (lambda () + (with-editor-input-port console-input-port + (lambda () + (within-editor edwin-editor + (lambda () + (fluid-let (((access *error-hook* error-system) + edwin-error-hook)) + (perform-buffer-initializations! (current-buffer)) + (push-command-loop (lambda () 'DONE) + (lambda (state) + (update-alpha-window! #!TRUE) + (top-level-command-reader) + state) + 'DUMMY-STATE)))))))))) + (tty-redraw-screen) + *the-non-printing-object*) + +(in-package system-global-environment + +(define tty-redraw-screen + (make-primitive-procedure 'TTY-REDRAW-SCREEN)) + +) + +(define editor-continuation) +(define recursive-edit-continuation) +(define recursive-edit-level) +(define current-editor) +(define saved-error-hook) + +(define (within-editor editor thunk) + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((editor-continuation continuation) + (recursive-edit-continuation #!FALSE) + (recursive-edit-level 0) + (current-editor editor) + (saved-error-hook (access *error-hook* error-system))) + (thunk))))) + +(define (enter-recursive-edit) + (let ((value + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((recursive-edit-continuation continuation) + (recursive-edit-level (1+ recursive-edit-level))) + (dynamic-wind recursive-edit-event! + command-reader + recursive-edit-event!)))))) + (if (eq? value 'ABORT) + (abort-current-command) + (begin (reset-command-prompt!) + value)))) + +(define (recursive-edit-event!) + (for-each (lambda (window) + (window-modeline-event! window 'RECURSIVE-EDIT)) + (window-list))) + +(define (exit-recursive-edit value) + (if recursive-edit-continuation + (recursive-edit-continuation value) + (editor-abort value))) + +(define (editor-abort value) + (editor-continuation value)) + +(declare (integrate current-frame current-bufferset current-kill-ring)) +(define (current-frame) (editor-frame-window current-editor)) +(define (current-bufferset) (editor-bufferset current-editor)) +(define (current-kill-ring) (editor-kill-ring current-editor)) +(define (current-char-history) (editor-char-history current-editor)) + +(define processing-error? + #!FALSE) + +(define (edwin-error-hook environment message irritant + substitute-environment?) + ((if processing-error? + saved-error-hook + (or (ref-variable "& Scheme Error Hook") + saved-error-hook)) + environment message irritant substitute-environment?)) + +(define-named-structure "Editor" + name + frame-window + bufferset + kill-ring + char-history) + +(define (make-editor name superior x-start y-start x-size y-size) + (let ((initial-buffer (make-buffer initial-buffer-name interaction-mode))) + (let ((bufferset (make-bufferset initial-buffer))) + (let ((editor (%make-editor))) + (vector-set! editor editor-index:name name) + (vector-set! editor editor-index:frame-window + ((access make-editor-frame window-package) + superior x-start y-start x-size y-size + name initial-buffer + (bufferset-create-buffer bufferset " *Typein-0*"))) + (vector-set! editor editor-index:bufferset bufferset) + (vector-set! editor editor-index:kill-ring (make-ring 10)) + (vector-set! editor editor-index:char-history (make-ring 100)) + editor)))) + +(define initial-buffer-name + "*scratch*") + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm new file mode 100644 index 000000000..2900409e7 --- /dev/null +++ b/v7/src/edwin/edtfrm.scm @@ -0,0 +1,109 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Editor Frame + +(declare (usual-integrations) + (integrate-external "edb:window.bin.0")) +(using-syntax class-syntax-table + +;;; Editor Frame + +(define-class editor-frame vanilla-window + (root-inferior typein-inferior selected-window cursor-window select-time)) + +(define (make-editor-frame superior x-start y-start x-size y-size + editor-name main-buffer typein-buffer) + (let ((window (=> superior :make-inferior editor-frame))) + (let ((main-window (make-buffer-frame window main-buffer #!TRUE)) + (typein-window (make-buffer-frame window typein-buffer #!FALSE))) + (with-instance-variables editor-frame window + (set! root-inferior (find-inferior inferiors main-window)) + (set! typein-inferior (find-inferior inferiors typein-window)) + (set! selected-window main-window) + (set! cursor-window main-window) + (set! select-time 2)) + (set-window-select-time! main-window 1) + (=> (window-cursor main-window) :enable!)) + (=> window :set-size! x-size y-size) + (=> superior :set-inferior-start! window x-start y-start) + window)) + +(define-method editor-frame (:set-size! window x y) + (usual=> window :set-size! x y) + (set-inferior-start! root-inferior 0 0) + (let ((y* (- y typein-y-size))) + (set-inferior-start! typein-inferior 0 y*) + (set-inferior-size! root-inferior x y*)) + (set-inferior-size! typein-inferior x-size typein-y-size)) + +(define typein-y-size 1) + +(define-method editor-frame (:new-root-window! window window*) + (set! root-inferior (find-inferior inferiors window*))) + +(define-procedure editor-frame (editor-frame-window0 window) + (window0 (inferior-window root-inferior))) + +(define-procedure editor-frame (editor-frame-typein-window window) + (inferior-window typein-inferior)) + +(define-procedure editor-frame (editor-frame-selected-window window) + selected-window) + +(define-procedure editor-frame (editor-frame-cursor-window window) + cursor-window) + +(define-procedure editor-frame (editor-frame-select-window! window window*) + (if (not (buffer-frame? window*)) + (error "Attempt to select non-window" window*)) + (=> (window-cursor cursor-window) :disable!) + (set! selected-window window*) + (set-window-select-time! window* select-time) + (set! select-time (1+ select-time)) + (set! cursor-window window*) + (=> (window-cursor cursor-window) :enable!)) + +(define-procedure editor-frame (editor-frame-select-cursor! window window*) + (if (not (buffer-frame? window*)) + (error "Attempt to select non-window" window*)) + (=> (window-cursor cursor-window) :disable!) + (set! cursor-window window*) + (=> (window-cursor cursor-window) :enable!)) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm new file mode 100644 index 000000000..0637ab157 --- /dev/null +++ b/v7/src/edwin/evlcom.scm @@ -0,0 +1,269 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Evaluation Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-variable "Scheme Environment" + "The environment used by the evaluation commands, or 'DEFAULT. +If 'DEFAULT, use the default (REP loop) environment." + 'DEFAULT) + +(define-variable "Scheme Syntax Table" + "The syntax table used by the evaluation commands, or false. +If false, use the default (REP loop) syntax-table." + false) + +(define-variable "Previous Evaluation Environment" + "The last explicit environment for an evaluation command." + false) + +(define-command ("^R Evaluate Definition" argument) + "Evaluate the definition at point. +Prints the result in the typein window. +With an argument, prompts for the evaluation environment. +Output goes to the transcript buffer." + (evaluate-sexp (current-definition-start) + (evaluation-environment argument))) + +(define-command ("^R Evaluate Sexp" argument) + "Evaluate the expression following point. +Prints the result in the typein window. +With an argument, prompts for the evaluation environment. +Output goes to the transcript buffer." + (evaluate-sexp (current-point) + (evaluation-environment argument))) + +(define-command ("^R Evaluate Previous Sexp" argument) + "Evaluate the expression preceding point. +Prints the result in the typein window. +With an argument, prompts for the evaluation environment. +Output goes to the transcript buffer." + (evaluate-sexp (backward-one-sexp (current-point)) + (evaluation-environment argument))) + +(define-command ("^R Evaluate Region" argument) + "Evaluate the region, printing the results in the typein window. +With an argument, prompts for the evaluation environment. +Output goes to the transcript buffer." + (evaluate-region (current-region) + (evaluation-environment argument))) + +(define-command ("^R Evaluate Buffer" argument) + "Evaluate the buffer. +The values are printed in the typein window. +With an argument, prompts for the evaluation environment. +Output goes to the transcript buffer." + (evaluate-region (buffer-region (current-buffer)) + (evaluation-environment argument))) + +(define-command ("^R Evaluate Previous Sexp into Buffer" argument) + "Evaluate the expression preceding point. +With an argument, prompts for the evaluation environment. +Output is inserted into the buffer at point." + (let ((start (backward-sexp (current-point) 1 false))) + (if (not start) (editor-error "No previous expression")) + (let ((environment (evaluation-environment argument))) + (with-output-to-current-point + (lambda () + (write-line (eval-with-history (with-input-from-mark start read) + environment))))))) + +(define-variable "Previous Typein Expression" + "The last expression evaluated in the typein window." + false) + +(define-command ("^R Evaluate Sexp Typein" argument) + "Read an evaluate an expression in the typein window. +With an argument, prompts for the evaluation environment." + (let ((string + (prompt-for-expression "Evaluate Sexp" + (ref-variable "Previous Typein Expression") + 'INVISIBLE-DEFAULT))) + (set-variable! "Previous Typein Expression" string) + (editor-eval (with-input-from-string string read) + (evaluation-environment argument)))) + +(define-command ("Unsnap Links" argument) + "Unsnaps all compiled code links." + (unsnap-links!)) + +(define-command ("Set Environment" argument) + "Sets the REP environment for the editor and any inferior REP loops." + (set-rep-base-environment! + (coerce-to-environment + (prompt-for-expression-value + "REP environment" + (ref-variable "Previous Evaluation Environment"))))) + +(define-command ("Set Syntax Table" argument) + "Sets the current syntax table (for the syntaxer, not the editor)." + (set-rep-base-syntax-table! + (prompt-for-expression-value "Set Syntax Table" false))) + +(define (evaluate-sexp input-mark environment) + (editor-eval (with-input-from-mark input-mark read) environment)) + +(define (evaluate-string string environment) + (eval-with-history (with-input-from-string string read) environment)) + +(define (editor-eval sexp environment) + (with-output-to-transcript-buffer + (lambda () + (let ((value (eval-with-history sexp environment))) + (transcript-write value) + value)))) + +(define (evaluate-region region environment) + (with-output-to-transcript-buffer + (lambda () + (with-input-from-region region + (lambda () + (define (loop object) + (if (not (eof-object? object)) + (begin (transcript-write (eval-with-history object environment)) + (loop (read))))) + (loop (read))))))) + +(define (eval-with-history expression environment) + (let ((scode (syntax expression (evaluation-syntax-table)))) + (with-new-history + (lambda () + (scode-eval scode environment))))) + +(define (prompt-for-expression prompt default-string #!optional default-type) + (if (unassigned? default-type) (set! default-type 'VISIBLE-DEFAULT)) + (prompt-for-completed-string prompt + default-string default-type + false 'NO-COMPLETION + prompt-for-expression-mode)) + +(define-major-mode "Prompt for Expression" "Scheme" + "Major mode for editing solicited input expressions. +Depending on what is being solicited, either defaulting or completion +may be available. The following commands are special to this mode: + +\\[^R Terminate Input] terminates the input. +\\[^R Yank Default String] yanks the default string, if there is one." + ((mode-initialization scheme-mode))) + +(define-key "Prompt for Expression" #\Return "^R Terminate Input") +(define-key "Prompt for Expression" #\C-M-Y "^R Yank Default String") + +(define (prompt-for-expression-value prompt default) + (evaluate-string (prompt-for-expression prompt default) + (evaluation-environment false))) + +(define (evaluation-syntax-table) + (or (ref-variable "Scheme Syntax Table") + (rep-syntax-table))) + +(define (evaluation-environment argument) + (cond (argument + (let ((string + (prompt-for-expression + "Evaluate in environment" + (ref-variable "Previous Evaluation Environment")))) + (set-variable! "Previous Evaluation Environment" string) + (coerce-to-environment (eval (with-input-from-string string read) + (evaluation-environment false))))) + ((eq? 'DEFAULT (ref-variable "Scheme Environment")) (rep-environment)) + (else (ref-variable "Scheme Environment")))) + +;;;; Transcript Buffer + +(define-variable "Transcript Buffer Name" + "Name of buffer to which evaluation commands record their output." + "*Transcript*") + +(define-variable "Enable Transcript Buffer" + "If true, I/O from evaluation commands is recorded in transcript buffer. +Recording is done only for commands that write their output to the +message area, not commands that write to a specific buffer." + false) + +(define (transcript-buffer) + (find-or-create-buffer (ref-variable "Transcript Buffer Name"))) + +(define (transcript-write value) + (if (ref-variable "Enable Transcript Buffer") + (write-line value)) + (if (or (not (ref-variable "Enable Transcript Buffer")) + (null? (buffer-windows (transcript-buffer)))) + (message (write-to-string value)))) + +(define (with-output-to-transcript-buffer thunk) + (if (ref-variable "Enable Transcript Buffer") + (with-interactive-output-port (transcript-output-port) thunk) + (thunk))) + +(define (transcript-output-port) + (let ((buffer (transcript-buffer))) + (let ((end (buffer-end buffer)) + (:type output-port-tag)) + (define (:print-self) + (unparse-with-brackets + (lambda () + (write-string "Output Port to ") + (write buffer)))) + + (define (:close) + 'DONE) + + (define (:write-char char) + (region-insert-char! end char)) + + (define (:write-string s) + (region-insert-string! end s)) + + (define (:flush-output) + (let ((windows (buffer-windows buffer))) + (if (not (null? windows)) + (begin (set-window-point! (car windows) end) + (window-direct-update! (car windows) false))))) + + (the-environment)))) + +;;; end USING-SYNTAX +) +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm new file mode 100644 index 000000000..e9fdf4ba9 --- /dev/null +++ b/v7/src/edwin/filcom.scm @@ -0,0 +1,434 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; File Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Toggle Read Only" argument) + "Change whether this buffer is visiting its file read-only." + (let ((buffer (current-buffer))) + ((if (buffer-writeable? buffer) + set-buffer-read-only! + set-buffer-writeable!) + buffer))) + +(define-command ("Find File" argument) + "Visit a file in its own buffer. +If the file is already in some buffer, select that buffer. +Otherwise, visit the file in a buffer named after the file." + (find-file (prompt-for-pathname "Find File" (current-default-pathname)))) + +(define-command ("Find File Other Window" argument) + "Visit a file in another window. +May create a window, or reuse one." + (find-file-other-window + (prompt-for-pathname "Find File Other Window" (current-default-pathname)))) + +(define-command ("^R Find Alternate File" argument) + "Find a file in its own buffer, killing the current buffer. +Like \\[Kill Buffer] followed by \\[Find File]." + (let ((buffer (current-buffer))) + (if (not (buffer-pathname buffer)) + (editor-error "Buffer not visiting any file")) + (let ((pathname + (prompt-for-pathname "Find Alternate File" + (current-default-pathname)))) + (define (kernel) + (kill-buffer-interactive buffer) + (find-file pathname)) + (if (not (other-buffer buffer)) + (let ((buffer* (new-buffer "*dummy*"))) + (kernel) + (kill-buffer buffer*)) + (kernel))))) + +(define ((file-finder select-buffer) pathname) + (let ((buffer (pathname->buffer pathname))) + (if buffer + (select-buffer buffer) + (let ((buffer (new-buffer (pathname->buffer-name pathname)))) + (read-buffer buffer pathname) + (select-buffer buffer))))) + +(define find-file + (file-finder select-buffer)) + +(define find-file-other-window + (file-finder select-buffer-other-window)) + +(define find-file-noselect + (file-finder identity-procedure)) + +(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*)))))))))))) + +(define (pathname=? x y) + (string=? (pathname->string x) + (pathname->string y))) + +(define (current-default-pathname) + (newest-pathname (buffer-pathname (current-buffer)))) + +(define-command ("^R Save File" argument) + "Save visited file on disk if modified." + (save-file (current-buffer))) + +(define (save-file buffer) + (if (buffer-modified? buffer) + (begin (if (buffer-pathname buffer) + (save-buffer-prepare-version buffer) + (set-visited-pathname buffer + (prompt-for-pathname + (string-append "Write buffer '" + (buffer-name buffer) + "' to file") + #!FALSE))) + (write-buffer-interactive buffer)) + (temporary-message "(No changes need to be written)"))) + +(define-command ("Save Some Buffers" argument) + "Saves some modified file-visiting buffers. Asks user about each one. +With argument, saves all with no questions." + (save-some-buffers argument)) + +(define (save-some-buffers #!optional no-confirmation?) + (if (unassigned? no-confirmation?) (set! no-confirmation? #!FALSE)) + (let ((buffers + (list-transform-positive (buffer-list) + (lambda (buffer) + (and (buffer-modified? buffer) + (buffer-pathname buffer)))))) + (if (null? buffers) + (temporary-message "(No buffers need saving)") + (for-each (lambda (buffer) + (save-buffer-prepare-version buffer) + (if (or no-confirmation? + (prompt-for-confirmation? + (string-append + "Save file '" + (pathname->string (buffer-pathname buffer)) + "'"))) + (write-buffer-interactive buffer))) + buffers)))) + +(define (save-buffer-prepare-version buffer) + (let ((pathname (buffer-pathname buffer))) + (if (and pathname (integer? (pathname-version pathname))) + (set-buffer-pathname! buffer (newest-pathname pathname))))) + +(define-command ("Set Visited File Name" argument) + "Change name of file visited in current buffer to given name. +With an argument, means make buffer not be visiting any file. +The next time the buffer is saved it will go in the newly specified file. " + (set-visited-pathname (current-buffer) + (if argument + #!FALSE + (prompt-for-pathname "Set Visited File Name" + (current-default-pathname))))) + +(define (set-visited-pathname buffer pathname) + (set-buffer-pathname! buffer pathname) + (set-buffer-truename! buffer #!FALSE) + (if pathname + (begin (let ((name (pathname->buffer-name pathname))) + (if (not (find-buffer name)) + (rename-buffer buffer name))) + (setup-buffer-auto-save! buffer) + (buffer-modified! buffer)) + (disable-buffer-auto-save! buffer))) + +(define-command ("Write File" argument) + "Store buffer in specified file. +This file becomes the one being visited." + (write-file (current-buffer) + (prompt-for-pathname "Write File" (current-default-pathname)))) + +(define (write-file buffer pathname) + (set-visited-pathname buffer pathname) + (write-buffer-interactive buffer)) + +(define-command ("Write Region" argument) + "Store the region in specified file." + (write-region (current-region) + (prompt-for-pathname "Write Region" + (current-default-pathname)))) + +(define-variable "Previous Inserted File" + "Pathname of the file that was most recently inserted." + #!FALSE) + +(define-command ("Insert File" argument) + "Insert contents of file into existing text. +Leaves point at the beginning, mark at the end." + (let ((pathname + (prompt-for-pathname + "Insert File" + (newest-pathname (or (ref-variable "Previous Inserted File") + (buffer-pathname (current-buffer))))))) + (set-variable! "Previous Inserted File" pathname) + (set-current-region! (insert-file (current-point) pathname)))) + +(define-command ("Revert Buffer" argument) + "Loads current buffer with version of file from disk." + (let ((buffer (current-buffer))) + (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD))) + (if method + (method argument) + (let ((pathname (buffer-pathname buffer)) + (point (current-point)) + (window (current-window))) + (if (not pathname) (editor-error "No file to revert from")) + (if (prompt-for-yes-or-no? "Restore file from disk") + (let ((y-point (window-point-y window)) + (where (mark-index point))) + (read-buffer buffer pathname) + (set-current-point! + (mark+ (buffer-start buffer) where 'LIMIT)) + (window-scroll-y-absolute! window y-point)))))))) + +(define-command ("Copy File" argument) + "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." + (let ((old (prompt-for-input-truename "Copy File" + (buffer-pathname (current-buffer))))) + (let ((new (prompt-for-output-truename "Copy to" old))) + (if (or (not (file-exists? new)) + (prompt-for-yes-or-no? + (string-append "File '" + (pathname->string new) + "' already exists; copy anyway"))) + (begin (copy-file old new) + (message "Copied '" (pathname->string old) + "' => '" (pathname->string new) "'")))))) + +(define-command ("Rename File" argument) + "Rename 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." + (let ((old (prompt-for-input-truename "Rename File" + (buffer-pathname (current-buffer))))) + (let ((new (prompt-for-output-truename "Rename to" old))) + (define (do-it) + (rename-file old new) + (message "Renamed '" (pathname->string old) + "' => '" (pathname->string new) "'")) + (if (file-exists? new) + (if (prompt-for-yes-or-no? + (string-append "File '" + (pathname->string new) + "' already exists; rename anyway")) + (begin (delete-file new) (do-it))) + (do-it))))) + +(define-command ("Delete File" argument) + "Delete a file; the name is read in the typein window." + (let ((old (prompt-for-input-truename "Delete File" + (buffer-pathname (current-buffer))))) + (if (prompt-for-confirmation? + (string-append "Delete '" + (pathname->string old) + "'")) + (delete-file old)))) + +;;;; Printer Support + +(define-command ("Print File" argument) + "Print a file on the local printer." + (print-region + (file->region + (prompt-for-input-truename "Print File" + (buffer-pathname (current-buffer)))))) + +(define-command ("Print Buffer" argument) + "Print the current buffer on the local printer." + (print-region (buffer-region (current-buffer)))) + +(define-command ("Print Page" argument) + "Print the current page on the local printer." + (print-region (page-interior-region (current-point)))) + +(define-command ("Print Region" argument) + "Print the current region on the local printer." + (print-region (current-region))) + +(define (print-region region) + (let ((temp (temporary-buffer "*Printout*"))) + (region-insert! (buffer-point temp) region) + (let ((temp-region (buffer-region temp))) + (untabify-region temp-region) + (region->file temp-region print-region-temp-filename)) + (translate-file print-region-temp-filename "PRINTER:") + (delete-file print-region-temp-filename) + (kill-buffer temp))) + +(define print-region-temp-filename + "*PRINTOUT") + +(define translate-file + (make-primitive-procedure 'TRANSLATE-FILE)) + +;;;; Supporting Stuff + +(define *default-pathname*) + +(define-command ("^R Complete Filename" argument) + "Attempt to complete the filename being edited in the echo area." + (let ((buffer (current-buffer))) + (let ((region (buffer-region buffer))) + (let ((string (region->string region))) + (if (string-null? string) + (begin (insert-string + (let ((truename + (pathname->input-truename *default-pathname*))) + (pathname->string (or truename *default-pathname*)))) + (insert-string " ")) + (complete-pathname (string->pathname string) *default-pathname* + (lambda (pathname) + (region-delete! region) + (insert-string (pathname->string pathname)) + (insert-string " ")) + (lambda (string start end) + (region-delete! region) + (insert-string (substring string start end))) + beep)))))) + +(define-command ("^R List Filename Completions" argument) + "List the possible completions for the filename being input." + ((access list-completions prompt-package) + (map pathname->string + (pathname-completions + (string->pathname (region->string (buffer-region (current-buffer)))) + *default-pathname*)))) + +;;; Derives buffername from pathname + +(define (pathname->buffer-name pathname) + (pathname-extract-string pathname 'NAME 'TYPE)) + +;;;; Prompting + +(define (prompt-for-input-truename prompt default) + (let ((path (prompt-for-pathname prompt default))) + (if (file-exists? path) + (pathname->input-truename path) + (editor-error "'" (pathname->string path) "' does not exist")))) + +(define (prompt-for-output-truename prompt default) + (pathname->output-truename (prompt-for-pathname prompt default))) + +(define (prompt-for-pathname prompt #!optional default) + (if (unassigned? default) (set! default #!FALSE)) + (fluid-let ((*default-pathname* (or default (get-default-pathname))) + (*pathname-cache* #!FALSE)) + (let ((string + (prompt-for-completed-string prompt + (pathname->string *default-pathname*) + 'VISIBLE-DEFAULT + #!FALSE + 'NO-COMPLETION + prompt-for-pathname-mode))) + (cond ((string-null? string) + *default-pathname*) + ;; If pathname was completed, it should be exact. But we + ;; do a merge of the directory part in case the completed + ;; file name was edited. + ((char=? #\Space (string-ref string (-1+ (string-length string)))) + (merge-pathnames + (string->pathname + (substring string 0 (-1+ (string-length string)))) + (pathname-extract *default-pathname* 'DEVICE 'DIRECTORY))) + ;; If it was quoted, then it may have strange name components, + ;; so we just default the directory part, taking the name as is. + ((char=? #\' (string-ref string 0)) + (merge-pathnames + (string->pathname (substring string 1 (string-length string))) + (pathname-extract *default-pathname* 'DEVICE 'DIRECTORY))) + ;; But normally we just do ordinary defaulting. + (else + (merge-pathnames (string->pathname string) + *default-pathname*)))))) + +(define (newest-pathname pathname) + (pathname-new-version (or pathname (get-default-pathname)) + 'NEWEST)) + +(define (get-default-pathname) + (merge-pathnames (ref-variable "Default Pathname") + (working-directory-pathname))) + +(define-variable "Default Pathname" + "Pathname to use for default when no other is available" + (string->pathname "FOO.SCM.0")) + +(define-major-mode "Prompt for Pathname" "Fundamental" + "Major mode for entering pathnames. +\\[^R Terminate Input] indicates that you are done entering the pathname. +\\[^R Complete Filename] will complete the pathname. +\\[^R List Filename Completions] will show you all possible completions. +\\[^R Yank Default String] will insert the default (if there is one.)" + 'DONE) + +(define-key "Prompt for Pathname" #\Return "^R Terminate Input") +(define-key "Prompt for Pathname" #\C-M-Y "^R Yank Default String") +(define-key "Prompt for Pathname" #\Space "^R Complete Filename") +(define-key "Prompt for Pathname" #\Tab "^R Complete Filename") +(define-key "Prompt for Pathname" #\? "^R List Filename Completions") + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm new file mode 100644 index 000000000..6c6631eea --- /dev/null +++ b/v7/src/edwin/fileio.scm @@ -0,0 +1,305 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; File <-> Buffer I/O + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +;;;; Input + +(define (read-buffer buffer pathname) + (let ((truename (pathname->input-truename pathname))) + (if truename + (begin (let ((region (file->region-interactive truename))) + (region-delete! (buffer-unclipped-region buffer)) + (region-insert! (buffer-start buffer) region)) + (set-buffer-point! buffer (buffer-start buffer))) + (temporary-message "(New File)")) + (set-buffer-truename! buffer truename)) + (set-buffer-pathname! buffer pathname) + (setup-buffer-auto-save! buffer) + (set-buffer-save-length! buffer) + (buffer-not-modified! buffer) + (undo-done! (buffer-point buffer)) + (initialize-buffer! buffer)) + +(define (initialize-buffer! buffer) + (initialize-buffer-modes! buffer) + (initialize-buffer-local-variables! buffer)) + +(define (insert-file mark pathname) + (let ((truename (pathname->input-truename pathname))) + (if truename + (region-insert! mark (file->region-interactive truename)) + (editor-error "File '" (pathname->string pathname) "' not found")))) + +(define (file->region-interactive truename) + (let ((filename (pathname->string truename))) + (temporary-message "Reading file '" filename "'") + (let ((region (file->region truename))) + (append-message " -- done") + region))) + +(define (file->region pathname) + (call-with-input-file pathname port->region)) + +(define (port->region port) + (group-region + (make-group + (if (not (lexical-unreferenceable? port ':rest->string)) + ((access :rest->string port)) + ((access :read-string port) char-set:null))))) + +;;;; Buffer Mode Initialization + +(define initialize-buffer-modes!) +(let () + +(set! initialize-buffer-modes! +(named-lambda (initialize-buffer-modes! buffer) + (let ((mode + (or (let ((mode-name (parse-buffer-mode-header buffer))) + (and mode-name + (let ((mode (string-table-get editor-modes mode-name))) + (and mode + (mode-major? mode) + mode)))) + (filename-default-mode buffer)))) + (set-buffer-major-mode! buffer + (or mode (ref-variable "Editor Default Mode")))))) + +(define (filename-default-mode buffer) + (let ((entry + (let ((pathname (buffer-pathname buffer))) + (and pathname + (let ((type (pathname-type pathname))) + (and (string? type) + (assoc-string-ci + type + (ref-variable "File Type to Major Mode")))))))) + (and entry (cdr entry)))) + +(define assoc-string-ci + (association-procedure string-ci=? car)) + +(define (parse-buffer-mode-header buffer) + (fluid-let (((ref-variable "Case Fold Search") true)) + (let ((start (buffer-start buffer))) + (let ((end (line-end start 0))) + (let ((start (re-search-forward "-\\*-[ \t]*" start end))) + (and start + (re-search-forward "[ \t]*-\\*-" start end) + (parse-mode-header start (re-match-start 0)))))))) + +(define (parse-mode-header start end) + (if (not (char-search-forward #\: start end)) + (extract-string start end) + (let ((mode-mark (re-search-forward "mode:[ \t]*" start end))) + (and mode-mark + (extract-string mode-mark + (if (re-search-forward "[ \t]*;" mode-mark end) + (re-match-start 0) + end)))))) + +) + +;;;; Local Variable Initialization + +(define-variable "Local Variable Search Limit" + "The maximum number of characters searched when looking for local variables +at the end of a file." + 3000) + +(define initialize-buffer-local-variables!) +(let () + +(set! initialize-buffer-local-variables! +(named-lambda (initialize-buffer-local-variables! buffer) + (let ((end (buffer-end buffer))) + (let ((start + (with-narrowed-region! + (make-region (mark- end + (ref-variable "Local Variable Search Limit") + 'LIMIT) + end) + (lambda () + (backward-one-page end))))) + (if start + (fluid-let (((ref-variable "Case Fold Search") true)) + (if (re-search-forward "Edwin Variables:[ \t]*" start) + (parse-local-variables buffer + (re-match-start 0) + (re-match-end 0))))))))) + +(define ((error-hook continuation var) . args) + (beep) + (message "Error while processing local variable: " var) + (continuation false)) + +(define (evaluate sexp) + (scode-eval (syntax sexp system-global-syntax-table) + system-global-environment)) + +(define ((local-binding-thunk name value)) + (make-local-binding! name value)) + +(define (parse-local-variables buffer start end) + (let ((prefix (extract-string (line-start start 0) start)) + (suffix (extract-string end (line-end end 0)))) + (let ((prefix-length (string-length prefix)) + (prefix? (not (string-null? prefix))) + (suffix-length (string-length suffix)) + (suffix? (not (string-null? suffix)))) + (define (loop mark) + (let ((start (line-start mark 1))) + (if (not start) (editor-error "Missing local variables entry")) + (do-line start (line-end start 0)))) + + (define (do-line start end) + (define (check-suffix mark) + (if (and suffix? (not (match-forward suffix mark))) + (editor-error "Local variables entry is missing the suffix"))) + (let ((m1 + (horizontal-space-end + (if prefix? + (or (match-forward prefix start) + (editor-error + "Local variables entry is missing the prefix")) + start)))) + (let ((m2 (if (char-search-forward #\: m1 end) + (re-match-start 0) + (editor-error + "Missing colon in local variables entry")))) + (let ((var (extract-string m1 (horizontal-space-start m2))) + (m3 (horizontal-space-end (mark1+ m2)))) + (if (not (string-ci=? var "End")) + (with-input-from-mark m3 read + (lambda (val m4) + (check-suffix (horizontal-space-end m4)) + (if (string-ci=? var "Mode") + (let ((mode (string-table-get + editor-modes + (extract-string m3 m4)))) + (if mode + ((if (mode-major? mode) + set-buffer-major-mode! + enable-buffer-minor-mode!) + buffer mode))) + (call-with-current-continuation + (lambda (continuation) + (fluid-let (((access *error-hook* error-system) + (error-hook continuation var))) + (if (string-ci=? var "Eval") + (evaluate val) + (add-buffer-initialization! + buffer + (local-binding-thunk + (variable-symbol (name->variable var)) + (evaluate val)))))))) + (loop m4)))))))) + + (loop start)))) + +) + +;;;; Output + +(define (write-buffer-interactive buffer) + (if (or (buffer-writeable? buffer) + (prompt-for-confirmation? + (string-append "Buffer '" + (buffer-name buffer) + "' is read only. Save anyway"))) + (begin (require-newline buffer) + (write-buffer buffer)))) + +(define-variable "Require Final Newline" + "True says silently put a newline at the end whenever a file is saved. +Neither false nor true says ask user whether to add a newline in each +such case. False means don't add newlines." + false) + +(define (require-newline buffer) + (if (ref-variable "Require Final Newline") + (without-group-clipped! (buffer-group buffer) + (lambda () + (let ((end (buffer-end buffer))) + (if (and (not (eqv? char:newline (extract-left-char end))) + (or (eq? (ref-variable "Require Final Newline") true) + (prompt-for-yes-or-no? + (string-append + "Buffer " (buffer-name buffer) + " does not end in newline. Add one")))) + (insert-newline end))))))) + +(define (write-buffer buffer) + (let ((truename (write-region (buffer-unclipped-region buffer) + (buffer-pathname buffer)))) + (if truename + (begin (set-buffer-truename! buffer truename) + (delete-auto-save-file! buffer) + (set-buffer-save-length! buffer) + (buffer-not-modified! buffer))))) + +(define (write-region region pathname) + (let ((truename (pathname->output-truename pathname))) + (let ((filename (pathname->string truename))) + (and (or (not (file-exists? truename)) + (prompt-for-yes-or-no? + (string-append "File '" filename "' exists. Write anyway"))) + (begin (temporary-message "Writing file '" filename "'") + (region->file region truename) + (append-message " -- done") + truename))))) + +(define (region->file region pathname) + (call-with-output-file pathname + (lambda (port) + (region->port port region)))) + +(define (region->port port region) + ((access :write-string port) (region->string region))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/fill.scm b/v7/src/edwin/fill.scm new file mode 100644 index 000000000..2f09a107a --- /dev/null +++ b/v7/src/edwin/fill.scm @@ -0,0 +1,211 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Text Fill Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("^R Fill Paragraph" argument) + "Fill this (or next) paragraph. +Point stays the same." + (fill-region (paragraph-text-region (current-point)))) + +(define-command ("^R Fill Region" argument) + "Fill text from point to mark." + (fill-region (current-region))) + +(define-variable "Fill Column" + "Controls where ^R Fill Paragraph and Auto Fill mode put the right margin." + 70) + +(define-command ("^R Set Fill Column" argument) + "Set fill column to argument or current column. +If an argument is given, that is used. +Otherwise the current position of the cursor is used." + (local-set-variable! "Fill Column" + (or argument (current-column))) + (temporary-message "Fill column set to " + (write-to-string (ref-variable "Fill Column")))) + +(define-variable "Fill Prefix" + "String for Auto Fill to insert at start of new line, or #!FALSE." + #!FALSE) + +(define-command ("^R Set Fill Prefix" argument) + "Set fill prefix to text between point and start of line." + (if (line-start? (current-point)) + (begin (local-set-variable! "Fill Prefix" #!FALSE) + (temporary-message "Fill prefix cancelled")) + (let ((string (extract-string (line-start (current-point) 0)))) + (local-set-variable! "Fill Prefix" string) + (temporary-message "Fill prefix now \"" + (ref-variable "Fill Prefix") + "\"")))) + +(define fill-region) +(let () + +(set! fill-region +(named-lambda (fill-region region) + (let ((start (region-start region)) + (end (region-end region))) + (let ((start (mark-right-inserting (skip-chars-forward "\n" start end))) + (end (mark-left-inserting (skip-chars-backward "\n" end start)))) + (with-narrowed-region! (make-region start end) + (lambda () + (canonicalize-sentence-endings start) + (remove-fill-prefix start) + (canonicalize-spacing start) + (delete-horizontal-space end) + (fill-region-loop start))))))) + +(define (fill-region-loop start) + (if (not (group-end? start)) + (begin + (if (ref-variable "Fill Prefix") + (insert-string (ref-variable "Fill Prefix") start)) + (let ((target (move-to-column start (ref-variable "Fill Column")))) + (if (not (group-end? target)) + (let ((end + (cond ((char-search-backward #\Space (mark1+ target) start) + (re-match-end 0)) + ((char-search-forward #\Space target) + (re-match-start 0)) + (else #!FALSE)))) + (if end + (let ((start (mark-left-inserting end))) + (delete-horizontal-space start) + (insert-newline start) + (fill-region-loop start))))))))) + +(define (canonicalize-sentence-endings mark) + (let ((ending (forward-sentence mark 1 #!FALSE))) + (if (and ending (not (group-end? ending))) + (if (char=? char:newline (mark-right-char ending)) + (let ((mark (mark-left-inserting ending))) + (insert-char #\Space mark) + (canonicalize-sentence-endings mark)) + (canonicalize-sentence-endings ending))))) + +(define (canonicalize-spacing mark) + (if (char-search-forward char:newline mark) + (let ((mark (mark-left-inserting (re-match-start 0)))) + (replace-next-char mark #\Space) + (remove-fill-prefix mark) + (canonicalize-spacing mark)))) + +(define (remove-fill-prefix mark) + (if (ref-variable "Fill Prefix") + (let ((end (match-forward (ref-variable "Fill Prefix") mark))) + (if end (delete-string mark end))))) + +(define (replace-next-char mark char) + (delete-string mark (mark1+ mark)) + (insert-char char mark)) + +) + +(define-command ("Auto Fill Mode" argument) + "Toggle Auto Fill mode. +With argument, turn Auto Fill mode on iff argument is positive." + (cond ((and (or (not argument) (positive? argument)) + (not (current-minor-mode? fill-mode))) + (enable-current-minor-mode! fill-mode)) + ((and (or (not argument) (not (positive? argument))) + (current-minor-mode? fill-mode)) + (disable-current-minor-mode! fill-mode)))) + +(define-command ("^R Auto Fill Space" (argument 1)) + "Breaks the line if it exceeds the fill column, then inserts a space." + (insert-chars #\Space argument) + (auto-fill-break)) + +(define-command ("^R Auto Fill Newline" argument) + "Breaks the line if it exceeds the fill column, then inserts a newline." + (auto-fill-break) + (^r-newline-command argument)) + +(define-minor-mode "Fill" + "" + 'DONE) + +(define-key "Fill" #\Space "^R Auto Fill Space") +(define-key "Fill" #\Return "^R Auto Fill Newline") + +(define (auto-fill-break) + (let ((point (current-point))) + (if (auto-fill-break? point) + (if (re-search-backward "[^ \t][ \t]+" + (move-to-column + point + (1+ (ref-variable "Fill Column"))) + (line-start point 0)) + (with-current-point (re-match-end 0) + ^r-indent-new-comment-line-command))))) + +(define (auto-fill-break? point) + (and (> (mark-column point) (ref-variable "Fill Column")) + (line-end? (horizontal-space-end point)))) + +(define-command ("^R Center Line" argument) + "Center this line's text within the line. +The width is Fill Column." + (center-line (current-point))) + +(define-variable "Left Margin" + "The number of columns to indent each line." + 0) + +(define (center-line mark) + (mark-permanent! mark) + (delete-horizontal-space (line-start mark 0)) + (delete-horizontal-space (line-end mark 0)) + (let ((d (- (- (ref-variable "Fill Column") (ref-variable "Left Margin")) + (mark-column (line-end mark 0))))) + (if (positive? d) + (insert-horizontal-space (+ (ref-variable "Left Margin") + (quotient d 2)) + (line-start mark 0))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm new file mode 100644 index 000000000..3e4c0d356 --- /dev/null +++ b/v7/src/edwin/hlpcom.scm @@ -0,0 +1,381 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Help Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("^R Help Prefix" argument) + "This is a prefix for more commands. +It reads another character (a subcommand) and dispatches on it." + (let ((char (prompt-for-char-with-interrupts + "A C D I K L M T V W or C-h for more help"))) + (dispatch-on-char + (current-comtab) + (list #\Backspace + (if (or (char=? char #\Backspace) + (char=? char #\?)) + (let ((buffer (temporary-buffer "*Help*"))) + (insert-string + "You have typed C-h, the help character. Type a Help option: + +A Command apropos. Type a substring, and see a list of commands + 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. +I Info. The Info documentation reader. +K Describe key. Type a key sequence; + it prints the full documentation. +L View Lossage. Prints the last 100 characters you typed. +M Describe Mode. Print documentation of current major mode, + which describes the commands peculiar to it. +T Help with Tutorial. Select the Emacs learn-by-doing tutorial. +V Describe variable. Type a variable name and get its documentation. +W Where is. Type a command name and get its key binding." + (buffer-point buffer)) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (pop-up-buffer buffer false) + (let ((window (get-buffer-window buffer))) + (define (loop) + (let ((char + (char-upcase + (prompt-for-typein + "A C D I K L M T V W or space to scroll: " + keyboard-read-char)))) + (cond ((or (char=? char #\Backspace) + (char=? char #\?)) + (loop)) + ((or (char=? char #\Space) + (char=? char #\C-V)) + (scroll-window window + (standard-scroll-window-argument + window false 1) + beep) + (loop)) + ((or (char=? char #\Rubout) + (char=? char #\M-V)) + (scroll-window window + (standard-scroll-window-argument + window false -1) + beep) + (loop)) + (else char)))) + (loop))) + char))))) + +(define-prefix-key "Fundamental" #\Backspace "^R Help Prefix") +(define-key "Fundamental" '(#\Backspace #\A) "Command Apropos") +(define-key "Fundamental" '(#\Backspace #\C) "Describe Key Briefly") +(define-key "Fundamental" '(#\Backspace #\D) "Describe Command") +(define-key "Fundamental" '(#\Backspace #\I) "Info") +(define-key "Fundamental" '(#\Backspace #\K) "Describe Key") +(define-key "Fundamental" '(#\Backspace #\L) "View Lossage") +(define-key "Fundamental" '(#\Backspace #\M) "Describe Mode") +(define-key "Fundamental" '(#\Backspace #\T) "Teach Emacs") +(define-key "Fundamental" '(#\Backspace #\V) "Describe Variable") +(define-key "Fundamental" '(#\Backspace #\W) "Where Is") + +;;;; Commands and Keys + +(define-command ("Command Apropos" argument) + "Prompts for a string, lists all commands containing it." + (let ((string (or (prompt-for-string "Command apropos" #!FALSE) ""))) + (with-output-to-help-display + (lambda () + (for-each (lambda (command) + (write-string (command-name command)) + (newline) + (print-key-bindings command) + (print-short-description (command-description command))) + (string-table-apropos editor-commands string)))))) + +(define-command ("Describe Command" argument) + "Prompts for a command, and describes it. +Prints the full documentation for the given command." + (let ((command (prompt-for-command "Describe Command"))) + (with-output-to-help-display + (lambda () + (write-string (command-name command)) + (newline) + (print-key-bindings command) + (write-description (command-description command)))))) + +(define-command ("Where Is" argument) + "Prompts for a command, and shows what key it is bound to." + (let ((command (prompt-for-command "Where is command"))) + (let ((bindings (comtab-key-bindings (current-comtab) command))) + (if (null? bindings) + (message "\"" (command-name command) "\" is not on any keys") + (message "\"" (command-name command) "\" is on " + (xchar->name (car bindings))))))) + +(define-command ("Describe Key Briefly" argument) + "Prompts for a key, and describes the command it is bound to. +Prints the brief documentation for that command." + (let ((char (prompt-for-key "Describe key briefly" (current-comtab)))) + (let ((command (comtab-entry (current-comtab) char))) + (if (eq? command (name->command "^R Bad Command")) + (help-describe-unbound-key char) + (message (xchar->name char) + " runs the command \"" + (command-name command) + "\""))))) + +(define-command ("Describe Key" argument) + "Prompts for a key, and describes the command it is bound to. +Prints the full documentation for that command." + (let ((char (prompt-for-key "Describe key" (current-comtab)))) + (let ((command (comtab-entry (current-comtab) char))) + (if (eq? command (name->command "^R Bad Command")) + (help-describe-unbound-key char) + (with-output-to-help-display + (lambda () + (write-string (string-append (xchar->name char) + " runs the command \"" + (command-name command) + "\":")) + (newline) + (write-description (command-description command)))))))) + +(define (help-describe-unbound-key char) + (message (xchar->name char) " is undefined")) + +;;;; Variables + +(define-command ("Variable Apropos" argument) + "Prompts for a string, lists all variables containing it." + (let ((string (or (prompt-for-string "Variable apropos" #!FALSE) ""))) + (with-output-to-help-display + (lambda () + (for-each (lambda (variable) + (write-string (variable-name variable)) + (newline) + (print-variable-binding variable) + (print-short-description (variable-description variable))) + (string-table-apropos editor-variables string)))))) + +(define-command ("Describe Variable" argument) + "Prompts for a variable, and describes it. +Prints the full documentation for the given variable." + (let ((variable (prompt-for-variable "Describe Variable"))) + (with-output-to-help-display + (lambda () + (write-string (variable-name variable)) + (newline) + (print-variable-binding variable) + (write-description (variable-description variable)))))) + +(define-command ("Set Variable" argument) + "Change the value of a variable. +Prompts for a variable, then sets its value to the argument, if any. +If no argument is given, reads a Scheme expression and evaluates it, +using that for the value." + (let ((variable (prompt-for-variable "Set Variable"))) + (variable-set! variable + (or argument + (prompt-for-expression-value + "Value" + (write-to-string (variable-ref variable))))))) + +(define-command ("Make Local Variable" argument) + "Make a variable have a local value in the current buffer. +With no argument, the variable's value is unchanged. +A numeric argument becomes the new value of the variable. +Just \\[^R Universal Argument] means prompt for the new value." + (let ((variable (prompt-for-variable "Make Local Variable"))) + (make-local-binding! (variable-symbol variable) + (cond ((not argument) (variable-ref variable)) + ((command-argument-multiplier-only?) + (prompt-for-expression-value + "Value" + (write-to-string (variable-ref variable)))) + (else argument))))) + +(define-command ("Kill Local Variable" argument) + "Make a variable use its global value in the current buffer." + (unmake-local-binding! + (variable-symbol (prompt-for-variable "Kill Local Variable")))) + +;;;; Other Stuff + +(define-command ("View Lossage" argument) + "Print the keyboard history." + (with-output-to-help-display + (lambda () + (for-each (lambda (char) + (write-string (string-append (char->name char) " "))) + (reverse (ring-list (current-char-history))))))) + +(define-command ("Describe Mode" argument) + "Print the documentation for the current mode." + (with-output-to-help-display + (lambda () + (write-description (mode-description (current-major-mode)))))) + +(define-command ("Teach Emacs" argument) + "Visit the Emacs learn-by-doing tutorial." + (delete-other-windows (current-window)) + (let ((pathname (string->pathname "*TUTORIAL"))) + (let ((buffer (pathname->buffer pathname))) + (if buffer + (select-buffer buffer) + (let ((buffer (new-buffer (pathname->buffer-name pathname)))) + (read-buffer buffer (string->pathname "ED:-TUTORIAL")) + (set-buffer-pathname! buffer pathname) + (set-buffer-truename! buffer pathname) + (select-buffer buffer) + (set-current-major-mode! fundamental-mode) + (disable-buffer-auto-save! buffer) + (let ((mark + (mark1+ + (line-end (search-forward "\n<<" (buffer-start buffer)) + 0)))) + (delete-string mark (line-end mark 0)) + (insert-newlines (- (window-y-size (current-window)) + (+ 4 (region-count-lines + (make-region (buffer-start buffer) + mark)))) + mark)) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer)))))) + +(define (with-output-to-help-display thunk) + (with-output-to-temporary-buffer "*Help*" thunk)) + +(define (write-description description) + (write-string (substitute-command-keys description))) + +(define (print-key-bindings command) + (let ((bindings (comtab-key-bindings (current-comtab) command))) + (if (not (null? bindings)) + (begin (write-string " which is bound to: ") + (write-string (char-list-string bindings)) + (newline))))) + +(define (char-list-string xchars) + (if (null? (cdr xchars)) + (xchar->name (car xchars)) + (string-append (xchar->name (car xchars)) + ", " + (char-list-string (cdr xchars))))) +(define (print-variable-binding variable) + (write-string " which is ") + (let ((symbol (variable-symbol variable))) + (cond ((lexical-unbound? edwin-package symbol) + (write-string "unbound")) + ((lexical-unassigned? edwin-package symbol) + (write-string "unassigned")) + (else + (write-string "bound to: ") + (write (lexical-reference edwin-package symbol))))) + (newline)) + +(define (print-short-description description) + (write-string " ") + (write-description (string-first-line description)) + (newline)) + +(define (string-first-line string) + (let ((index (string-find-next-char string char:newline))) + (if index + (substring string 0 index) + string))) + +(define (substitute-command-keys string #!optional start end) + (if (unassigned? start) (set! start 0)) + (if (unassigned? end) (set! end (string-length string))) + + (define (find-escape start*) + (define (loop start) + (let ((index (substring-find-next-char string start end #\\))) + (if (not index) + (list (substring string start* end)) + (let ((next (1+ index))) + (if (= next end) + (list (substring string start* end)) + (cond ((char=? #\[ (string-ref string next)) + (cons (substring string start* index) + (subst-key (1+ next)))) + ((char=? #\= (string-ref string next)) + (cons (substring string start* index) + (quote-next (1+ next)))) + (else (loop next)))))))) + (loop start*)) + + (define (subst-key start) + (let ((index (substring-find-next-char string start end #\]))) + (if (not index) + (error "SUBSTITUTE-COMMAND-KEYS: Missing ]") + (cons (command->key-name + (name->command (substring string start index))) + (find-escape (1+ index)))))) + + (define (quote-next start) + (if (= start end) + (finish start) + (let ((next (1+ start))) + (if (char=? #\\ (string-ref string start)) + (if (= next end) + (finish start) + (continue start (1+ next))) + (continue start next))))) + + (define (continue start end) + (cons (substring string start end) + (find-escape end))) + + (define (finish start) + (list (substring string start end))) + + (apply string-append (find-escape start))) + +(define (command->key-name command) + (let ((bindings (comtab-key-bindings (current-comtab) command))) + (if (null? bindings) + (string-append "M-X " (command-name command)) + (xchar->name (car bindings))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/image.scm b/v7/src/edwin/image.scm new file mode 100644 index 000000000..45296ff0f --- /dev/null +++ b/v7/src/edwin/image.scm @@ -0,0 +1,299 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Display Imaging + +(declare (usual-integrations)) + +;;; Display imaging is the process by which strings are converted into +;;; an image which can be displayed on a screen. The IMAGE +;;; abstraction, implemented here, captures that process. Given a +;;; string, it is capable of generating another string which is the +;;; visual representation of that string. In addition, it retains the +;;; ability to associate indices into the string with columns in the +;;; representation. + +;;; *** One important note: the image abstraction will not "correctly" +;;; display strings that contain newlines. Currently, a newline in +;;; such a string will be represented by the string "^M". This is so +;;; because images are intended to be used on a per-line basis; that +;;; is, the string should be for a single line. + +;;; Images are implemented in terms of another abstraction, called a +;;; PARSE, which describes how characters in the string are displayed. +;;; Most characters are represented by themselves (these are called +;;; "graphic" characters), but others (called "non-graphic" +;;; characters) are represented by strings of graphic characters. + +;;; A parse, then, is a list of alternating index/string pairs. The +;;; index is the position of the next non-graphic character in the +;;; string, and the following string is its representation. If two or +;;; more non-graphic characters are adjacent, then the list contains a +;;; single index, followed by the representations of each of the +;;; non-graphic characters, in succession. Finally, if the +;;; non-graphic characters appear at the beginning of the string, then +;;; the index is omitted altogether. + +;;; This representation has a number of advantages. + +;;; [] Most of the time, there are no non-graphic characters in the +;;; string; then the parse is the empty list. + +;;; [] Adjacent non-graphic characters (tabs) are common in indented +;;; Lisp code; this representation optimizes specially for this +;;; case. + +;;; [] The association of string indices and image columns is very +;;; straightforward. + +(define (make-image string) + (parse-string-for-image string + (lambda (parse column-size) + (vector string parse column-size)))) + +(define (make-null-image) + (vector "" '() 0)) + +(define (image-direct-output-insert-char! image char) + (vector-set! image 0 (string-append-char (vector-ref image 0) char)) + (vector-set! image 2 (1+ (vector-ref image 2)))) + +(define (image-direct-output-insert-substring! image string start end) + (vector-set! image 0 + (string-append-substring (vector-ref image 0) + string start end)) + (vector-set! image 2 (+ (vector-ref image 2) (- end start)))) + +(declare (integrate image-string image-parse image-column-size + image-index-size)) + +(define (image-string image) + (declare (integrate image)) + (vector-ref image 0)) + +(define (image-parse image) + (declare (integrate image)) + (vector-ref image 1)) + +(define (image-column-size image) + (declare (integrate image)) + (vector-ref image 2)) + +(define (image-index-size image) + (declare (integrate image)) + (string-length (image-string image))) + +(define (image-representation image) + (let ((string (image-string image)) + (result-end (image-column-size image))) + (let ((string-end (string-length string)) + (result (string-allocate result-end))) + (define (loop parse string-start result-start) + (cond ((null? parse) + (substring-move-right! string string-start string-end + result result-start)) + ((string? (car parse)) + (let ((size (string-length (car parse)))) + (substring-move-right! (car parse) 0 size + result result-start) + (loop (cdr parse) + (1+ string-start) + (+ result-start size)))) + ((number? (car parse)) + (substring-move-right! string string-start (car parse) + result result-start) + (loop (cdr parse) + (car parse) + (+ result-start (- (car parse) string-start)))) + (else + (error "Bad parse element" (car parse))))) + + (loop (image-parse image) 0 0) + result))) + +(define (image-index->column image index) + (define (loop parse start column) + (cond ((null? parse) + (+ column (- index start))) + ((string? (car parse)) + (if (= index start) + column + (loop (cdr parse) + (1+ start) + (+ column (string-length (car parse)))))) + ((number? (car parse)) + (if (<= index (car parse)) + (+ column (- index start)) + (loop (cdr parse) + (car parse) + (+ column (- (car parse) start))))) + (else + (error "Bad parse element" (car parse))))) + + (loop (image-parse image) 0 0)) + +(define (image-column->index image column) + (define (loop parse start c) + (cond ((null? parse) + (+ start (- column c))) + ((string? (car parse)) + (let ((new-c (+ c (string-length (car parse))))) + (if (< column new-c) + start + (loop (cdr parse) (1+ start) new-c)))) + ((number? (car parse)) + (let ((new-c (+ c (- (car parse) start)))) + (if (< column new-c) + (+ start (- column c)) + (loop (cdr parse) (car parse) new-c)))) + (else + (error "Bad parse element" (car parse))))) + + (loop (image-parse image) 0 0)) + +;;;; Parsing + +(define (parse-string-for-image string receiver) + (parse-substring-for-image string 0 (string-length string) receiver)) + +(define (string-column-length string start-column) + (substring-column-length string 0 (string-length string) start-column)) + +(define (string-index->column string start-column index) + (+ start-column (substring-column-length string 0 index start-column))) + +(define (string-column->index string start-column column if-lose) + (substring-column->index string 0 (string-length string) start-column + column if-lose)) + +(define (char-column-length char start-column) + (string-length (char-representation char start-column))) + +(define parse-substring-for-image) +(define substring-column-length) +(define substring-column->index) +(define char-representation) +(let () + +(set! parse-substring-for-image +(named-lambda (parse-substring-for-image string start end receiver) + (define (loop start column receiver) + (let ((index (substring-find-next-char-in-set string start end + non-graphic-chars))) + (if (not index) + (receiver '() (+ column (- end start))) + (let ((column (+ column (- index start)))) + (let ((representation (char-rep string index column))) + (loop (1+ index) + (+ column (string-length representation)) + (lambda (parse column-size) + (receiver (if (= index start) (cons representation parse) + (cons index (cons representation parse))) + column-size)))))))) + (loop start 0 receiver))) + +(set! substring-column-length +(named-lambda (substring-column-length string start end start-column) + (define (loop i c) + (let ((index (substring-find-next-char-in-set string i end + non-graphic-chars))) + (if (not index) + (+ c (- end i)) + (let ((c (+ c (- index i)))) + (loop (1+ index) + (+ c (string-length (char-rep string index c)))))))) + (loop start start-column))) + +(set! substring-column->index +(named-lambda (substring-column->index string start end start-column + column #!optional if-lose) + (define (loop i c left) + (let ((index (substring-find-next-char-in-set string i end + non-graphic-chars))) + (if (not index) + (let ((n (- end i))) + (cond ((<= left n) (+ left i)) + ((unassigned? if-lose) end) + (else (if-lose (+ c n))))) + (let ((n (- index i))) + (if (<= left n) + (+ left i) + (let ((left (- left n)) + (c (+ c n))) + (let ((n (string-length (char-rep string index c)))) + (cond ((< left n) index) + ((= left n) (1+ index)) + (else (loop (1+ index) (+ c n) (- left n))))))))))) + (if (zero? column) + start + (loop start start-column (- column start-column))))) + +(declare (integrate char-rep)) +(define (char-rep string index column) + (declare (integrate string index column)) + (char-representation (string-ref string index) column)) + +(set! char-representation +(named-lambda (char-representation char column) + (if (char=? char #\Tab) + (vector-ref tab-display-images (remainder column 8)) + (vector-ref display-images (char->ascii char))))) + +(define non-graphic-chars + (apply char-set + `(,@(let loop ((n #x00)) + (if (= n #x20) + '() + (cons (ascii->char n) (loop (1+ n))))) + ,(ascii->char #x7F)))) + +(define tab-display-images + #(" " " " " " " " " " " " " " " ")) + +(define display-images + #("^@" "^A" "^B" "^C" "^D" "^E" "^F" "^G" + "^H" "^I" "^J" "^K" "^L" "^M" "^N" "^O" + "^P" "^Q" "^R" "^S" "^T" "^U" "^V" "^W" + "^X" "^Y" "^Z" "^[" "^\\" "^]" "^^" "^_" + " " "!" "\"" "#" "$" "%" "&" "'" "(" ")" "*" "+" "," "-" "." "/" + "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ":" ";" "<" "=" ">" "?" + "@" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" + "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "[" "\\" "]" "^" "_" + "`" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" + "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?")) + +) \ No newline at end of file diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm new file mode 100644 index 000000000..6d0669436 --- /dev/null +++ b/v7/src/edwin/info.scm @@ -0,0 +1,658 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Info Mode +;;; Shamelessly copied from GNU Emacs. + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define history '()) +(define current-file #!FALSE) +(define current-node #!FALSE) + +(define-major-mode "Info" "Fundamental" + "Info mode provides commands for browsing through the Info documentation tree. +Documentation in Info is divided into \"nodes\", each of which +discusses one topic and contains references to other nodes +which discuss related topics. Info has commands to follow +the references and show you other nodes. + +h Invoke the Info tutorial. + +Selecting other nodes: +n Move to the \"next\" node of this node. +p Move to the \"previous\" node of this node. +u Move \"up\" from this node. +m Pick menu item specified by name (or abbreviation). + Picking a menu item causes another node to be selected. +f Follow a cross reference. Reads name of reference. +l Move to the last node you were at. + +Moving within a node: +Space scroll forward a page. +Rubout scroll backward. +b Go to beginning of node. + +Advanced commands: +q Quit Info: reselect previously selected buffer. +e Edit contents of selected node. +1 Pick first item in node's menu. +2, 3, 4, 5 Pick second ... fifth item in node's menu. +g Move to node specified by name. + You may include a filename as well, as (FILENAME)NODENAME. +s Search through this Info file for specified regexp, + and select the node in which the next occurrence is found." + (local-set-variable! "Syntax Table" text-mode:syntax-table) + (local-set-variable! "Case Fold Search" #!TRUE) + (local-set-variable! "Info Tag Table Start" #!FALSE) + (local-set-variable! "Info Tag Table End" #!FALSE) + (buffer-put! (current-buffer) 'MODELINE-STRING info-modeline-string)) + +(define (info-modeline-string window) + (string-append "--" + (modeline-modified-string window) + "-Info: (" + (let ((pathname (buffer-pathname (window-buffer window)))) + (if pathname + (pathname-name pathname) + "")) + ")" + (or current-node "") + " " + (modeline-mode-string window) + "--" + (modeline-percentage-string window))) + +(define-key "Info" #\Space "^R Next Screen") +(define-key "Info" #\. "^R Goto Beginning") +(define-key "Info" #\1 "^R Info First Menu Item") +(define-key "Info" #\2 "^R Info Second Menu Item") +(define-key "Info" #\3 "^R Info Third Menu Item") +(define-key "Info" #\4 "^R Info Fourth Menu Item") +(define-key "Info" #\5 "^R Info Fifth Menu Item") +(define-key "Info" #\? "^R Info Summary") +(define-key "Info" #\B "^R Goto Beginning") +(define-key "Info" #\D "^R Info Directory") +(define-key "Info" #\E "^R Info Edit") +(define-key "Info" #\F "^R Info Follow Reference") +(define-key "Info" #\G "^R Info Goto Node") +(define-key "Info" #\H "^R Info Help") +(define-key "Info" #\L "^R Info Last") +(define-key "Info" #\M "^R Info Menu") +(define-key "Info" #\N "^R Info Next") +(define-key "Info" #\P "^R Info Previous") +(define-key "Info" #\Q "^R Info Exit") +(define-key "Info" #\S "^R Info Search") +(define-key "Info" #\U "^R Info Up") +(define-key "Info" #\Rubout "^R Previous Screen") + +(define-major-mode "Info-Edit" "Text" + "Major mode for editing the contents of an Info node. +The editing commands are the same as in Text mode, +except for \\[^R Info Cease Edit] to return to Info." + (local-set-variable! "Page Delimiter" + (string-append "^\f\\|" + (ref-variable "Page Delimiter"))) + ((mode-initialization text-mode))) + +(define-prefix-key "Info-Edit" #\C-C "^R Prefix Character") +(define-key "Info-Edit" '(#\C-C #\C-C) "^R Info Cease Edit") + +(define-command ("^R Info Edit" argument) + "Edit the contents of this Info node. +Allowed only if the variable Info Enable Edit is not false." + (if (not (ref-variable "Info Enable Edit")) + (editor-error "Editing Info nodes is not enabled")) + (set-buffer-writeable! (current-buffer)) + (set-current-major-mode! info-edit-mode) + (message "Editing: Type C-C C-C to return to Info")) + +(define-command ("^R Info Cease Edit" argument) + "Finish editing Info node; switch back to Info proper." + (save-buffer-changes (current-buffer)) + (set-current-major-mode! info-mode) + (set-buffer-read-only! (current-buffer)) + (clear-message)) + +(define-command ("Info" argument) + "Create a buffer for Info, the documentation browser program." + (let ((buffer (find-buffer "*Info*"))) + (if buffer + (select-buffer buffer) + (begin (set! current-file #!FALSE) + (set! current-node #!FALSE) + (set! history '()) + (^r-info-directory-command))))) + +(define-command ("^R Info Directory" argument) + "Go to the Info directory node." + (find-node "dir" "Top")) + +(define-command ("^R Info Help" argument) + "Enter the Info tutorial." + (find-node "info" + (if (< (window-y-size (current-window)) 23) + "Help-Small-Screen" + "Help"))) + +(define-command ("^R Info Next" argument) + "Go to the next node of this node." + (follow-pointer extract-node-next "Next")) + +(define-command ("^R Info Previous" argument) + "Go to the previous node of this node." + (follow-pointer extract-node-previous "Previous")) + +(define-command ("^R Info Up" argument) + "Go to the superior node of this node." + (follow-pointer extract-node-up "Up")) + +(define (follow-pointer extractor name) + (goto-node (or (extractor (buffer-start (current-buffer))) + (editor-error "Node has no " name)))) + +(define-command ("^R Info Last" argument) + "Go back to the last node visited." + (if (null? history) + (editor-error "This is the first Info node you have looked at")) + (let ((entry (car history))) + (set! history (cdr history)) + (find-node (vector-ref entry 0) (vector-ref entry 1)) + (set! history (cdr history)) + (set-current-point! + (mark+ (region-start (buffer-unclipped-region (current-buffer))) + (vector-ref entry 2))))) + +(define-command ("^R Info Exit" argument) + "Exit Info by selecting some other buffer." + (let ((buffer (current-buffer))) + (select-buffer (previous-buffer)) + (bury-buffer buffer))) + +(define-command ("^R Info Goto Node" argument) + "Go to Info node of given name. Give just NODENAME or (FILENAME)NODENAME." + (goto-node (prompt-for-string "Goto node" #!FALSE))) + +(define-command ("^R Info Search" argument) + "Search for regexp, starting from point, and select node it's found in." + (let ((regexp (prompt-for-string "Search (regexp)" + (ref-variable "Info Previous Search"))) + (buffer (current-buffer))) + (set-variable! "Info Previous Search" regexp) + (let ((mark + (without-group-clipped! (buffer-group buffer) + (lambda () + (re-search-forward regexp))))) + (if mark + (begin (if (group-end? mark) ;then not in current node + (record-current-node)) + (buffer-widen! buffer) + (select-node buffer mark)) + (editor-failure))))) + +(define-command ("^R Info Summary" argument) + "Display a brief summary of all Info commands." + (let ((buffer (temporary-buffer "*Help*"))) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-description (mode-description (current-major-mode))))) + (set-buffer-point! buffer (buffer-start buffer)) + (buffer-not-modified! buffer) + (with-selected-buffer buffer + (lambda () + (define (loop) + (update-alpha-window! #!FALSE) + (let ((end-visible? (window-mark-visible? (current-window) + (buffer-end buffer)))) + (message (if end-visible? + "Type Space to return to Info" + "Type Space to see more")) + (let ((char (%keyboard-peek-char))) + (if (char=? char #\Space) + (begin (keyboard-read-char) + (if (not end-visible?) + (begin (^r-next-screen-command) + (loop)))))))) + (loop) + (clear-message))))) + +;;;; Menus + +(define-command ("^R Info Menu" argument) + "Go to node for menu item of given name." + (let ((menu (find-menu))) + (if (not menu) + (editor-error "No menu in this node") + (goto-node (prompt-for-alist-value "Menu item" + (collect-menu-items menu)))))) + +(define-command ("^R Info First Menu Item" argument) + "Go to the node of the first menu item." + (nth-menu-item 0)) + +(define-command ("^R Info Second Menu Item" argument) + "Go to the node of the second menu item." + (nth-menu-item 1)) + +(define-command ("^R Info Third Menu Item" argument) + "Go to the node of the third menu item." + (nth-menu-item 2)) + +(define-command ("^R Info Fourth Menu Item" argument) + "Go to the node of the fourth menu item." + (nth-menu-item 3)) + +(define-command ("^R Info Fifth Menu Item" argument) + "Go to the node of the fifth menu item." + (nth-menu-item 4)) + +(define (nth-menu-item n) + (define (loop mark n) + (cond ((not mark) (editor-error "Too few items in menu")) + ((zero? n) (goto-node (menu-item-name mark))) + (else (loop (next-menu-item mark) (-1+ n))))) + (loop (next-menu-item (or (find-menu) (editor-error "No menu in this node"))) + n)) + +(define (find-menu) + (search-forward "\n* menu:" (buffer-start (current-buffer)))) + +(define (collect-menu-items mark) + (let ((item (next-menu-item mark))) + (if (not item) + '() + (cons (cons (menu-item-keyword item) + (menu-item-name item)) + (collect-menu-items item))))) + +(define (next-menu-item mark) + (re-search-forward "\n\\*[ \t]+" (line-end mark 0))) + +(define (menu-item-keyword item) + (let ((end (char-search-forward #\: item (line-end item 0)))) + (if end + (extract-string item (re-match-start 0)) + (error "Menu item missing colon")))) + +(define (menu-item-name item) + (let ((colon (char-search-forward #\: item (line-end item 0)))) + (cond ((not colon) (error "Menu item missing colon")) + ((match-forward "::" (re-match-start 0)) + (extract-string item (re-match-start 0))) + (else + (%menu-item-name (horizontal-space-end colon)))))) + +(define (%menu-item-name start) + (if (line-end? start) + (error "Menu item missing node name") + (extract-string start + (let ((end (line-end start 0))) + (if (re-search-forward "[.,\t]" start end) + (re-match-start 0) + end))))) + +;;;; Cross References + +(define-command ("^R Info Follow Reference" argument) + "Follow cross reference, given name, to the node it refers to. +The name may be an abbreviation of the reference name." + (let ((items (collect-cref-items (buffer-start (current-buffer))))) + (if (null? items) + (editor-error "No cross references in this node") + (goto-node (prompt-for-alist-value "Follow reference named" items))))) + +(define (collect-cref-items mark) + (let ((item (next-cref-item mark))) + (if (not item) + '() + (cons (cons (cref-item-keyword item) + (cref-item-name item)) + (collect-cref-items item))))) + +(define (next-cref-item start) + (re-search-forward "\\*Note[ \t\n]*" start)) + +(define (cref-item-keyword item) + (let ((colon (char-search-forward #\: item))) + (if colon + (%cref-item-keyword item (re-match-start 0)) + (error "Cross reference missing colon")))) + +(define (%cref-item-keyword item colon) + (let ((string (extract-string item colon))) + (string-replace! string char:newline #\Space) + (string-trim string))) + +(define (cref-item-name item) + (let ((colon (char-search-forward #\: item))) + (cond ((not colon) (error "Cross reference missing colon")) + ((match-forward "::" (re-match-start 0)) + (%cref-item-keyword item (re-match-start 0))) + (else + (%menu-item-name (cref-item-space-end colon)))))) + +(define (cref-item-space-end mark) + (skip-chars-forward " \t\n" mark)) + +;;;; Validation + +(define-command ("Info Validate" argument) + "Check that every node pointer points to an existing node." + (let ((nodes (current-nodes-list)) + (losers '())) + (define (validate this-name type node-name) + (and node-name + (parse-node-name node-name + (lambda (filename nodename) + (and (not filename) + (let ((entry (node-assoc nodename nodes))) + (if (not entry) + (set! losers + (cons (vector this-name type node-name) + losers))) + entry)))))) + (for-each (lambda (entry) + (let ((name (car entry)) + (node (region-start (cadr entry)))) + (define (validate-extract type extractor) + (validate name type (extractor node))) + + (define ((validate-item prefix) item) + (validate name + (string-append prefix " " (car item)) + (cdr item))) + + (with-region-clipped! (cadr entry) + (lambda () + (let ((entry* (validate-extract "Next" + extract-node-next))) + (if (and entry* + (or (not (caddr entry*)) + (not (string-ci=? (caddr entry*) name)))) + (set! losers + (cons (vector name + "Previous-pointer in Next" + (car entry*)) + losers)))) + (validate-extract "Previous" extract-node-previous) + (validate-extract "Up" extract-node-up) + (let ((menu (find-menu))) + (if menu + (for-each (validate-item "Menu item") + (collect-menu-items menu)))) + (for-each (validate-item "Reference") + (collect-cref-items node)))))) + nodes) + (report-losers losers))) + +(define (report-losers losers) + (if (null? losers) + (message "File appears valid") + (with-output-to-temporary-buffer " *problems in info file*" + (lambda () + (for-each (lambda (loser) + (write-string + (string-append "In node " (vector-ref loser 0) + ", invalid " (vector-ref loser 1) + ": " (vector-ref loser 2))) + (newline)) + losers))))) + +(define (current-nodes-list) + (let ((buffer (current-buffer))) + (without-group-clipped! (buffer-group buffer) + (lambda () + (collect-nodes (buffer-start buffer)))))) + +(define (collect-nodes mark) + (let ((node (next-node mark (group-end mark)))) + (if (not node) + '() + (let ((name (extract-node-name node))) + (if name + (cons (list name (node-region node) (extract-node-previous node)) + (collect-nodes node)) + (collect-nodes node)))))) + +(define node-assoc + (association-procedure string-ci=? car)) + +;;;; Node Parsing + +(define (goto-node name) + (parse-node-name name find-node)) + +(define (find-node filename nodename) + (let ((pathname + (and filename + (merge-pathnames (->pathname filename) + (->pathname (ref-variable "Info Directory")))))) + (if (and pathname (not (file-exists? pathname))) + (error "Info file does not exist" pathname)) + (record-current-node) + (let ((buffer (find-or-create-buffer "*Info*"))) + ;; Switch files if necessary. + (if (and pathname + (not (and (buffer-pathname buffer) + (pathname=? pathname (buffer-pathname buffer))))) + (begin (buffer-reset! buffer) + (read-buffer buffer pathname) + (set-buffer-major-mode! buffer info-mode) + (find-tag-table buffer)) + (group-un-clip! (buffer-group buffer))) + (set-buffer-read-only! buffer) + (if (string=? nodename "*") + (begin (set! current-file pathname) + (set! current-node nodename) + (select-buffer buffer)) + (select-node buffer + (let ((end (buffer-end buffer))) + (define (loop start) + (let ((node (next-node start end))) + (if node + (if (let ((name (extract-node-name node))) + (and name + (string-ci=? nodename name))) + node + (loop node)) + (error "FIND-NODE: No such node" nodename)))) + (loop (node-search-start buffer nodename)))))))) + +(define (parse-node-name name receiver) + (let ((name (string-trim name))) + (if (char=? (string-ref name 0) #\() + (let ((index (string-find-next-char name #\)))) + (if index + (let ((filename (string-trim (substring name 1 index))) + (nodename (string-trim (substring name (1+ index) + (string-length name))))) + (receiver filename + (if (string-null? nodename) "Top" nodename))) + (error "PARSE-NODE-NAME: Missing close paren" name))) + (receiver #!FALSE (if (string-null? name) "Top" name))))) + +(define (record-current-node) + (if current-file + (set! history + (cons (vector current-file + current-node + (mark-index (current-point))) + history)))) + +(define (select-node buffer point) + (let ((node (node-start point (group-start point)))) + (set! current-file (buffer-pathname buffer)) + (set! current-node (extract-node-name node)) + ;; **** need to add active node hacking here **** + (region-clip! (node-region node)) + (select-buffer buffer) + (set-current-point! point))) + +(define (node-start start end) + (let ((mark (search-backward "\n" start end))) + (and mark + (line-start mark 2)))) + +(define (node-region node) + (make-region node (node-end node))) + +(define (node-end node) + (let ((end (group-end node))) + (define (loop start) + (let ((mark (re-search-forward "[\f]" start))) + (cond ((not mark) end) + ((char=? (extract-left-char (re-match-start 0)) char:newline) + (mark-1+ (re-match-start 0))) + (else (loop mark))))) + (loop node))) + +(define (next-node start end) + (let ((mark (search-forward "\n" start end))) + (and mark + (line-start mark 1)))) + +(define ((field-value-extractor field) node) + (let ((end (line-end node 0))) + (let ((mark (re-search-forward field node end))) + (and mark + (string-trim + (extract-string mark + (skip-chars-forward "^,\t" mark end))))))) + +(define extract-node-name + (field-value-extractor "Node:")) + +(define extract-node-up + (field-value-extractor "Up:")) + +(define extract-node-previous + (field-value-extractor "Prev\\(ious\\|\\):")) + +(define extract-node-next + (field-value-extractor "Next:")) + +;;;; Tag Tables + +(define-command ("Info Tagify" argument) + "Create or update tag table of current info file." + (let ((buffer (current-buffer))) + (without-group-clipped! (buffer-group buffer) + (lambda () + (with-read-only-defeated (buffer-end buffer) + (lambda () + ;; Flush old tag table if present. + (find-tag-table buffer) + (if (ref-variable "Info Tag Table Start") + (delete-string (mark- (ref-variable "Info Tag Table Start") + (string-length tag-table-start-string)) + (mark+ (ref-variable "Info Tag Table End") + (string-length tag-table-end-string)))) + ;; Then write new table. + (let ((entries (collect-tag-entries (buffer-start buffer)))) + (with-output-to-mark (buffer-end buffer) + (lambda () + (write-string tag-table-start-string) + (for-each (lambda (entry) + (write-string (cdr entry)) + (write-char #\Rubout) + (write (mark-index (car entry))) + (newline)) + entries) + (write-string tag-table-end-string)))))) + ;; Finally, reset the tag table marks. + (find-tag-table buffer))))) + +(define (collect-tag-entries mark) + (let ((node (next-node mark (group-end mark)))) + (if (not node) + '() + (let ((entry (extract-tag-entry node))) + (if entry + (cons (cons node entry) + (collect-tag-entries node)) + (collect-tag-entries node)))))) + +(define (extract-tag-entry node) + (let ((end (line-end node 0))) + (let ((mark (search-forward "Node:" node end))) + (and mark + (string-trim + (extract-string node + (skip-chars-forward "^,\t" mark end))))))) + +(define tag-table-start-string + "\f\nTag table:\n") + +(define tag-table-end-string + "\nEnd tag table\n") + +(define (find-tag-table buffer) + (let ((end (buffer-end buffer))) + (let ((mark (line-start end -8))) + (if mark + (let ((tag-table-end + (and (search-forward tag-table-end-string mark) + (re-match-start 0)))) + (set-variable! "Info Tag Table Start" + (and tag-table-end + (search-backward tag-table-start-string + tag-table-end) + (re-match-end 0))) + (set-variable! "Info Tag Table End" tag-table-end)) + (begin (set-variable! "Info Tag Table Start" #!FALSE) + (set-variable! "Info Tag Table End" #!FALSE)))))) + +(define (node-search-start buffer nodename) + (if (not (ref-variable "Info Tag Table Start")) + (buffer-start buffer) + (let ((string (string-append "Node: " nodename "¢))) + (let ((mark (search-forward string + (ref-variable "Info Tag Table Start") + (ref-variable "Info Tag Table End")))) + (or (and mark + (mark+ (buffer-start buffer) + (max 0 (- (with-input-from-mark mark read) 1000)))) + (buffer-start buffer)))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access info-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm new file mode 100644 index 000000000..f8a78fae5 --- /dev/null +++ b/v7/src/edwin/input.scm @@ -0,0 +1,276 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Keyboard Input + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(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))) + +(define (%keyboard-peek-char) + (remap-alias-char (peek-char editor-input-port))) + +(define (%keyboard-read-char) + (let ((char (remap-alias-char (read-char editor-input-port)))) + (ring-push! (current-char-history) char) + (if *defining-keyboard-macro?* + (keyboard-macro-write-char char)) + char)) + +(define keyboard-active? + (make-primitive-procedure 'TTY-READ-CHAR-READY?)) + +(define reset-command-prompt!) +(define command-prompt) +(define set-command-prompt!) + +(define (append-command-prompt! string) + (set-command-prompt! (string-append (command-prompt) string))) + +(define message) +(define temporary-message) +(define append-message) +(define clear-message) + +(define keyboard-read-char) +(define keyboard-peek-char) + +(define keyboard-package + (make-environment + +#| + +The interaction between command prompts and messages is complicated. +Here is a description of the state transition graph. + +State variables: + +a : there is a command prompt +b : the command prompt is displayed +c : there is a message +d : the message should be erased + +Constraints: + +b implies a +d implies c +b implies (not d) +c implies (not b) + +Valid States: + +abcd +0000 0 : idle state +0010 2 : message +0011 3 : temporary message +1000 8 : undisplayed command prompt +1010 A : message with undisplayed command prompt +1011 B : temporary message with undisplayed command prompt +1100 C : displayed command prompt + +Transition operations: + +0: reset-command-prompt +1: set-command-prompt +2: message +3: temporary-message +4: clear-message +5: timeout + +Transition table: + + 012345 +0 082300 +8 08230C +C *C230C * is special -- see the code. +2 2A2302 +3 3B2300 +A 2AAB8C +B 3BAB8C + +|# + +(define command-prompt-string false) +(define command-prompt-displayed? false) +(define message-string false) +(define message-should-be-erased? false) + +;;; Should only be called by the command reader. This prevents +;;; carryover from one command to the next. +(set! reset-command-prompt! +(named-lambda (reset-command-prompt!) + (set! command-prompt-string false) + (if command-prompt-displayed? + ;; To make it more visible, the command prompt is erased after + ;; timeout instead of right away. + (begin (set! command-prompt-displayed? false) + (set! message-should-be-erased? true))))) + +(set! command-prompt +(named-lambda (command-prompt) + (or command-prompt-string ""))) + +(set! set-command-prompt! +(named-lambda (set-command-prompt! string) + (if (not (string-null? string)) + (begin (set! command-prompt-string string) + (if command-prompt-displayed? + ((access set-message! prompt-package) string)))))) + +(define ((message-writer temporary?) . args) + (if command-prompt-displayed? + (begin (set! command-prompt-string false) + (set! command-prompt-displayed? false))) + (set! message-string (apply string-append args)) + (set! message-should-be-erased? temporary?) + ((access set-message! prompt-package) message-string)) + +(set! message (message-writer false)) +(set! temporary-message (message-writer true)) + +(set! append-message +(named-lambda (append-message . args) + (if (not message-string) + (error "Attempt to append to nonexistent message")) + (set! message-string + (string-append message-string + (apply string-append args))) + ((access set-message! prompt-package) message-string))) + +(set! clear-message +(named-lambda (clear-message) + (set! command-prompt-string false) + (set! command-prompt-displayed? false) + (set! message-string false) + (set! message-should-be-erased? false) + ((access clear-message! prompt-package)))) + +(declare (compilable-primitive-functions + (keyboard-active? tty-read-char-ready?))) + +(define ((keyboard-reader macro-read-char read-char)) + (if *executing-keyboard-macro?* + (macro-read-char) + (begin + (if (not (keyboard-active? 0)) + (begin (update-alpha-window! false) + (if (and (positive? (ref-variable "Auto Save Interval")) + (> *auto-save-keystroke-count* + (ref-variable "Auto Save Interval")) + (> *auto-save-keystroke-count* 20)) + (begin (do-auto-save) + (set! *auto-save-keystroke-count* 0))))) + (set! *auto-save-keystroke-count* (1+ *auto-save-keystroke-count*)) + (cond ((within-typein-edit?) + (if message-string + (begin (keyboard-active? + (if message-should-be-erased? 50 200)) + (set! message-string false) + (set! message-should-be-erased? false) + ((access clear-message! prompt-package))))) + ((and (or message-should-be-erased? + (and command-prompt-string + (not command-prompt-displayed?))) + (not (keyboard-active? 50))) + (begin (set! message-string false) + (set! message-should-be-erased? false) + (if command-prompt-string + (begin (set! command-prompt-displayed? true) + ((access set-message! prompt-package) + command-prompt-string)) + ((access clear-message! prompt-package)))))) + (read-char)))) + +(set! keyboard-read-char + (keyboard-reader (lambda () (keyboard-macro-read-char)) + %keyboard-read-char)) + +(set! keyboard-peek-char + (keyboard-reader (lambda () (keyboard-macro-peek-char)) + %keyboard-peek-char)) + +)) + +(define char-controlify) +(define char-metafy) +(define char-control-metafy) +(define char-base) +(let () + +(set! char-controlify +(named-lambda (char-controlify char) + (make-char (char-code char) + (controlify (char-bits char))))) + +(set! char-metafy +(named-lambda (char-metafy char) + (make-char (char-code char) + (metafy (char-bits char))))) + +(set! char-control-metafy +(named-lambda (char-control-metafy char) + (make-char (char-code char) + (controlify (metafy (char-bits char)))))) + +(set! char-base +(named-lambda (char-base char) + (make-char (char-code char) 0))) + +(define (controlify i) + (if (>= (remainder i #x2) #x1) i (+ #x1 i))) + +(define (metafy i) + (if (>= (remainder i #x4) #x2) i (+ #x2 i))) + +) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm new file mode 100644 index 000000000..113f4ac5a --- /dev/null +++ b/v7/src/edwin/intmod.scm @@ -0,0 +1,194 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Interaction Mode + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-major-mode "Interaction" "Scheme" + "Major mode for evaluating Scheme expressions interactively. +Same as Scheme mode, except for + +\\[^R Interaction Execute] evaluates the current expression. +\\[^R Interaction Refresh] deletes the contents of the buffer. +\\[^R Interaction Yank] yanks the last expression. +\\[^R Interaction Yank Pop] yanks an earlier expression, replacing a yank." + (local-set-variable! "Interaction Prompt" + (ref-variable "Interaction Prompt")) + (local-set-variable! "Interaction Kill Ring" (make-ring 32)) + (local-set-variable! "Scheme Environment" + (ref-variable "Scheme Environment")) + (local-set-variable! "Scheme Syntax-table" + (ref-variable "Scheme Syntax-table")) + ((mode-initialization scheme-mode))) + +(define-key "Interaction" #\Return "^R Interaction Execute") +(define-prefix-key "Interaction" #\C-C "^R Prefix Character") +(define-key "Interaction" '(#\C-C #\Page) "^R Interaction Refresh") +(define-key "Interaction" '(#\C-C #\C-Y) "^R Interaction Yank") +(define-key "Interaction" '(#\C-C #\C-R) "^R Interaction Yank Pop") + +(define-command ("Interaction Mode" argument) + "Make the current mode be Interaction mode." + (set-current-major-mode! Interaction-mode) + (let ((buffer (current-buffer))) + (if (not (mark= (buffer-start buffer) (buffer-end buffer))) + (begin (set-current-point! (buffer-end buffer)) + (insert-interaction-prompt)) + (insert-interaction-prompt #!FALSE)))) + +(define (insert-interaction-prompt #!optional newlines?) + (if (unassigned? newlines?) (set! newlines? #!TRUE)) + (if newlines? (insert-newlines 2)) + (insert-string "1 ") + (insert-string (ref-variable "Interaction Prompt")) + (insert-string " ") + (buffer-put! (current-buffer) + interaction-mode:buffer-mark-tag + (mark-right-inserting (current-point)))) + +(define interaction-mode:buffer-mark-tag + "Mark") + +(define-variable "Interaction Prompt" + "Prompt string used by Interaction mode." + "]=>") + +(define-variable "Interaction Kill Ring" + "Kill ring used by Interaction mode evaluation commands.") + +(define-command ("^R Interaction Execute" argument) + "Evaluate the input expression. +With an argument, calls ^R Insert Self instead. + +If invoked in the current `editing area', evaluates the expression there. + The editing area is defined as the space between the last prompt and + the end of the buffer. The expression is checked to make sure that it + is properly balanced, and that there is only one such expression. + +Otherwise, goes to the end of the current line, copies the preceding + expression to the editing area, then evaluates it. In this case the + editing area must be empty. + +Output is inserted into the buffer at the end." + (define (extract-expression start) + (let ((expression (extract-string start (forward-one-sexp start)))) + (ring-push! (ref-variable "Interaction Kill Ring") expression) + expression)) + + (if argument + (^r-insert-self-command argument) + (let ((mark (or (buffer-get (current-buffer) + interaction-mode:buffer-mark-tag) + (error "Missing interaction buffer mark"))) + (point (current-point))) + (if (mark< point (line-start mark 0)) + (begin + (if (not (group-end? mark)) + (editor-error "Can't copy: unfinished expression")) + (let ((start (backward-one-sexp (line-end point 0)))) + (if (not start) (editor-error "No previous expression")) + (let ((expression (extract-expression start))) + (set-current-point! mark) + (insert-string expression mark)))) + (let ((state (parse-partial-sexp mark (group-end mark)))) + (if (or (not (zero? (parse-state-depth state))) + (parse-state-in-string? state) + (parse-state-in-comment? state) + (parse-state-quoted? state)) + (editor-error "Imbalanced expression")) + (let ((last-sexp (parse-state-last-sexp state))) + (if (not last-sexp) + (editor-error "No expression")) + (extract-expression last-sexp)) + (set-current-point! (group-end point)))) + (dynamic-wind + (lambda () 'DONE) + (lambda () + (^G-interceptor (lambda ((continuation) value) + (newline) + (write-string "Abort!") + (continuation 'EXIT)) + (lambda () + (let ((environment (evaluation-environment #!FALSE))) + (with-output-to-current-point + (lambda () + (write-line (eval-with-history (with-input-from-mark mark + read) + environment)))))))) + insert-interaction-prompt)))) + +(define-command ("^R Interaction Refresh" argument) + "Delete the contents of the buffer, then prompt for input. +Preserves the current `editing area'." + (let ((buffer (current-buffer))) + (let ((edit-area + (extract-string (buffer-get buffer interaction-mode:buffer-mark-tag) + (buffer-end buffer)))) + (region-delete! (buffer-region buffer)) + (insert-interaction-prompt #!FALSE) + (insert-string edit-area)))) + +(define interaction-mode:yank-command-message + "Yank") + +(define-command ("^R Interaction Yank" argument) + "Yank the last input expression." + (push-current-mark! (mark-right-inserting (current-point))) + (insert-string (ring-ref (ref-variable "Interaction Kill Ring") 0)) + (set-command-message! interaction-mode:yank-command-message)) + +(define-command ("^R Interaction Yank Pop" argument) + "Yank the last input expression." + (command-message-receive interaction-mode:yank-command-message + (lambda () + (delete-string (pop-current-mark!) (current-point)) + (push-current-mark! (mark-right-inserting (current-point))) + (ring-pop! (ref-variable "Interaction Kill Ring")) + (insert-string (ring-ref (ref-variable "Interaction Kill Ring") 0)) + (set-command-message! interaction-mode:yank-command-message)) + (lambda () + (editor-error "No previous yank to replace")))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/keymap.scm b/v7/src/edwin/keymap.scm new file mode 100644 index 000000000..385e9716d --- /dev/null +++ b/v7/src/edwin/keymap.scm @@ -0,0 +1,94 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Command Summary + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Make Command Summary" argument) + "Make a summary of current key bindings in the buffer *Summary*. +Previous contents of that buffer are killed first." + (let ((buffer (temporary-buffer "*Summary*"))) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-keymap "" + ((access comtab-dispatch-alists comtab-package) + (car (mode-comtabs fundamental-mode)))))) + (select-buffer buffer) + (set-current-point! (buffer-start buffer)))) + +(define (write-keymap prefix da) + (for-each (lambda (element) + (write-string prefix) + (write-string (pad-on-right-to (char->name (car element)) 9)) + (write-string " ") + (write-string (command-name (cdr element))) + (newline)) + (sort-by-char (filter-uninteresting (cdr da)))) + (for-each (lambda (element) + (write-keymap (string-append prefix + (char->name (car element)) + " ") + (cdr element))) + (sort-by-char (car da)))) + +(define (uninteresting-element? element) + (or (char-lower-case? (char-base (car element))) + (let ((name (command-name (cdr element)))) + (or (string=? name "^R Insert Self") + (string=? name "^R Negative Argument") + (string=? name "^R Argument Digit") + (string=? name "^R Auto Negative Argument") + (string=? name "^R Autoargument Digit") + (string=? name "^R Autoargument"))))) + +(define filter-uninteresting + (negative-list-transformer uninteresting-element? '())) + +(define (sort-by-char elements) + (sort elements + (lambda (a b) + (char n 1) + (begin (ring-pop! ring) + (pop-loop (-1+ n))))) + (if (ring-empty? ring) (editor-error "Nothing to un-kill")) + (cond ((command-argument-multiplier-only?) + (unkill (ring-ref ring 0))) + ((positive? argument) + (pop-loop argument) + (unkill-reversed (ring-ref ring 0))))) + (set-command-message! un-kill-tag)) + +(define-command ("^R Un-kill Pop" (argument 1)) + "Correct after \\[^R Un-Kill] to use an earlier kill. +Requires that the region contain the most recent killed stuff, +as it does immediately after using \\[^R Un-Kill]. +It is deleted and replaced with the previous killed stuff, +which is rotated to the front of the kill ring. +With 0 as argument, just deletes the region with no replacement, +but the region must still match the last killed stuff." + (command-message-receive un-kill-tag + (lambda () + (let ((ring (current-kill-ring)) + (point (current-point))) + (if (or (ring-empty? ring) + (not (match-string (ring-ref ring 0) (current-mark) point))) + (editor-error "Region does not match last kill")) + (delete-string (pop-current-mark!) point) + (if (not (zero? argument)) + (begin (ring-pop! ring) + (unkill-reversed (ring-ref ring 0)))))) + (lambda () + (editor-error "No previous un-kill to replace"))) + (set-command-message! un-kill-tag)) + +;;;; Marks + +(define-variable "Mark Ring Maximum" + "The maximum number of marks that are saved on the mark ring. +This variable is only noticed when a buffer is created, so changing +it later will not affect existing buffers." + 16) + +(define-command ("^R Set/Pop Mark" argument) + "Sets or pops the mark. +With no C-U's, pushes point as the mark. +With one C-U, pops the mark into point. +With two C-U's, pops the mark and throws it away." + (let ((n (command-argument-multiplier-exponent))) + (cond ((zero? n) (push-current-mark! (current-point))) + ((= n 1) (set-current-point! (pop-current-mark!))) + ((= n 2) (pop-current-mark!)) + (else (editor-error))))) + +(define-command ("^R Mark Beginning" argument) + "Set mark at beginning of buffer." + (push-current-mark! (buffer-start (current-buffer)))) + +(define-command ("^R Mark End" argument) + "Set mark at end of buffer." + (push-current-mark! (buffer-end (current-buffer)))) + +(define-command ("^R Mark Whole Buffer" argument) + "Set point at beginning and mark at end of buffer. +Pushes the old point on the mark first, so two pops restore it. +With argument, puts point at end and mark at beginning." + (push-current-mark! (current-point)) + ((if (not argument) set-current-region! set-current-region-reversed!) + (buffer-region (current-buffer)))) + +(define-command ("^R Exchange Point and Mark" argument) + "Exchange positions of point and mark." + (let ((point (current-point)) + (mark (current-mark))) + (if (not mark) (editor-error "No mark to exchange")) + (set-current-point! mark) + (set-current-mark! point))) + +;;;; Q-Registers + +(define-command ("^R Get Q-reg" argument) + "Get contents of Q-reg (reads name from tty). +Usually leaves the pointer before, and the mark after, the text. +With argument, puts point after and mark before." + (not-implemented)) + +(define-command ("^R Put Q-reg" argument) + "Put point to mark into Q-reg (reads name from tty). +With an argument, the text is also deleted." + (not-implemented)) + +;;;; Transposition + +(define-command ("^R Transpose Characters" (argument 1)) + "Transpose the characters before and after the cursor. +With a positive argument it transposes the characters before and after +the cursor, moves right, and repeats the specified number of times, +dragging the character to the left of the cursor right. + +With a negative argument, it transposes the two characters to the left +of the cursor, moves between them, and repeats the specified number of +times, exactly undoing the positive argument form. + +With a zero argument, it transposes the characters at point and mark. + +At the end of a line, with no argument, the preceding two characters +are transposed." + (cond ((and (= argument 1) (line-end? (current-point))) + (twiddle-characters (mark-1+ (current-point) 'ERROR) + (current-point))) + ((positive? argument) + (twiddle-characters (current-point) + (mark+ (current-point) argument 'ERROR))) + ((negative? argument) + (twiddle-characters (current-point) + (mark- (current-point) (1+ (- argument)) 'ERROR))) + (else + (let ((m1 (mark-right-inserting (current-point))) + (m2 (mark-right-inserting (current-mark)))) + (let ((r1 (region-extract! + (make-region (current-point) + (mark1+ (current-point) 'ERROR)))) + (r2 (region-extract! + (make-region (current-mark) + (mark1+ (current-mark) 'ERROR))))) + (region-insert! m1 r2) + (region-insert! m2 r1)) + (set-current-point! m1) + (set-current-mark! m2))))) + +(define (twiddle-characters m1 m2) + (let ((m* (mark-left-inserting m2))) + (region-insert! m* (region-extract! (make-region (mark-1+ m1 'ERROR) m1))) + (set-current-point! m*))) + +(define-command ("^R Transpose Regions" argument) + "Transpose regions defined by point and last 3 marks. +To transpose two non-overlapping regions, set the mark successively at three +of the four boundaries, put point at the fourth, and call this function. +On return, the cursor and saved marks retain their original order, but are +adjusted to delineate the interchanged regions. Thus two consecutive +calls to this function will leave the buffer unchanged." + (not-implemented)) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/kmacro.scm b/v7/src/edwin/kmacro.scm new file mode 100644 index 000000000..d2ea8bab5 --- /dev/null +++ b/v7/src/edwin/kmacro.scm @@ -0,0 +1,258 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Keyboard Macros + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define *defining-keyboard-macro?* false) +(define *executing-keyboard-macro?* false) +(define *keyboard-macro-position*) +(define *keyboard-macro-continuation*) +(define last-keyboard-macro false) +(define keyboard-macro-buffer) +(define keyboard-macro-buffer-end) +(define named-keyboard-macros (make-string-table)) + +(define (with-keyboard-macro-disabled thunk) + (define old-executing) + (define old-defining) + (define new-executing false) + (define new-defining false) + (dynamic-wind (lambda () + (set! old-executing + (set! *executing-keyboard-macro?* + (set! new-executing))) + (set! old-defining + (set! *defining-keyboard-macro?* + (set! new-defining))) + (if (not (eq? old-defining *defining-keyboard-macro?*)) + (keyboard-macro-event))) + thunk + (lambda () + (set! new-executing + (set! *executing-keyboard-macro?* + (set! old-executing))) + (set! new-defining + (set! *defining-keyboard-macro?* + (set! old-defining))) + (if (not (eq? new-defining *defining-keyboard-macro?*)) + (keyboard-macro-event))))) + +(define (keyboard-macro-disable) + (set! *defining-keyboard-macro?* false) + (set! *executing-keyboard-macro?* false) + (keyboard-macro-event)) + +(define (keyboard-macro-event) + (window-modeline-event! (current-window) 'KEYBOARD-MACRO-EVENT)) + +(define (keyboard-macro-read-char) + (let ((char (keyboard-macro-peek-char))) + (set! *keyboard-macro-position* (cdr *keyboard-macro-position*)) + char)) + +(define (keyboard-macro-peek-char) + (if (null? *keyboard-macro-position*) + (*keyboard-macro-continuation* true) + (car *keyboard-macro-position*))) + +(define (keyboard-macro-write-char char) + (set! keyboard-macro-buffer (cons char keyboard-macro-buffer))) + +(define (keyboard-macro-finalize-chars) + (set! keyboard-macro-buffer-end keyboard-macro-buffer)) + +(define (keyboard-macro-execute macro repeat) + (fluid-let ((*executing-keyboard-macro?* true) + (*keyboard-macro-position*) + (*keyboard-macro-continuation*)) + (define (loop n) + (set! *keyboard-macro-position* macro) + (if (call-with-current-continuation + (lambda (c) + (set! *keyboard-macro-continuation* c) + (command-reader))) + (cond ((zero? n) (loop 0)) + ((> n 1) (loop (-1+ n)))))) + (if (not (negative? repeat)) (loop repeat)))) + +(define (keyboard-macro-define name macro) + (string-table-put! named-keyboard-macros name last-keyboard-macro) + (make-command name "Command defined by keyboard macro" + (lambda (#!optional argument) + (if (or (unassigned? argument) (not argument)) + (set! argument 1)) + (keyboard-macro-execute macro argument)))) + +(define-command ("Start Keyboard Macro" argument) + "Record subsequent keyboard input, defining a keyboard macro. +The commands are recorded even as they are executed. +Use \\[End Keyboard Macro] to finish recording and make the macro available. +Use \\[Name Last Keyboard Macro] to give it a permanent name. +With argument, append to last keyboard macro defined; + this begins by re-executing that macro as if you typed it again." + (if *defining-keyboard-macro?* + (editor-error "Already defining keyboard macro")) + (cond ((not argument) + (set! keyboard-macro-buffer '()) + (set! keyboard-macro-buffer-end '()) + (set! *defining-keyboard-macro?* true) + (keyboard-macro-event) + (message "Defining keyboard macro...")) + ((not last-keyboard-macro) + (editor-error "No keyboard macro has been defined")) + (else + (set! *defining-keyboard-macro?* true) + (keyboard-macro-event) + (message "Appending to keyboard macro...") + (keyboard-macro-execute last-keyboard-macro 1)))) + +(define-command ("End Keyboard Macro" (argument 1)) + "Finish defining a keyboard macro. +The definition was started by \\[Start Keyboard Macro]. +The macro is now available for use via \\[Call Last Keyboard Macro], + or it can be given a name with \\[Name Last Keyboard Macro] and then invoked + under that name. +With numeric argument, repeat macro now that many times, + counting the definition just completed as the first repetition." + (if *defining-keyboard-macro?* + (begin (set! *defining-keyboard-macro?* false) + (keyboard-macro-event) + (set! last-keyboard-macro (reverse keyboard-macro-buffer-end)) + (message "Keyboard macro defined"))) + (cond ((zero? argument) + (keyboard-macro-execute last-keyboard-macro 0)) + ((> argument 1) + (keyboard-macro-execute last-keyboard-macro (-1+ argument))))) + +(define-command ("Call Last Keyboard Macro" (argument 1)) + "Call the last keyboard macro that you defined with \\[Start Keyboard Macro]. +To make a macro permanent so you can call it even after + defining others, use \\[Name Last Keyboard Macro]." + (if *defining-keyboard-macro?* + (editor-error "Can execute anonymous macro while defining one.")) + (if (not last-keyboard-macro) + (editor-error "No keyboard macro has been defined")) + (keyboard-macro-execute last-keyboard-macro argument)) + +(define-command ("Name Last Keyboard Macro" argument) + "Assign a name to the last keyboard macro defined." + (if *defining-keyboard-macro?* + (editor-error "Can't name a keyboard macro while defining one.")) + (if (not last-keyboard-macro) + (editor-error "No keyboard macro has been defined")) + (keyboard-macro-define (prompt-for-string "Name last keyboard macro" false) + last-keyboard-macro)) + +(define-command ("Write Keyboard Macro" argument) + "Save keyboard macro in file. +Use LOAD to load the file. +With argument, also record the keys it is bound to." + (let ((name (prompt-for-completed-string "Write keyboard macro" + false 'NO-DEFAULT + named-keyboard-macros + 'STRICT-COMPLETION))) + (let ((pathname (prompt-for-pathname (string-append "Write keyboard macro " + name + " to file") + (current-default-pathname))) + (buffer (temporary-buffer "*Write-Keyboard-Macro-temp*"))) + (with-output-to-mark (buffer-point buffer) + (lambda () + (write-string "(IN-PACKAGE EDWIN-PACKAGE") + (newline) (write-string " (KEYBOARD-MACRO-DEFINE ") (write name) + (newline) (write-string " '") + (write (string-table-get named-keyboard-macros name)) + (write-string ")") + (if argument + (for-each (lambda (key) + (newline) + (write-string " (DEFINE-KEY \"Fundamental\" '") + (write key) + (write-string " ") + (write name) + (write-string ")")) + (comtab-key-bindings (mode-comtabs fundamental-mode) + (name->command name)))) + (newline) (write-string ")"))) + (set-buffer-pathname! buffer pathname) + (write-buffer buffer) + (kill-buffer buffer)))) + +(define-command ("Keyboard Macro Query" argument) + "Query user during keyboard macro execution. +With prefix argument, enters recursive edit, + reading keyboard commands even within a keyboard macro. + You can give different commands each time the macro executes. +Without argument, reads a character. Your options are: + Space -- execute the rest of the macro. + Rubout -- skip the rest of the macro; start next repetition. + C-D -- skip the rest of the macro and don't repeat it any more. + C-R -- Enter a recursive edit, then on exit ask again for a character + C-L -- redisplay screen and ask again." + (define (loop) + (let ((char (with-keyboard-macro-disabled + (lambda () + (set-command-prompt! + "Proceed with macro? (Space, Rubout, C-D, C-R or C-L)") + (char-upcase (keyboard-read-char)))))) + (cond ((char=? char #\Space)) + ((char=? char #\Rubout) + (*keyboard-macro-continuation* true)) + ((char=? char #\C-D) + (*keyboard-macro-continuation* false)) + ((char=? char #\C-R) + (with-keyboard-macro-disabled enter-recursive-edit) + (loop)) + ((or (char=? char #\C-L) (char=? char #\Page)) + (window-redraw! (current-window) false) + (loop)) + (else + (beep) + (loop))))) + (cond (argument (with-keyboard-macro-disabled enter-recursive-edit)) + (*executing-keyboard-macro?* (loop)))) + +;;; end USING-SYNTAX +) +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/lincom.scm b/v7/src/edwin/lincom.scm new file mode 100644 index 000000000..6ad6f7751 --- /dev/null +++ b/v7/src/edwin/lincom.scm @@ -0,0 +1,418 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Line/Indentation Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +;;;; Lines + +(define-command ("^R Count Lines Region" argument) + "Type number of lines from point to mark." + (message "Region has " + (write-to-string (region-count-lines (current-region))) + " lines")) + +(define-command ("^R Transpose Lines" (argument 1)) + "Transpose the lines before and after the cursor. +With a positive argument it transposes the lines before and after the +cursor, moves right, and repeats the specified number of times, +dragging the line to the left of the cursor right. + +With a negative argument, it transposes the two lines to the left of +the cursor, moves between them, and repeats the specified number of +times, exactly undoing the positive argument form. + +With a zero argument, it transposes the lines at point and mark. + +At the end of a buffer, with no argument, the preceding two lines are +transposed." + + (cond ((and (= argument 1) (group-end? (current-point))) + (if (not (line-start? (current-point))) + (insert-newlines 1)) + (let ((region + (region-extract! + (make-region (forward-line (current-point) -2 'ERROR) + (forward-line (current-point) -1 'ERROR))))) + (region-insert! (current-point) region))) + (else + (transpose-things forward-line argument)))) + +;;;; Pages + +(define-command ("^R Next Page" (argument 1)) + "Move forward to page boundary. With arg, repeat, or go back if negative. +A page boundary is any string in Page Delimiters, at a line's beginning." + (set-current-point! (forward-page (current-point) argument 'BEEP))) + +(define-command ("^R Previous Page" (argument 1)) + "Move backward to page boundary. With arg, repeat, or go fwd if negative. +A page boundary is any string in Page Delimiters, at a line's beginning." + (set-current-point! (backward-page (current-point) argument 'BEEP))) + +(define-command ("^R Mark Page" (argument 0)) + "Put mark at end of page, point at beginning." + (let ((end (forward-page (current-point) (1+ argument) 'LIMIT))) + (set-current-region! (make-region (backward-page end 1 'LIMIT) end)))) + +(define-command ("^R Narrow Bounds to Page" argument) + "Make text outside current page invisible." + (region-clip! (page-interior-region (current-point)))) + +(define (page-interior-region point) + (if (and (group-end? point) + (mark= (re-match-forward (ref-variable "Page Delimiter") + (line-start point 0) + point) + point)) + (make-region point point) + (let ((end (forward-page point 1 'LIMIT))) + (make-region (backward-page end 1 'LIMIT) + (let ((end* (line-end end -1 'LIMIT))) + (if (mark< end* point) + end + end*)))))) + +(define-command ("^R Count Lines Page" argument) + "Report number of lines on current page." + (let ((point (current-point))) + (let ((end + (let ((end (forward-page point 1 'LIMIT))) + (if (group-end? end) end (line-start end 0))))) + (let ((start (backward-page end 1 'LIMIT))) + (message "Page has " (count-lines-string start end) + " lines (" (count-lines-string start point) + "+" (count-lines-string point end) ")"))))) + +(define (count-lines-string start end) + (write-to-string (region-count-lines (make-region start end)))) + +(define-command ("What Page" argument) + "Report page and line number of point." + (without-group-clipped! (buffer-group (current-buffer)) + (lambda () + (message "Page " (write-to-string (current-page)) + ", Line " (write-to-string (current-line)))))) + +(define (current-page) + (region-count-pages (make-region (buffer-start (current-buffer)) + (current-point)))) + +(define (current-line) + (region-count-lines + (make-region (backward-page (forward-page (current-point) 1 'LIMIT) + 1 'LIMIT) + (current-point)))) + +(define (region-count-pages region) + (let ((end (region-end region))) + (define (loop count start) + (if (or (not start) (mark> start end)) + count + (loop (1+ count) (forward-page start 1)))) + (loop 0 (region-start region)))) + +;;;; Indentation + +(define (indent-to-left-margin argument) + (maybe-change-indentation (ref-variable "Left Margin") + (line-start (current-point) 0))) + +(define-variable "Indent Line Procedure" + "Procedure used to indent current line. +If this is the procedure INDENT-TO-LEFT-MARGIN, +\\[^R Indent for Tab] will insert tab characters rather than indenting." + indent-to-left-margin) + +(define-command ("^R Indent According to Mode" argument) + "Indent line in proper way for current major mode. +The exact behavior of this command is determined +by the variable Indent Line Procedure." + ((ref-variable "Indent Line Procedure") argument)) + +(define-command ("^R Indent for Tab" argument) + "Indent line in proper way for current major mode. +The exact behavior of this command is determined +by the variable Indent Line Procedure." + (if (eq? (ref-variable "Indent Line Procedure") indent-to-left-margin) + (insert-chars #\Tab (or argument 1)) + ((ref-variable "Indent Line Procedure") argument))) + +(define-command ("^R Tab" (argument 1)) + "Insert a tab character." + (insert-chars #\Tab argument)) + +(define-command ("^R Indent New Line" argument) + "Inserts newline, then indents the second line. +Any spaces before the inserted newline are deleted. +Uses Indent Line Procedure to do the indentation, +except that if there is a Fill Prefix it is used to indent. +An argument is passed on to Indent Line Procedure." + (delete-horizontal-space) + (^r-newline-command) + (if (ref-variable "Fill Prefix") + (region-insert-string! (current-point) (ref-variable "Fill Prefix")) + (^r-indent-according-to-mode-command argument))) + +(define-command ("Reindent then Newline and Indent" argument) + "Reindent the current line according to mode (like Tab), then insert +a newline, and indent the new line indent according to mode." + (delete-horizontal-space) + (^r-indent-according-to-mode-command #!FALSE) + (^r-newline-command) + (^r-indent-according-to-mode-command #!FALSE)) + +(define-command ("^R Newline" argument) + "Insert newline, or move onto blank line. +A blank line is one containing only spaces and tabs +\(which are killed if we move onto it). Single blank lines +\(followed by nonblank lines) are not eaten up this way. +An argument inhibits this." + (cond ((not argument) + (if (line-end? (current-point)) + (let ((m1 (line-start (current-point) 1))) + (if (and m1 (line-blank? m1) + (let ((m2 (line-start m1 1))) + (and m2 (line-blank? m2)))) + (begin (set-current-point! m1) + (delete-horizontal-space)) + (insert-newlines 1))) + (insert-newlines 1))) + (else + (insert-newlines argument)))) + +(define-command ("^R Split Line" (argument 1)) + "Move rest of this line vertically down. +Inserts a newline, and then enough tabs/spaces so that +what had been the rest of the current line is indented as much as +it had been. Point does not move, except to skip over indentation +that originally followed it. +With argument, makes extra blank lines in between." + (set-current-point! (horizontal-space-end (current-point))) + (let ((m* (mark-right-inserting (current-point)))) + (insert-newlines (max argument 1)) + (insert-horizontal-space (mark-column m*)) + (set-current-point! m*))) + +(define-command ("^R Back to Indentation" argument) + "Move to end of this line's indentation." + (set-current-point! (horizontal-space-end (line-start (current-point) 0)))) + +(define-command ("^R Delete Horizontal Space" argument) + "Delete all spaces and tabs around point." + (delete-horizontal-space)) + +(define-command ("^R Just One Space" argument) + "Delete all spaces and tabs around point, leaving just one space." + (delete-horizontal-space) + (insert-chars #\Space 1)) + +(define-command ("^R Delete Blank Lines" argument) + "Kill all blank lines around this line's end. +If done on a non-blank line, kills all spaces and tabs at the end of +it, and all following blank lines (Lines are blank if they contain +only spaces and tabs). +If done on a blank line, deletes all preceding blank lines as well." + (define (find-first-blank m1) + (let ((m2 (line-start m1 -1))) + (cond ((not m2) m1) + ((not (line-blank? m2)) m1) + (else (find-first-blank m2))))) + (define (find-last-blank m1) + (let ((m2 (line-start m1 1))) + (cond ((not m2) m1) + ((not (line-blank? m2)) m1) + (else (find-last-blank m2))))) + (region-delete! + (let ((point (current-point))) + (make-region (if (line-blank? point) + (find-first-blank (line-start point 0)) + (horizontal-space-start (line-end point 0))) + (line-end (find-last-blank point) 0))))) + +(define-command ("^R Delete Indentation" argument) + "Kill newline and indentation at front of line. +Leaves one space in place of them. With argument, +moves down one line first (killing newline after current line)." + (set-current-point! + (horizontal-space-start + (line-end (current-point) (if (not argument) -1 0) 'ERROR))) + (let ((point (current-point))) + (region-delete! (make-region point (line-start point 1 'ERROR))) + (if fill-prefix + (let ((match (match-forward fill-prefix))) + (if match (delete-string match)))) + (delete-horizontal-space) + (if (or (line-start? point) + (line-end? point) + (not (or (char-set-member? delete-indentation-right-protected + (mark-left-char point)) + (char-set-member? delete-indentation-left-protected + (mark-right-char point))))) + (insert-chars #\Space 1)))) + +(define-variable "Delete Indentation Right Protected" + "^R Delete Indentation won't insert a space to the right of these." + (char-set #\( #\,)) + +(define-variable "Delete Indentation Left Protected" + "^R Delete Indentation won't insert a space to the left of these." + (char-set #\))) + +(define-variable "Indent Tabs Mode" + "If #!FALSE, do not use tabs for indentation or horizontal spacing." + #!TRUE) + +(define-command ("Indent Tabs Mode" argument) + "Enables or disables use of tabs as indentation. +A positive argument turns use of tabs on; +zero or negative, turns it off. +With no argument, the mode is toggled." + (set! indent-tabs-mode + (if argument + (positive? argument) + (not indent-tabs-mode)))) + +(define-command ("^R Indent Region" argument) + "Indent all lines between point and mark. +With argument, indents each line to exactly that column. +Otherwise, does Tab on each line. +A line is processed if its first character is in the region. +The mark is left after the last line processed." + (cond ((not argument) (not-implemented)) + ((not (negative? argument)) + (current-region-of-lines + (lambda (start end) + (define (loop mark) + (change-indentation argument mark) + (if (not (mark= mark end)) + (loop (mark-right-inserting (line-start mark 1))))) + (loop start)))))) + +(define-command ("^R Indent Rigidly" argument) + "Shift text in region sideways as a unit. +All the lines in the region (first character between point and mark) +have their indentation incremented by the numeric argument +of this command (which may be negative). +Exception: lines containing just spaces and tabs become empty." + (if argument + (current-region-of-lines + (lambda (start end) + (define (loop mark) + (if (line-blank? mark) + (delete-horizontal-space mark) + (change-indentation (max (+ argument (current-indentation mark)) + 0) + mark)) + (if (not (mark= mark end)) + (loop (mark-right-inserting (line-start mark 1))))) + (loop start))))) + +(define (current-region-of-lines receiver) + (let ((r (current-region))) + (let ((start (mark-right-inserting (line-start (region-start r) 0)))) + (receiver start + (if (mark= start (line-start (region-end r) 0)) + start + (mark-right-inserting + (line-start (region-end r) + (if (line-start? (region-end r)) -1 0)))))))) + +(define-variable "Tab Width" + "Distance between tab stops (for display of tab characters), in columns." + 8) + +(define-command ("Untabify" argument) + "Convert all tabs in region to multiple spaces, preserving column. +The variable Tabs Width controls action." + (untabify-region (current-region))) + +(define (untabify-region region) + (let ((end (region-end region))) + (define (loop start) + (if (char-search-forward #\Tab start end) + (let ((tab (re-match-start 0)) + (next (mark-left-inserting (re-match-end 0)))) + (let ((n-spaces (- (mark-column next) (mark-column tab)))) + (delete-string tab next) + (insert-chars #\Space n-spaces next)) + (loop next)))) + (loop (region-start region)))) + +(define-command ("Tabify" argument) + "" + (not-implemented)) + +(define-command ("^R Indent Relative" argument) + "Indents the current line directly below the previous non blank line." + (let ((point (current-point))) + (let ((indentation (indentation-of-previous-non-blank-line point))) + (cond ((not (= indentation (current-indentation point))) + (change-indentation indentation point)) + ((line-start? (horizontal-space-start point)) + (set-current-point! (horizontal-space-end point))))))) + +(define (indentation-of-previous-non-blank-line mark) + (let ((start (find-previous-non-blank-line mark))) + (if start (current-indentation start) 0))) + +(define-command ("^R Tab to Tab Stop" argument) + "" + (not-implemented)) + +(define-command ("Edit Indented Text" argument) + "" + (not-implemented)) + +(define-command ("Edit Tab Stops" argument) + "" + (not-implemented)) + +(define-command ("Edit Tabular Text" argument) + "" + (not-implemented)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/linden.scm b/v7/src/edwin/linden.scm new file mode 100644 index 000000000..43d1793e9 --- /dev/null +++ b/v7/src/edwin/linden.scm @@ -0,0 +1,367 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Lisp Indentation + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define lisp-indentation-package + (make-environment + +;;; CALCULATE-LISP-INDENTATION returns either an integer, which is the +;;; column to indent to, or a pair. In the latter case this means +;;; that subsequent forms in the same expression may not be indented +;;; the same way; so the car is the indentation, and the cdr is a mark +;;; pointing at the beginning of the containing expression. Typically +;;; this is passed back in as PARSE-START to speed up the indentation +;;; of many forms at once. + +(define (calculate-lisp-indentation mark #!optional parse-start) + (if (unassigned? parse-start) + (set! parse-start + (or (backward-one-definition-start mark) + (group-start mark)))) + (find-outer-container parse-start (line-start mark 0))) + +(define (find-outer-container start indent-point) + (let ((state (parse-partial-sexp start indent-point 0))) + (if (mark= (parse-state-location state) indent-point) + (find-inner-container state #!FALSE #!FALSE indent-point) + (find-outer-container (parse-state-location state) indent-point)))) + +(define (find-inner-container state container last-sexp indent-point) + (if (<= (parse-state-depth state) 0) + (simple-indent state container last-sexp indent-point) + (let ((container (parse-state-containing-sexp state)) + (last-sexp (parse-state-last-sexp state))) + (let ((after-opener (mark1+ container))) + (if (and last-sexp (mark> last-sexp after-opener)) + (let ((peek (parse-partial-sexp last-sexp indent-point 0))) + (if (not (parse-state-containing-sexp peek)) + (simple-indent state container last-sexp indent-point) + (find-inner-container peek container last-sexp + indent-point))) + (simple-indent state container last-sexp indent-point)))))) + +(define (simple-indent state container last-sexp indent-point) + (cond ((parse-state-in-string? state) + (mark-column (horizontal-space-end indent-point))) + ((and (integer? (ref-variable "Lisp Indent Offset")) container) + (+ (ref-variable "Lisp Indent Offset") (mark-column container))) + ((positive? (parse-state-depth state)) + (if (not last-sexp) + (mark-column (mark1+ container)) + (normal-indent state container last-sexp indent-point))) + (else + (mark-column (parse-state-location state))))) + +;;; +;;; The following are true when the indent hook is called: +;;; +;;; * CONTAINER < NORMAL-INDENT <= LAST-SEXP < INDENT-POINT +;;; * Since INDENT-POINT is a line start, LAST-SEXP is on a +;;; line previous to that line. +;;; * NORMAL-INDENT is at the start of an expression. +;;; + +(define (normal-indent state container last-sexp indent-point) + (let ((first-sexp (forward-to-sexp-start (mark1+ container) last-sexp))) + (let ((normal-indent + (if (mark> (line-end container 0) last-sexp) + ;; CONTAINER and LAST-SEXP are on same line. + ;; If FIRST-SEXP = LAST-SEXP, indent under that, else + ;; indent under the second expression on that line. + (if (mark= first-sexp last-sexp) + last-sexp + (forward-to-sexp-start (forward-one-sexp first-sexp) + last-sexp)) + ;; LAST-SEXP is on subsequent line -- indent under the + ;; first expression on that line. + (forward-to-sexp-start (line-start last-sexp 0) last-sexp)))) + (if (char=? #\( (char->syntax-code (mark-right-char first-sexp))) + ;; The first expression is a list -- don't bother to call + ;; the indent hook. + (mark-column (backward-prefix-chars normal-indent)) + (let ((normal-indent (backward-prefix-chars normal-indent))) + (or (and (ref-variable "Lisp Indent Hook") + ((ref-variable "Lisp Indent Hook") + state indent-point normal-indent)) + (mark-column normal-indent))))))) + +;;;; Indent Hook + +;;; Look at the first expression in the containing expression, and if +;;; it is an atom, look it up in the Lisp Indent Methods table. Three +;;; types of entry are recognized: +;;; +;;; 'DEFINITION means treat this form as a definition. +;;; means treat this form as a special form. +;;; Otherwise, the entry must be a procedure, which is called. + +(define (standard-lisp-indent-hook state indent-point normal-indent) + (let ((first-sexp + (forward-to-sexp-start (mark1+ (parse-state-containing-sexp state)) + indent-point))) + (and (let ((syntax (char->syntax-code (mark-right-char first-sexp)))) + (or (char=? #\w syntax) + (char=? #\_ syntax))) + (let ((name (extract-string first-sexp + (forward-one-sexp first-sexp)))) + (let ((method + (string-table-get (ref-variable "Lisp Indent Methods") + name))) + (cond ((or (eq? method 'DEFINITION) + (and (not method) + (<= 3 (string-length name)) + (substring-ci=? "DEF" 0 3 name 0 3))) + (lisp-indent-definition state indent-point normal-indent)) + ((integer? method) + (lisp-indent-special-form method state indent-point + normal-indent)) + (method + (method state indent-point normal-indent)))))))) + +;;; Indent the first subform in a definition at the body indent. +;;; Indent subsequent subforms normally. + +(define (lisp-indent-definition state indent-point normal-indent) + (let ((container (parse-state-containing-sexp state))) + (and (mark> (line-end container 0) (parse-state-last-sexp state)) + (+ (ref-variable "Lisp Body Indent") (mark-column container))))) + +;;; Indent the first N subforms normally, but then indent the +;;; remaining forms at the body-indent. If this is one of the first +;;; N, a cons is returned, the cdr of which is CONTAINING-SEXP. This +;;; is to speed up indentation of successive forms. + +(define (lisp-indent-special-form n state indent-point normal-indent) + (if (negative? n) (error "Special form indent hook negative" n)) + (let ((container (parse-state-containing-sexp state))) + (let ((body-indent (+ (ref-variable "Lisp Body Indent") + (mark-column container))) + (normal-indent (mark-column normal-indent))) + (define (loop n mark) + (cond ((not mark) + (cons normal-indent container)) + ((zero? n) + (if (forward-one-sexp mark indent-point) + normal-indent + (min body-indent normal-indent))) + (else + (loop (-1+ n) (forward-one-sexp mark indent-point))))) + (let ((second-sexp + (forward-to-sexp-start (forward-one-sexp (mark1+ container) + indent-point) + indent-point))) + (cond ((mark< second-sexp indent-point) (loop n second-sexp)) + ((zero? n) body-indent) + (else (cons normal-indent container))))))) + +;;;; Indent Line + +(define (lisp-indent-line whole-sexp?) + (let ((start (indentation-end (current-point)))) + (if (not (match-forward ";;;" start)) + (let ((indentation + (let ((indent (calculate-lisp-indentation start))) + (if (pair? indent) (car indent) indent)))) + (let ((shift-amount (- indentation (mark-column start)))) + (cond ((not (zero? shift-amount)) + (change-indentation indentation start) + (if whole-sexp? + (indent-code-rigidly start (forward-sexp start 1 'ERROR) + shift-amount #!FALSE))) + ((within-indentation? (current-point)) + (set-current-point! start)))))))) + +(define (indent-code-rigidly start end shift-amount nochange-regexp) + (let ((end (mark-left-inserting end))) + (define (phi1 start state) + (let ((start* (line-start start 1 'LIMIT))) + (if (mark< start* end) + (phi2 start* + (parse-partial-sexp start start* #!FALSE #!FALSE state))))) + + (define (phi2 start state) + (if (not (or (parse-state-in-string? state) + (parse-state-in-comment? state) + (and nochange-regexp + (re-match-forward nochange-regexp start)))) + (let ((start (horizontal-space-end start)) + (end (line-end start 0))) + (cond ((line-end? start) (delete-horizontal-space start)) + ((match-forward ";;;" start) 'DONE) + (else + (change-indentation (max 0 + (+ (mark-column start) + shift-amount)) + start))))) + (phi1 start state)) + + (phi1 start #!FALSE))) + +;;;; Indent Expression + +(define (lisp-indent-sexp point) + (let ((end (mark-permanent! (line-start (forward-sexp point 1 'ERROR) 0)))) + (define (loop start indent-stack) + (next-line-start start #!FALSE + (lambda (start state) + (let ((indent-stack (adjust-stack (parse-state-depth state) + indent-stack))) + (cond ((mark= start end) + (if (not (or (parse-state-in-string? state) + (parse-state-in-comment? state))) + (indent-expression-line start indent-stack))) + ((indent-comment-line start indent-stack) + (loop start indent-stack)) + ((line-blank? start) + (delete-horizontal-space start) + (loop start indent-stack)) + (else + (indent-expression-line start indent-stack) + (loop start indent-stack))))))) + + (define (next-line-start start state receiver) + (let ((start* (line-start start 1))) + (let ((state* (parse-partial-sexp start start* #!FALSE #!FALSE state))) + (if (or (not (or (parse-state-in-string? state*) + (parse-state-in-comment? state*))) + (mark= start* end)) + (receiver start* state*) + (next-line-start start* state* receiver))))) + + (if (mark< point end) (loop point '())))) + +(define (indent-comment-line start indent-stack) + (let ((mark (horizontal-space-end start))) + (and (match-forward ";" mark) + (begin (maybe-change-indentation + (cond ((match-forward ";;;" mark) + (mark-column mark)) + ((match-forward ";;" mark) + (compute-indentation start indent-stack)) + (else comment-column)) + mark) + #!TRUE)))) + +(define (indent-expression-line start indent-stack) + (maybe-change-indentation (compute-indentation start indent-stack) + start)) + +(define (compute-indentation start indent-stack) + (cond ((null? indent-stack) + (let ((indent (calculate-lisp-indentation start))) + (if (pair? indent) + (car indent) + indent))) + ((and (car indent-stack) + (integer? (car indent-stack))) + (car indent-stack)) + (else + (let ((indent + (calculate-lisp-indentation + start + (or (car indent-stack) + (backward-one-definition-start start) + (group-start start))))) + (if (pair? indent) + (begin (set-car! indent-stack (cdr indent)) + (car indent)) + (begin (set-car! indent-stack indent) + indent)))))) + +(define (adjust-stack depth-delta indent-stack) + (cond ((zero? depth-delta) indent-stack) + ((positive? depth-delta) (up-stack depth-delta indent-stack)) + (else (down-stack depth-delta indent-stack)))) + +(define (down-stack n stack) + (if (= -1 n) + (cdr stack) + (down-stack (1+ n) (cdr stack)))) + +(define (up-stack n stack) + (if (= 1 n) + (cons #!FALSE stack) + (up-stack (-1+ n) (cons #!FALSE stack)))) + +;;;; Indent Comment + +(define (lisp-comment-locate mark) + (and (re-search-forward ";+[ \t]*" mark (line-end mark 0)) + (cons (re-match-start 0) (re-match-end 0)))) + +(define (lisp-comment-indentation mark) + (cond ((match-forward ";;;" mark) + 0) + ((match-forward ";;" mark) + (let ((indentation (calculate-lisp-indentation mark))) + (if (pair? indentation) (car indentation) indentation))) + (else + (max (1+ (mark-column (horizontal-space-start mark))) + comment-column)))) + +;;; end LISP-INDENTATION-PACKAGE +)) + +;;;; Control Variables + +(define-variable "Lisp Indent Offset" + "If not false, the number of extra columns to indent a subform." + #!FALSE) + +(define-variable "Lisp Indent Hook" + "If not false, a procedure for modifying lisp indentation." + #!FALSE) + +(define-variable "Lisp Indent Methods" + "String table identifying special forms for lisp indentation.") + +(define-variable "Lisp Body Indent" + "Number of extra columns to indent the body of a special form." + 2) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access lisp-indentation-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/lspcom.scm b/v7/src/edwin/lspcom.scm new file mode 100644 index 000000000..cea6c3207 --- /dev/null +++ b/v7/src/edwin/lspcom.scm @@ -0,0 +1,232 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Lisp Commands + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +;;;; S-expression Commands + +(define-command ("^R Forward Sexp" (argument 1)) + "Move forward across one balanced expression. +With argument, do this that many times." + (move-thing forward-sexp argument)) + +(define-command ("^R Backward Sexp" (argument 1)) + "Move backward across one balanced expression. +With argument, do this that many times." + (move-thing backward-sexp argument)) + +(define-command ("^R Flash Forward Sexp" (argument 1)) + "Flash the char which ends the expression to the right of point. +Shows you where \\[^R Forward Sexp] would go." + (mark-flash (forward-sexp (current-point) argument) + (if (negative? argument) 'RIGHT 'LEFT))) + +(define-command ("^R Flash Backward Sexp" (argument 1)) + "Flash the char which starts the expression to the left of point. +Shows you where \\[^R Backward Sexp] would go." + (mark-flash (backward-sexp (current-point) argument) + (if (negative? argument) 'LEFT 'RIGHT))) + +(define-command ("^R Kill Sexp" (argument 1)) + "Kill the syntactic expression following the cursor. +With argument, kill that many expressions after (or before) the cursor." + (kill-thing forward-sexp argument)) + +(define-command ("^R Backward Kill Sexp" (argument 1)) + "Kill the syntactic expression preceding the cursor. +With argument, kill that many expressions before (or after) the cursor." + (kill-thing backward-sexp argument)) + +(define-command ("^R Transpose Sexps" (argument 1)) + "Transpose the sexps before and after point. +See ^R Transpose Words, reading 'sexp' for 'word'." + (transpose-things forward-sexp argument)) + +(define-command ("^R Mark Sexp" (argument 1)) + "Mark one or more sexps from point." + (mark-thing forward-sexp argument)) + +;;;; List Commands + +(define-command ("^R Forward List" (argument 1)) + "Move forward across one balanced group of parentheses. +With argument, do this that many times." + (move-thing forward-list argument)) + +(define-command ("^R Backward List" (argument 1)) + "Move backward across one balanced group of parentheses. +With argument, do this that many times." + (move-thing backward-list argument)) + +(define-command ("^R Forward Down List" (argument 1)) + "Move forward down one level of parentheses. +With argument, do this that many times. +A negative argument means move backward but still go down a level." + (move-thing forward-down-list argument)) + +(define-command ("^R Backward Down List" (argument 1)) + "Move backward down one level of parentheses. +With argument, do this that many times. +A negative argument means move forward but still go down a level." + (move-thing backward-down-list argument)) + +(define-command ("^R Forward Up List" (argument 1)) + "Move forward out one level of parentheses. +With argument, do this that many times. +A negative argument means move backward but still to a less deep spot." + (move-thing forward-up-list argument)) + +(define-command ("^R Backward Up List" (argument 1)) + "Move backward out one level of parentheses. +With argument, do this that many times. +A negative argument means move forward but still to a less deep spot." + (move-thing backward-up-list argument)) + +;;;; Definition Commands + +(define-command ("^R Beginning of Definition" (argument 1)) + "Move to beginning of this or previous definition. +Leaves the mark behind, in case typed by accident. +With a negative argument, moves forward to the beginning of a definition. +The beginning of a definition is determined by Definition Start." + (move-thing backward-definition-start argument)) + +(define-command ("^R End of Definition" (argument 1)) + "Move to end of this or next definition. +Leaves the mark behind, in case typed by accident. +With argument of 2, finds end of following definition. +With argument of -1, finds end of previous definition, etc." + (move-thing forward-definition-end (if (zero? argument) 1 argument))) + +(define-command ("^R Mark Definition" argument) + "Put mark at end of definition, point at beginning." + (let ((point (current-point))) + (let ((end (forward-definition-end point 1 'ERROR))) + (let ((start (backward-definition-start end 1 'ERROR))) + (push-current-mark! point) + (push-current-mark! end) + (set-current-point! + (or (re-search-backward "^\n" start (mark-1+ start)) + start)))))) + +(define-command ("^R Reposition Window" argument) + "Reposition window so current definition is at the top. +If this would place point off screen, nothing happens." + (reposition-window-top (current-definition-start))) + +(define (current-definition-start) + (let ((point (current-point))) + (if (definition-start? point) + point + (backward-definition-start point 1 'ERROR)))) + +;;;; Miscellaneous Commands + +(define-command ("^R Lisp Insert Paren" (argument 1)) + "Insert one or more close parens, flashing the matching open paren." + (insert-chars (current-command-char) argument) + (if (positive? argument) + (let ((point (current-point))) + (if (and (not (mark-left-char-quoted? point)) + (not (keyboard-active? 5))) + (mark-flash (backward-one-sexp point) 'RIGHT))))) + +(define-command ("^R Indent for Lisp" argument) + "Indent current line as lisp code. +With argument, indent any additional lines of the same expression +rigidly along with this one." + ((access lisp-indent-line lisp-indentation-package) argument)) + +(define-command ("^R Indent Sexp" argument) + "Indent each line of the expression starting just after the point." + ((access lisp-indent-sexp lisp-indentation-package) (current-point))) + +;;;; Motion Covers + +(define forward-sexp) +(define backward-sexp) +(make-motion-pair forward-one-sexp backward-one-sexp + (lambda (f b) + (set! forward-sexp f) + (set! backward-sexp b))) + +(define forward-list) +(define backward-list) +(make-motion-pair forward-one-list backward-one-list + (lambda (f b) + (set! forward-list f) + (set! backward-list b))) + +(define forward-down-list) +(define backward-down-list) +(make-motion-pair forward-down-one-list backward-down-one-list + (lambda (f b) + (set! forward-down-list f) + (set! backward-down-list b))) + +(define forward-up-list) +(define backward-up-list) +(make-motion-pair forward-up-one-list backward-up-one-list + (lambda (f b) + (set! forward-up-list f) + (set! backward-up-list b))) + +(define forward-definition-start) +(define backward-definition-start) +(make-motion-pair forward-one-definition-start backward-one-definition-start + (lambda (f b) + (set! forward-definition-start f) + (set! backward-definition-start b))) + +(define forward-definition-end) +(define backward-definition-end) +(make-motion-pair forward-one-definition-end backward-one-definition-end + (lambda (f b) + (set! forward-definition-end f) + (set! backward-definition-end b))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm new file mode 100644 index 000000000..dfbc77db7 --- /dev/null +++ b/v7/src/edwin/macros.scm @@ -0,0 +1,206 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Editor Macros + +(declare (usual-integrations)) + +(define edwin-syntax-table + (make-syntax-table system-global-syntax-table)) + +(define edwin-macros + (make-environment + +;;; DEFINE-NAMED-STRUCTURE is a simple alternative to DEFSTRUCT, +;;; which defines a vector-based tagged data structure. The first +;;; argument is a string, which will be stored in the structure's 0th +;;; slot. The remaining arguments are symbols, which should be the +;;; names of the slots. Do not use the slot names %TAG or %SIZE. + +(syntax-table-define edwin-syntax-table 'DEFINE-NAMED-STRUCTURE + (macro (name . slots) + (define ((make-symbols x) y) + (make-symbol x y)) + + (define (make-symbol . args) + (string->symbol (apply string-append args))) + + (let ((structure-string (string-upcase name)) + (slot-strings (map symbol->string slots))) + (let ((prefix (string-append structure-string "-"))) + (let ((structure-name (string->symbol structure-string)) + (tag-name (make-symbol "%" prefix "TAG")) + (constructor-name (make-symbol "%MAKE-" structure-string)) + (predicate-name (make-symbol structure-string "?")) + (slot-names + (map (make-symbols (string-append prefix "INDEX:")) + slot-strings)) + (selector-names (map (make-symbols prefix) slot-strings))) + (define (slot-loop slot-names n) + (if (null? slot-names) + '() + (cons `(DEFINE ,(car slot-names) ,n) + (slot-loop (cdr slot-names) (1+ n))))) + + (define (selector-loop selector-names n) + (if (null? selector-names) + '() + (cons `(DEFINE-INTEGRABLE + (,(car selector-names) ,structure-name) + (VECTOR-REF ,structure-name ,n)) + (selector-loop (cdr selector-names) (1+ n))))) + + `(BEGIN (DEFINE ,tag-name ,name) + (DEFINE (,constructor-name) + (LET ((,structure-name + (VECTOR-CONS ,(1+ (length slots)) '()))) + (VECTOR-SET! ,structure-name 0 ,tag-name) + ,structure-name)) + (DEFINE (,predicate-name OBJECT) + (AND (VECTOR? OBJECT) + (NOT (ZERO? (VECTOR-LENGTH OBJECT))) + (EQ? ,tag-name (VECTOR-REF OBJECT 0)))) + ,@(slot-loop slot-names 1) + ,@(selector-loop selector-names 1))))))) + +(syntax-table-define edwin-syntax-table 'DEFINE-INTEGRABLE + (macro (name . body) + `(BEGIN (DECLARE (INTEGRATE ,(if (pair? name) (car name) name))) + (DEFINE ,name + ,@(if (pair? name) + `((DECLARE (INTEGRATE ,@(cdr name)))) + '()) + ,@body)))) + +(syntax-table-define edwin-syntax-table 'DEFINE-COMMAND + (macro (bvl description . body) + (let ((name (car bvl)) + (arg-names (map (lambda (arg) (if (pair? arg) (car arg) arg)) + (cdr bvl))) + (arg-inits (map (lambda (arg) (and (pair? arg) (cadr arg))) + (cdr bvl)))) + (let ((procedure-name + (string->symbol + (string-append (canonicalize-name-string name) + "-COMMAND")))) + `(BEGIN (DEFINE (,procedure-name #!OPTIONAL ,@arg-names) + ,@(map (lambda (arg-name arg-init) + `(IF ,(if (not arg-init) + `(UNASSIGNED? ,arg-name) + `(OR (UNASSIGNED? ,arg-name) + (NOT ,arg-name))) + (SET! ,arg-name ,arg-init))) + arg-names arg-inits) + ,@body) + (MAKE-COMMAND ,name ,description ,procedure-name)))))) + +(syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE + (macro (name description #!optional value) + (let ((variable-name (string->symbol (canonicalize-name-string name)))) + `(BEGIN (DEFINE ,variable-name + ,@(if (unassigned? value) + '() + `(,value))) + (MAKE-VARIABLE ',name ',description ',variable-name))))) + +(define (make-conditional-definition name value) + (make-definition name + (make-conditional (make-unbound? name) + value + (make-conditional (make-unassigned? name) + (make-unassigned-object) + (make-variable name))))) + +(syntax-table-define edwin-syntax-table 'REF-VARIABLE + (macro (name) + (string->symbol (canonicalize-name-string name)))) + +(syntax-table-define edwin-syntax-table 'SET-VARIABLE! + (macro (name #!optional value) + `(SET! ,(string->symbol (canonicalize-name-string name)) + ,@(if (unassigned? value) '() `(,value))))) + +(syntax-table-define edwin-syntax-table 'GLOBAL-SET-VARIABLE! + (macro (name #!optional value) + (let ((variable-name (string->symbol (canonicalize-name-string name)))) + `(BEGIN (UNMAKE-LOCAL-BINDING! ',variable-name) + (SET! ,variable-name + ,@(if (unassigned? value) '() `(,value))))))) + +(syntax-table-define edwin-syntax-table 'LOCAL-SET-VARIABLE! + (macro (name #!optional value) + `(MAKE-LOCAL-BINDING! ',(string->symbol (canonicalize-name-string name)) + ,@(if (unassigned? value) + '() + `(,value))))) + +(syntax-table-define edwin-syntax-table 'DEFINE-MAJOR-MODE + (macro (name super-mode-name description . initialization) + (let ((vname + (string->symbol + (string-append (canonicalize-name-string name) + "-MODE")))) + `(DEFINE ,vname + (MAKE-MODE ,name TRUE + ,(if super-mode-name + `(MODE-COMTABS (NAME->MODE ,super-mode-name)) + ''()) + ,description + (LAMBDA () ,@initialization)))))) + +(syntax-table-define edwin-syntax-table 'DEFINE-MINOR-MODE + (macro (name description . initialization) + (let ((vname + (string->symbol + (string-append (canonicalize-name-string name) + "-MODE")))) + `(DEFINE ,vname + (MAKE-MODE ,name false '() + ,description + (LAMBDA () ,@initialization)))))) + +(define (canonicalize-name-string name) + (let ((name (string-upcase name))) + (string-replace! name #\Space #\-) + name)) + +;;; end EDWIN-MACROS package. +)) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-macros +;;; End: diff --git a/v7/src/edwin/midas.scm b/v7/src/edwin/midas.scm new file mode 100644 index 000000000..ac227854b --- /dev/null +++ b/v7/src/edwin/midas.scm @@ -0,0 +1,83 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Midas Mode + +(declare (usual-integrations)) + +(using-syntax edwin-syntax-table + +(define-command ("Midas Mode" argument) + "Enter Midas mode." + (set-current-major-mode! midas-mode)) + +(define-major-mode "Midas" "Fundamental" + "Major mode for editing assembly code." + (local-set-variable! "Syntax Table" midas-mode:syntax-table) + (local-set-variable! "Comment Column" 40) + (local-set-variable! "Comment Locator Hook" + (access lisp-comment-locate lisp-indentation-package)) + (local-set-variable! "Comment Indent Hook" midas-comment-indentation) + (local-set-variable! "Comment Start" ";") + (local-set-variable! "Comment End" "") + (local-set-variable! "Paragraph Start" "^$") + (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start")) + (local-set-variable! "Indent Line Procedure" ^r-tab-command) + (if (ref-variable "Midas Mode Hook") ((ref-variable "Midas Mode Hook")))) + +(define midas-mode:syntax-table (make-syntax-table)) +(modify-syntax-entry! midas-mode:syntax-table #\; "< ") +(modify-syntax-entry! midas-mode:syntax-table char:newline "> ") +(modify-syntax-entry! midas-mode:syntax-table #\. "w ") +(modify-syntax-entry! midas-mode:syntax-table #\' "' ") +(modify-syntax-entry! midas-mode:syntax-table #\$ "' ") +(modify-syntax-entry! midas-mode:syntax-table #\% "' ") +(modify-syntax-entry! midas-mode:syntax-table #\# "' ") + +(define (midas-comment-indentation mark) + (if (match-forward ";;;" mark) + 0 + (max (1+ (mark-column (horizontal-space-start mark))) + comment-column))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm new file mode 100644 index 000000000..95bc4475b --- /dev/null +++ b/v7/src/edwin/modefs.scm @@ -0,0 +1,333 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Fundamental Mode + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Fundamental Mode" argument) + "Make the current mode be Fundamental Mode. +All normal editing modes are defined relative to this mode." + (set-current-major-mode! fundamental-mode)) + +(define-major-mode "Fundamental" #!FALSE + "Major mode not specialized for anything in particular. +Most other major modes are defined by comparison to this one." + (if (ref-variable "Fundamental Mode Hook") + ((ref-variable "Fundamental Mode Hook")))) + +(define-variable "Fundamental Mode Hook" + "If not false, a thunk to call when entering Fundamental mode." + #!FALSE) + +(define-variable "Editor Default Mode" + "The default major mode for new buffers." + fundamental-mode) + +(define-variable "File Type to Major Mode" + "Specifies the major mode for new buffers based on file type. +This is an alist, the cars of which are pathname types, +and the cdrs of which are major modes." + `(("ASM" . ,(name->mode "Midas")) + ("C" . ,(name->mode "C")) + ("PAS" . ,(name->mode "Pascal")) + ("S" . ,(name->mode "Scheme")) + ("SCM" . ,(name->mode "Scheme")) + ("TXI" . ,(name->mode "Texinfo")) + ("TXT" . ,(name->mode "Text")))) + +(define-default-key "Fundamental" "^R Bad Command") + +(define-key "Fundamental" char-set:graphic "^R Insert Self") +(define-key "Fundamental" char-set:numeric "^R Autoargument Digit") +(define-key "Fundamental" #\- "^R Auto Negative Argument") + +(define-key "Fundamental" #\Tab "^R Indent for Tab") +(define-key "Fundamental" #\Linefeed "^R Indent New Line") +(define-key "Fundamental" #\Page "^R New Window") +(define-key "Fundamental" #\Return "^R Newline") +(define-key "Fundamental" #\Altmode "^R Prefix Meta") +(define-key "Fundamental" #\Rubout "^R Backward Delete Character") + +(define-key "Fundamental" #\C-Space "^R Set/Pop Mark") +;!"#$ +(define-key "Fundamental" #\C-% "Replace String") +;'()*+, +(define-key "Fundamental" #\C-- "^R Negative Argument") +(define-key "Fundamental" #\C-. "Tags Loop Continue") +;/ +(define-key "Fundamental" #\C-0 "^R Argument Digit") +(define-key "Fundamental" #\C-1 "^R Argument Digit") +(define-key "Fundamental" #\C-2 "^R Argument Digit") +(define-key "Fundamental" #\C-3 "^R Argument Digit") +(define-key "Fundamental" #\C-4 "^R Argument Digit") +(define-key "Fundamental" #\C-5 "^R Argument Digit") +(define-key "Fundamental" #\C-6 "^R Argument Digit") +(define-key "Fundamental" #\C-7 "^R Argument Digit") +(define-key "Fundamental" #\C-8 "^R Argument Digit") +(define-key "Fundamental" #\C-9 "^R Argument Digit") +;: +(define-key "Fundamental" #\C-\; "^R Indent for Comment") +(define-key "Fundamental" #\C-< "^R Mark Beginning") +(define-key "Fundamental" #\C-= "What Cursor Position") +(define-key "Fundamental" #\C-> "^R Mark End") +;? +(define-key "Fundamental" #\C-@ "^R Set/Pop Mark") +(define-key "Fundamental" #\C-A "^R Beginning of Line") +(define-key "Fundamental" #\C-B "^R Backward Character") +;C +(define-key "Fundamental" #\C-D "^R Delete Character") +(define-key "Fundamental" #\C-E "^R End of Line") +(define-key "Fundamental" #\C-F "^R Forward Character") +;GHIJ +(define-key "Fundamental" #\C-K "^R Kill Line") +;LM +(define-key "Fundamental" #\C-N "^R Down Real Line") +(define-key "Fundamental" #\C-O "^R Open Line") +(define-key "Fundamental" #\C-P "^R Up Real Line") +(define-key "Fundamental" #\C-Q "^R Quoted Insert") +(define-key "Fundamental" #\C-R "^R Reverse Search") +(define-key "Fundamental" #\C-S "^R Incremental Search") +(define-key "Fundamental" #\C-T "^R Transpose Characters") +(define-key "Fundamental" #\C-U "^R Universal Argument") +(define-key "Fundamental" #\C-V "^R Next Screen") +(define-key "Fundamental" #\C-W "^R Kill Region") +(define-prefix-key "Fundamental" #\C-X "^R Prefix Character") +(define-key "Fundamental" #\C-Y "^R Un-Kill") +(define-key "Fundamental" #\C-Z "^R Prefix Control-Meta") +;[\ +(define-key "Fundamental" #\C-\] "Abort Recursive Edit") +(define-key "Fundamental" #\C-^ "^R Prefix Control") +(define-key "Fundamental" #\C-_ "Undo") +;`{|}~ +(define-key "Fundamental" #\C-Rubout "^R Backward Delete Hacking Tabs") + +(define-key "Fundamental" #\M-Backspace "^R Mark Definition") +(define-key "Fundamental" #\M-Tab "^R Tab") +(define-key "Fundamental" #\M-Linefeed "^R Indent New Comment Line") +(define-key "Fundamental" #\M-Page "^R Twiddle Buffers") +(define-key "Fundamental" #\M-Return "^R Back to Indentation") +;Altmode +(define-key "Fundamental" #\M-Space "^R Just One Space") +;!"#$ +(define-key "Fundamental" #\M-% "Query Replace") +;'()* +(define-key "Fundamental" #\M-+ "Pascal Filer") +(define-key "Fundamental" #\M-, "Pascal Emulator") +(define-key "Fundamental" #\M-- "^R Autoargument") +(define-key "Fundamental" #\M-. "Find Tag") +(define-key "Fundamental" #\M-/ "Describe Command") +(define-key "Fundamental" #\M-0 "^R Autoargument") +(define-key "Fundamental" #\M-1 "^R Autoargument") +(define-key "Fundamental" #\M-2 "^R Autoargument") +(define-key "Fundamental" #\M-3 "^R Autoargument") +(define-key "Fundamental" #\M-4 "^R Autoargument") +(define-key "Fundamental" #\M-5 "^R Autoargument") +(define-key "Fundamental" #\M-6 "^R Autoargument") +(define-key "Fundamental" #\M-7 "^R Autoargument") +(define-key "Fundamental" #\M-8 "^R Autoargument") +(define-key "Fundamental" #\M-9 "^R Autoargument") +;: +(define-key "Fundamental" #\M-\; "^R Indent for Comment") +(define-key "Fundamental" #\M-< "^R Goto Beginning") +(define-key "Fundamental" #\M-= "^R Count Lines Region") +(define-key "Fundamental" #\M-> "^R Goto End") +(define-key "Fundamental" #\M-? "Describe Command") +(define-key "Fundamental" #\M-@ "^R Mark Word") +(define-key "Fundamental" #\M-A "^R Backward Sentence") +(define-key "Fundamental" #\M-B "^R Backward Word") +(define-key "Fundamental" #\M-C "^R Uppercase Initial") +(define-key "Fundamental" #\M-D "^R Kill Word") +(define-key "Fundamental" #\M-E "^R Forward Sentence") +(define-key "Fundamental" #\M-F "^R Forward Word") +;(define-key "Fundamental" #\M-G "^R Fill Region") +(define-key "Fundamental" #\M-H "^R Mark Paragraph") +(define-key "Fundamental" #\M-I "^R Tab to Tab Stop") +(define-key "Fundamental" #\M-J "^R Indent New Comment Line") +(define-key "Fundamental" #\M-K "^R Kill Sentence") +(define-key "Fundamental" #\M-L "^R Lowercase Word") +(define-key "Fundamental" #\M-M "^R Back to Indentation") +;NOP +(define-key "Fundamental" #\M-Q "^R Fill Paragraph") +(define-key "Fundamental" #\M-R "^R Move to Screen Edge") +;S +(define-key "Fundamental" #\M-T "^R Transpose Words") +(define-key "Fundamental" #\M-U "^R Uppercase Word") +(define-key "Fundamental" #\M-V "^R Previous Screen") +(define-key "Fundamental" #\M-W "^R Copy Region") +(define-key "Fundamental" #\M-X "^R Extended Command") +(define-key "Fundamental" #\M-Y "^R Un-Kill Pop") +;Z +(define-key "Fundamental" #\M-\[ "^R Backward Paragraph") +(define-key "Fundamental" #\M-\\ "^R Delete Horizontal Space") +(define-key "Fundamental" #\M-\] "^R Forward Paragraph") +(define-key "Fundamental" #\M-^ "^R Delete Indentation") +;_`{|} +(define-key "Fundamental" #\M-~ "^R Buffer Not Modified") +(define-key "Fundamental" #\M-Rubout "^R Backward Kill Word") + +(define-key "Fundamental" #\C-M-Space "^R Mark Sexp") +(define-key "Fundamental" #\C-M-0 "^R Argument Digit") +(define-key "Fundamental" #\C-M-1 "^R Argument Digit") +(define-key "Fundamental" #\C-M-2 "^R Argument Digit") +(define-key "Fundamental" #\C-M-3 "^R Argument Digit") +(define-key "Fundamental" #\C-M-4 "^R Argument Digit") +(define-key "Fundamental" #\C-M-5 "^R Argument Digit") +(define-key "Fundamental" #\C-M-6 "^R Argument Digit") +(define-key "Fundamental" #\C-M-7 "^R Argument Digit") +(define-key "Fundamental" #\C-M-8 "^R Argument Digit") +(define-key "Fundamental" #\C-M-9 "^R Argument Digit") +(define-key "Fundamental" #\C-M-- "^R Negative Argument") + +(define-key "Fundamental" #\C-M-\\ "^R Indent Region") +(define-key "Fundamental" #\C-M-^ "^R Delete Indentation") +(define-key "Fundamental" #\C-M-\( "^R Backward Up List") +(define-key "Fundamental" #\C-M-\) "^R Forward Up List") +(define-key "Fundamental" #\C-M-@ "^R Mark Sexp") +(define-key "Fundamental" #\C-M-\; "^R Kill Comment") + +(define-key "Fundamental" #\C-M-A "^R Beginning of Definition") +(define-key "Fundamental" #\C-M-B "^R Backward Sexp") +(define-key "Fundamental" #\C-M-C "^R Exit") +(define-key "Fundamental" #\C-M-D "^R Forward Down List") +(define-key "Fundamental" #\C-M-E "^R End of Definition") +(define-key "Fundamental" #\C-M-F "^R Forward Sexp") +;GHIJ +(define-key "Fundamental" #\C-M-K "^R Kill Sexp") +;LM +(define-key "Fundamental" #\C-M-N "^R Forward List") +(define-key "Fundamental" #\C-M-O "^R Split Line") +(define-key "Fundamental" #\C-M-P "^R Backward List") +;Q +(define-key "Fundamental" #\C-M-R "^R Reposition Window") +;S +(define-key "Fundamental" #\C-M-T "^R Transpose Sexps") +(define-key "Fundamental" #\C-M-U "^R Backward Up List") +(define-key "Fundamental" #\C-M-V "^R Scroll Other Window") +(define-key "Fundamental" #\C-M-W "^R Append Next Kill") +;XYZ +(define-key "Fundamental" #\C-M-Rubout "^R Backward Kill Sexp") + +;Backspace +(define-key "Fundamental" '(#\C-X #\Tab) "^R Indent Rigidly") +;Linefeed +(define-key "Fundamental" '(#\C-X #\Page) "^R Lowercase Region") +;Return,Altmode +;A +(define-key "Fundamental" '(#\C-X #\C-B) "List Buffers") +;C +(define-key "Fundamental" '(#\C-X #\C-D) "List Directory") +(define-key "Fundamental" '(#\C-X #\C-E) "^R Evaluate Previous Sexp") +(define-key "Fundamental" '(#\C-X #\C-F) "Find File") +;GHIJKLM +(define-key "Fundamental" '(#\C-X #\C-N) "^R Set Goal Column") +(define-key "Fundamental" '(#\C-X #\C-O) "^R Delete Blank Lines") +(define-key "Fundamental" '(#\C-X #\C-P) "^R Mark Page") +(define-key "Fundamental" '(#\C-X #\C-Q) "Toggle Read Only") +;R +(define-key "Fundamental" '(#\C-X #\C-S) "^R Save File") +(define-key "Fundamental" '(#\C-X #\C-T) "^R Transpose Lines") +(define-key "Fundamental" '(#\C-X #\C-U) "^R Uppercase Region") +(define-key "Fundamental" '(#\C-X #\C-V) "^R Find Alternate File") +(define-key "Fundamental" '(#\C-X #\C-W) "Write File") +(define-key "Fundamental" '(#\C-X #\C-X) "^R Exchange Point and Mark") +(define-key "Fundamental" '(#\C-X #\C-Z) "^R Return to Superior") +;!"#$%&' +(define-key "Fundamental" '(#\C-X #\() "Start Keyboard Macro") +(define-key "Fundamental" '(#\C-X #\)) "End Keyboard Macro") +;*+,- +(define-key "Fundamental" '(#\C-X #\.) "^R Set Fill Prefix") +(define-key "Fundamental" '(#\C-X #\/) "Point to Register") +(define-key "Fundamental" '(#\C-X #\0) "^R Delete Window") +(define-key "Fundamental" '(#\C-X #\1) "^R Delete Other Windows") +(define-key "Fundamental" '(#\C-X #\2) "^R Split Window Vertically") +(define-key "Fundamental" '(#\C-X #\3) "Kill Pop Up Buffer") +(define-prefix-key "Fundamental" '(#\C-X #\4) "^R Prefix Character") +(define-key "Fundamental" '(#\C-X #\4 #\.) "Find Tag Other Window") +(define-key "Fundamental" '(#\C-X #\4 #\B) "Select Buffer Other Window") +(define-key "Fundamental" '(#\C-X #\4 #\D) "Dired Other Window") +(define-key "Fundamental" '(#\C-X #\4 #\F) "Find File Other Window") +(define-key "Fundamental" '(#\C-X #\5) "^R Split Window Horizontally") +;: +(define-key "Fundamental" '(#\C-X #\;) "^R Set Comment Column") +;< +(define-key "Fundamental" '(#\C-X #\=) "What Cursor Position") +;>?A +(define-key "Fundamental" '(#\C-X #\B) "Select Buffer") +;C +(define-key "Fundamental" '(#\C-X #\D) "Dired") +(define-key "Fundamental" '(#\C-X #\E) "Call Last Keyboard Macro") +(define-key "Fundamental" '(#\C-X #\F) "^R Set Fill Column") +(define-key "Fundamental" '(#\C-X #\G) "Insert Register") +(define-key "Fundamental" '(#\C-X #\H) "^R Mark Whole Buffer") +(define-key "Fundamental" '(#\C-X #\I) "Insert File") +(define-key "Fundamental" '(#\C-X #\J) "Register to Point") +(define-key "Fundamental" '(#\C-X #\K) "Kill Buffer") +(define-key "Fundamental" '(#\C-X #\L) "^R Count Lines Page") +;M +;(define-key "Fundamental" '(#\C-X #\N) "^R Narrow Bounds to Region") +(define-key "Fundamental" '(#\C-X #\O) "^R Other Window") +;(define-key "Fundamental" '(#\C-X #\P) "^R Narrow Bounds to Page") +(define-key "Fundamental" '(#\C-X #\Q) "Keyboard Macro Query") +(define-key "Fundamental" '(#\C-X #\R) "Copy Rectangle to Register") +(define-key "Fundamental" '(#\C-X #\S) "Save Some Buffers") +;(define-key "Fundamental" '(#\C-X #\T) "^R Transpose Regions") +(define-key "Fundamental" '(#\C-X #\U) "Undo") +(define-key "Fundamental" '(#\C-X #\V) "^R Screen Video") +(define-key "Fundamental" '(#\C-X #\W) "^R Widen Bounds") +(define-key "Fundamental" '(#\C-X #\X) "Copy to Register") +;Y +(define-key "Fundamental" '(#\C-X #\Z) "^R Scheme") +(define-key "Fundamental" '(#\C-X #\[) "^R Previous Page") +;\ +(define-key "Fundamental" '(#\C-X #\]) "^R Next Page") +(define-key "Fundamental" '(#\C-X #\^) "^R Enlarge Window Vertically") +;_` +(define-key "Fundamental" '(#\C-X #\{) "^R Shrink Window Horizontally") +;| +(define-key "Fundamental" '(#\C-X #\}) "^R Enlarge Window Horizontally") +;~ +(define-key "Fundamental" '(#\C-X #\Rubout) "^R Backward Kill Sentence") + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm new file mode 100644 index 000000000..6594ab51c --- /dev/null +++ b/v7/src/edwin/modes.scm @@ -0,0 +1,82 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Modes + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-named-structure "Mode" + name + major? + comtabs + description + initialization + alist) + +(define (make-mode name major? comtabs description initialization) + (let ((mode (or (string-table-get editor-modes name) + (let ((mode (%make-mode))) + (vector-set! mode mode-index:comtabs (list (make-comtab))) + (string-table-put! editor-modes name mode) + mode)))) + (vector-set! mode mode-index:name name) + (vector-set! mode mode-index:major? major?) + (set-cdr! (vector-ref mode mode-index:comtabs) comtabs) + (vector-set! mode mode-index:description description) + (vector-set! mode mode-index:initialization initialization) + (vector-set! mode mode-index:alist '()) + mode)) + +(define (mode-comtab mode) + (car (mode-comtabs mode))) + +(define editor-modes + (make-string-table)) + +(define-unparser %mode-tag + (lambda (mode) + (write-string "Mode ") + (write-string (mode-name mode)))) + +(define (name->mode name) + (or (string-table-get editor-modes name) + (make-mode name #!TRUE '() "" + (lambda () (error "Undefined mode" name))))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/modwin.scm b/v7/src/edwin/modwin.scm new file mode 100644 index 000000000..2d353193b --- /dev/null +++ b/v7/src/edwin/modwin.scm @@ -0,0 +1,150 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Modeline Window + +(declare (usual-integrations) + (integrate-external "edb:window.bin.0")) +(using-syntax (access class-syntax-table edwin-package) + +(define-class modeline-window vanilla-window + (old-buffer-modified?)) + +(define-method modeline-window (:initialize! window window*) + (usual=> window :initialize! window*) + (set! y-size 1) + (set! old-buffer-modified? 'UNKNOWN)) + +(define-method modeline-window (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (if (< yl yu) + (with-inverse-video! (ref-variable "Mode Line Inverse Video") + (lambda () + (screen-write-substring! + screen x-start y-start + (string-pad-right (modeline-string superior) + x-size #\-) + xl xu)))) + true) + +(define (with-inverse-video! flag? thunk) + (if flag? + (let ((inverse? (screen-inverse-video! false))) + (dynamic-wind (lambda () + (screen-inverse-video! (not inverse?))) + thunk + (lambda () + (screen-inverse-video! inverse?)))) + (thunk))) + +(define-method modeline-window (:event! window type) + (cond ((eq? type 'BUFFER-MODIFIED) + (let ((new (buffer-modified? (window-buffer superior)))) + (if (not (eq? old-buffer-modified? new)) + (begin (setup-redisplay-flags! redisplay-flags) + (set! old-buffer-modified? new))))) + ((eq? type 'NEW-BUFFER) + (set! old-buffer-modified? 'UNKNOWN)) + ((eq? type 'CURSOR-MOVED)) + (else + (setup-redisplay-flags! redisplay-flags)))) + +(define (modeline-string window) + ((or (buffer-get (window-buffer window) 'MODELINE-STRING) + standard-modeline-string) + window)) + +(define (standard-modeline-string window) + (string-append "--" + (modeline-modified-string window) + "-Edwin: " + (string-pad-right (buffer-display-name (window-buffer window)) + 30) + " " + (modeline-mode-string window) + "--" + (modeline-percentage-string window))) + +(define (modeline-modified-string window) + (let ((buffer (window-buffer window))) + (cond ((not (buffer-writeable? buffer)) "%%") + ((buffer-modified? buffer) "**") + (else "--")))) + +(define (modeline-mode-string window) + (let ((buffer (window-buffer window))) + (define (loop modes) + (if (null? (cdr modes)) + (string-append (mode-name (car modes)) + (if *defining-keyboard-macro?* " Def" "") + (if (group-clipped? (buffer-group buffer)) + " Narrow" "")) + (string-append (mode-name (car modes)) + " " + (loop (cdr modes))))) + (string-append (make-string recursive-edit-level #\[) + "(" + (loop (buffer-modes buffer)) + ")" + (make-string recursive-edit-level #\])))) + +(define (modeline-percentage-string window) + (let ((buffer (window-buffer window))) + (define (buffer-percentage) + (round + (* 100 + (let ((start-index (mark-index (buffer-start buffer)))) + (/ (- (mark-index (window-start-mark window)) start-index) + (- (mark-index (buffer-end buffer)) start-index)))))) + (if (window-mark-visible? window (buffer-start buffer)) + (if (window-mark-visible? window (buffer-end buffer)) + "All" "Top") + (if (window-mark-visible? window (buffer-end buffer)) + "Bot" + (string-append + (string-pad-left (write-to-string (buffer-percentage)) + 2) + "%"))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: (access class-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/motcom.scm b/v7/src/edwin/motcom.scm new file mode 100644 index 000000000..c5de436d3 --- /dev/null +++ b/v7/src/edwin/motcom.scm @@ -0,0 +1,179 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Motion Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("^R Beginning of Line" (argument 1)) + "Move point to beginning of line." + (set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT))) + +(define-command ("^R Backward Character" (argument 1)) + "Move back one character. +With argument, move that many characters backward. +Negative arguments move forward." + (move-thing mark- argument)) + +(define-command ("^R End of Line" (argument 1)) + "Move point to end of line." + (set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT))) + +(define-command ("^R Forward Character" (argument 1)) + "Move forward one character. +With argument, move that many characters forward. +Negative args move backward." + (move-thing mark+ argument)) + +(define-command ("^R Goto Beginning" argument) + "Go to beginning of buffer (leaving mark behind). +With arg from 0 to 10, goes that many tenths of the file +down from the beginning. Just C-U as arg means go to end." + (push-current-mark! (current-point)) + (cond ((not argument) + (set-current-point! (buffer-start (current-buffer)))) + ((command-argument-multiplier-only?) + (set-current-point! (buffer-end (current-buffer)))) + ((<= 0 argument 10) + (set-current-point! (region-10ths (buffer-region (current-buffer)) + argument))))) + +(define-command ("^R Goto End" argument) + "Go to end of buffer (leaving mark behind). +With arg from 0 to 10, goes up that many tenths of the file from the end." + (push-current-mark! (current-point)) + (cond ((not argument) + (set-current-point! (buffer-end (current-buffer)))) + ((<= 0 argument 10) + (set-current-point! (region-10ths (buffer-region (current-buffer)) + (- 10 argument)))))) + +(define (region-10ths region n) + (mark+ (region-start region) + (quotient (* n (region-count-chars region)) 10))) + +(define-command ("Goto Char" (argument 0)) + "Goto the Nth character from the start of the buffer. +A negative argument goes to the -Nth character from the end of the buffer." + (let ((mark (mark+ ((if (negative? argument) buffer-end buffer-start) + (current-buffer)) + argument))) + (if mark + (set-current-point! mark) + (editor-error)))) + +(define-command ("Goto Line" (argument 0)) + "Goto the Nth line from the start of the buffer. +A negative argument goes to the -Nth line from the end of the buffer." + (let ((mark (line-start ((if (negative? argument) buffer-end buffer-start) + (current-buffer)) + argument))) + (if mark + (set-current-point! mark) + (editor-error)))) + +(define-command ("Goto Page" (argument 1)) + "Goto the Nth page from the start of the buffer. +A negative argument goes to the -Nth page from the end of the buffer." + (let ((mark (forward-page ((if (negative? argument) buffer-end buffer-start) + (current-buffer)) + (cond ((negative? argument) argument) + ((positive? argument) (-1+ argument)) + (else 1))))) + (if mark + (set-current-point! mark) + (editor-error)))) + +(define-variable "Goal Column" + "Semipermanent goal column for vertical motion, +as set by \\[^R Set Goal Column], or false, indicating no goal column." + #!FALSE) + +(define temporary-goal-column-tag + "Temporary Goal Column") + +(define-command ("^R Set Goal Column" argument) + "Set (or flush) a permanent goal for vertical motion. +With no argument, makes the current column the goal for vertical +motion commands. They will always try to go to that column. +With argument, clears out any previously set goal. +Only \\[^R Up Real Line] and \\[^R Down Real Line] are affected." + (set! goal-column + (and (not argument) + (current-column)))) + +(define (current-goal-column) + (or goal-column + (command-message-receive temporary-goal-column-tag + identity-procedure + current-column))) + +(define-command ("^R Down Real Line" argument) + "Move down vertically to next real line. +Continuation lines are skipped. If given after the +last newline in the buffer, makes a new one at the end." + (let ((column (current-goal-column))) + (cond ((not argument) + (let ((mark (line-start (current-point) 1 #!FALSE))) + (if mark + (set-current-point! (move-to-column mark column)) + (begin (set-current-point! (group-end (current-point))) + (insert-newlines 1))))) + ((not (zero? argument)) + (set-current-point! + (move-to-column (line-start (current-point) argument 'FAILURE) + column)))) + (set-command-message! temporary-goal-column-tag column))) + +(define-command ("^R Up Real Line" (argument 1)) + "Move up vertically to next real line. +Continuation lines are skipped." + (let ((column (current-goal-column))) + (if (not (zero? argument)) + (set-current-point! + (move-to-column (line-start (current-point) (- argument) 'FAILURE) + column))) + (set-command-message! temporary-goal-column-tag column))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/motion.scm b/v7/src/edwin/motion.scm new file mode 100644 index 000000000..1d16df3b2 --- /dev/null +++ b/v7/src/edwin/motion.scm @@ -0,0 +1,249 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Motion within Groups + +(declare (usual-integrations) + (integrate-external "edb:struct.bin.0")) + +;;;; Motion by Characters + +(define (limit-mark-motion limit? limit) + (cond ((eq? limit? 'LIMIT) limit) + ((eq? limit? 'BEEP) (beep) limit) + ((eq? limit? 'FAILURE) (editor-failure) limit) + ((eq? limit? 'ERROR) (editor-error)) + ((not limit?) #!FALSE) + (else (error "Unknown limit type" limit?)))) + +(define (mark1+ mark #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (let ((group (mark-group mark)) + (index (mark-index mark))) + (if (group-end-index? group index) + (limit-mark-motion limit? (group-end-mark group)) + (make-mark group (1+ index))))) + +(define (mark-1+ mark #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (let ((group (mark-group mark)) + (index (mark-index mark))) + (if (group-start-index? group index) + (limit-mark-motion limit? (group-start-mark group)) + (make-mark group (-1+ index))))) + +(define (region-count-chars region) + (- (region-end-index region) + (region-start-index region))) + +(define mark+) +(define mark-) +(let () + +(set! mark+ +(named-lambda (mark+ mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%mark+ mark n limit?)) + ((negative? n) (%mark- mark (- n) limit?)) + (else mark)))) + +(set! mark- +(named-lambda (mark- mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%mark- mark n limit?)) + ((negative? n) (%mark+ mark (- n) limit?)) + (else mark)))) + +(define (%mark+ mark n limit?) + (let ((group (mark-group mark))) + (let ((new-index (+ (mark-index mark) n))) + (if (> new-index (group-end-index group)) + (limit-mark-motion limit? (group-end-mark group)) + (make-mark group new-index))))) + +(define (%mark- mark n limit?) + (let ((group (mark-group mark))) + (let ((new-index (- (mark-index mark) n))) + (if (< new-index (group-start-index group)) + (limit-mark-motion limit? (group-start-mark group)) + (make-mark group new-index))))) + +) + +;;;; Motion by Lines + +;;; Move to the beginning of the Nth line, starting from INDEX in +;;; GROUP, where positive N means down, negative N means up, and zero +;;; N means the current line. If such a line exists, call IF-OK on +;;; the position (of the line's start), otherwise call IF-NOT-OK on +;;; the limiting mark (the group's start or end) which was exceeded. + +(define (move-vertically group index n if-ok if-not-ok) + (cond ((positive? n) + (let ((limit (group-end-index group))) + (define (loop+ i n) + (let ((j (%find-next-newline group i limit))) + (cond ((not j) (if-not-ok (group-end-mark group))) + ((= n 1) (if-ok (1+ j))) + (else (loop+ (1+ j) (-1+ n)))))) + (loop+ index n))) + ((negative? n) + (let ((limit (group-start-index group))) + (define (loop- i n) + (let ((j (%find-previous-newline group i limit))) + (cond ((zero? n) (if-ok (or j limit))) + ((not j) (if-not-ok (group-start-mark group))) + (else (loop- (-1+ j) (1+ n)))))) + (loop- index n))) + (else + (if-ok (let ((limit (group-start-index group))) + (or (%find-previous-newline group index limit) + limit)))))) + +(define (line-start-index group index) + (or (%find-previous-newline group index (group-start-index group)) + (group-start-index group))) + +(define (line-end-index group index) + (or (%find-next-newline group index (group-end-index group)) + (group-end-index group))) + +(define (line-start-index? group index) + (or (group-start-index? group index) + (char=? (group-left-char group index) char:newline))) + +(define (line-end-index? group index) + (or (group-end-index? group index) + (char=? (group-right-char group index) char:newline))) + +(define (line-start mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (let ((group (mark-group mark))) + (move-vertically group (mark-index mark) n + (lambda (index) + (make-mark group index)) + (lambda (mark) + (limit-mark-motion limit? mark))))) + +(define (line-end mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (let ((group (mark-group mark))) + (move-vertically group (mark-index mark) n + (lambda (index) + (let ((end + (%find-next-newline group index (group-end-index group)))) + (if end + (make-mark group end) + (group-end-mark group)))) + (lambda (mark) + (limit-mark-motion limit? mark))))) + +(define (line-start? mark) + (line-start-index? (mark-group mark) (mark-index mark))) + +(define (line-end? mark) + (line-end-index? (mark-group mark) (mark-index mark))) + +(define (region-count-lines region) + (group-count-lines (region-group region) + (region-start-index region) + (region-end-index region))) + +(define (group-count-lines group start end) + (define (phi1 start n) + (if (= start end) + n + (phi2 (%find-next-newline group start end) + (1+ n)))) + (define (phi2 i n) + (if (not i) + n + (phi1 (1+ i) n))) + (phi1 start 0)) + +;;;; Motion by Columns + +(define (mark-column mark) + (group-index->column (mark-group mark) (mark-index mark))) + +(define (move-to-column mark column) + (let ((group (mark-group mark)) + (index (mark-index mark))) + (make-mark group + (group-column->index group + (line-start-index group index) + (line-end-index group index) + 0 + column)))) + +(define (group-index->column group index) + (group-column-length group (line-start-index group index) index 0)) + +(define (group-column-length group start-index end-index start-column) + (if (= start-index end-index) + 0 + (let ((start (group-index->position group start-index #!TRUE)) + (end (group-index->position group end-index #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (if (and (<= start gap-start) + (<= gap-end end)) + (substring-column-length text gap-end end + (substring-column-length text start gap-start start-column)) + (substring-column-length text start end start-column))))) + +(define (group-column->index group start-index end-index start-column column) + (if (= start-index end-index) + start-index + (let ((start (group-index->position group start-index #!TRUE)) + (end (group-index->position group end-index #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (cond ((<= end gap-start) + (substring-column->index text start end start-column column)) + ((>= start gap-end) + (- (substring-column->index text start end start-column column) + (group-gap-length group))) + (else + (substring-column->index text start gap-start start-column + column + (lambda (gap-column) + (- (substring-column->index text gap-end end gap-column + column) + (group-gap-length group))))))))) \ No newline at end of file diff --git a/v7/src/edwin/nvector.scm b/v7/src/edwin/nvector.scm new file mode 100644 index 000000000..ab4ff3dde --- /dev/null +++ b/v7/src/edwin/nvector.scm @@ -0,0 +1,55 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; New Vector Operations + +(declare (usual-integrations)) + +(define (define-unparser tag unparser) + ((access add-unparser-special-object! unparser-package) + tag + (lambda (object) + (unparse-with-brackets + (lambda () + (unparser object))))) + tag) + +(define (vector-delq! vector index item) + (vector-set! vector index (delq! item (vector-ref vector index)))) + +(define (vector-push! vector index item) + (vector-set! vector index (cons item (vector-ref vector index)))) \ No newline at end of file diff --git a/v7/src/edwin/pasmod.scm b/v7/src/edwin/pasmod.scm new file mode 100644 index 000000000..c8a50a550 --- /dev/null +++ b/v7/src/edwin/pasmod.scm @@ -0,0 +1,174 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Pascal Mode + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Pascal Mode" argument) + "Enter Pascal mode." + (set-current-major-mode! pascal-mode)) + +(define-major-mode "Pascal" "Fundamental" + "Major mode specialized for editing Pascal code." + (local-set-variable! "Syntax Table" pascal-mode:syntax-table) + (local-set-variable! "Syntax Ignore Comments Backwards" #!TRUE) + (local-set-variable! "Indent Line Procedure" ^r-pascal-indent-command) + (local-set-variable! "Comment Column" 32) + (local-set-variable! "Comment Locator Hook" pascal-comment-locate) + (local-set-variable! "Comment Indent Hook" pascal-comment-indentation) + (local-set-variable! "Comment Start" "(* ") + (local-set-variable! "Comment End" " *)") + (local-set-variable! "Paragraph Start" "^$") + (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start")) + (local-set-variable! "Delete Indentation Right Protected" (char-set #\( #\[)) + (local-set-variable! "Delete Indentation Left Protected" (char-set #\) #\])) + (if (ref-variable "Pascal Mode Hook") + ((ref-variable "Pascal Mode Hook")))) + +(define pascal-mode:syntax-table (make-syntax-table)) +(modify-syntax-entry! pascal-mode:syntax-table #\( "()1 ") +(modify-syntax-entry! pascal-mode:syntax-table #\) ")( 4") +(modify-syntax-entry! pascal-mode:syntax-table #\[ "(] ") +(modify-syntax-entry! pascal-mode:syntax-table #\] ")[ ") +(modify-syntax-entry! pascal-mode:syntax-table #\{ "< ") +(modify-syntax-entry! pascal-mode:syntax-table #\} "> ") +(modify-syntax-entry! pascal-mode:syntax-table #\' "\" ") +(modify-syntax-entry! pascal-mode:syntax-table #\$ "\" ") +(modify-syntax-entry! pascal-mode:syntax-table #\* "_ 23") +(modify-syntax-entry! pascal-mode:syntax-table #\. "_ ") +(modify-syntax-entry! pascal-mode:syntax-table #\^ "_ ") +(modify-syntax-entry! pascal-mode:syntax-table #\@ "' ") +(modify-syntax-entry! pascal-mode:syntax-table #\% " ") +(modify-syntax-entry! pascal-mode:syntax-table #\" " ") +(modify-syntax-entry! pascal-mode:syntax-table #\\ " ") + +(define (pascal-comment-locate mark) + (if (re-search-forward "\\((\\*\\|{\\)[ \t]*" mark (line-end mark 0)) + (cons (re-match-start 0) (re-match-end 0)))) + +(define (pascal-comment-indentation mark) + (let ((start (horizontal-space-start mark))) + (if (line-start? start) + (indentation-of-previous-non-blank-line mark) + (max (1+ (mark-column start)) + (ref-variable "Comment Column"))))) + +(define-key "Pascal" #\C-\( "^R Pascal Shift Left") +(define-key "Pascal" #\C-\) "^R Pascal Shift Right") +(define-key "Pascal" #\Rubout "^R Backward Delete Hacking Tabs") + +(define-command ("^R Pascal Indent" argument) + "Indents the current line for Pascal code." + (let ((point (current-point))) + (let ((indentation (calculate-pascal-indentation point))) + (cond ((not (= indentation (current-indentation point))) + (change-indentation indentation point)) + ((line-start? (horizontal-space-start point)) + (set-current-point! (horizontal-space-end point))))))) + +(define-command ("^R Pascal Shift Right" (argument 1)) + "Shift the current line right by Pascal Shift Increment. +With an argument, shifts right that many times." + (if (not (zero? argument)) + (let ((mark (line-start (current-point) 0))) + (change-indentation (+ (current-indentation mark) + (* argument + (ref-variable "Pascal Shift Increment"))) + mark)))) + +(define-command ("^R Pascal Shift Left" (argument 1)) + "Shift the current line left by Pascal Shift Increment. +With an argument, shifts left that many times." + (if (not (zero? argument)) + (let ((mark (line-start (current-point) 0))) + (change-indentation (- (current-indentation mark) + (* argument + (ref-variable "Pascal Shift Increment"))) + mark)))) + +(define (calculate-pascal-indentation mark) + (let ((def-start + (let ((nb (find-previous-non-blank-line mark))) + (if (not nb) + (group-start mark) + (let ((start (backward-one-paragraph nb))) + (if (not start) + (group-start mark) + (line-start start 1))))))) + (define (find-statement-start mark) + (let ((start (find-previous-non-blank-line mark))) + (cond ((not start) #!FALSE) + ((mark< start def-start) def-start) + (else + (let ((container + (parse-state-containing-sexp + (parse-partial-sexp def-start start)))) + (if container + (find-statement-start start) + start)))))) + (let ((state (parse-partial-sexp def-start (line-start mark 0)))) + (let ((container (parse-state-containing-sexp state)) + (last-sexp (parse-state-last-sexp state))) + (if container + ;; Inside some parenthesized expression or arglist. + (if (mark> (line-end container 0) last-sexp) + ;; Indent first line under opening paren. + (mark-column (horizontal-space-end (mark1+ container))) + ;; Indent subsequent line under previous line. + (indentation-of-previous-non-blank-line mark)) + (let ((start (find-statement-start mark))) + (if (not start) + 0 + (let ((start (horizontal-space-end start))) + (let ((indentation (mark-column start))) + (if (and (ref-variable "Pascal Indentation Keywords") + (re-match-forward + (ref-variable "Pascal Indentation Keywords") + start)) + (+ indentation + (ref-variable "Pascal Shift Increment")) + indentation)))))))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm new file mode 100644 index 000000000..ba6b1bb1d --- /dev/null +++ b/v7/src/edwin/prompt.scm @@ -0,0 +1,501 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; User Prompting + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-variable "Enable Recursive Minibuffers" + "If true, allow minibuffers to invoke commands which use +recursive minibuffers." + false) + +(define within-typein-edit) +(define within-typein-edit?) +(define prompt-for-typein) +(define prompt-for-completed-string) +(define prompt-for-string) +(define prompt-for-string-table-value) +(define prompt-for-alist-value) +(define prompt-for-command) +(define prompt-for-variable) +(define prompt-for-char) +(define prompt-for-char-without-interrupts) +(define prompt-for-char-with-interrupts) +(define prompt-for-key) +(define prompt-for-confirmation?) +(define prompt-for-yes-or-no?) + +(define prompt-package + (make-environment + +(define typein-edit-continuation false) +(define typein-edit-abort-flag "Abort") +(define typein-edit-depth -1) +(define typein-saved-buffers '()) +(define typein-saved-window) + +(set! within-typein-edit +(named-lambda (within-typein-edit thunk) + (if (and (not (ref-variable "Enable Recursive Minibuffers")) + (typein-window? (current-window))) + (editor-error "Command attempted to use minibuffer while in minibuffer")) + (let ((value + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((typein-edit-continuation continuation) + (typein-edit-depth (1+ typein-edit-depth)) + (typein-saved-buffers + (cons (window-buffer (typein-window)) + typein-saved-buffers)) + (typein-saved-window (current-window))) + (dynamic-wind + (lambda () + (select-window (typein-window)) + (select-buffer + (find-or-create-buffer + (string-append " *Typein-" + (write-to-string typein-edit-depth) + "*"))) + (buffer-reset! (current-buffer)) + (reset-command-prompt!) + (%clear-message!)) + thunk + (lambda () + (select-window (typein-window)) + (let ((buffer (car typein-saved-buffers))) + (bufferset-guarantee-buffer! (current-bufferset) buffer) + (select-buffer buffer)) + (reset-command-prompt!) + (%clear-message!) + (if (zero? typein-edit-depth) + (buffer-reset! (current-buffer))) + (cond ((window-visible? typein-saved-window) + (select-window typein-saved-window)) + ((zero? typein-edit-depth) + (select-window (other-window))))))))))) + (if (eq? value typein-edit-abort-flag) + (abort-current-command) + value)))) + +(set! within-typein-edit? +(named-lambda (within-typein-edit?) + (not (false? typein-edit-continuation)))) + +;;; The following are used by MESSAGE and friends. + +(define (set-message! message) + ((access set-override-message! window-package) + ((access frame-text-inferior window-package) (typein-window)) + message) + (window-direct-update! (typein-window) true)) + +(define (clear-message!) + (%clear-message!) + (window-direct-update! (typein-window) true)) + +(define (%clear-message!) + ((access clear-override-message! window-package) + ((access frame-text-inferior window-package) (typein-window)))) + +(define (update-typein!) + (window-direct-update! (typein-window) false)) + +(define (typein-window) + ((access editor-frame-typein-window window-package) (current-frame))) + +(set! prompt-for-typein +(named-lambda (prompt-for-typein prompt-string thunk) + (within-typein-edit + (lambda () + (insert-string prompt-string) + (with-narrowed-region! (let ((mark (current-point))) + (make-region (mark-right-inserting mark) + (mark-left-inserting mark))) + (lambda () + (^G-interceptor ^G-wrapper thunk))))))) + +(define ((^G-wrapper continuation) value) + (cond ((not (eq? (current-window) (typein-window))) (abort-current-command)) + ;; This should NEVER happen. + ((not typein-edit-continuation) (continuation value)) + (else (typein-edit-continuation typein-edit-abort-flag)))) + +(define ((typein-editor-thunk mode)) + (let ((buffer (current-buffer))) + (ring-clear! (buffer-mark-ring buffer)) + (push-current-mark! (buffer-start buffer))) + (set-current-major-mode! mode) + (command-reader)) + +(define (exit-typein-edit) + (if (not typein-edit-continuation) + (error "Not editing typein; can't exit")) + ;; Indicate that typein has been accepted. + ((access home-cursor! window-package) + ((access frame-text-inferior window-package) (current-window))) + (typein-edit-continuation (typein-string))) + +(define (typein-string) + (region->string (buffer-region (current-buffer)))) + +(define (set-typein-string! string #!optional update?) + (if (unassigned? update?) (set! update? true)) + (let ((dont-update? + (or (not update?) + (window-needs-redisplay? (typein-window))))) + (region-delete! (buffer-region (current-buffer))) + (insert-string string) + (if (not dont-update?) (update-typein!)))) + +(define (set-typein-substring! string start end #!optional update?) + (if (unassigned? update?) (set! update? true)) + (let ((dont-update? + (or (not update?) + (window-needs-redisplay? (typein-window))))) + (region-delete! (buffer-region (current-buffer))) + (insert-substring string start end) + (if (not dont-update?) (update-typein!)))) + +;;;; String Prompt + +(define *default-string*) +(define *default-type*) +(define *completion-string-table*) +(define *completion-type*) +(define *pop-up-window*) + +(set! prompt-for-completed-string +(named-lambda (prompt-for-completed-string prompt default-string default-type + completion-string-table + completion-type #!optional mode) + (if (unassigned? mode) (set! mode prompt-for-string-mode)) + (fluid-let ((*default-string* default-string) + (*default-type* default-type) + (*completion-string-table* completion-string-table) + (*completion-type* completion-type) + (*pop-up-window* false)) + (dynamic-wind + (lambda () 'DONE) + (lambda () + (prompt-for-typein + (string-append + prompt + (if (or (memq default-type + '(NO-DEFAULT NULL-DEFAULT INVISIBLE-DEFAULT)) + (not default-string)) + "" + (string-append " (Default is: '" default-string "')")) + ": ") + (typein-editor-thunk mode))) + (lambda () + (if (and *pop-up-window* (window-visible? *pop-up-window*)) + (window-delete! *pop-up-window*) + (let ((buffer (find-buffer " *Completions*"))) + (if buffer + (let ((replacement (other-buffer buffer))) + (for-each (lambda (window) + (select-buffer-in-window replacement window)) + (buffer-windows buffer)) + (bury-buffer buffer)))))))))) + +(define-major-mode "Prompt for String" "Fundamental" + "Major mode for editing solicited input strings. +Depending on what is being solicited, either defaulting or completion +may be available. The following commands are special to this mode: + +\\[^R Terminate Input] terminates the input. +\\[^R Yank Default String] yanks the default string, if there is one. +\\[^R Complete Input] completes as much of the input as possible. +\\[^R Complete Input Space] completes up to the next space. +\\[^R List Completions] displays possible completions of the input." + 'DONE) + +(define-key "Prompt for String" #\Return "^R Terminate Input") +(define-key "Prompt for String" #\C-M-Y "^R Yank Default String") +(define-key "Prompt for String" #\Tab "^R Complete Input") +(define-key "Prompt for String" #\Space "^R Complete Input Space") +(define-key "Prompt for String" #\? "^R List Completions") + +(define-command ("^R Yank Default String" argument) + "Insert the default string at point." + (if *default-string* + (insert-string *default-string*) + (editor-failure))) + +(define-command ("^R Complete Input" argument) + "Attempt to complete the current input string." + (cond ((not *completion-string-table*) + ;; Effectively, this means do what would be done if this + ;; command was not defined by this mode. + (dispatch-on-command (comtab-entry (cdr (current-comtab)) + (current-command-char)))) + ((not (complete-input-string *completion-string-table* true)) + (editor-failure)))) + +(define-command ("^R Complete Input Space" argument) + "Attempt to complete the input string, up to the next space." + (cond ((not *completion-string-table*) + (dispatch-on-command (comtab-entry (cdr (current-comtab)) + (current-command-char)))) + ((not (complete-input-string-to-char *completion-string-table* + #\Space)) + (editor-failure)))) + +(define-command ("^R List Completions" argument) + "List the possible completions for the given input." + (if *completion-string-table* + (list-completions + (string-table-completions *completion-string-table* + (typein-string))) + (^r-insert-self-command))) + +(define (list-completions strings) + (let ((window + (with-output-to-temporary-buffer " *Completions*" + (lambda () + (if (null? strings) + (write-string + "There are no valid completions for this input.") + (begin (write-string "Possible completions:") + (newline) + (write-strings-densely strings))))))) + (if (not *pop-up-window*) + (set! *pop-up-window* window)))) + +(define-command ("^R Terminate Input" argument) + "Terminate the input string. +If defaulting is in effect, and there is no input, use the default. +If completion is in effect, then: + If completion is cautious, return only if the input is completed. + If completion is strict, don't return unless the input completes." + (cond ((string-null? (typein-string)) + (cond ((eq? *default-type* 'NULL-DEFAULT) + (exit-typein-edit)) + ((or (eq? *default-type* 'NO-DEFAULT) + (not *default-string*)) + (if (and (eq? *completion-type* 'STRICT-COMPLETION) + (complete-input-string *completion-string-table* + false)) + (exit-typein-edit) + (begin (update-typein!) + (editor-failure)))) + (else + (set-typein-string! *default-string* false) + (exit-typein-edit)))) + ((eq? *completion-type* 'CAUTIOUS-COMPLETION) + (if (string-table-get *completion-string-table* (typein-string)) + (exit-typein-edit) + (editor-failure))) + ((eq? *completion-type* 'STRICT-COMPLETION) + (if (complete-input-string *completion-string-table* false) + (exit-typein-edit) + (begin (update-typein!) + (editor-failure)))) + (else + (exit-typein-edit)))) + +(define (complete-input-string string-table update?) + (string-table-complete string-table (typein-string) + (lambda (string) + (set-typein-string! string update?)) + (lambda (string limit) + (set-typein-substring! string 0 limit update?)) + (lambda () + 'DONE)) + (string-table-get string-table (typein-string))) + +(define (complete-input-string-to-char string-table char) + (let ((original (typein-string))) + (string-table-complete-to-char string-table original char + (lambda (string limit) + (if (> limit (string-length original)) + (set-typein-substring! string 0 limit)) + true) + (lambda (string limit) + (and (> limit (string-length original)) + (begin (set-typein-substring! string 0 limit) + true))) + (lambda () + false)))) + +(define (string-table-complete-to-char string-table string char if-unambiguous + if-ambiguous if-not-found) + (string-table-complete string-table string + (lambda (new-string) + (if-unambiguous + new-string + (let ((end (string-length new-string))) + (let ((index + (substring-find-next-char new-string (string-length string) + end char))) + (if index + (1+ index) + end))))) + (lambda (new-string limit) + (let ((index (substring-find-next-char new-string (string-length string) + limit char))) + (if index + (if-unambiguous new-string (1+ index)) + (let ((string (string-append-char string char))) + (string-table-complete string-table string + (lambda (new-string) + (if-unambiguous new-string (string-length string))) + (lambda (new-string limit) + (if-ambiguous new-string (string-length string))) + (lambda () + (if-ambiguous new-string limit))))))) + if-not-found)) + +(set! prompt-for-string +(named-lambda (prompt-for-string prompt default-string #!optional default-type) + (if (unassigned? default-type) (set! default-type 'VISIBLE-DEFAULT)) + (prompt-for-completed-string prompt + default-string default-type + false 'NO-COMPLETION))) + +(set! prompt-for-string-table-value +(named-lambda (prompt-for-string-table-value prompt string-table) + (string-table-get string-table + (prompt-for-completed-string prompt + false 'NO-DEFAULT + string-table + 'STRICT-COMPLETION)))) + +(set! prompt-for-alist-value +(named-lambda (prompt-for-alist-value prompt alist) + (prompt-for-string-table-value prompt (alist->string-table alist)))) + +(define ((string-table-prompter string-table) prompt) + (prompt-for-string-table-value prompt string-table)) + +(set! prompt-for-command + (string-table-prompter editor-commands)) + +(set! prompt-for-variable + (string-table-prompter editor-variables)) + +;;;; Character Prompts + +(define ((character-prompter read-char) prompt) + (set-command-prompt! (string-append prompt ": ")) + (let ((char (read-char))) + (set-command-prompt! (string-append (command-prompt) (char->name char))) + char)) + +(set! prompt-for-char-without-interrupts + (character-prompter + (lambda () + (with-editor-interrupts-disabled keyboard-read-char)))) + +(set! prompt-for-char-with-interrupts + (character-prompter + (lambda () + (keyboard-read-char)))) + +(set! prompt-for-char + prompt-for-char-with-interrupts) + +(set! prompt-for-key +(named-lambda (prompt-for-key prompt #!optional comtab) + (if (unassigned? comtab) (set! comtab (current-comtab))) + (let ((string (string-append prompt ": "))) + (define (outer-loop prefix) + (define (inner-loop char) + (let ((chars (append! prefix (list char)))) + (set-command-prompt! (string-append string (xchar->name chars))) + (if (prefix-char-list? comtab chars) + (outer-loop chars) + (let ((command (comtab-entry comtab chars))) + (if (memq command extension-commands) + (inner-loop (fluid-let ((execute-extended-chars? false)) + (dispatch-on-command command))) + chars))))) + (inner-loop (keyboard-read-char))) + (set-command-prompt! string) + (outer-loop '())))) + +;;;; Confirmation Prompts + +(set! prompt-for-confirmation? +(named-lambda (prompt-for-confirmation? prompt) + (define (loop) + (let ((char (char-upcase (keyboard-read-char)))) + (cond ((or (char=? char #\Y) + (char=? char #\Space)) + (set-command-prompt! (string-append (command-prompt) "Yes")) + true) + ((or (char=? char #\N) + (char=? char #\Rubout)) + (set-command-prompt! (string-append (command-prompt) "No")) + false) + (else + (editor-failure) + (loop))))) + (set-command-prompt! (string-append prompt " (Y or N)? ")) + (loop))) + +(set! prompt-for-yes-or-no? +(named-lambda (prompt-for-yes-or-no? prompt) + (string-ci=? + "Yes" + (prompt-for-typein (string-append prompt " (Yes or No)? ") + (typein-editor-thunk prompt-for-yes-or-no-mode))))) + +(define-command ("^R Terminate Yes or No" argument) + "Like ^R Terminate Input, but insists on ``Yes'' or ``No'' as an answer." + (let ((string (typein-string))) + (if (or (string-ci=? "Yes" string) + (string-ci=? "No" string)) + (exit-typein-edit) + (editor-error "Please enter ``Yes'' or ``No''")))) + +(define-major-mode "Prompt for Yes or No" "Fundamental" + "Enter either ``Yes'' or ``No''." + 'DONE) + +(define-key "Prompt for Yes or No" #\Return "^R Terminate Yes or No") + +;;; end PROMPT-PACKAGE +))) + +;;; Edwin Variables: +;;; Scheme Environment: (access prompt-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/reccom.scm b/v7/src/edwin/reccom.scm new file mode 100644 index 000000000..1b79b4657 --- /dev/null +++ b/v7/src/edwin/reccom.scm @@ -0,0 +1,140 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Rectangle Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define rectangle-ring (list 'RECTANGLE)) + +(define (delete-rectangle mark1 mark2 #!optional fill-flag move?) ;mark2 is always "point" + (if (unassigned? fill-flag) (set! fill-flag #!false)) ;where applicable + (if (unassigned? move?) (set! move? #!FALSE)) + (let* ((mark-order (if (mark> mark1 mark2) + (cons mark2 mark1) + (cons mark1 mark2))) + (first (car mark-order)) + (last (cdr mark-order)) + (column-order (let ((c1 (mark-column first)) + (c2 (mark-column last))) + (if (< c1 c2) (cons c1 c2) (cons c2 c1)))) + (column1 (car column-order)) + (column2 (cdr column-order)) + (spacenum (- column2 column1)) + (spacenum$ (make-string spacenum #\space)) + (newl (make-string 1 CHAR:NEWLINE))) + (define (iter line-mark ring-list) + (let ((perm-mark (if line-mark (mark-left-inserting line-mark) #!False))) + (if (or (not perm-mark) (mark> perm-mark last)) + ring-list + (let* ((mark-1 (mark-permanent! (move-to-column perm-mark column1))) + (mark-2 (mark-permanent! (move-to-column perm-mark column2))) + (line$ (extract-string mark-1 mark-2))) + (if (not move?) (delete-string mark-1 mark-2)) + (if fill-flag + (let ((colend (mark-column (line-end mark-1 0)))) + (if (< colend column1) + (set! mark-1 (make-space-to-column column1 mark-1))) + (insert-string spacenum$ mark-1))) + (iter (line-start perm-mark 1) (append ring-list (list line$))))))) + (iter first (list spacenum)))) + +(define-command ("Kill Rectangle" (argument 1)) + "Delete rectangle with corners at point and mark; save as last killed one." + (set-cdr! rectangle-ring (delete-rectangle (current-mark) (current-point)))) + +(define-command ("Delete Rectangle" (argument 1)) + "Delete (don't save) text in rectangle with point and mark as corners. +The same range of columns is deleted in each line +starting with the line where the region begins +and ending with the line where the region ends." + (delete-rectangle (current-mark) (current-point))) + +(define-command ("Open Rectangle" (argument 1)) + "Blank out rectangle with corners at point and mark, shifting text right. +The text previously in the region is not overwritten by the blanks, +but instead winds up to the right of the rectangle." + (delete-rectangle (current-mark) (current-point) #!TRUE #!TRUE)) + +(define-command ("Clear Rectangle" (argument 1)) + "Blank out rectangle with corners at point and mark. +The text previously in the region is overwritten by the blanks." + (delete-rectangle (current-mark) (current-point) #!TRUE)) + +(define (make-space-to-column column mark) ;new make-space-to-column + (mark-permanent! mark) + (change-column column mark) + (line-end mark 0)) + +(define (yank-rectangle rectangle point) + (let ((goal (mark-column point)) + (newline$ (make-string 1 CHAR:NEWLINE))) + (if (null? (cdr rectangle)) + (editor-error "No rectangle to yank.") + (let ((columns (cadr rectangle))) + (define (iter line-mark before-line-mark insert$) + (if (not (null? insert$)) + (let* ((next$ (car insert$)) + (sl (string-length next$)) + (final$ (if (< sl columns) (string-append next$ + (Make-string (- columns sl) #\space)) + next$)) + (end-of-line (if line-mark (mark-left-inserting line-mark) + (let () (insert-newline before-line-mark) + before-line-mark))) + (current-col (mark-column end-of-line))) + (insert-string final$ + (if (< current-col goal) + (make-space-to-column goal end-of-line) + (move-to-column end-of-line goal))) + (iter (line-end end-of-line 1) + end-of-line + (cdr insert$))))) + (iter (line-end point 0) point (cddr rectangle)))))) + +(define-command ("Yank Rectangle" (argument 1)) + "Yank the last killed rectangle with upper left corner at point." + (yank-rectangle rectangle-ring (current-point))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access rectangle-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/regcom.scm b/v7/src/edwin/regcom.scm new file mode 100644 index 000000000..03f87d0d3 --- /dev/null +++ b/v7/src/edwin/regcom.scm @@ -0,0 +1,205 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1987 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. +;;; + +;;;; Register Commands + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +(define register-command-package + (make-environment + +(define-command ("Point to Register" argument) + "Store current location of point in a register." + (set-register! (prompt-for-register "Point to Register") + (make-buffer-position (current-point) (current-buffer)))) + +(define-command ("Register to Point" argument) + "Move point to location stored in a register." + (let ((register (prompt-for-register "Register to Point"))) + (let ((value (get-register register))) + (if (not (buffer-position? value)) + (register-error register "does not contain a buffer position.")) + (select-buffer + (or (buffer-position-buffer value) + (register-error register + "points to a buffer which has been deleted"))) + (set-current-point! (buffer-position-mark value))))) + +(define-command ("Number to Register" argument) + "Store a number in a given register. +With prefix arg, stores that number in the register. +Otherwise, reads digits from the buffer starting at point." + (set-register! (prompt-for-register "Number to Register") + (or argument + (let ((start (current-point)) + (end (skip-chars-forward "[0-9]"))) + (if (mark= start end) + 0 + (with-input-from-region (make-region start end) + read)))))) + +(define-command ("Increment Register" (argument 1)) + "Add the prefix arg to the contents of a given register. +The prefix defaults to one." + (let ((register (prompt-for-register "Increment Register"))) + (let ((value (get-register register))) + (if (not (integer? value)) + (register-error register "does not contain a number")) + (set-register! register (+ value argument))))) + +(define-command ("Copy to Register" argument) + "Copy region into given register. +With prefix arg, delete as well." + (let ((region (current-region))) + (set-register! (prompt-for-register "Copy to Register") + (region->string region)) + (if argument (region-delete! region)))) + +(define-command ("Insert Register" argument) + "Insert contents of given register at point. +Normally puts point before and mark after the inserted text. +With prefix arg, puts mark before and point after." + ((if argument unkill-reversed unkill) + (let ((value (get-register (prompt-for-register "Insert Register")))) + (cond ((string? value) value) + ((integer? value) (write-to-string value)) + (else (register-error "does not contain text")))))) + +(define-command ("Append to Register" argument) + "Append region to text in given register. +With prefix arg, delete as well." + (let ((region (current-region)) + (register (prompt-for-register "Append to Register"))) + (let ((value (get-register register))) + (if (not (string? value)) + (register-error register "does not contain text")) + (set-register! register (string-append value (region->string region)))) + (if argument (region-delete! region)))) + +(define-command ("Prepend to Register" argument) + "Prepend region to text in given register. +With prefix arg, delete as well." + (let ((region (current-region)) + (register (prompt-for-register "Prepend to Register"))) + (let ((value (get-register register))) + (if (not (string? value)) + (editor-error register "does not contain text")) + (set-register! register (string-append (region->string region) value))) + (if argument (region-delete! region)))) + +(define-command ("View Register" argument) + "Display what is contained in a given register." + (let ((register (prompt-for-register "View Register"))) + (let ((value (get-register register))) + (if (not value) + (message "Register " (register-name register) " is empty") + (with-output-to-temporary-buffer "*Output*" + (lambda () + (write-string "Register ") + (write-string (register-name register)) + (write-string " contains ") + (cond ((integer? value) + (write value)) + ((string? value) + (write-string "the string:\n") + (write-string value)) + ((buffer-position? value) + (let ((buffer (buffer-position-buffer value))) + (if (not buffer) + (write-string "an invalid buffer position") + (begin + (write-string "a buffer position:\nbuffer ") + (write-string (buffer-name buffer)) + (write-string ", position ") + (write + (mark-index (buffer-position-mark value))))))) + (else + (write-string "a random object:\n") + (write value))))))))) + +(define prompt-for-register + prompt-for-char) + +(define (register-error register . strings) + (apply editor-error "Register " (register-name register) " " strings)) + +(define register-name + char->name) + +(define (get-register char) + (let ((entry (assv char register-alist))) + (and entry + (cdr entry)))) + +(define (set-register! char value) + (let ((entry (assv char register-alist))) + (if entry + (set-cdr! entry value) + (set! register-alist + (cons (cons char value) + register-alist))))) + +(define register-alist + '()) + +(define (make-buffer-position mark buffer) + (cons buffer-position-tag (cons mark (hash buffer)))) + +(define (buffer-position? object) + (and (pair? object) + (eq? buffer-position-tag (car object)))) + +(define buffer-position-tag + "Buffer Position") + +(define buffer-position-mark + cadr) + +(define (buffer-position-buffer position) + (unhash (cddr position))) + +;;; end REGISTER-COMMAND-PACKAGE +)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access register-command-package edwin-package) +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; End: diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm new file mode 100644 index 000000000..656816181 --- /dev/null +++ b/v7/src/edwin/regexp.scm @@ -0,0 +1,334 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Regular Expressions + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define char-search-forward) +(define search-forward) +(define re-search-forward) +(define char-search-backward) +(define search-backward) +(define re-search-backward) +(define char-match-forward) +(define match-forward) +(define re-match-forward) +(define char-match-backward) +(define match-backward) +(define re-match-start) +(define re-match-end) + +(define regular-expression-package + (make-environment + (let-syntax () + +(define-macro (define-search name key-name searcher compile-key + mark-limit mark-compare) + `(SET! ,name + (NAMED-LAMBDA (,name ,key-name #!OPTIONAL START END LIMIT?) + (COND ((UNASSIGNED? START) + (SET! START (CURRENT-POINT)) + (SET! END (,mark-limit START)) + (SET! LIMIT? #!FALSE)) + ((UNASSIGNED? END) + (SET! END (,mark-limit START)) + (SET! LIMIT? #!FALSE)) + (ELSE + (IF (NOT (,mark-compare START END)) + (ERROR ,(string-append (symbol->string name) + ": Marks incorrectly related") + START END)) + (IF (UNASSIGNED? LIMIT?) (SET! LIMIT? #!FALSE)))) + (OR (,searcher (MARK-GROUP START) + (MARK-INDEX START) + (MARK-INDEX END) + (,compile-key ,key-name)) + (LIMIT-MARK-MOTION LIMIT? END))))) + +(define-macro (make-primitive name) + (make-primitive-procedure name)) + +(define match-group) +(define registers (make-vector 20)) + +(set! re-match-start +(named-lambda (re-match-start i) + (if (or (negative? i) (> i 9)) + (error "RE-MATCH-START: No such register" i) + (let ((group (unhash match-group))) + (if (not group) + (error "RE-MATCH-START: No match registers" i) + (make-mark group (vector-ref registers i))))))) + +(set! re-match-end +(named-lambda (re-match-end i) + (if (or (negative? i) (> i 9)) + (error "RE-MATCH-END: No such register" i) + (let ((group (unhash match-group))) + (if (not group) + (error "RE-MATCH-END: No match registers" i) + (make-mark group (vector-ref registers (+ i 10)))))))) + +(define (%re-finish group index) + (if index + (begin (set! match-group (hash group)) + (make-mark group index)) + (begin (set! match-group (hash #!FALSE)) + #!FALSE))) + +(define pattern-cache + (make-list 32 '(foo . bar))) + +(define (compile-pattern regexp) + ;; Incredible hair here to prevent excessive consing. + ((if (ref-variable "Case Fold Search") cdr car) + (cdr (or (assq regexp pattern-cache) + (begin (set! pattern-cache + (cons (cons regexp + (cons (re-compile-pattern regexp #!FALSE) + (re-compile-pattern regexp #!TRUE))) + (except-last-pair! pattern-cache))) + (car pattern-cache)))))) + +(define (compile-char char) + (re-compile-char char (ref-variable "Case Fold Search"))) + +(define (compile-string string) + (re-compile-string string (ref-variable "Case Fold Search"))) + +;;;; Search + +(define-search char-search-forward char + %re-search-forward compile-char group-end mark<=) + +(define-search search-forward string + %re-search-forward compile-string group-end mark<=) + +(define-search re-search-forward regexp + %re-search-forward compile-pattern group-end mark<=) + +(define (%re-search-forward group start end pattern) + (%re-finish group + (%%re-search-forward pattern + (re-translation-table + (ref-variable "Case Fold Search")) + (ref-variable "Syntax Table") + registers + group start end))) + +(define %%re-search-forward + (make-primitive re-search-forward)) + +(define-search char-search-backward char + %re-search-backward compile-char group-start mark>=) + +(define-search search-backward string + %re-search-backward compile-string group-start mark>=) + +(define-search re-search-backward regexp + %re-search-backward compile-pattern group-start mark>=) + +(define (%re-search-backward group start end pattern) + (%re-finish group + (%%re-search-backward pattern + (re-translation-table + (ref-variable "Case Fold Search")) + (ref-variable "Syntax Table") + registers + group end start))) + +(define %%re-search-backward + (make-primitive re-search-backward)) + +;;;; Match + +(define-macro (define-forward-match name key-name compile-key) + `(SET! ,name + (NAMED-LAMBDA (,name ,key-name #!OPTIONAL START END) + (COND ((UNASSIGNED? START) + (SET! START (CURRENT-POINT)) + (SET! END (GROUP-END START))) + ((UNASSIGNED? END) + (SET! END (GROUP-END START))) + ((NOT (MARK<= START END)) + (ERROR ,(string-append (symbol->string name) + ": Marks incorrectly related") + START END))) + (%RE-MATCH-FORWARD (MARK-GROUP START) + (MARK-INDEX START) + (MARK-INDEX END) + (,compile-key ,key-name))))) + +(define-forward-match char-match-forward char compile-char) +(define-forward-match match-forward string compile-string) +(define-forward-match re-match-forward regexp compile-pattern) + +(define (%re-match-forward group start end pattern) + (%re-finish group + (%%re-match-forward pattern + (re-translation-table + (ref-variable "Case Fold Search")) + (ref-variable "Syntax Table") + registers + group start end))) + +(define %%re-match-forward + (make-primitive re-match)) + +(set! char-match-backward +(named-lambda (char-match-backward char #!optional start end) + (cond ((unassigned? start) + (set! start (current-point)) + (set! end (group-start start))) + ((unassigned? end) + (set! end (group-start start))) + ((not (mark>= start end)) + (error "CHAR-MATCH-BACKWARD: Marks incorrectly related" start end))) + (%re-match-backward (mark-group start) + (mark-index start) + (-1+ (mark-index start)) + (mark-index end) + (compile-char char)))) + +(set! match-backward +(named-lambda (match-backward string #!optional start end) + (cond ((unassigned? start) + (set! start (current-point)) + (set! end (group-start start))) + ((unassigned? end) + (set! end (group-start start))) + ((not (mark>= start end)) + (error "MATCH-BACKWARD: Marks incorrectly related" start end))) + (%re-match-backward (mark-group start) + (mark-index start) + (- (mark-index start) (string-length string)) + (mark-index end) + (compile-string string)))) + +(define (%re-match-backward group start mark end pattern) + (and (<= end mark) + (%re-match-forward group mark start pattern) + mark)) + +;;; end REGULAR-EXPRESSION-PACKAGE +))) + +;;;; Quote + +(define re-quote-string + (let ((special (char-set #\[ #\] #\* #\. #\\ #\? #\+ #\^ #\$))) + (named-lambda (re-quote-string string) + (let ((end (string-length string))) + (define (count start n) + (let ((index (substring-find-next-char-in-set string start end + special))) + (if index + (count (1+ index) (1+ n)) + n))) + (let ((n (count 0 0))) + (if (zero? n) + string + (let ((result (string-allocate (+ end n)))) + (define (loop start i) + (let ((index + (substring-find-next-char-in-set string start end + special))) + (if index + (begin (substring-move-right! string start index + result i) + (let ((i (+ i (- index start)))) + (string-set! result i #\\) + (string-set! result (1+ i) + (string-ref string index)) + (loop (1+ index) (+ i 2)))) + (substring-move-right! string start end result i)))) + (loop 0 0) + result))))))) + +;;;; Char Skip + +(define (skip-chars-forward pattern #!optional start end limit?) + (cond ((unassigned? start) + (set! start (current-point)) + (set! end (group-end start)) + (set! limit? 'LIMIT)) + ((unassigned? end) + (set! end (group-end start)) + (set! limit? 'LIMIT)) + (else + (if (not (mark<= start end)) + (error "SKIP-CHARS-FORWARD: Marks incorrectly related" start end)) + (if (unassigned? limit?) (set! limit? 'LIMIT)))) + (let ((index + (%find-next-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + (re-compile-char-set pattern #!TRUE)))) + (if index + (make-mark (mark-group start) index) + (limit-mark-motion limit? end)))) + +(define (skip-chars-backward pattern #!optional start end limit?) + (cond ((unassigned? start) + (set! start (current-point)) + (set! end (group-start start)) + (set! limit? 'LIMIT)) + ((unassigned? end) + (set! end (group-start start)) + (set! limit? 'LIMIT)) + (else + (if (not (mark>= start end)) + (error "SKIP-CHARS-FORWARD: Marks incorrectly related" start end)) + (if (unassigned? limit?) (set! limit? 'LIMIT)))) + (let ((index + (%find-previous-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + (re-compile-char-set pattern #!TRUE)))) + (if index + (make-mark (mark-group start) index) + (limit-mark-motion limit? end)))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/regops.scm b/v7/src/edwin/regops.scm new file mode 100644 index 000000000..c1131c776 --- /dev/null +++ b/v7/src/edwin/regops.scm @@ -0,0 +1,404 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Operations on Groups + +(declare (usual-integrations) + (integrate-external "edb:struct.bin.0")) + +;;;; Region/Mark Operations + +;;; These operations are high level, easy to use, but slow compared to +;;; the direct group operations below. They also cons marks, which +;;; may be a consideration under certain circumstances. + +(define (string->region string) + (group-region (make-group (string-copy string)))) + +(define (substring->region string start end) + (group-region (make-group (substring string start end)))) + +(define (region-insert! mark region) + (let ((string (region->string region)) + (group (mark-group mark)) + (start (mark-index mark))) + (let ((n (string-length string))) + (group-insert-substring! group start string 0 n) + (%make-region (%make-temporary-mark group start #!FALSE) + (%make-temporary-mark group (+ start n) #!TRUE))))) + +(define (region-insert-string! mark string) + (group-insert-substring! (mark-group mark) (mark-index mark) + string 0 (string-length string))) + +(define (region-insert-substring! mark string start end) + (group-insert-substring! (mark-group mark) (mark-index mark) + string start end)) + +(define (region-insert-newline! mark) + (group-insert-char! (mark-group mark) (mark-index mark) char:newline)) + +(define (region-insert-char! mark char) + (group-insert-char! (mark-group mark) (mark-index mark) char)) + +(define (region->string region) + (group-extract-string (region-group region) + (region-start-index region) + (region-end-index region))) + +(define (region-delete! region) + (group-delete! (region-group region) + (region-start-index region) + (region-end-index region))) + +(define (region-extract! region) + (let ((group (region-group region)) + (start (region-start-index region)) + (end (region-end-index region))) + (let ((string (group-extract-string group start end))) + (group-delete! group start end) + (group-region (make-group string))))) + +(define (region-copy region) + (string->region (region->string region))) + +(define (mark-left-char mark) + (if (group-start? mark) + (error "No left char: MARK-LEFT-CHAR" mark) + (group-left-char (mark-group mark) (mark-index mark)))) + +(define (mark-right-char mark) + (if (group-end? mark) + (error "No right char: MARK-RIGHT-CHAR" mark) + (group-right-char (mark-group mark) (mark-index mark)))) + +(define (mark-delete-left-char! mark) + (if (group-start? mark) + (error "No left char: MARK-DELETE-LEFT-CHAR!" mark) + (group-delete-left-char! (mark-group mark) (mark-index mark)))) + +(define (mark-delete-right-char! mark) + (if (group-end? mark) + (error "No right char: MARK-DELETE-RIGHT-CHAR!" mark) + (group-delete-right-char! (mark-group mark) (mark-index mark)))) + +;;; **** This is not a great thing to do. It will screw up any marks +;;; that are within the region, pushing them to either side. +;;; Conceptually we just want the characters to be altered. + +(define (region-transform! region operation) + (let ((m (mark-permanent! (region-start region)))) + (let ((string (operation (region->string region)))) + (region-delete! region) + (region-insert-string! m string)))) + +;;;; Clipping + +(define (region-clip! region) + (let ((group (region-group region)) + (start (mark-right-inserting (region-start region))) + (end (mark-left-inserting (region-end region)))) + (record-clipping! group (mark-index start) (mark-index end)) + (vector-set! group group-index:start-mark start) + (vector-set! group group-index:end-mark end) + (vector-set! group group-index:display-start start) + (vector-set! group group-index:display-end end))) + +(define (group-un-clip! group) + (let ((start (%make-permanent-mark group 0 #!FALSE)) + (end (%make-permanent-mark group (group-length group) #!TRUE))) + (record-clipping! group 0 (group-length group)) + (vector-set! group group-index:start-mark start) + (vector-set! group group-index:end-mark end) + (vector-set! group group-index:display-start start) + (vector-set! group group-index:display-end end))) + +(define (with-region-clipped! new-region thunk) + (let ((group (region-group new-region)) + (old-region)) + (dynamic-wind (lambda () + (set! old-region (group-region group)) + (region-clip! (set! new-region))) + thunk + (lambda () + (set! new-region (group-region group)) + (region-clip! (set! old-region)))))) + +(define (without-group-clipped! group thunk) + (define old-region) + (dynamic-wind (lambda () + (set! old-region (group-region group)) + (group-un-clip! group)) + thunk + (lambda () + (region-clip! (set! old-region))))) + +(define (group-clipped? group) + (not (and (zero? (group-start-index group)) + (= (group-end-index group) (group-length group))))) + +(define (group-unclipped-region group) + (make-region (make-mark group 0) + (make-mark group (group-length group)))) + +;;;; Group Operations + +;;; These high-performance ops deal directly with groups and indices +;;; for speed and the least consing. Since indices are not in general +;;; valid across modifications to the group, they can only be used in +;;; limited ways. To save an index across a modification, it must be +;;; consed into a permanent mark. + +(define (group-extract-string group start end) + (let ((text (group-text group)) + (gap-start (group-gap-start group)) + (length (group-gap-length group))) + (cond ((<= end gap-start) + (substring text start end)) + ((>= start gap-start) + (substring text (+ start length) (+ end length))) + (else + (let ((string (string-allocate (- end start)))) + (substring-move-right! text start gap-start string 0) + (substring-move-right! text (group-gap-end group) (+ end length) + string (- gap-start start)) + string))))) + +(define (group-insert-string! group index string) + (group-insert-substring! group index string 0 (string-length string))) + +(define (group-left-char group index) + (string-ref (group-text group) + (-1+ (group-index->position group index #!FALSE)))) + +(define (group-right-char group index) + (string-ref (group-text group) + (group-index->position group index #!TRUE))) + +(define (group-delete-left-char! group index) + (group-delete! group (-1+ index) index)) + +(define (group-delete-right-char! group index) + (group-delete! group index (1+ index))) + +;;; This parameter controls how much extra space (in characters) is +;;; allocated when the gap is too small to contain a given insertion. +(define gap-allocation-extra 2000) + +(define group-insert-char!) +(define %group-insert-char!) +(define group-insert-substring!) +(define %group-insert-substring!) +(define group-delete!) +(define group-operations-package) +(let () + +(set! group-operations-package + (the-environment)) + +(set! group-insert-char! +(named-lambda (group-insert-char! group index char) + (without-interrupts + (lambda () + (group-insert-char-kernel group index char) + (record-insertion! group index (group-gap-start group)))))) + +(set! %group-insert-char! +(named-lambda (%group-insert-char! group index char) + (without-interrupts + (lambda () + (group-insert-char-kernel group index char))))) + +(set! group-insert-substring! +(named-lambda (group-insert-substring! group index string start end) + (without-interrupts + (lambda () + (group-insert-substring-kernel group index string start end) + (record-insertion! group index (group-gap-start group)))))) + +(set! %group-insert-substring! +(named-lambda (%group-insert-substring! group index string start end) + (without-interrupts + (lambda () + (group-insert-substring-kernel group index string start end))))) + +(declare (integrate group-insert-char-kernel group-insert-substring-kernel)) + +(define (group-insert-char-kernel group index char) + (declare (integrate group index char)) + (barf-if-read-only group) + (move-gap-to! group index) + (guarantee-gap-length! group 1) + (string-set! (group-text group) index char) + (vector-set! group group-index:gap-length (-1+ (group-gap-length group))) + (let ((gap-start* (1+ index))) + (vector-set! group group-index:gap-start gap-start*) + (undo-record-insertion! group index gap-start*))) + +(define (group-insert-substring-kernel group index string start end) + (declare (integrate group index string start end)) + (barf-if-read-only group) + (move-gap-to! group index) + (let ((n (- end start))) + (guarantee-gap-length! group n) + (substring-move-right! string start end (group-text group) index) + (vector-set! group group-index:gap-length (- (group-gap-length group) n)) + (let ((gap-start* (+ index n))) + (vector-set! group group-index:gap-start gap-start*) + (undo-record-insertion! group index gap-start*)))) + +(set! group-delete! +(named-lambda (group-delete! group start end) + (without-interrupts + (lambda () + (if (not (= start end)) + (begin (barf-if-read-only group) + (let ((gap-start (group-gap-start group)) + (new-end (+ end (group-gap-length group)))) + ;; Guarantee that the gap is between START and END. + (cond ((< gap-start start) + (move-gap-to-right! group start)) + ((> gap-start end) + (move-gap-to-left! group end))) + (undo-record-deletion! group start end) + (record-deletion! group start end) + ;; Clear out any marks. + (for-each-mark group + (lambda (mark) + (let ((position (mark-position mark))) + (if (and (<= start position) + (<= position new-end)) + (%set-mark-position! + mark + (if (mark-left-inserting? mark) + new-end + start)))))) + ;; Widen the gap to the new boundaries. + (vector-set! group group-index:gap-start start) + (vector-set! group group-index:gap-end new-end) + (vector-set! group group-index:gap-length + (- new-end start))))))))) + +(declare (integrate barf-if-read-only)) +(define (barf-if-read-only group) + (declare (integrate group)) + (if (group-read-only? group) + (editor-error "Trying to modify read only text."))) + +;;;; The Gap + +(define (move-gap-to! group index) + (let ((gap-start (group-gap-start group))) + (cond ((< index gap-start) + (move-gap-to-left! group index)) + ((> index gap-start) + (move-gap-to-right! group index))))) + +(define (move-gap-to-left! group new-start) + (let ((start (group-gap-start group)) + (length (group-gap-length group)) + (text (group-text group))) + (let ((new-end (+ new-start length))) + (for-each-mark group + (lambda (mark) + (let ((position (mark-position mark))) + (cond ((and (< new-start position) + (<= position start)) + (%set-mark-position! mark (+ position length))) + ((and (mark-left-inserting? mark) + (= new-start position)) + (%set-mark-position! mark new-end)))))) + (substring-move-right! text new-start start text new-end) + (vector-set! group group-index:gap-start new-start) + (vector-set! group group-index:gap-end new-end)))) + +(define (move-gap-to-right! group new-start) + (let ((start (group-gap-start group)) + (end (group-gap-end group)) + (length (group-gap-length group)) + (text (group-text group))) + (let ((new-end (+ new-start length))) + (for-each-mark group + (lambda (mark) + (let ((position (mark-position mark))) + (cond ((and (> new-end position) + (>= position end)) + (%set-mark-position! mark (- position length))) + ((and (not (mark-left-inserting? mark)) + (= new-end position)) + (%set-mark-position! mark new-start)))))) + (substring-move-left! text end new-end text start) + (vector-set! group group-index:gap-start new-start) + (vector-set! group group-index:gap-end new-end)))) + +(define (guarantee-gap-length! group n) + (if (< (group-gap-length group) n) + (let ((n (+ n gap-allocation-extra)) + (text (group-text group)) + (start (group-gap-start group)) + (end (group-gap-end group)) + (length (group-gap-length group))) + (let ((end* (string-length text))) + (let ((text* (string-allocate (+ end* n))) + (new-end (+ end n))) + (substring-move-right! text 0 start text* 0) + (substring-move-right! text end end* text* new-end) + (vector-set! group group-index:text text*) + (vector-set! group group-index:gap-end new-end) + (if (zero? length) + (for-each-mark group + (lambda (mark) + (let ((position (mark-position mark))) + (cond ((> position end) + (%set-mark-position! mark (+ position n))) + ((= position end) + (%set-mark-position! + mark + (if (mark-left-inserting? mark) + new-end start))))))) + (for-each-mark group + (lambda (mark) + (let ((position (mark-position mark))) + (if (>= position end) + (%set-mark-position! mark (+ position n))))))))) + (vector-set! group group-index:gap-length (+ length n))))) + +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; End: diff --git a/v7/src/edwin/replaz.scm b/v7/src/edwin/replaz.scm new file mode 100644 index 000000000..da170af61 --- /dev/null +++ b/v7/src/edwin/replaz.scm @@ -0,0 +1,251 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Replacement Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-variable "Replace String Search" + "The last string that a replacement command searched for." + false) + +(define-variable "Replace String Replace" + "The last string that a replacement command replaced with." + false) + +(define-variable "Case Replace" + "If not false, means replacement commands should preserve case." + true) + +(define-command ("Replace String" argument) + "Replace occurrences of a given string with another one. +Preserve case in each match if Case Replace and Case Fold Search +are true and the given strings have no uppercase letters. +With an argument, replace only matches surrounded by word boundaries." + (interactive-replace-string "Replace String" argument false)) + +(define-command ("Query Replace" argument) + "Replace some occurrences of a given string with another one. +As each match is found, the user must type a character saying +what to do with it. +Type C-H within Query Replace for directions. + +Preserve case in each match if Case Replace and Case Fold Search +are true and the given strings have no uppercase letters. +With an argument, replace only matches surrounded by word boundaries." + (interactive-replace-string "Query Replace" argument true)) + +(define (interactive-replace-string name replace-words-only? query?) + (replace-string-arguments name + (replace-string name replace-words-only? query? + true))) + +(define (replace-string-arguments name receiver) + (let ((source + (prompt-for-string name + (ref-variable "Replace String Search") + 'VISIBLE-DEFAULT))) + (let ((target + (prompt-for-string "Replace with" + (ref-variable "Replace String Replace") + 'NULL-DEFAULT))) + (set-variable! "Replace String Search" source) + (set-variable! "Replace String Replace" target) + (receiver source target)))) + +(define ((replace-string name replace-words-only? query? clear-on-exit?) + source target) + ;; Returns TRUE iff the query loop was exited at the user's request, + ;; FALSE iff the loop finished by failing to find an occurrence. + (let ((preserve-case? (and (ref-variable "Case Replace") + (ref-variable "Case Fold Search") + (string-lower-case? source) + (not (string-null? target)) + (string-lower-case? target))) + (upper (delay (string-upcase target))) + (capital (delay (string-capitalize target))) + (words-only-source + (delay (string-append "\\b" (re-quote-string source) "\\b"))) + (message-string + (string-append name ": " (write-to-string source) + " => " (write-to-string target))) + (old-notification (ref-variable "Auto Push Point Notification"))) + + (define (find-next-occurrence start receiver) + (if (if replace-words-only? + (re-search-forward (force words-only-source) start) + (search-forward source start)) + (receiver (re-match-start 0) (re-match-end 0)) + (begin (if clear-on-exit? (clear-message)) + false))) + + (define (query-loop start end) + (undo-boundary! end) + (push-current-mark! start) + (find-next-occurrence end + (lambda (start end) + (set-current-point! end) + (perform-query (mark-right-inserting start) + (current-point) + false)))) + + (define (replacement-loop start) + (undo-boundary! start) + (find-next-occurrence start + (lambda (start end) + (let ((end (mark-left-inserting end))) + (perform-replacement start end) + (replacement-loop end))))) + + (define (perform-replacement start end) + (let ((replaced (extract-string start end))) + (delete-string start end) + (insert-string (cond ((not preserve-case?) target) + ((string-upper-case? replaced) (force upper)) + ((string-capitalized? replaced) + (force capital)) + (else target)) + end))) + + (define (edit) + (fluid-let (((ref-variable "Auto Push Point Notification") + old-notification)) + (clear-message) + (enter-recursive-edit) + (set-message))) + + (define (set-message) + (message message-string)) + + (define (perform-query start end replaced?) + (let ((char (char-upcase (keyboard-read-char)))) + (cond ((char=? #\Space char) + (if (not replaced?) (perform-replacement start end)) + (query-loop start end)) + ((char=? #\Rubout char) + (query-loop start end)) + ((char=? #\Altmode char) + (if clear-on-exit? (clear-message)) + true) + ((char=? #\. char) + (if (not replaced?) (perform-replacement start end)) + (if clear-on-exit? (clear-message)) + true) + ((char=? #\, char) + (if (not replaced?) (perform-replacement start end)) + (perform-query start end true)) + ((char=? #\C-R char) + (edit) + (perform-query start end replaced?)) + ((char=? #\C-W char) + (if (not replaced?) (delete-string start end)) + (edit) + (query-loop start end)) + ((char=? #\! char) + (if (not replaced?) (perform-replacement start end)) + (replacement-loop end)) + ((char=? #\^ char) + (set-current-point! (pop-current-mark!)) + (perform-query (current-mark) (current-mark) true)) + ((or (char=? #\C-H char) (char=? #\Backspace char)) + (with-output-to-help-display + (lambda () + (write-string "Query replacing ") + (write source) + (write-string " with ") + (write target) + (write-string ". + +Type space to replace one match, Rubout to skip to next, +Altmode to exit, Period to replace one match and exit, +Comma to replace but not move point immediately, +C-R to enter recursive edit, C-W to delete match and recursive edit, +! to replace all remaining matches with no more questions, +^ to move point back to previous match."))) + (perform-query start end replaced?)) + (else + (if clear-on-exit? (clear-message)) + (execute-char (current-comtab) char) + true)))) + + (set-message) + (let ((point (current-point))) + (if query? + (fluid-let (((ref-variable "Auto Push Point Notification") false)) + (query-loop point point)) + (replacement-loop point))))) + +;;;; Occurrence Commands + +(define-command ("Count Occurrences" argument) + "Print the number of occurrences of a given regexp following point." + (let ((regexp (prompt-for-string "Count Occurrences (regexp)" false))) + (define (loop start n) + (let ((mark (re-search-forward regexp start))) + (if (not mark) + (message (write-to-string n) " occurrences") + (loop mark (1+ n))))) + (loop (current-point) 0))) + +(define-command ("List Occurrences" (argument 0)) + "Show all lines containing a given regexp following point. +The argument, if given, is the number of context lines to show + on either side of each line; this defaults to zero." + (let ((regexp (prompt-for-string "List Occurrences (regexp)" false)) + (-arg (- argument)) + (1+arg (1+ argument))) + (with-output-to-temporary-buffer "*Occur*" + (lambda () + (define (loop start) + (let ((mark (re-search-forward regexp start))) + (if mark + (begin (write-string (extract-string (line-start mark -arg) + (line-start mark 1+arg))) + (write-string "--------") + (newline) + (loop (line-start mark 1)))))) + (loop (current-point)))))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/ring.scm b/v7/src/edwin/ring.scm new file mode 100644 index 000000000..ecaffe9ab --- /dev/null +++ b/v7/src/edwin/ring.scm @@ -0,0 +1,112 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1984 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. +;;; + +;;;; Rings + +(declare (usual-integrations)) + +(define (ring-list ring) + (vector-ref ring 2)) + +(define make-ring) +(define ring-size) +(define ring-clear!) +(define ring-empty?) +(define ring-push!) +(define ring-pop!) +(define ring-ref) +(define ring-set!) +(let () + +(define (list-ref l i) + (cond ((null? l) (error "Index too large" 'LIST-REF)) + ((zero? i) (car l)) + (else (list-ref (cdr l) (-1+ i))))) + +(define (list-set! l i o) + (define (loop l i) + (cond ((null? l) (error "Index too large" 'LIST-SET!)) + ((zero? i) (set-car! l o)) + (else (list-ref (cdr l) (-1+ i))))) + (loop l i)) + +(define (list-truncate! l i) + (cond ((null? l) 'DONE) + ((= i 1) (set-cdr! l '())) + (else (list-truncate! (cdr l) (-1+ i))))) + +(set! make-ring +(named-lambda (make-ring size) + (if (< size 1) + (error "Ring size too small" size) + (vector "Ring" size '())))) + +(set! ring-size +(named-lambda (ring-size ring) + (length (vector-ref ring 2)))) + +(set! ring-clear! +(named-lambda (ring-clear! ring) + (vector-set! ring 2 '()))) + +(set! ring-empty? +(named-lambda (ring-empty? ring) + (null? (vector-ref ring 2)))) + +(set! ring-push! +(named-lambda (ring-push! ring object) + (vector-set! ring 2 (cons object (vector-ref ring 2))) + (list-truncate! (vector-ref ring 2) (vector-ref ring 1)))) + +(set! ring-pop! +(named-lambda (ring-pop! ring) + (let ((l (vector-ref ring 2))) + (if (null? l) + (error "Ring empty" ring) + (let ((object (car l))) + (vector-set! ring 2 (append! (cdr l) (list object))) + object))))) + +(set! ring-ref +(named-lambda (ring-ref ring index) + (list-ref (vector-ref ring 2) (remainder index (ring-size ring))))) + +(set! ring-set! +(named-lambda (ring-set! ring index object) + (list-set! (vector-ref ring 2) (remainder index (ring-size ring)) object))) + +) \ No newline at end of file diff --git a/v7/src/edwin/schmod.scm b/v7/src/edwin/schmod.scm new file mode 100644 index 000000000..26d8bc960 --- /dev/null +++ b/v7/src/edwin/schmod.scm @@ -0,0 +1,207 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Scheme Mode + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Scheme Mode" argument) + "Enter Scheme mode." + (set-current-major-mode! scheme-mode)) + +(define-major-mode "Scheme" "Fundamental" + "Major mode specialized for editing Scheme code. +Tab indents the current line for Scheme. +\\[^R Indent Sexp] indents the next s-expression. + +\\[^R Evaluate Previous Sexp into Buffer] evaluates the expression preceding point. + All output is inserted into the buffer at point. +\\[^R Evaluate Sexp Typein] reads and evaluates an expression in the typein window. + +The following evaluation commands keep a transcript of all output in +the buffer *Transcript*: + +\\[^R Evaluate Definition] evaluates the current definition. +\\[^R Evaluate Buffer] evaluates the buffer. +\\[^R Evaluate Sexp] evaluates the expression following point. +\\[^R Evaluate Previous Sexp] evaluates the expression preceding point. +\\[^R Evaluate Region] evaluates the current region." + + (local-set-variable! "Syntax Table" scheme-mode:syntax-table) + (local-set-variable! "Syntax Ignore Comments Backwards" #!FALSE) + (local-set-variable! "Lisp Indent Hook" + (access standard-lisp-indent-hook + lisp-indentation-package)) + (local-set-variable! "Lisp Indent Methods" scheme-mode:indent-methods) + (local-set-variable! "Comment Column" 40) + (local-set-variable! "Comment Locator Hook" + (access lisp-comment-locate lisp-indentation-package)) + (local-set-variable! "Comment Indent Hook" + (access lisp-comment-indentation + lisp-indentation-package)) + (local-set-variable! "Comment Start" ";") + (local-set-variable! "Comment End" "") + (local-set-variable! "Paragraph Start" "^$") + (local-set-variable! "Paragraph Separate" (ref-variable "Paragraph Start")) + (local-set-variable! "Indent Line Procedure" ^r-indent-for-lisp-command) + (if (ref-variable "Scheme Mode Hook") ((ref-variable "Scheme Mode Hook")))) + +(define-variable "Scheme Mode Hook" + "If not false, a thunk to call when entering Scheme mode." + #!FALSE) + +(define-key "Scheme" #\Rubout "^R Backward Delete Hacking Tabs") +(define-key "Scheme" #\) "^R Lisp Insert Paren") +(define-key "Scheme" #\M-O "^R Evaluate Buffer") +(define-key "Scheme" #\M-Z "^R Evaluate Definition") +(define-key "Scheme" #\C-M-= "^R Evaluate Previous Sexp into Buffer") +(define-key "Scheme" #\C-M-Q "^R Indent Sexp") +(define-key "Scheme" #\C-M-X "^R Evaluate Sexp") +(define-key "Scheme" #\C-M-Z "^R Evaluate Region") + +;;;; Read Syntax + +(define scheme-mode:syntax-table (make-syntax-table)) + +(modify-syntax-entries! scheme-mode:syntax-table #\C-\@ #\/ "_ ") +(modify-syntax-entries! scheme-mode:syntax-table #\: #\@ "_ ") +(modify-syntax-entries! scheme-mode:syntax-table #\[ #\` "_ ") +(modify-syntax-entries! scheme-mode:syntax-table #\{ #\Rubout "_ ") + +(modify-syntax-entry! scheme-mode:syntax-table #\Space " ") +(modify-syntax-entry! scheme-mode:syntax-table #\Tab " ") +(modify-syntax-entry! scheme-mode:syntax-table #\Page " ") +(modify-syntax-entry! scheme-mode:syntax-table #\[ " ") +(modify-syntax-entry! scheme-mode:syntax-table #\] " ") +(modify-syntax-entry! scheme-mode:syntax-table #\{ " ") +(modify-syntax-entry! scheme-mode:syntax-table #\} " ") +(modify-syntax-entry! scheme-mode:syntax-table #\| " 23") + +(modify-syntax-entry! scheme-mode:syntax-table #\; "< ") +(modify-syntax-entry! scheme-mode:syntax-table char:newline "> ") + +(modify-syntax-entry! scheme-mode:syntax-table #\' "' ") +(modify-syntax-entry! scheme-mode:syntax-table #\` "' ") +(modify-syntax-entry! scheme-mode:syntax-table #\, "' ") +(modify-syntax-entry! scheme-mode:syntax-table #\@ "' ") +(modify-syntax-entry! scheme-mode:syntax-table #\# "' 14") + +(modify-syntax-entry! scheme-mode:syntax-table #\" "\" ") +(modify-syntax-entry! scheme-mode:syntax-table #\\ "\\ ") +(modify-syntax-entry! scheme-mode:syntax-table #\( "() ") +(modify-syntax-entry! scheme-mode:syntax-table #\) ")( ") + +;;;; Indentation + +(define (scheme-mode:indent-let-method state indent-point normal-indent) + ((access lisp-indent-special-form lisp-indentation-package) + (let ((m (parse-state-containing-sexp state))) + (let ((start (forward-to-sexp-start (forward-one-sexp (mark1+ m) + indent-point) + indent-point))) + (if (and start + (not (re-match-forward "\\s(" start))) + 2 + 1))) + state indent-point normal-indent)) + +(define scheme-mode:indent-methods (make-string-table)) + +(for-each (lambda (entry) + (string-table-put! scheme-mode:indent-methods + (symbol->string (car entry)) + (cdr entry))) + `((CASE . 1) + (DO . 2) + (FLUID-LET . 1) + (IN-PACKAGE . 1) + (LAMBDA . 1) + (LET . ,scheme-mode:indent-let-method) + (LET* . 1) + (LET-SYNTAX . 1) + (LETREC . 1) + (LOCAL-DECLARE . 1) + (MACRO . 1) + (MAKE-ENVIRONMENT . 0) + (MAKE-PACKAGE . 2) + (NAMED-LAMBDA . 1) + (REC . 1) + (USING-SYNTAX . 1) + + (CALL-WITH-INPUT-FILE . 1) + (WITH-INPUT-FROM-FILE . 1) + (WITH-INPUT-FROM-PORT . 1) + (WITH-INPUT-FROM-STRING . 1) + (CALL-WITH-OUTPUT-FILE . 1) + (WITH-OUTPUT-TO-FILE . 1) + (WITH-OUTPUT-TO-PORT . 1) + (WITH-OUTPUT-TO-STRING . 1) + (SYNTAX-TABLE-DEFINE . 2) + (LIST-TRANSFORM-POSITIVE . 1) + (LIST-TRANSFORM-NEGATIVE . 1) + (LIST-SEARCH-POSITIVE . 1) + (LIST-SEARCH-NEGATIVE . 1) + + (ACCESS-COMPONENTS . 1) + (ASSIGNMENT-COMPONENTS . 1) + (COMBINATION-COMPONENTS . 1) + (COMMENT-COMPONENTS . 1) + (CONDITIONAL-COMPONENTS . 1) + (DISJUNCTION-COMPONENTS . 1) + (DECLARATION-COMPONENTS . 1) + (DEFINITION-COMPONENTS . 1) + (DELAY-COMPONENTS . 1) + (IN-PACKAGE-COMPONENTS . 1) + (LAMBDA-COMPONENTS . 1) + (LAMBDA-COMPONENTS* . 1) + (LAMBDA-COMPONENTS** . 1) + (OPEN-BLOCK-COMPONENTS . 1) + (PATHNAME-COMPONENTS . 1) + (PROCEDURE-COMPONENTS . 1) + (SEQUENCE-COMPONENTS . 1) + (UNASSIGNED?-COMPONENTS . 1) + (UNBOUND?-COMPONENTS . 1) + (VARIABLE-COMPONENTS . 1) + )) + +;;; end USING-SYNTAX +) +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/screen.scm b/v7/src/edwin/screen.scm new file mode 100644 index 000000000..6f4c4eff2 --- /dev/null +++ b/v7/src/edwin/screen.scm @@ -0,0 +1,234 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Virtual Screen Abstraction + +(declare (usual-integrations)) + +(define screen?) +(define screen-x-size) +(define screen-y-size) +(define the-alpha-screen) +(define subscreen) +(define screen-inverse-video!) +(define screen-clear!) +(define subscreen-clear!) +(define screen-write-cursor!) +(define screen-write-char!) +(define screen-write-substring!) +(define screen-write-substrings!) +(let () +(let-syntax ((make-primitive + (macro (name) + (make-primitive-procedure name)))) + +(set! screen-inverse-video! + (make-primitive screen-inverse-video!)) + +(define %screen-write-cursor! + (make-primitive screen-write-cursor!)) + +(define %screen-write-ascii! + (make-primitive screen-write-character!)) + +(define %screen-write-substring! + (make-primitive screen-write-substring!)) + +(define %subscreen-clear! + (make-primitive subscreen-clear!)) + +(define (make-screen axl axu ayl ayu) + (vector screen-tag axl axu ayl ayu)) + +(define screen-tag "Screen") + +(set! screen? +(named-lambda (screen? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? (vector-ref object 0) screen-tag)))) + +(set! screen-x-size +(named-lambda (screen-x-size screen) + (- (vector-ref screen 2) (vector-ref screen 1)))) + +(set! screen-y-size +(named-lambda (screen-y-size screen) + (- (vector-ref screen 4) (vector-ref screen 3)))) + +;;; Majorly bummed in two ways: (1) all clipping has been removed, on +;;; the assumption that the window system will never write outside the +;;; bounds of the screen, and (2) the only screen ever used is +;;; `the-alpha-screen', so that no offsets are needed. + +(set! the-alpha-screen + (make-screen 0 ((make-primitive screen-x-size)) + 0 ((make-primitive screen-y-size)))) + +(set! subscreen-clear! +(named-lambda (subscreen-clear! screen xl xu yl yu) + (%subscreen-clear! xl yl xu yu))) + +(set! screen-write-cursor! +(named-lambda (screen-write-cursor! screen x y) + (%screen-write-cursor! x y))) + +(set! screen-write-char! +(named-lambda (screen-write-char! screen x y char) + (%screen-write-ascii! x y (char->ascii char)))) + +(set! screen-write-substring! +(named-lambda (screen-write-substring! screen x y string bil biu) + (%screen-write-substring! x y string bil biu))) + +(set! screen-write-substrings! +(named-lambda (screen-write-substrings! screen x y strings bil biu bjl bju) + (with-screen screen + (lambda (axl axu ayl ayu) + (clip axl axu x bil biu + (lambda (bxl ail aiu) + (clip ayl ayu y bjl bju + (lambda (byl ajl aju) + (define (loop y j) + (if (< j aju) + (begin (%screen-write-substring! bxl y + (vector-ref strings j) + ail aiu) + (loop (1+ y) (1+ j))))) + (loop byl ajl))))))))) + +(define (clip axl axu x bil biu receiver) + (let ((ail (- bil x))) + (if (< ail biu) + (let ((aiu (+ ail (- axu axl)))) + (if (positive? x) + (let ((bxl (+ x axl))) + (if (< bxl axu) + (receiver bxl bil (if (< aiu biu) aiu biu)))) + (receiver axl ail (if (< aiu biu) aiu biu))))))) + +(define (with-screen screen receiver) + (receiver (vector-ref screen 1) + (vector-ref screen 2) + (vector-ref screen 3) + (vector-ref screen 4))) + +#| Old code with full clipping and screen hackery. + +(set! subscreen +(named-lambda (subscreen screen xl xu yl yu) + (with-screen screen + (lambda (axl axu ayl ayu) + (let ((bxl (+ xl axl)) + (bxu (+ xu axl)) + (byl (+ yl ayl)) + (byu (+ yu ayl))) + (make-screen (max axl bxl) + (min axu bxu) + (max ayl byl) + (min ayu byu))))))) + +(set! screen-clear! +(named-lambda (screen-clear! screen) + (with-screen screen + (lambda (axl axu ayl ayu) + (%subscreen-clear! axl ayl axu ayu))))) + +(set! subscreen-clear! +(named-lambda (subscreen-clear! screen xl xu yl yu) + (with-screen screen + (lambda (axl axu ayl ayu) + (let ((bxl (+ xl axl)) + (bxu (+ xu axl)) + (byl (+ yl ayl)) + (byu (+ yu ayl))) + (%subscreen-clear! (if (> axl bxl) axl bxl) + (if (> ayl byl) ayl byl) + (if (< axu bxu) axu bxu) + (if (< ayu byu) ayu byu))))))) + +(set! screen-write-cursor! +(named-lambda (screen-write-cursor! screen x y) + (with-screen screen + (lambda (axl axu ayl ayu) + (let ((bxl (+ axl x)) + (byl (+ ayl y))) + (if (and (not (negative? x)) (< bxl axu) + (not (negative? y)) (< byl ayu)) + (%screen-write-cursor! bxl byl))))))) + +(set! screen-write-char! +(named-lambda (screen-write-char! screen x y char) + (with-screen screen + (lambda (axl axu ayl ayu) + (let ((bxl (+ axl x)) + (byl (+ ayl y))) + (if (and (not (negative? x)) (< bxl axu) + (not (negative? y)) (< byl ayu)) + (%screen-write-ascii! bxl byl (char->ascii char)))))))) + +(set! screen-write-substring! +(named-lambda (screen-write-substring! screen x y string bil biu) + (with-screen screen + (lambda (axl axu ayl ayu) + (clip axl axu x bil biu + (lambda (bxl ail aiu) + (let ((byl (+ ayl y))) + (if (and (not (negative? y)) (< byl ayu)) + (%screen-write-substring! bxl byl string ail aiu))))))))) + +|# + +)) + +(define the-alpha-screen-x-size + (screen-x-size the-alpha-screen)) + +(define the-alpha-screen-y-size + (screen-y-size the-alpha-screen)) + +(define (screen-write-string! screen x y string) + (screen-write-substring! screen x y string 0 (string-length string))) + +(define (screen-write-strings! screen x y strings) + (screen-write-substrings! screen x y strings + 0 (string-length (vector-ref strings 0)) + 0 (vector-length strings))) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; End: diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm new file mode 100644 index 000000000..054e33ba2 --- /dev/null +++ b/v7/src/edwin/search.scm @@ -0,0 +1,366 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Search/Match Primitives + +;;; The operations in this file are for internal editor use only. For +;;; the user level search and match primitives, see the regular +;;; expression search and match procedures. + +(declare (usual-integrations) + (integrate-external "edb:struct.bin.0")) + +;;;; Character Search +#| +(define (find-next-char start end char) + (if (not (mark<= start end)) + (error "Marks incorrectly related: FIND-NEXT-CHAR" start end)) + (let ((index (%find-next-char (mark-group start) + (mark-index start) + (mark-index end) + char))) + (and index (make-mark (mark-group start) index)))) + +(define (find-previous-char start end char) + (if (not (mark>= start end)) + (error "Marks incorrectly related: FIND-PREVIOUS-CHAR" start end)) + (let ((index (%find-previous-char (mark-group start) + (mark-index start) + (mark-index end) + char))) + (and index (make-mark (mark-group start) index)))) +|# +(define (%find-next-newline group start end) + (and (not (= start end)) + (let ((start (group-index->position group start #!TRUE)) + (end (group-index->position group end #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (let ((pos + (if (and (<= start gap-start) (<= gap-end end)) + (or (substring-find-next-char-ci text start gap-start + char:newline) + (substring-find-next-char-ci text gap-end end + char:newline)) + (substring-find-next-char-ci text start end + char:newline)))) + (and pos (group-position->index group pos)))))) + +(define (%find-previous-newline group start end) + (and (not (= start end)) + (let ((start (group-index->position group start #!FALSE)) + (end (group-index->position group end #!TRUE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (let ((pos + (if (and (<= end gap-start) (<= gap-end start)) + (or (substring-find-previous-char-ci text gap-end start + char:newline) + (substring-find-previous-char-ci text end gap-start + char:newline)) + (substring-find-previous-char-ci text end start + char:newline)))) + (and pos (1+ (group-position->index group pos))))))) + +;;;; Character-set Search +#| +(define ((char-set-forward-search char-set) start end #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (or (find-next-char-in-set start end char-set) + (limit-mark-motion limit? end))) + +(define ((char-set-backward-search char-set) start end #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (or (find-previous-char-in-set start end char-set) + (limit-mark-motion limit? end))) + +(define (find-next-char-in-set start end char-set) + (if (not (mark<= start end)) + (error "Marks incorrectly related: FIND-NEXT-CHAR-IN-SET" start end)) + (let ((index + (%find-next-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + char-set))) + (and index (make-mark (mark-group start) index)))) + +(define (find-previous-char-in-set start end char-set) + (if (not (mark>= start end)) + (error "Marks incorrectly related: FIND-PREVIOUS-CHAR-IN-SET" start end)) + (let ((index + (%find-previous-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + char-set))) + (and index (make-mark (mark-group start) index)))) +|# + +(define (%find-next-char-in-set group start end char-set) + (and (not (= start end)) + (let ((start (group-index->position group start #!TRUE)) + (end (group-index->position group end #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (let ((pos + (if (and (<= start gap-start) + (<= gap-end end)) + (or (substring-find-next-char-in-set text start gap-start + char-set) + (substring-find-next-char-in-set text gap-end end + char-set)) + (substring-find-next-char-in-set text start end + char-set)))) + (and pos (group-position->index group pos)))))) + +(define (%find-previous-char-in-set group start end char-set) + (and (not (= start end)) + (let ((start (group-index->position group start #!FALSE)) + (end (group-index->position group end #!TRUE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (let ((pos + (if (and (<= end gap-start) + (<= gap-end start)) + (or (substring-find-previous-char-in-set text gap-end start + char-set) + (substring-find-previous-char-in-set text end gap-start + char-set)) + (substring-find-previous-char-in-set text end start + char-set)))) + (and pos (1+ (group-position->index group pos))))))) + +;;;; String Search +#| +(define (find-next-string start-mark end-mark string) + (find-next-substring start-mark end-mark string 0 (string-length string))) + +(define (find-next-substring start-mark end-mark string start end) + (if (not (mark<= start-mark end-mark)) + (error "Marks incorrectly related: FIND-NEXT-SUBSTRING" + start-mark end-mark)) + (if (= start end) + start-mark + (let ((index + (%find-next-substring (mark-group start-mark) + (mark-index start-mark) + (mark-index end-mark) + string start end))) + (and index (make-mark (mark-group start-mark) index))))) + +(define (%find-next-string group start-index end-index string) + (%find-next-substring group start-index end-index + string 0 (string-length string))) + +(define (find-previous-string start-mark end-mark string) + (find-previous-substring start-mark end-mark + string 0 (string-length string))) + +(define (find-previous-substring start-mark end-mark string start end) + (if (not (mark>= start-mark end-mark)) + (error "Marks incorrectly related: FIND-PREVIOUS-SUBSTRING" + start-mark end-mark)) + (if (= start end) + end-mark + (let ((index + (%find-previous-substring (mark-group start-mark) + (mark-index start-mark) + (mark-index end-mark) + string start end))) + (and index (make-mark (mark-group start-mark) index))))) + +(define (%find-previous-string group start-index end-index string) + (%find-previous-substring group start-index end-index + string 0 (string-length string))) + +(define (%find-next-substring group start-index end-index string start end) + (let ((char (string-ref string start)) + (bound (- end-index (-1+ (- end start))))) + (define (loop first) + (and first + (if (%match-next-substring group first end-index string start end) + first + (and (< first bound) + (loop (%find-next-char group (1+ first) bound char)))))) + (and (< start-index bound) + (loop (%find-next-char group start-index bound char))))) + +(define (%find-previous-substring group start-index end-index string start end) + (let ((char (string-ref string (-1+ end))) + (bound (+ end-index (-1+ (- end start))))) + (define (loop first) + (and first + (if (%match-previous-substring group first end-index + string start end) + first + (and (> first bound) + (loop (%find-previous-char group (-1+ first) bound + char)))))) + (and (> start-index bound) + (loop (%find-previous-char group start-index bound char))))) + +;;;; String Match + +(define (match-next-strings start end strings) + (define (loop strings) + (and (not (null? strings)) + (or (match-next-string start end (car strings)) + (loop (cdr strings))))) + (loop strings)) + +(define (match-next-string start end string) + (match-next-substring start end string 0 (string-length string))) + +(define (match-next-substring start-mark end-mark string start end) + (if (not (mark<= start-mark end-mark)) + (error "Marks incorrectly related: MATCH-NEXT-SUBSTRING" + start-mark end-mark)) + (let ((index + (%match-next-substring (mark-group start-mark) + (mark-index start-mark) + (mark-index end-mark) + string start end))) + (and index (make-mark (mark-group start-mark) index)))) + +(define (match-previous-strings start end strings) + (define (loop strings) + (and (not (null? strings)) + (or (match-previous-string start end (car strings)) + (loop (cdr strings))))) + (loop strings)) + +(define (match-previous-string start end string) + (match-previous-substring start end string 0 (string-length string))) + +(define (match-previous-substring start-mark end-mark string start end) + (if (not (mark>= start-mark end-mark)) + (error "Marks incorrectly related: MATCH-PREVIOUS-SUBSTRING" + start-mark end-mark)) + (let ((index + (%match-previous-substring (mark-group start-mark) + (mark-index start-mark) + (mark-index end-mark) + string start end))) + (and index (make-mark (mark-group start-mark) index)))) + +(define (%match-next-string group start-index end-index string) + (%match-next-substring group start-index end-index + string 0 (string-length string))) + +(define (%match-previous-string group start-index end-index string) + (%match-previous-substring group start-index end-index + string 0 (string-length string))) + +(define (%match-next-substring group start-index end-index string start end) + (let ((end-index* (+ start-index (- end start)))) + (and (<= end-index* end-index) + (%%match-substring group start-index end-index* string start end) + end-index*))) + +(define (%match-previous-substring group start-index end-index + string start end) + (let ((end-index* (- start-index (- end start)))) + (and (>= end-index* end-index) + (%%match-substring group end-index* start-index string start end) + end-index*))) + +(define (%%match-substring group start-index end-index string start end) + (and (not (= start-index end-index)) + (let ((start* (group-index->position group start-index #!TRUE)) + (end* (group-index->position group end-index #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (if (and (<= start* gap-start) (<= gap-end end*)) + (let ((split (+ start (- gap-start start*)))) + (and (substring-ci=? text start* gap-start string start split) + (substring-ci=? text gap-end end* string split end))) + (substring-ci=? text start* end* string start end))))) + +;;;; Character Match + +(define (match-next-char start end char) + (%match-next-char (mark-group start) + (mark-index start) + (mark-index end) + char)) + +(define (%match-next-char group start end char) + (and (< start end) + (char=? char (group-right-char group start)) + (1+ start))) + +(define (match-previous-char start end char) + (%match-previous-char (mark-group start) + (mark-index start) + (mark-index end) + char)) + +(define (%match-previous-char group start end char) + (and (> start end) + (char=? char (group-left-char group start)) + (-1+ start))) + +(define (match-next-char-in-set start end char-set) + (%match-next-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + char-set)) + +(define (%match-next-char-in-set group start end char-set) + (and (< start end) + (char-set-member? char-set (group-right-char group start)) + (1+ start))) + +(define (match-previous-char-in-set start end char-set) + (%match-previous-char-in-set (mark-group start) + (mark-index start) + (mark-index end) + char-set)) + +(define (%match-previous-char-in-set group start end char-set) + (and (> start end) + (char-set-member? char-set (group-left-char group start)) + (-1+ start))) +|# + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; End: diff --git a/v7/src/edwin/sercom.scm b/v7/src/edwin/sercom.scm new file mode 100644 index 000000000..e6e1d5139 --- /dev/null +++ b/v7/src/edwin/sercom.scm @@ -0,0 +1,496 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Search Commands + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +;;;; Character Search +;;; JAR Special + +(define-variable "Case Fold Search" + "If not false, search commands are insensitive to case." + true) + +(define-command ("^R Character Search" argument) + "Search for a single character. +Special characters: + C-A calls \\[Search Forward]. + C-R searches backwards for the current default. + C-S searches forward for the current default. + C-Q quotes the character to be searched for; + this allows search for special characters." + (character-search argument true)) + +(define-command ("^R Reverse Character Search" argument) + "Like \\[^R Winning Character Search], but searches backwards." + (character-search argument false)) + +(define (character-search argument forward?) + (define (char-search char) + (search-finish + ((if forward? char-search-forward char-search-backward) + char))) + + (define (string-search operator) + (search-finish (operator (ref-variable "Previous Search String")))) + + (define (search-finish mark) + (if mark + (set-current-point! mark) + (editor-failure))) + + (let ((char (prompt-for-char "Character Search"))) + (case (char-upcase char) + ((#\C-A) + ((if forward? + search-forward-command + search-backward-command) + argument)) + ((#\C-S) (string-search search-forward)) + ((#\C-R) (string-search search-backward)) + ((#\C-Q) + (char-search (prompt-for-char-without-interrupts "Quote Character"))) + (else (char-search char))))) + +;;;; String Search + +(define-variable "Previous Search String" + "Last string searched for by any string search command." + "") + +(define-variable "Previous Search Regexp" + "Last regular expression searched for by any search command." + false) + +(let () + +(define (search-command prompter prompt procedure) + (let ((mark (procedure (prompter prompt)))) + (if mark + (begin (push-current-mark! (current-point)) + (set-current-point! mark)) + (editor-failure)))) + +(define (search-prompt prompt) + (let ((string (prompt-for-string prompt + (ref-variable "Previous Search String")))) + (set-variable! "Previous Search String" string) + string)) + +(define (re-search-prompt prompt) + (let ((regexp (prompt-for-string prompt + (ref-variable "Previous Search Regexp")))) + (set-variable! "Previous Search Regexp" regexp) + regexp)) + +(define-command ("Search Forward" argument) + "Search forward from point for a character string. +Sets point at the end of the occurrence found." + (search-command search-prompt "Search" search-forward)) + +(define-command ("Search Backward" argument) + "Search backward from point for a character string. +Sets point at the beginning of the occurrence found." + (search-command search-prompt "Search Backward" search-backward)) + +(define-command ("RE Search Forward" argument) + "Search forward from point for a regular expression. +Sets point at the end of the occurrence found." + (search-command re-search-prompt "RE Search" re-search-forward)) + +(define-command ("RE Search Backward" argument) + "Search backward from point for a character string. +Sets point at the beginning of the occurrence found." + (search-command re-search-prompt "RE Search Backward" re-search-backward)) + +) + +;;;; Incremental Search + +(define incremental-search-package + (make-environment + +(define-command ("^R Incremental Search" argument) + "Search for character string as you type it. +C-Q quotes special characters. Rubout cancels last character. +C-S repeats the search, forward, and C-R repeats it backward. +C-R or C-S with search string empty changes the direction of search + or brings back search string from previous search. +Altmode exits the search. +Other Control and Meta chars exit the search and then are executed. +If not all the input string can be found, the rest is not discarded. + You can rub it out, discard it all with C-G, exit, + or use C-R or C-S to search the other way. +Quitting a successful search aborts the search and moves point back; + quitting a failing search just discards whatever input wasn't found." + (incremental-search true)) + +(define-command ("^R Reverse Search" argument) + "Incremental Search Backwards. +Like \\[^R Incremental Search] but in reverse." + (incremental-search false)) + +(define-command ("^R I-Search Append Character" argument) + "Append this character to the current string being searched." + (i-search-append-char (current-command-char))) + +(define-command ("^R I-Search Quote Character" argument) + "Append a quoted character to the current string being searched." + (i-search-append-char (with-editor-interrupts-disabled %keyboard-read-char))) + +(define (i-search-append-char char) + (set-current-search-state! + (incremental-search:append-char current-search-state char)) + (i-search-detect-failure current-search-state)) + +(define (i-search-detect-failure search-state) + (if (and (not (search-state-successful? search-state)) + (or (search-state-successful? (search-state-parent search-state)) + (not (eq? (search-state-forward? search-state) + (search-state-forward? + (search-state-parent search-state)))))) + (editor-failure))) + +(define-command ("^R I-Search Editor Command" argument) + "Exit search and push this character back for normal processing." + (incremental-search:terminate! current-search-state (current-command-char))) + +(define-command ("^R I-Search Next Occurrence" argument) + "Search for the next occurrence of the current search string." + (set-current-search-state! + (incremental-search:next-occurrence current-search-state)) + (i-search-detect-failure current-search-state)) + +(define-command ("^R I-Search Previous Occurrence" argument) + "Search for the previous occurrence of the current search string." + (set-current-search-state! + (incremental-search:previous-occurrence current-search-state)) + (i-search-detect-failure current-search-state)) + +(define-command ("^R I-Search Previous State" argument) + "Revert to the last state the search was in." + (set-current-search-state! + (incremental-search:delete-char current-search-state))) + +(define-command ("^R I-Search Previous Successful State" argument) + "Revert to the last successful state and exit search if there is none." + (pop-to-successful-state!)) + +(define-command ("^R I-Search Terminate" argument) + "Terminates I-Search Mode." + (incremental-search:terminate! current-search-state false)) + +(define-major-mode "Incremental Search" #!FALSE + "Major mode for incremental search. +See \"^R Incremental Search\" for details." + 'DONE) + +(define-default-key "Incremental Search" "^R I-Search Editor Command") +(define-key "Incremental Search" char-set:standard + "^R I-Search Append Character") +(define-key "Incremental Search" #\Tab "^R I-Search Append Character") +(define-key "Incremental Search" #\C-Q "^R I-Search Quote Character") +(define-key "Incremental Search" #\C-S "^R I-Search Next Occurrence") +(define-key "Incremental Search" #\C-R "^R I-Search Previous Occurrence") +(define-key "Incremental Search" #\Rubout "^R I-Search Previous State") +(define-key "Incremental Search" #\C-G "^R I-Search Previous Successful State") +(define-key "Incremental Search" #\Altmode "^R I-Search Terminate") + +(define incremental-search-exit) +(define incremental-search-window) +(define current-search-state) +(define text-start-mark) + +(define (incremental-search forward?) + (if (typein-window? (current-window)) (editor-error)) + (let ((old-point (current-point)) + (old-window (current-window)) + (old-case-fold-search (ref-variable "Case Fold Search"))) + (let ((y-point (window-point-y old-window))) + (let ((result + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((incremental-search-exit continuation) + (incremental-search-window old-window) + (current-search-state false) + (text-start-mark)) + (within-typein-edit + (lambda () + (set-current-major-mode! incremental-search-mode) + (local-set-variable! "Case Fold Search" + old-case-fold-search) + (select-cursor old-window) + (set-current-search-state! + (initial-search-state forward? old-point)) + (incremental-search-loop)))))))) + (cond ((eq? result 'ABORT) + (set-current-point! old-point) + (window-scroll-y-absolute! (current-window) y-point)) + ((command? result) + (dispatch-on-command result)) + (else + (push-current-mark! old-point) + (if (char? result) + (execute-char (current-comtab) result)))))))) + +(define (incremental-search-loop) + (let ((result + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((*^G-interrupt-continuation* continuation)) + (command-reader)))))) + (if (eq? result ^G-abortion-tag) ;; Handle ^G and go on + (begin (incremental-search:pop!) + (incremental-search-loop)) + result))) + +(define (incremental-search:append-char state char) + (let ((window (current-window))) + (let ((point (window-point window))) + (region-insert-char! point char) + (window-direct-update! window false) + (let ((text (extract-string text-start-mark point))) + (cond ((not (search-state-successful? state)) + (unsuccessful-search-state state text + (search-state-forward? state))) + ((search-state-forward? state) + (find-next-search-state state + text + (search-state-start-point state))) + (else + (find-previous-search-state + state text + (let ((end (search-state-end-point state))) + (if (or (group-end? end) + (mark= end (search-state-initial-point state))) + end + (mark1+ end)))))))))) + +(define (incremental-search:delete-char state) + (let ((parent (search-state-parent state))) + (if (null? parent) (editor-error)) + (let ((window (current-window))) + (let ((point (window-point window))) + (region-delete! + (make-region point + (mark- point + (- (string-length (search-state-text state)) + (string-length (search-state-text parent))))))) + (window-direct-update! window false)) + parent)) + +(define (incremental-search:terminate! state char) + (if (and (not char) + (null? (search-state-parent state))) + (incremental-search-exit + (name->command + (if (search-state-forward? state) + "Search Forward" + "Search Backward")))) + (save-search-state-text! state) + (set-window-point! + incremental-search-window + (search-state-point (most-recent-successful-search-state state))) + (incremental-search-exit char)) + +(define (incremental-search:pop!) + (let ((success (most-recent-successful-search-state current-search-state))) + (if (eq? success current-search-state) + (begin (save-search-state-text! success) + (incremental-search-exit 'ABORT)) + (set-current-search-state! success)))) + +(define (save-search-state-text! state) + (if (not (null? (search-state-parent state))) + (set-variable! "Previous Search String" (search-state-text state)))) + +(define (incremental-search:next-occurrence state) + (cond ((null? (search-state-parent state)) + (let ((point (search-state-initial-point state))) + (if (not (search-state-forward? state)) + (initial-search-state true point) + (begin (insert-string (ref-variable "Previous Search String")) + (find-next-search-state + state + (ref-variable "Previous Search String") + point))))) + ((search-state-successful? state) + (find-next-search-state state + (search-state-text state) + ((if (search-state-forward? state) + search-state-end-point + search-state-start-point) + state))) + ((not (search-state-forward? state)) + (find-next-search-state state + (search-state-text state) + (search-state-point state))) + (else + (unsuccessful-search-state state (search-state-text state) true)))) + +(define (incremental-search:previous-occurrence state) + (cond ((null? (search-state-parent state)) + (let ((point (search-state-initial-point state))) + (if (search-state-forward? state) + (initial-search-state false point) + (begin (insert-string (ref-variable "Previous Search String")) + (find-previous-search-state + state + (ref-variable "Previous Search String") + point))))) + ((search-state-successful? state) + (find-previous-search-state state + (search-state-text state) + ((if (search-state-forward? state) + search-state-end-point + search-state-start-point) + state))) + ((search-state-forward? state) + (find-previous-search-state state + (search-state-text state) + (search-state-point state))) + (else + (unsuccessful-search-state state (search-state-text state) false)))) + +(define (initial-search-state forward? point) + (make-search-state "" '() forward? true point point point point)) + +(define (unsuccessful-search-state parent text forward?) + (let ((start-point (search-state-start-point parent))) + (make-search-state text parent forward? false + start-point + (mark+ start-point (string-length text)) + (search-state-point parent) + (search-state-initial-point parent)))) + +(define (find-next-search-state state text start) + (if (search-forward text start) + (let ((start-point (re-match-start 0)) + (end-point (re-match-end 0))) + (make-search-state text state true true + start-point end-point end-point + (if (search-state-forward? state) + (search-state-initial-point state) + (search-state-start-point state)))) + (unsuccessful-search-state state text true))) + +(define (find-previous-search-state state text start) + (if (search-backward text start) + (let ((start-point (re-match-start 0)) + (end-point (re-match-end 0))) + (make-search-state text state false true + start-point end-point start-point + (if (search-state-forward? state) + (search-state-end-point state) + (search-state-initial-point state)))) + (unsuccessful-search-state state text false))) + +(define (set-current-search-state! state) + (if (or (not current-search-state) + (not (eq? (search-state-successful? state) + (search-state-successful? current-search-state))) + (not (eq? (search-state-forward? state) + (search-state-forward? current-search-state)))) + (let ((window (current-window))) + (let ((point (window-point window))) + (region-delete! (buffer-region (window-buffer window))) + (region-insert-string! + point + (string-append (if (search-state-successful? state) + "" "Failing ") + (if (search-state-forward? state) + "" "Reverse ") + "I-Search: ")) + (set! text-start-mark (mark-right-inserting point)) + (region-insert-string! point (search-state-text state)) + (window-direct-update! window false)))) + (if (not (keyboard-active? 0)) + (set-window-point! incremental-search-window (search-state-point state))) + (set! current-search-state state)) + +(define (most-recent-successful-search-state state) + (cond ((search-state-successful? state) + state) + ((null? (search-state-parent state)) + (error "Search state chain terminated improperly")) + (else + (most-recent-successful-search-state (search-state-parent state))))) + +(define-named-structure "Search-State" + text + parent + forward? + successful? + start-point + end-point + point + initial-point) + +(define (make-search-state text parent forward? successful? + start-point end-point point initial-point) + (let ((state (%make-search-state))) + (vector-set! state search-state-index:text text) + (vector-set! state search-state-index:parent parent) + (vector-set! state search-state-index:forward? forward?) + (vector-set! state search-state-index:successful? successful?) + (vector-set! state search-state-index:start-point start-point) + (vector-set! state search-state-index:end-point end-point) + (vector-set! state search-state-index:point point) + (vector-set! state search-state-index:initial-point initial-point) + state)) + +(define-unparser %search-state-tag + (lambda (state) + (if (not (search-state-successful? state)) + (write-string "Failing ")) + (if (not (search-state-forward? state)) + (write-string "Reverse ")) + (write-string "Search State: ") + (write-string (search-state-text state)))) + +;;; end INCREMENTAL-SEARCH-PACKAGE +)) + +;;; end USING-SYNTAX +) +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/simple.scm b/v7/src/edwin/simple.scm new file mode 100644 index 000000000..c264a5d73 --- /dev/null +++ b/v7/src/edwin/simple.scm @@ -0,0 +1,198 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Simple Editing Procedures + +(declare (usual-integrations)) + +(define (insert-char char #!optional point) + (if (unassigned? point) (set! point (current-point))) + (group-insert-char! (mark-group point) (mark-index point) char)) + +(define (insert-chars char n #!optional point) + (if (unassigned? point) (set! point (current-point))) + (cond ((= n 1) + (group-insert-char! (mark-group point) (mark-index point) char)) + ((> n 1) + (group-insert-substring! (mark-group point) (mark-index point) + (make-string n char) 0 n)))) + +(define (insert-newline #!optional point) + (if (unassigned? point) (set! point (current-point))) + (group-insert-char! (mark-group point) (mark-index point) char:newline)) + +(define (insert-newlines n #!optional point) + (if (unassigned? point) (set! point (current-point))) + (cond ((= n 1) + (group-insert-char! (mark-group point) (mark-index point) + char:newline)) + ((> n 1) + (group-insert-substring! (mark-group point) (mark-index point) + (make-string n char:newline) 0 n)))) + +(define (extract-left-char #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group point)) + (index (mark-index point))) + (and (not (group-start-index? group index)) + (group-left-char group index)))) + +(define (extract-right-char #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group point)) + (index (mark-index point))) + (and (not (group-end-index? group index)) + (group-right-char group index)))) + +(define (delete-left-char #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group point)) + (index (mark-index point))) + (if (group-start-index? group index) + (editor-error "Attempt to delete past start of buffer") + (group-delete-left-char! group index)))) + +(define (delete-right-char #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group point)) + (index (mark-index point))) + (if (group-end-index? group index) + (editor-error "Attempt to delete past end of buffer") + (group-delete-right-char! group index)))) + +(define (insert-string string #!optional point) + (if (unassigned? point) (set! point (current-point))) + (group-insert-string! (mark-group point) (mark-index point) string)) + +(define (insert-substring string start end #!optional point) + (if (unassigned? point) (set! point (current-point))) + (group-insert-substring! (mark-group point) (mark-index point) + string start end)) + +(define (extract-string mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group mark)) + (index1 (mark-index mark)) + (index2 (mark-index point))) + (if (not (eq? group (mark-group point))) + (error "EXTRACT-STRING: Marks not related" mark point)) + (if (< index1 index2) + (group-extract-string group index1 index2) + (group-extract-string group index2 index1)))) + +(define (delete-string mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group mark)) + (index1 (mark-index mark)) + (index2 (mark-index point))) + (if (not (eq? group (mark-group point))) + (error "DELETE-STRING: Marks not related" mark point)) + (if (< index1 index2) + (group-delete! group index1 index2) + (group-delete! group index2 index1)))) + +(define (match-string string mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (let ((group (mark-group mark)) + (index1 (mark-index mark)) + (index2 (mark-index point)) + (length (string-length string))) + (define (kernel index1 index2) + (let ((pos1 (group-index->position group index1 #!TRUE)) + (pos2 (group-index->position group index2 #!FALSE)) + (gap-start (group-gap-start group)) + (gap-end (group-gap-end group)) + (text (group-text group))) + (if (and (<= pos1 gap-start) (<= gap-end pos2)) + (let ((split (- gap-start pos1))) + (and (substring=? text pos1 gap-start string 0 split) + (substring=? text gap-end pos2 string split length))) + (substring=? text pos1 pos2 string 0 length)))) + (if (not (eq? group (mark-group point))) + (error "MATCH-STRING: Marks not related" mark point)) + (cond ((= index1 index2) (zero? length)) + ((< index1 index2) (kernel index1 index2)) + (else (kernel index2 index1))))) + +(define (upcase-area mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (region-transform! (make-region mark point) uppercase-string!)) + +(define (downcase-area mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (region-transform! (make-region mark point) lowercase-string!)) + +(define (capitalize-area mark #!optional point) + (if (unassigned? point) (set! point (current-point))) + (region-transform! (make-region mark point) capitalize-string!)) + +(define (uppercase-string! string) + (string-upcase! string) + string) + +(define (lowercase-string! string) + (string-downcase! string) + string) + +(define (capitalize-string! string) + (string-downcase! string) + (string-set! string 0 (char-upcase (string-ref string 0))) + string) + +(define (current-column) + (mark-column (current-point))) + +(define (mark-flash mark #!optional type) + (if (unassigned? type) (set! type #!FALSE)) + (cond (*executing-keyboard-macro?*) + ((not mark) (beep)) + ((window-mark-visible? (current-window) mark) + (with-current-point mark + (lambda () + (update-alpha-window! #!FALSE) + (keyboard-active? 50)))) + (else + (temporary-message + (let ((start (line-start mark 0)) + (end (line-end mark 0))) + (cond ((eq? type 'RIGHT) (extract-string mark end)) + ((eq? type 'LEFT) (extract-string start mark)) + (else (extract-string start end)))))))) + +(define (reposition-window-top mark) + (if (not (and mark (set-window-start-mark! (current-window) mark #!FALSE))) + (beep))) \ No newline at end of file diff --git a/v7/src/edwin/strpad.scm b/v7/src/edwin/strpad.scm new file mode 100644 index 000000000..eb401e63a --- /dev/null +++ b/v7/src/edwin/strpad.scm @@ -0,0 +1,110 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; String Padding Stuff + +(declare (usual-integrations)) + +(define (add-padding-on-right string n) + (if (zero? n) + string + (let ((l (string-length string))) + (let ((result (make-string (+ l n) #\Space))) + (substring-move-right! string 0 l result 0) + result)))) + +(define (add-padding-on-left string n) + (if (zero? n) + string + (let ((l (string-length string))) + (let ((result (make-string (+ l n) #\Space))) + (substring-move-right! string 0 l result n) + result)))) + +(define (pad-on-right-to string n) + (let ((l (string-length string))) + (if (> n l) + (let ((result (make-string n #\Space))) + (substring-move-right! string 0 l result 0) + result) + string))) + +(define (pad-on-left-to string n) + (let ((l (string-length string))) + (let ((delta (- n l))) + (if (positive? delta) + (let ((result (make-string n #\Space))) + (substring-move-right! string 0 l result delta) + result) + string)))) + +(define (write-strings-densely strings) + (pad-strings-on-right strings + (lambda (n strings) + (let ((n-per-line (max 1 (quotient 79 (+ 2 n))))) + (define (loop strings i) + (if (not (null? strings)) + (begin (write-string " ") + (write-string (car strings)) + (if (= i n-per-line) + (begin (newline) + (loop (cdr strings) 1)) + (loop (cdr strings) (1+ i)))))) + (loop strings 1))))) + +(define ((pad-strings-to-max-column pad) strings receiver) + (define (max-loop strings n acc) + (if (null? strings) + (adjust-loop acc n '()) + (let ((c (string-length (car strings)))) + (max-loop (cdr strings) + (if (> c n) c n) + (cons (cons (car strings) c) acc))))) + (define (adjust-loop strings n acc) + (if (null? strings) + (receiver n acc) + (adjust-loop (cdr strings) + n + (cons (pad (caar strings) (- n (cdar strings))) + acc)))) + (max-loop strings 0 '())) + +(define pad-strings-on-right + (pad-strings-to-max-column add-padding-on-right)) + +(define pad-strings-on-left + (pad-strings-to-max-column add-padding-on-left)) \ No newline at end of file diff --git a/v7/src/edwin/strtab.scm b/v7/src/edwin/strtab.scm new file mode 100644 index 000000000..6d23fc09b --- /dev/null +++ b/v7/src/edwin/strtab.scm @@ -0,0 +1,262 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; String Tables + +(declare (usual-integrations)) + +(define (make-string-table #!optional initial-size) + (if (unassigned? initial-size) (set! initial-size 10)) + (vector string-table-tag + (vector-cons initial-size '()) + 0)) + +(define (alist->string-table alist) + (let ((v (list->vector + (sort alist + (lambda (x y) + (string-ci= index (group-end-index group))) + +(define (set-group-read-only! group) + (vector-set! group group-index:read-only? #!TRUE)) + +(define (set-group-writeable! group) + (vector-set! group group-index:read-only? #!FALSE)) + +(define (group-region group) + (%make-region (group-start-mark group) (group-end-mark group))) + +(define (group-position->index group position) + (cond ((> position (group-gap-end group)) + (- position (group-gap-length group))) + ((> position (group-gap-start group)) + (group-gap-start group)) + (else position))) + +(define (group-index->position group index left-inserting?) + (cond ((> index (group-gap-start group)) + (+ index (group-gap-length group))) + ((= index (group-gap-start group)) + (if left-inserting? + (group-gap-end group) + (group-gap-start group))) + (else index))) + +(define (set-group-undo-data! group undo-data) + (vector-set! group group-index:undo-data undo-data)) + +(define (set-group-modified! group sense) + (vector-set! group group-index:modified? sense)) + +(define (set-group-point! group point) + (vector-set! group group-index:point (mark-left-inserting point))) + +(define (with-narrowed-region! region thunk) + (with-group-text-clipped! (region-group region) + (region-start-index region) + (region-end-index region) + thunk)) + +(define (with-group-text-clipped! group start end thunk) + (define old-text-start) + (define old-text-end) + (define new-text-start (%make-permanent-mark group start #!FALSE)) + (define new-text-end (%make-permanent-mark group end #!TRUE)) + (dynamic-wind (lambda () + (set! old-text-start (group-start-mark group)) + (set! old-text-end (group-end-mark group)) + (vector-set! group group-index:start-mark new-text-start) + (vector-set! group group-index:end-mark new-text-end)) + thunk + (lambda () + (set! new-text-start (group-start-mark group)) + (set! new-text-end (group-end-mark group)) + (vector-set! group group-index:start-mark old-text-start) + (vector-set! group group-index:end-mark old-text-end)))) + +(define (record-insertion! group start end) + (define (loop daemons) + (if (not (null? daemons)) + (begin ((car daemons) group start end) + (loop (cdr daemons))))) + (loop (group-insert-daemons group))) + +(define (add-group-insert-daemon! group daemon) + (vector-set! group group-index:insert-daemons + (cons daemon (vector-ref group group-index:insert-daemons)))) + +(define (remove-group-insert-daemon! group daemon) + (vector-set! group group-index:insert-daemons + (delq! daemon (vector-ref group group-index:insert-daemons)))) + +(define (record-deletion! group start end) + (define (loop daemons) + (if (not (null? daemons)) + (begin ((car daemons) group start end) + (loop (cdr daemons))))) + (loop (group-delete-daemons group))) + +(define (add-group-delete-daemon! group daemon) + (vector-set! group group-index:delete-daemons + (cons daemon (vector-ref group group-index:delete-daemons)))) + +(define (remove-group-delete-daemon! group daemon) + (vector-set! group group-index:delete-daemons + (delq! daemon (vector-ref group group-index:delete-daemons)))) + +(define (record-clipping! group start end) + (define (loop daemons) + (if (not (null? daemons)) + (begin ((car daemons) group start end) + (loop (cdr daemons))))) + (loop (group-clip-daemons group))) + +(define (add-group-clip-daemon! group daemon) + (vector-set! group group-index:clip-daemons + (cons daemon (vector-ref group group-index:clip-daemons)))) + +(define (remove-group-clip-daemon! group daemon) + (vector-set! group group-index:clip-daemons + (delq! daemon (vector-ref group group-index:clip-daemons)))) + +;;;; Marks + +(define-named-structure "Mark" + group position left-inserting?) + +(declare (integrate make-mark %make-permanent-mark %%make-mark + %set-mark-position! mark~)) + +(define (make-mark group index) + (declare (integrate group index)) + (%make-temporary-mark group index #!TRUE)) + +(define (%make-permanent-mark group index left-inserting?) + (declare (integrate group index left-inserting?)) + (mark-permanent! (%make-temporary-mark group index left-inserting?))) + +(define (%make-temporary-mark group index left-inserting?) + (%%make-mark group + (group-index->position group index left-inserting?) + left-inserting?)) + +(define (%%make-mark group position left-inserting?) + (declare (integrate group position left-inserting?)) + (let ((mark (%make-mark))) + (vector-set! mark mark-index:group group) + (vector-set! mark mark-index:position position) + (vector-set! mark mark-index:left-inserting? left-inserting?) + mark)) + +(define (mark-index mark) + (group-position->index (mark-group mark) (mark-position mark))) + +(define (%set-mark-position! mark position) + (declare (integrate mark position)) + (vector-set! mark mark-index:position position)) + +(define (mark~ mark1 mark2) + (declare (integrate mark1 mark2)) + (eq? (mark-group mark1) (mark-group mark2))) + +(define (mark-right-inserting mark) + (mark-permanent! + (if (mark-left-inserting? mark) + (%make-temporary-mark (mark-group mark) (mark-index mark) #!FALSE) + mark))) + +(define (mark-left-inserting mark) + (mark-permanent! + (if (mark-left-inserting? mark) + mark + (%make-temporary-mark (mark-group mark) (mark-index mark) #!TRUE)))) + +;;; The marks list is cleaned every time that FOR-EACH-MARK! is +;;; called. It may be necessary to do this a little more often. + +(declare (compilable-primitive-functions object-hash)) + +(define (mark-permanent! mark) + (let ((n (object-hash mark)) + (marks (group-marks (mark-group mark)))) + (if (not (memq n marks)) + (vector-set! (mark-group mark) group-index:marks (cons n marks)))) + mark) + +(define (for-each-mark group procedure) + (define (loop-1 marks) + (if (not (null? marks)) + (let ((mark (object-unhash (car marks)))) + (if mark + (begin (procedure mark) + (loop-2 marks (cdr marks))) + (begin (vector-set! group group-index:marks (cdr marks)) + (loop-1 (cdr marks))))))) + + (define (loop-2 previous marks) + (if (not (null? marks)) + (let ((mark (object-unhash (car marks)))) + (if mark + (begin (procedure mark) + (loop-2 marks (cdr marks))) + (begin (set-cdr! previous (cddr previous)) + (loop-2 previous (cdr previous))))))) + + (loop-1 (group-marks group))) + +(define (mark/~ mark1 mark2) + (not (mark~ mark1 mark2))) + +(define (mark= mark1 mark2) + (and (mark~ mark1 mark2) + (= (mark-index mark1) (mark-index mark2)))) + +(define (mark/= mark1 mark2) + (and (mark~ mark1 mark2) + (not (= (mark-index mark1) (mark-index mark2))))) + +(define (mark< mark1 mark2) + (and (mark~ mark1 mark2) + (< (mark-index mark1) (mark-index mark2)))) + +(define (mark<= mark1 mark2) + (and (mark~ mark1 mark2) + (<= (mark-index mark1) (mark-index mark2)))) + +(define (mark> mark1 mark2) + (and (mark~ mark1 mark2) + (> (mark-index mark1) (mark-index mark2)))) + +(define (mark>= mark1 mark2) + (and (mark~ mark1 mark2) + (>= (mark-index mark1) (mark-index mark2)))) + +(declare (integrate group-start group-end)) + +(define (group-start mark) + (declare (integrate mark)) + (group-start-mark (mark-group mark))) + +(define (group-end mark) + (declare (integrate mark)) + (group-end-mark (mark-group mark))) + +(define (group-start? mark) + (group-start-index? (mark-group mark) (mark-index mark))) + +(define (group-end? mark) + (group-end-index? (mark-group mark) (mark-index mark))) + +;;;; Regions + +(declare (integrate %make-region region-start region-end)) + +(define %make-region cons) +(define region-start car) +(define region-end cdr) + +(define (make-region start end) + (cond ((mark<= start end) (%make-region start end)) + ((mark<= end start) (%make-region end start)) + (else (error "Marks not related" start end)))) +(declare (integrate region-group region-start-index region-end-index)) + +(define (region-group region) + (declare (integrate region)) + (mark-group (region-start region))) + +(define (region-start-index region) + (declare (integrate region)) + (mark-index (region-start region))) + +(define (region-end-index region) + (declare (integrate region)) + (mark-index (region-end region))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/syntax.scm b/v7/src/edwin/syntax.scm new file mode 100644 index 000000000..d1d679cee --- /dev/null +++ b/v7/src/edwin/syntax.scm @@ -0,0 +1,430 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Syntax tables for Edwin + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table +(let-syntax ((make-primitive (macro (name) (make-primitive-procedure name)))) + +;;;; Syntax Tables + +(define-variable "Syntax Table" + "The syntax-table used for word and list parsing.") + +(define-variable "Syntax Ignore Comments Backwards" + "If true, ignore comments in backwards expression parsing. +This should be false for comments that end in Newline, like Lisp. +It can be true for comments that end in }, like Pascal. +This is because Newline occurs alot when it doesn't +indicate a comment ending." + #!FALSE) + +(define make-syntax-table) +(define syntax-table?) +(define syntax-table-copy vector-copy) +(define modify-syntax-entry!) +(define modify-syntax-entries!) +(let () + +(define standard-syntax-table) +(define key-type) + +(define string->syntax-entry + (make-primitive string->syntax-entry)) + +(set! make-syntax-table +(named-lambda (make-syntax-table) + (vector-copy standard-syntax-table))) + +;;; **** Fucking compiler miscompiles PRIMITIVE-TYPE? here, +;;; so flush this randomness for now. +;(set! syntax-table? +;(named-lambda (syntax-table? object) +; (and (vector? object) +; (= 256 (vector-length object)) +; (primitive-type? key-type (vector-ref object 0))))) + +(set! modify-syntax-entry! +(named-lambda (modify-syntax-entry! syntax-table char string) +; (if (not (syntax-table? syntax-table)) +; (error "Not a syntax table" syntax-table)) + (vector-set! syntax-table (char->ascii char) (string->syntax-entry string)))) + +(set! modify-syntax-entries! +(named-lambda (modify-syntax-entries! syntax-table cl ch string) +; (if (not (syntax-table? syntax-table)) +; (error "Not a syntax table" syntax-table)) + (let ((ah (char->ascii ch)) + (entry (string->syntax-entry string))) + (define (loop a) + (vector-set! syntax-table a entry) + (if (< a ah) (loop (1+ a)))) + (loop (char->ascii cl))))) + +(let ((entry (string->syntax-entry ""))) + (set! key-type (primitive-type entry)) + (let ((table (vector-cons 256 entry))) + (modify-syntax-entries! table #\0 #\9 "w") + (modify-syntax-entries! table #\A #\Z "w") + (modify-syntax-entries! table #\a #\z "w") + (modify-syntax-entry! table #\$ "w") + (modify-syntax-entry! table #\% "w") + (modify-syntax-entry! table #\( "()") + (modify-syntax-entry! table #\) ")(") + (modify-syntax-entry! table #\[ "(]") + (modify-syntax-entry! table #\] ")[") + (modify-syntax-entry! table #\{ "(}") + (modify-syntax-entry! table #\} "){") + (modify-syntax-entry! table #\" "\"") + (modify-syntax-entry! table #\\ "\\") + (for-each (lambda (char) + (modify-syntax-entry! table char "_")) + (string->list "_-+*/&|<>=")) + (for-each (lambda (char) + (modify-syntax-entry! table char ".")) + (string->list ".,;:?!#@~^'`")) + (set! standard-syntax-table table) + (set-variable! "Syntax Table" table))) + +;; **** compiler complains about assignment to unassigned variable for +;; value unless this is here. +'DONE +) + +;;;; Word Parsing + +(define forward-word) +(define backward-word) +(define forward-to-word) +(let () + +(set! forward-word +(named-lambda (forward-word mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%forward-word mark n limit?)) + ((negative? n) (%backward-word mark (- n) limit?)) + (else mark)))) + +(set! backward-word +(named-lambda (backward-word mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%backward-word mark n limit?)) + ((negative? n) (%forward-word mark (- n) limit?)) + (else mark)))) + +(set! forward-to-word +(named-lambda (forward-to-word mark #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (let ((index (scan-forward-to-word (ref-variable "Syntax Table") + (mark-group mark) + (mark-index mark) + (mark-index (group-end mark))))) + (if (not index) + (limit-mark-motion limit? (group-end mark)) + (make-mark (mark-group mark) index))))) + +(define (%forward-word mark n limit?) + (let ((group (mark-group mark)) + (end (mark-index (group-end mark)))) + (define (loop start n) + (let ((m (scan-word-forward (ref-variable "Syntax Table") + group start end))) + (cond ((not m) (limit-mark-motion limit? (make-mark group start))) + ((= n 1) (make-mark group m)) + (else (loop m (-1+ n)))))) + (loop (mark-index mark) n))) + +(define (%backward-word mark n limit?) + (let ((group (mark-group mark)) + (end (mark-index (group-start mark)))) + (define (loop start n) + (let ((m (scan-word-backward (ref-variable "Syntax Table") + group start end))) + (cond ((not m) (limit-mark-motion limit? (make-mark group start))) + ((= n 1) (make-mark group m)) + (else (loop m (-1+ n)))))) + (loop (mark-index mark) n))) + +(define scan-word-forward + (make-primitive scan-word-forward)) + +(define scan-forward-to-word + (make-primitive scan-forward-to-word)) + +(define scan-word-backward + (make-primitive scan-word-backward)) + +;; **** compiler complains about assignment to unassigned variable for +;; value unless this is here. +'DONE +) + +;;;; Lisp Parsing + +(define forward-one-sexp) +(define backward-one-sexp) +(define backward-prefix-chars) +(define forward-one-list) +(define backward-one-list) +(define forward-up-one-list) +(define backward-up-one-list) +(define forward-down-one-list) +(define backward-down-one-list) +(define mark-right-char-quoted?) +(let () + +(set! forward-one-sexp +(named-lambda (forward-one-sexp start #!optional end) + (cond ((unassigned? end) (set! end (group-end start))) + ((not (mark<= start end)) (error "END less than START" end))) + (%forward-list start end 0 #!TRUE))) + +(set! backward-one-sexp +(named-lambda (backward-one-sexp start #!optional end) + (cond ((unassigned? end) (set! end (group-start start))) + ((not (mark>= start end)) (error "END greater than START" end))) + (let ((mark (%backward-list start end 0 #!TRUE))) + (and mark (backward-prefix-chars mark end))))) + +(set! backward-prefix-chars +(named-lambda (backward-prefix-chars start #!optional end) + (cond ((unassigned? end) (set! end (group-start start))) + ((not (mark>= start end)) (error "END greater than START" end))) + (make-mark (mark-group start) + (scan-backward-prefix-chars (ref-variable "Syntax Table") + (mark-group start) + (mark-index start) + (mark-index end))))) + +(set! forward-one-list +(named-lambda (forward-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-end start))) + ((not (mark<= start end)) (error "END less than START" end))) + (%forward-list start end 0 #!FALSE))) + +(set! backward-one-list +(named-lambda (backward-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-start start))) + ((not (mark>= start end)) (error "END greater than START" end))) + (%backward-list start end 0 #!FALSE))) + +(set! forward-up-one-list +(named-lambda (forward-up-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-end start))) + ((not (mark<= start end)) (error "END less than START" end))) + (%forward-list start end 1 #!FALSE))) + +(set! backward-up-one-list +(named-lambda (backward-up-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-start start))) + ((not (mark>= start end)) (error "END greater than START" end))) + (%backward-list start end 1 #!FALSE))) + +(set! forward-down-one-list +(named-lambda (forward-down-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-end start))) + ((not (mark<= start end)) (error "END less than START" end))) + (%forward-list start end -1 #!FALSE))) + +(set! backward-down-one-list +(named-lambda (backward-down-one-list start #!optional end) + (cond ((unassigned? end) (set! end (group-start start))) + ((not (mark>= start end)) (error "END greater than START" end))) + (%backward-list start end -1 #!FALSE))) + +(set! mark-right-char-quoted? +(named-lambda (mark-right-char-quoted? mark) + (quoted-char? (ref-variable "Syntax Table") + (mark-group mark) + (mark-index mark) + (group-start-index (mark-group mark))))) + +(define (%forward-list start end depth sexp?) + (let ((index (scan-list-forward (ref-variable "Syntax Table") + (mark-group start) + (mark-index start) (mark-index end) + depth sexp? #!TRUE))) + (and index (make-mark (mark-group start) index)))) + +(define (%backward-list start end depth sexp?) + (let ((index (scan-list-backward (ref-variable "Syntax Table") + (mark-group start) + (mark-index start) (mark-index end) + depth sexp? + (ref-variable + "Syntax Ignore Comments Backwards")))) + (and index (make-mark (mark-group start) index)))) + +(define scan-list-forward + (make-primitive scan-list-forward)) + +(define scan-list-backward + (make-primitive scan-list-backward)) + +(define scan-backward-prefix-chars + (make-primitive scan-backward-prefix-chars)) + +(define quoted-char? + (make-primitive quoted-char?)) + +;; **** compiler complains about assignment to unassigned variable for +;; value unless this is here. +'DONE +) + +(define (mark-left-char-quoted? mark) + (if (not (group-start? mark)) + (mark-right-char-quoted? (mark-1+ mark)) + (error "Mark has no left char" mark))) + +(define (forward-to-sexp-start mark end) + (parse-state-location (parse-partial-sexp mark end 0 #!TRUE))) + +(define parse-partial-sexp) +(define char->syntax-code) +(let () + +(set! parse-partial-sexp +(named-lambda (parse-partial-sexp start end #!optional + target-depth stop-before? old-state) + (if (or (unassigned? target-depth) (not target-depth)) + (set! target-depth -1000000)) + (if (unassigned? stop-before?) (set! stop-before? #!FALSE)) + (if (unassigned? old-state) (set! old-state #!FALSE)) + (if (not (mark<= start end)) (error "Marks incorrectly related" start end)) + (let ((group (mark-group start))) + (let ((state (scan-sexps-forward (ref-variable "Syntax Table") + group + (mark-index start) + (mark-index end) + target-depth stop-before? old-state))) + ;; Convert the returned indices to marks. + (if (vector-ref state 4) + (vector-set! state 4 (make-mark group (vector-ref state 4)))) + (if (vector-ref state 5) + (vector-set! state 5 (make-mark group (vector-ref state 5)))) + (vector-set! state 6 (make-mark group (vector-ref state 6))) + state)))) + +(set! char->syntax-code +(named-lambda (char->syntax-code char) + (%char->syntax-code (ref-variable "Syntax Table") char))) + +(define scan-sexps-forward + (make-primitive scan-sexps-forward)) + +(define %char->syntax-code + (make-primitive char->syntax-code)) + +;; **** compiler complains about assignment to unassigned variable for +;; value unless this is here. +'DONE +) + +(define (parse-state-depth state) + (vector-ref state 0)) + +(define (parse-state-in-string? state) ;#!FALSE or ASCII delimiter. + (vector-ref state 1)) + +(define (parse-state-in-comment? state) ;#!FALSE or 1 or 2. + (vector-ref state 2)) + +(define (parse-state-quoted? state) + (vector-ref state 3)) + +(define (parse-state-last-sexp state) + (vector-ref state 4)) + +(define (parse-state-containing-sexp state) + (vector-ref state 5)) + +(define (parse-state-location state) + (vector-ref state 6)) + +;;;; Definition Start/End + +(define-variable "Definition Start" + "Regexp to match start of a definition." + "^\\s(") + +(define (definition-start? mark) + (re-match-forward (ref-variable "Definition Start") mark)) + +(define (forward-one-definition-start mark) + (and (re-search-forward (ref-variable "Definition Start") + (if (line-start? mark) (line-end mark 0) mark)) + (re-match-start 0))) + +(define (backward-one-definition-start mark) + (re-search-backward (ref-variable "Definition Start") mark)) + +(define (forward-one-definition-end mark) + (define (loop start) + (let ((end (forward-one-list start))) + (and end + (let ((end* + (let ((end (horizontal-space-end end))) + (if (re-match-forward "[;\n]" end) + (line-start end 1 'LIMIT) + end)))) + (if (mark> end* mark) + end* + (loop (forward-one-definition-start end))))))) + (and (not (group-end? mark)) + (loop + (or (backward-one-definition-start (mark1+ mark)) + (forward-one-definition-start (group-start mark)))))) + +(define (backward-one-definition-end mark) + (let ((start (backward-one-definition-start mark))) + (and start + (let ((end (forward-one-definition-end start))) + (and end + (if (mark< end mark) + end + (let ((start (backward-one-definition-start start))) + (and start (forward-one-definition-end start))))))))) + +;;; end USING-SYNTAX +)) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm new file mode 100644 index 000000000..de0211018 --- /dev/null +++ b/v7/src/edwin/tagutl.scm @@ -0,0 +1,314 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Tags Facility +;;; From GNU Emacs (thank you RMS) + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-command ("Visit Tags Table" argument) + "Tell tags commands to use a given tags table file." + (set-variable! + "Tags Table Pathname" + (prompt-for-pathname "Visit tags table" + (or (ref-variable "Tags Table Pathname") + (pathname-new-type (current-default-pathname) + "TAG"))))) + +(define-command ("Find Tag" argument) + "Find tag (in current tags table) whose name contains a given string. + Selects the buffer that the tag is contained in +and puts point at its definition. + With argument, searches for the next tag in the tags table that matches +the string used in the previous Find Tag." + (&find-tag-command argument find-file)) + +(define-command ("Find Tag Other Window" argument) + "Like \\[Find Tag], but selects buffer in another window." + (&find-tag-command argument find-file-other-window)) + +(define (&find-tag-command previous-tag? find-file) + (if previous-tag? + (find-tag previous-find-tag-string + ;; Kludgerous. User should not be able to flush + ;; tags buffer. Maybe should be done another way. + (or (object-unhash previous-find-tag-mark) + (editor-error "No previous Find Tag (or buffer killed)")) + find-file) + (let ((string (prompt-for-string "Find tag" previous-find-tag-string))) + (set! previous-find-tag-string string) + (find-tag string + (buffer-start (tags-table-buffer)) + find-file)))) + +(define-command ("Generate Tags Table" argument) + "Generate a tags table from a files list of Scheme files. + A files list is a file containing only strings which are file names. + The generated tags table has the same name as the files list, except that +the file type is TAG." + (let ((pathname + (prompt-for-pathname "Files List" + (pathname-new-type (current-default-pathname) + "FLS")))) + (let ((truename (pathname->input-truename pathname))) + (if (not truename) (editor-error "No such file")) + (make-tags-table (read-file truename) + (let ((pathname (pathname-new-type pathname "TAG"))) + (if (integer? (pathname-version pathname)) + (pathname-new-version pathname 'NEWEST) + pathname)) + scheme-tag-regexp)))) + +(define (tags-table-buffer) + (if (not (ref-variable "Tags Table Pathname")) + (visit-tags-table-command false)) + (let ((pathname (ref-variable "Tags Table Pathname"))) + (or (pathname->buffer pathname) + (let ((buffer (new-buffer (pathname->buffer-name pathname)))) + (read-buffer buffer pathname) + (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page)) + (editor-error "File " (pathname->string pathname) + " not a valid tag table")) + buffer)))) + +(define (tag->pathname tag) + (define (loop mark) + (let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1)))) + (let ((mark (mark+ (line-start file-mark 1) + (with-input-from-mark file-mark read)))) + (if (mark> mark tag) + (string->pathname (extract-string (line-start file-mark 0) + (mark-1+ file-mark))) + (loop mark))))) + (loop (group-start tag))) + +(define (tags-table-pathnames) + (let ((buffer (tags-table-buffer))) + (define (loop mark) + (let ((file-mark (skip-chars-backward "^,\n" (line-end mark 1)))) + (let ((mark (mark+ (line-start file-mark 1) + (with-input-from-mark file-mark read)))) + (cons (string->pathname (extract-string (line-start file-mark 0) + (mark-1+ file-mark))) + (if (group-end? mark) + '() + (loop mark)))))) + (or (buffer-get buffer tags-table-pathnames) + (let ((pathnames (loop (buffer-start buffer)))) + (buffer-put! buffer tags-table-pathnames pathnames) + pathnames)))) + +;;;; Find Tag + +(define previous-find-tag-string + false) + +(define previous-find-tag-mark + (object-hash false)) + +(define (find-tag string start find-file) + (define (loop mark) + (let ((mark (search-forward string mark))) + (and mark + (or (re-match-forward find-tag-match-regexp mark) + (loop mark))))) + (let ((tag (loop start))) + (set! previous-find-tag-mark (object-hash tag)) + (if (not tag) + (editor-failure "Tag not found") + (let ((regexp + (string-append + "^" + (re-quote-string (extract-string (mark-1+ tag) + (line-start tag 0))))) + (start (with-input-from-mark tag read))) + (find-file + (merge-pathnames (tag->pathname tag) + (pathname-directory-path + (ref-variable "Tags Table Pathname")))) + (let* ((buffer (current-buffer)) + (group (buffer-group buffer)) + (end (group-end-index group))) + (define (loop offset) + (let ((index (- start offset))) + (if (positive? index) + (or (re-search-forward regexp + (make-mark group index) + (make-mark group + (min (+ start offset) + end))) + (loop (* 3 offset))) + (re-search-forward regexp (make-mark group 0))))) + (buffer-widen! buffer) + (push-current-mark! (current-point)) + (let ((mark (loop 1000))) + (if (not mark) + (editor-failure "Tag no longer in file") + (set-current-point! (line-start mark 0))))))))) + +(define find-tag-match-regexp + (let ((rubout (char->string #\Rubout))) + (string-append "[^" (char->string char:newline) rubout "]*" rubout))) + +;;;; Tags Table Generation + +(define scheme-tag-regexp + "^(def\\(ine-variable\\(\\s \\|\\s>\\)*\"[^\"]+\"\\|ine-command\\(\\s \\|\\s>\\)*(\\(\\s \\|\\s>\\)*\"[^\"]+\"\\|ine-\\(method\\|procedure\\)\\(\\s \\|\\s>\\)+\\(\\sw\\|\\s_\\)+\\(\\(\\s \\|\\s>\\)*(+\\(\\s \\|\\s>\\)*\\|\\(\\s \\|\\s>\\)+\\)\\(\\sw\\|\\s_\\)+\\|\\(\\sw\\|\\s_\\)*\\(\\(\\s \\|\\s>\\)*(+\\(\\s \\|\\s>\\)*\\|\\(\\s \\|\\s>\\)+\\)\\(\\sw\\|\\s_\\)+\\)") + +(define (make-tags-table input-filenames output-filename definition-regexp) + (let ((input-buffer (temporary-buffer " *tags-input*")) + (output-buffer (temporary-buffer " *tags-output*"))) + (let ((output (buffer-point output-buffer))) + (define (do-file filename) + (insert-string "\f\n" output) + (insert-string filename output) + (insert-char #\, output) + (let ((recording-mark (mark-right-inserting output))) + (insert-newline output) + (let ((file-start (mark-index output))) + (read-buffer input-buffer (->pathname filename)) + (let ((end (buffer-end input-buffer))) + (define (definition-loop mark) + (if (and mark (re-search-forward definition-regexp mark end)) + (let ((end (re-match-end 0))) + (let ((start (line-start end 0))) + (insert-string (extract-string start end) output) + (insert-char #\Rubout output) + (insert-string (write-to-string (mark-index start)) + output) + (insert-newline output) + (definition-loop (line-start start 1)))))) + (definition-loop (buffer-start input-buffer))) + (insert-string (write-to-string (- (mark-index output) file-start)) + recording-mark)))) + (for-each do-file input-filenames)) + (set-buffer-point! output-buffer (buffer-start output-buffer)) + (kill-buffer input-buffer) + (set-visited-pathname output-buffer (->pathname output-filename)) + (write-buffer output-buffer) + (kill-buffer output-buffer))) + +;;;; Tags Search + +(define-command ("Tags Search" argument) + "Search through all files listed in tag table for a given string. +Stops when a match is found. +To continue searching for next match, use command \\[Tags Loop Continue]." + (let ((string + (prompt-for-string "Tags Search" + (ref-variable "Previous Search String")))) + (set-variable! "Previous Search String" string) + (tags-search (re-quote-string string)))) + +(define-command ("RE Tags Search" argument) + "Search through all files listed in tag table for a given regexp. +Stops when a match is found. +To continue searching for next match, use command \\[Tags Loop Continue]." + (let ((regexp + (prompt-for-string "RE Tags Search" + (ref-variable "Previous Search Regexp")))) + (set-variable! "Previous Search Regexp" regexp) + (tags-search regexp))) + +(define-command ("Tags Query Replace" argument) + "Query replace a given string with another one though all files listed +in tag table. If you exit (C-G or Altmode), you can resume the query +replace with the command \\[Tags Loop Continue]." + (replace-string-arguments "Tags Query Replace" + (lambda (source target) + (let ((replacer (replace-string "Tags Query Replace" false true false))) + (set! tags-loop-operator + (lambda (buffer start) + (select-buffer-no-record buffer) + (set-current-point! start) + (replacer source target)))))) + (set! tags-loop-done clear-message) + (tags-loop-start (tags-table-pathnames))) + +(define-command ("Tags Loop Continue" argument) + "Continue last \\[Tags Search] or \\[Tags Query Replace] command." + (let ((buffer (object-unhash tags-loop-buffer))) + (if (and (not (null? tags-loop-entry)) + buffer) + (tags-loop-continue buffer (buffer-point buffer)) + (editor-error "No Tags Loop in progress")))) + +(define tags-loop-buffer (object-hash false)) +(define tags-loop-entry '()) +(define tags-loop-operator) +(define tags-loop-done) + +(define (tags-search regexp) + (set! tags-loop-operator + (lambda (buffer start) + (let ((mark (re-search-forward regexp start))) + (and mark + (begin (if (not (eq? (current-buffer) buffer)) + (select-buffer buffer)) + (set-current-point! mark) + (temporary-message "Tags Search succeeded") + true))))) + (set! tags-loop-done + (lambda () + (editor-failure "Tags Search failed"))) + (tags-loop-start (tags-table-pathnames))) + +(define (tags-loop-start entries) + (set! tags-loop-entry entries) + (if (null? entries) + (tags-loop-done) + (let ((buffer (find-file-noselect (car entries)))) + (set! tags-loop-buffer (object-hash buffer)) + (tags-loop-continue buffer (buffer-start buffer))))) + +(define (tags-loop-continue buffer start) + (if (not (and (buffer-alive? buffer) + (tags-loop-operator buffer start))) + (tags-loop-start (cdr tags-loop-entry)))) + +(define find-file-noselect + (file-finder identity-procedure)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access tags-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/texcom.scm b/v7/src/edwin/texcom.scm new file mode 100644 index 000000000..09edd9f92 --- /dev/null +++ b/v7/src/edwin/texcom.scm @@ -0,0 +1,213 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Text Commands + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +(define-major-mode "Text" "Fundamental" + "Major mode for editing english text." + (local-set-variable! "Syntax Table" text-mode:syntax-table) + (if (ref-variable "Text Mode Hook") ((ref-variable "Text Mode Hook")))) + +(define-key "Text" #\M-S "^R Center Line") + +(define text-mode:syntax-table (make-syntax-table)) +(modify-syntax-entry! text-mode:syntax-table #\" " ") +(modify-syntax-entry! text-mode:syntax-table #\\ " ") +(modify-syntax-entry! text-mode:syntax-table #\[ "(] ") +(modify-syntax-entry! text-mode:syntax-table #\] ")[ ") +(modify-syntax-entry! text-mode:syntax-table #\{ "(} ") +(modify-syntax-entry! text-mode:syntax-table #\} "){ ") +(modify-syntax-entry! text-mode:syntax-table #\' "w ") + +(define-variable "Text Mode Hook" + "If not false, a thunk to call when entering Text mode." + #!FALSE) + +(define (turn-on-auto-fill) + (enable-current-minor-mode! fill-mode)) + +(define-command ("Text Mode" argument) + "Make the current mode be Text mode." + (set-current-major-mode! text-mode)) + +(define-major-mode "Indented-Text" "Text" + "Like Text mode, but indents each line under previous non-blank line." + ((mode-initialization text-mode)) + (local-set-variable! "Indent Line Procedure" ^r-indent-relative-command)) + +(define-command ("Indented Text Mode" argument) + "Make the current mode be Indented Text mode." + (set-current-major-mode! indented-text-mode)) + +;;;; Words + +(define-command ("^R Forward Word" (argument 1)) + "Move one or more words forward." + (move-thing forward-word argument)) + +(define-command ("^R Backward Word" (argument 1)) + "Move one or more words backward." + (move-thing backward-word argument)) + +(define-command ("^R Mark Word" (argument 1)) + "Set mark one or more words from point." + (mark-thing forward-word argument)) + +(define-command ("^R Kill Word" (argument 1)) + "Kill one or more words forward." + (kill-thing forward-word argument)) + +(define-command ("^R Backward Kill Word" (argument 1)) + "Kill one or more words backward." + (kill-thing backward-word argument)) + +(define-command ("^R Transpose Words" (argument 1)) + "Transpose the words before and after the cursor. +With a positive argument it transposes the words before and after the + cursor, moves right, and repeats the specified number of times, + dragging the word to the left of the cursor right. +With a negative argument, it transposes the two words to the left of + the cursor, moves between them, and repeats the specified number of + times, exactly undoing the positive argument form. +With a zero argument, it transposes the words at point and mark." + (transpose-things forward-word argument)) + +;;;; Case Conversion + +(define-command ("^R Uppercase Region" argument) + "Convert region to upper case." + (upcase-area (current-mark))) + +(define-command ("^R Lowercase Region" argument) + "Convert region to lower case." + (downcase-area (current-mark))) + +(define-command ("^R Uppercase Word" (argument 1)) + "Uppercase one or more words. +Moves forward over the words affected. +With a negative argument, uppercases words before point +but does not move point." + (upcase-area (forward-word (current-point) argument 'ERROR))) + +(define-command ("^R Lowercase Word" (argument 1)) + "Lowercase one or more words. +Moves forward over the words affected. +With a negative argument, lowercases words before point +but does not move point." + (downcase-area (forward-word (current-point) argument 'ERROR))) + +(define-command ("^R Uppercase Initial" (argument 1)) + "Put next word in lowercase, but capitalize initial. +With an argument, capitalizes that many words." + (define (capitalize-one-word) + (set-current-point! (forward-to-word (current-point) 'ERROR)) + (capitalize-area (forward-word (current-point) 1 'ERROR))) + (cond ((positive? argument) + (dotimes argument + (lambda (i) + (capitalize-one-word)))) + ((negative? argument) + (let ((p (current-point))) + (set-current-point! (forward-word p argument 'ERROR)) + (dotimes (- argument) + (lambda (i) + (capitalize-one-word))) + (set-current-point! p))))) + +;;;; Sentences + +(define-command ("^R Forward Sentence" (argument 1)) + "Move forward to next sentence-end. With argument, repeat. +With negative argument, move backward repeatedly to sentence-beginning. +Sentence ends are identified by the value of Sentence End +treated as a regular expression. Also, every paragraph boundary +terminates sentences as well." + (move-thing forward-sentence argument)) + +(define-command ("^R Backward Sentence" (argument 1)) + "Move backward to start of sentence. With arg, do it arg times. +See \\[^R Forward Sentence] for more information." + (move-thing backward-sentence argument)) + +(define-command ("^R Mark Sentence" (argument 1)) + "Put point at beginning and mark at end of sentence. +If you are between sentences, the following sentence is used +unless you are at the end of a paragraph." + (let ((end (forward-sentence (current-point) 1 'ERROR))) + (set-current-region! (make-region (backward-sentence end 1 'ERROR) end)))) + +(define-command ("^R Kill Sentence" (argument 1)) + "Kill forward to end of sentence. +Accepts numeric argument of either sign." + (kill-thing forward-sentence argument)) + +(define-command ("^R Backward Kill Sentence" (argument 1)) + "Kill backward to end of sentence. +Accepts numeric argument of either sign." + (kill-thing backward-sentence argument)) + +;;;; Paragraphs + +(define-command ("^R Forward Paragraph" (argument 1)) + "Move forward to end of paragraph. +See documentation on ^R Backward Paragraph." + (move-thing forward-paragraph argument)) + +(define-command ("^R Backward Paragraph" (argument 1)) + "Move backward to start of paragraph. +Paragraphs are delimited by blank lines or by lines which +start with a delimiter in Paragraph Delimiter or Page Delimiter. +If there is a fill prefix, any line that doesn't start with it +starts a paragraph. +Lines which start with the any character in Text Justifier +Escape Chars, if that character is matched by Paragraph Delimiter, +count as blank lines in that they separate paragraphs and +are not part of them." + (move-thing backward-paragraph argument)) + +(define-command ("^R Mark Paragraph" argument) + "Put point and mark around this paragraph. +In between paragraphs, puts it around the next one. +See ^R Backward Paragraph for paragraph definition." + (let ((end (forward-paragraph (current-point) 1 'ERROR))) + (set-current-region! (make-region (backward-paragraph end 1 'ERROR) end)))) + +;;; end USING-SYNTAX +) \ No newline at end of file diff --git a/v7/src/edwin/things.scm b/v7/src/edwin/things.scm new file mode 100644 index 000000000..499ec1d0a --- /dev/null +++ b/v7/src/edwin/things.scm @@ -0,0 +1,316 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Textual Entities + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +;;;; Motion Primitives + +;;; This file "defines" various kinds of things like lines, pages, +;;; words, etc. The "definition" of a FOO entity consists of two +;;; procedures, FORWARD-FOO and BACKWARD-FOO, each of which takes +;;; three arguments: [1] a mark to start from, [2] the number of FOOs +;;; to traverse, and [3] a limit for LIMIT-MARK-MOTION. The value of +;;; the procedure should be either a mark or #!FALSE. + +;;; If the number is positive, traverse that many FOOs in the given +;;; direction; if negative, in the opposite direction; and zero means +;;; don't move. It is assumed that no two FOOs overlap; they may or +;;; may not touch one another. When moving forward, stop to the right +;;; of the rightmost edge of the FOO. When moving backward, stop to +;;; the left of the leftmost edge. + +;;; MAKE-MOTION-PAIR will generate these two procedures, given the +;;; simpler primitives to move forward or backward once. + +(define (make-motion-pair forward-one-thing backward-one-thing receiver) + (define (forward-thing mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%forward-thing mark n limit?)) + ((negative? n) (%backward-thing mark (- n) limit?)) + (else mark))) + + (define (%forward-thing mark n limit?) + (define (loop mark n) + (let ((end (forward-one-thing mark))) + (cond ((not end) (limit-mark-motion limit? mark)) + ((= n 1) end) + (else (loop end (-1+ n)))))) + (loop mark n)) + + (define (backward-thing mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%backward-thing mark n limit?)) + ((negative? n) (%forward-thing mark (- n) limit?)) + (else mark))) + + (define (%backward-thing mark n limit?) + (define (loop mark n) + (let ((start (backward-one-thing mark))) + (cond ((not start) (limit-mark-motion limit? mark)) + ((= n 1) start) + (else (loop start (-1+ n)))))) + (loop mark n)) + + (receiver forward-thing backward-thing)) + +;;;; Generic Operations + +(define (move-thing forward-thing argument) + (set-current-point! (forward-thing (current-point) argument 'FAILURE))) + +(define (move-thing-saving-point forward-thing argument) + (let ((mark (current-point))) + (push-current-mark! mark) + (set-current-point! (forward-thing mark argument 'FAILURE)))) + +(define (mark-thing forward-thing n) + (push-current-mark! (forward-thing (current-point) n 'ERROR))) + +(define (kill-thing forward-thing n) + (kill-region (forward-thing (current-point) n 'ERROR))) + +(define (transpose-things forward-thing n) + (define (forward-once i) + (let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR)))) + (set-current-point! m4) + (let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR)))) + (let ((m1 (mark-permanent! (forward-thing m2 -1 'ERROR)))) + (let ((m3 (forward-thing m1 1 'ERROR))) + (region-insert! m4 (region-extract! (make-region m1 m3))) + (region-insert! m1 (region-extract! (make-region m2 m4)))))))) + + (define (backward-once i) + (let ((m2 (mark-permanent! (forward-thing (current-point) -1 'ERROR)))) + (let ((m1 (mark-left-inserting (forward-thing m2 -1 'ERROR)))) + (let ((m3 (forward-thing m1 1 'ERROR)) + (m4 (mark-right-inserting (forward-thing m2 1 'ERROR)))) + (region-insert! m4 (region-extract! (make-region m1 m3))) + (region-insert! m1 (region-extract! (make-region m2 m4)))) + (set-current-point! m1)))) + + (define (special) + (let ((m1 (normalize (current-point))) + (m2 (normalize (current-mark)))) + (cond ((mark< m1 m2) + (exchange m1 m2 + (lambda (m1 m2) + (set-current-point! m2) + (set-current-mark! m1)))) + ((mark< m2 m1) + (exchange m2 m1 + (lambda (m2 m1) + (set-current-point! m2) + (set-current-mark! m1))))))) + + (define (exchange m1 m2 receiver) + (let ((m1 (mark-right-inserting m1)) + (m3 (forward-thing m1 1 'ERROR)) + (m2 (mark-permanent! m2)) + (m4 (mark-right-inserting (forward-thing m2 1 'ERROR)))) + (region-insert! m4 (region-extract! (make-region m1 m3))) + (region-insert! m1 (region-extract! (make-region m2 m4))) + (receiver m4 m1))) + + (define (normalize m) + (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR)) + + (cond ((positive? n) (dotimes n forward-once)) + ((negative? n) (dotimes (- n) backward-once)) + (else (special)))) + +;;;; Horizontal Space + +(define (region-blank? region) + (not (skip-chars-forward " \t" + (region-start region) + (region-end region) + #!FALSE))) + +(define (line-blank? mark) + (not (skip-chars-forward " \t" + (line-start mark 0) + (line-end mark 0) + #!FALSE))) + +(define (horizontal-space-region mark) + (make-region (horizontal-space-start mark) + (horizontal-space-end mark))) + +(define (horizontal-space-start mark) + (skip-chars-backward " \t" mark (line-start mark 0))) + +(define (horizontal-space-end mark) + (skip-chars-forward " \t" mark (line-end mark 0))) + +(define (compute-horizontal-space c1 c2 receiver) + ;; Compute the number of tabs/spaces required to fill from column C1 + ;; to C2 with whitespace. It is assumed that C1 >= C2. + (if (ref-variable "Indent Tabs Mode") + (let ((qr1 (integer-divide c1 (ref-variable "Tab Width"))) + (qr2 (integer-divide c2 (ref-variable "Tab Width")))) + (if (> (integer-divide-quotient qr1) (integer-divide-quotient qr2)) + (receiver (- (integer-divide-quotient qr1) + (integer-divide-quotient qr2)) + (integer-divide-remainder qr1)) + (receiver 0 + (- (integer-divide-remainder qr1) + (integer-divide-remainder qr2))))) + (receiver 0 (- c2 c1)))) + +(define (insert-horizontal-space target-column #!optional point) + (set! point + (if (unassigned? point) (current-point) (mark-left-inserting point))) + (compute-horizontal-space target-column (mark-column point) + (lambda (n-tabs n-spaces) + (insert-chars #\Tab n-tabs point) + (insert-chars #\Space n-spaces point)))) + +(define (delete-horizontal-space #!optional point) + (if (unassigned? point) (set! point (current-point))) + (delete-string (horizontal-space-start point) + (horizontal-space-end point))) + +(define find-previous-blank-line + (let () + (define (loop mark) + (cond ((line-blank? mark) mark) + ((group-start? mark) #!FALSE) + (else (loop (line-start mark -1))))) + + (named-lambda (find-previous-blank-line mark) + (let ((start (line-start mark -1))) + (and start (loop start)))))) + +(define find-next-blank-line + (let () + (define (loop mark) + (cond ((line-blank? mark) mark) + ((group-start? mark) #!FALSE) + (else (loop (line-start mark 1))))) + + (named-lambda (find-next-blank-line mark) + (let ((start (line-start mark 1))) + (and start (loop start)))))) + +(define find-previous-non-blank-line + (let () + (define (loop mark) + (cond ((not (line-blank? mark)) mark) + ((group-start? mark) #!FALSE) + (else (loop (line-start mark -1))))) + + (named-lambda (find-previous-non-blank-line mark) + (let ((start (line-start mark -1))) + (and start (loop start)))))) + +(define find-next-non-blank-line + (let () + (define (loop mark) + (cond ((not (line-blank? mark)) mark) + ((group-start? mark) #!FALSE) + (else (loop (line-start mark 1))))) + + (named-lambda (find-next-non-blank-line mark) + (let ((start (line-start mark 1))) + (and start (loop start)))))) + +;;;; Indentation + +(define (maybe-change-indentation indentation #!optional point) + (if (unassigned? point) (set! point (current-point))) + (if (not (= indentation (mark-indentation point))) + (change-indentation indentation point))) + +(define (change-indentation indentation point) + (change-column indentation (line-start point 0))) + +(define (current-indentation #!optional point) + (mark-indentation (if (unassigned? point) (current-point) point))) + +(define (mark-indentation mark) + (mark-column (indentation-end mark))) + +(define (indentation-end mark) + (horizontal-space-end (line-start mark 0))) + +(define (within-indentation? mark) + (line-start? (horizontal-space-start mark))) + +(define (maybe-change-column column #!optional point) + (if (unassigned? point) (set! point (current-point))) + (if (not (= column (mark-column point))) + (change-column column point))) + +(define (change-column column point) + (mark-permanent! point) + (delete-horizontal-space point) + (insert-horizontal-space column point)) + +;;;; Lines + +(define (forward-line mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%forward-line mark n limit?)) + ((negative? n) (%backward-line mark (- n) limit?)) + (else mark))) + +(define %forward-line + line-start) + +(define (backward-line mark n #!optional limit?) + (if (unassigned? limit?) (set! limit? #!FALSE)) + (cond ((positive? n) (%backward-line mark n limit?)) + ((negative? n) (%forward-line mark (- n) limit?)) + (else mark))) + +(define (%backward-line mark n limit?) + (line-start mark + (- (if (line-start? mark) + n + (-1+ n))) + limit?)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/tparse.scm b/v7/src/edwin/tparse.scm new file mode 100644 index 000000000..d33e5c967 --- /dev/null +++ b/v7/src/edwin/tparse.scm @@ -0,0 +1,279 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Text Parsing + +(declare (usual-integrations)) +(using-syntax edwin-syntax-table + +;;;; Pages + +(define-variable "Page Delimiter" + "Regexp describing line-beginnings that separate pages." + "^\f") + +(define (forward-one-page mark) + (and (not (group-end? mark)) + (or (re-search-forward (ref-variable "Page Delimiter") mark) + (group-end mark)))) + +(define (backward-one-page mark) + (and (not (group-start? mark)) + (if (re-search-backward (ref-variable "Page Delimiter") (mark-1+ mark)) + (re-match-end 0) + (group-start mark)))) + +(define (page-start mark) + (or (re-match-forward (ref-variable "Page Delimiter") (line-start mark 0)) + (if (re-search-backward (ref-variable "Page Delimiter") (mark-1+ mark)) + (re-match-end 0) + (group-start mark)))) + +(define forward-page) +(define backward-page) +(make-motion-pair forward-one-page backward-one-page + (lambda (f b) + (set! forward-page f) + (set! backward-page b))) + +;;;; Paragraphs + +(define-variable "Paragraph Start" + "Regexp for beginning of a line that starts OR separates paragraphs." + "^[ \t\n]") + +(define-variable "Paragraph Separate" + "Regexp for beginning of a line that separates paragraphs. +If you change this, you may have to change Paragraph Start also." + "^[ \t]*$") + +(define forward-one-paragraph) +(let () + +(set! forward-one-paragraph +(named-lambda (forward-one-paragraph mark) + (and (not (group-end? mark)) + ((if (and (ref-variable "Fill Prefix") + (not (string-null? (ref-variable "Fill Prefix")))) + forward-fill + forward-nofill) + mark (group-end mark))))) + +(define (forward-nofill mark end) + (let ((prefix (string-append (ref-variable "Page Delimiter") "\\|"))) + (let ((start (string-append prefix (ref-variable "Paragraph Start"))) + (separate + (string-append prefix (ref-variable "Paragraph Separate")))) + (forward-kernel mark + (named-lambda (separator? mark) + (re-match-forward separate mark)) + (named-lambda (skip-body mark) + (if (re-search-forward start (line-end mark 0) end) + (re-match-start 0) + end)))))) + +(define (forward-fill mark end) + (let ((fill-prefix (re-quote-string (ref-variable "Fill Prefix")))) + (let ((prefix (string-append (ref-variable "Page Delimiter") "\\|^" + fill-prefix))) + (let ((start (string-append prefix "[ \t\n]")) + (separate (string-append prefix "[ \t]*$"))) + (define (skip-body mark) + (let ((lstart (line-start mark 1))) + (cond ((not lstart) end) + ((or (not (re-match-forward fill-prefix lstart)) + (re-match-forward start lstart)) + lstart) + (else (skip-body lstart))))) + (forward-kernel mark + (named-lambda (separator? lstart) + (or (not (re-match-forward fill-prefix lstart)) + (re-match-forward separate lstart))) + skip-body))))) + +(define (forward-kernel mark separator? skip-body) + (define (skip-separators mark) + (let ((lstart (line-start mark 1))) + (and lstart + (if (separator? lstart) + (skip-separators lstart) + lstart)))) + (if (separator? (line-start mark 0)) + (let ((para-start (skip-separators mark))) + (and para-start (skip-body para-start))) + (skip-body mark))) + +) + +(define backward-one-paragraph) +(let () + +(set! backward-one-paragraph +(named-lambda (backward-one-paragraph mark) + (and (not (group-start? mark)) + ((if (and (ref-variable "Fill Prefix") + (not (string-null? (ref-variable "Fill Prefix")))) + backward-fill + backward-nofill) + mark (group-start mark) (group-end mark))))) + +(define (backward-nofill mark start end) + (let ((prefix (string-append (ref-variable "Page Delimiter") "\\|"))) + (let ((starter (string-append prefix (ref-variable "Paragraph Start"))) + (separator + (string-append prefix (ref-variable "Paragraph Separate")))) + (backward-kernel mark + (named-lambda (separator? mark) + (re-match-forward separator mark)) + (named-lambda (skip-body mark) + (if (re-search-backward starter mark start) + (re-match-start 0) + start)))))) + +(define (backward-fill mark start end) + (let ((fill-prefix (re-quote-string (ref-variable "Fill Prefix")))) + (let ((prefix (string-append (ref-variable "Page Delimiter") "\\|^" + fill-prefix))) + (let ((starter (string-append prefix "[ \t\n]")) + (separator (string-append prefix "[ \t]*$"))) + (define (skip-body mark) + (let ((lstart (line-start mark -1))) + (cond ((not lstart) start) + ((or (not (re-match-forward fill-prefix lstart)) + (re-match-forward starter lstart)) + lstart) + (else (skip-body lstart))))) + (backward-kernel mark + (named-lambda (separator? lstart) + (or (not (re-match-forward fill-prefix lstart)) + (re-match-forward separator lstart))) + skip-body))))) + +(define (backward-kernel mark separator? skip-body) + (define (skip-separators mark) + (let ((lstart (line-start mark -1))) + (and lstart + (if (separator? lstart) + (skip-separators lstart) + lstart)))) + (if (separator? (line-start mark 0)) + (let ((para-start (skip-separators mark))) + (and para-start (skip-body para-start))) + (skip-body mark))) + +) + +(define forward-paragraph) +(define backward-paragraph) +(make-motion-pair forward-one-paragraph backward-one-paragraph + (lambda (f b) + (set! forward-paragraph f) + (set! backward-paragraph b))) + +(define (paragraph-text-region mark) + (let ((end (or (paragraph-text-end mark) (group-end mark)))) + (make-region (or (paragraph-text-start end) (group-start mark)) + end))) + +(define (paragraph-text-start mark) + (let ((start (backward-one-paragraph mark))) + (and start + (if (and (ref-variable "Fill Prefix") + (not (string-null? (ref-variable "Fill Prefix")))) + (if (match-forward (ref-variable "Fill Prefix") start) + start + (line-start start 1)) + (let ((start + (if (re-match-forward (ref-variable "Paragraph Separate") + start) + (line-start start 1) + start))) + (or (skip-chars-forward " \t\n" start mark #!FALSE) + (if (group-start? start) + start + (paragraph-text-start start)))))))) + +(define (paragraph-text-end mark) + (let ((end (forward-one-paragraph mark))) + (and end + (let ((mark* (if (line-start? end) (mark-1+ end) end))) + (if (mark>= mark* mark) + mark* + (let ((mark* (mark1+ mark*))) + (if (group-end? mark*) + mark* + (paragraph-text-end mark*)))))))) + +;;;; Sentences + +(define-variable "Sentence End" + "Regexp describing the end of a sentence. +All paragraph boundaries also end sentences, regardless." + "[.?!][]\")]*\\($\\|\t\\| \\)[ \t\n]*") + +(define (forward-one-sentence mark) + (let ((end (paragraph-text-end mark))) + (and end + (let ((mark (re-search-forward (ref-variable "Sentence End") + mark end))) + (if mark + (skip-chars-backward " \t\n" mark (re-match-start 0) #!FALSE) + end))))) + +(define (backward-one-sentence mark) + (let ((start (paragraph-text-start mark))) + (and start + (if (re-search-backward (string-append (ref-variable "Sentence End") + "[^ \t\n]") + mark start) + (mark-1+ (re-match-end 0)) + start)))) + +(define forward-sentence) +(define backward-sentence) +(make-motion-pair forward-one-sentence backward-one-sentence + (lambda (f b) + (set! forward-sentence f) + (set! backward-sentence b))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/tximod.scm b/v7/src/edwin/tximod.scm new file mode 100644 index 000000000..175675359 --- /dev/null +++ b/v7/src/edwin/tximod.scm @@ -0,0 +1,83 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1987 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. +;;; + +;;;; Texinfo Mode + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +(define-command ("Texinfo Mode" argument) + "Make the current mode be Texinfo mode." + (set-current-major-mode! texinfo-mode)) + +(define-major-mode "Texinfo" "Text" + "Major mode for editing texinfo files. +These are files that are input for TeX and also to be turned +into Info files by \\[Texinfo Format Buffer]. +These files must be written in a very restricted and +modified version of TeX input format." + ((mode-initialization text-mode)) + (local-set-variable! "Syntax Table" texinfo-mode:syntax-table) + (local-set-variable! "Fill Column" 75) + (local-set-variable! "Require Final Newline" true) + (local-set-variable! "Page Delimiter" + (string-append "^@node\\|" + (ref-variable "Page Delimiter"))) + (local-set-variable! "Paragraph Start" + (string-append "^\\|^@[a-z]*[ \n]\\|" + (ref-variable "Paragraph Start"))) + (local-set-variable! "Paragraph Separate" + (string-append "^\\|^@[a-z]*[ \n]\\|" + (ref-variable "Paragraph Separate"))) + (if (ref-variable "Texinfo Mode Hook") ((ref-variable "Texinfo Mode Hook")))) + +(define texinfo-mode:syntax-table + (make-syntax-table)) + +(modify-syntax-entry! texinfo-mode:syntax-table #\" " ") +(modify-syntax-entry! texinfo-mode:syntax-table #\\ " ") +(modify-syntax-entry! texinfo-mode:syntax-table #\@ "\\") +(modify-syntax-entry! texinfo-mode:syntax-table #\C-Q "\\") +(modify-syntax-entry! texinfo-mode:syntax-table #\' "w") + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; End: diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm new file mode 100644 index 000000000..0da672199 --- /dev/null +++ b/v7/src/edwin/undo.scm @@ -0,0 +1,423 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Undo, translated from the GNU Emacs implementation in C. + +(declare (usual-integrations) + (integrate-external "edb:struct.bin.0")) +(using-syntax edwin-syntax-table + +(define enable-group-undo!) +(define undo-record-insertion!) +(define undo-record-deletion!) +(define undo-boundary!) +(define undo-done!) + +(define undo-package + (make-environment + +(declare (integrate initial-undo-records initial-undo-chars + maximum-undo-records maximum-undo-chars)) + +(define initial-undo-records 8) +(define initial-undo-chars 128) +(define maximum-undo-records 512) +(define maximum-undo-chars 8192) + +(define-named-structure "Undo-Data" + records ; vector of records + next-record ; position in vector + chars ; string of characters + next-char ; position in string + ) + +(declare (integrate %make-undo-record undo-record-index:type + undo-record-index:start undo-record-index:length + undo-record-type undo-record-start undo-record-length + mark-not-undoable!)) + +(define (%make-undo-record) + (vector-cons 3 #!FALSE)) + +(define undo-record-index:type 0) +(define undo-record-index:start 1) +(define undo-record-index:length 2) + +(define (undo-record-type undo-record) + (declare (integrate undo-record)) + (vector-ref undo-record 0)) + +(define (undo-record-start undo-record) + (declare (integrate undo-record)) + (vector-ref undo-record 1)) + +(define (undo-record-length undo-record) + (declare (integrate undo-record)) + (vector-ref undo-record 2)) + +(define (undo-records-ref records index) + (or (vector-ref records index) + (let ((new-record (%make-undo-record))) + (vector-set! records index new-record) + new-record))) + +;;;; Basic Record Keeping + +(define last-undo-group #!FALSE) +(define last-undo-record #!FALSE) + +(set! enable-group-undo! +(named-lambda (enable-group-undo! group) + (without-interrupts + (lambda () + (let ((undo-data (%make-undo-data)) + (records (vector-cons initial-undo-records #!FALSE))) + (mark-not-undoable! records (-1+ initial-undo-records)) + (vector-set! undo-data undo-data-index:records records) + (vector-set! undo-data undo-data-index:next-record 0) + (vector-set! undo-data undo-data-index:chars + (string-allocate initial-undo-chars)) + (vector-set! undo-data undo-data-index:next-char 0) + (set-group-undo-data! group undo-data)))))) + +(define (new-undo! undo-data type group start length) + (let ((undo-record (undo-records-ref (undo-data-records undo-data) + (undo-data-next-record undo-data)))) + (let ((next (1+ (undo-data-next-record undo-data)))) + (cond ((< next (vector-length (undo-data-records undo-data))) + (vector-set! undo-data undo-data-index:next-record next)) + ((>= next maximum-undo-records) + (vector-set! undo-data undo-data-index:next-record 0)) + (else + (let ((records (undo-data-records undo-data)) + (new-records (vector-cons maximum-undo-records #!FALSE))) + (subvector-move-right! records 0 (vector-length records) + new-records 0) + (mark-not-undoable! new-records (-1+ maximum-undo-records)) + (vector-set! undo-data undo-data-index:records new-records) + (vector-set! undo-data undo-data-index:next-record next))))) + (mark-not-undoable! (undo-data-records undo-data) + (undo-data-next-record undo-data)) + (vector-set! undo-record undo-record-index:type type) + (vector-set! undo-record undo-record-index:start start) + (vector-set! undo-record undo-record-index:length length) + (set! last-undo-record undo-record)) + (set! last-undo-group group) + (if (not (eq? 'BOUNDARY type)) + (set! last-undone-record -1))) + +(define (mark-not-undoable! records index) + (declare (integrate records index)) + (vector-set! (undo-records-ref records index) + undo-record-index:type 'NOT-UNDOABLE)) + +(define (undo-store-chars! undo-data group start end) + (let ((text (group-text group)) + (gap-start (group-gap-start group)) + (length (group-gap-length group))) + (cond ((<= end gap-start) + (undo-store-substring! undo-data text start end)) + ((>= start gap-start) + (undo-store-substring! undo-data text (+ start length) + (+ end length))) + (else + (undo-store-substring! undo-data text start gap-start) + (undo-store-substring! undo-data text (group-gap-end group) + (+ end length)))))) + +(define (undo-store-substring! undo-data string start end) + (let ((chars (undo-data-chars undo-data)) + (i (undo-data-next-char undo-data))) + (let ((room (- (string-length chars) i)) + (needed (- end start))) + (cond ((> room needed) + (substring-move-right! string start end chars i) + (vector-set! undo-data undo-data-index:next-char (+ i needed)) + (set! number-chars-left (- number-chars-left needed))) + ((= room needed) + (substring-move-right! string start end chars i) + (vector-set! undo-data undo-data-index:next-char 0) + (set! number-chars-left (- number-chars-left needed))) + ((< (string-length chars) maximum-undo-chars) + (let ((new-chars (string-allocate maximum-undo-chars))) + (substring-move-right! chars 0 i new-chars 0) + (vector-set! undo-data undo-data-index:chars new-chars)) + (set! number-chars-left + (+ (- maximum-undo-chars (string-length chars)) + number-chars-left)) + (undo-store-substring! undo-data string start end)) + (else + (let ((new-start (+ start room))) + (substring-move-right! string start new-start chars i) + (vector-set! undo-data undo-data-index:next-char 0) + (set! number-chars-left (- number-chars-left room)) + (undo-store-substring! undo-data string new-start end))))))) + +;;;; External Recording Hooks + +;;; These assume that they are called before the regular recording +;;; daemons, for the following reason: to check the old status of the +;;; GROUP-MODIFIED? flag before the buffer daemon updates it. + +(set! undo-record-insertion! +(named-lambda (undo-record-insertion! group start end) + (let ((undo-data (group-undo-data group))) + (if undo-data + (begin + (if (not (eq? group last-undo-group)) + (begin (undo-mark-previous! undo-data 'BOUNDARY group + (mark-index (group-point group))) + (set! last-undo-record #!FALSE))) + (if (not (group-modified? group)) + (new-undo! undo-data 'UNMODIFY group start 0)) + (let ((length (- end start))) + (if (and last-undo-record + (eq? 'DELETE (undo-record-type last-undo-record)) + (= start (+ (undo-record-start last-undo-record) + (undo-record-length last-undo-record)))) + (vector-set! last-undo-record undo-record-index:length + (+ length (undo-record-length last-undo-record))) + (new-undo! undo-data 'DELETE group start length)))))))) + +(set! undo-record-deletion! +(named-lambda (undo-record-deletion! group start end) + (let ((undo-data (group-undo-data group))) + (if undo-data + (begin + (if (not (eq? group last-undo-group)) + (begin (undo-mark-previous! undo-data 'BOUNDARY group + (mark-index (group-point group))) + (set! last-undo-record #!FALSE))) + (if (not (group-modified? group)) + (new-undo! undo-data 'UNMODIFY group start 0)) + (let ((length (- end start))) + (if (and last-undo-record + (eq? 'INSERT (undo-record-type last-undo-record)) + (= start (undo-record-start last-undo-record))) + (vector-set! last-undo-record undo-record-index:length + (+ length (undo-record-length last-undo-record))) + (new-undo! undo-data 'INSERT group start length))) + (undo-store-chars! undo-data group start end)))))) + +(set! undo-boundary! +(named-lambda (undo-boundary! point) + (without-interrupts + (lambda () + (let ((group (mark-group point))) + (let ((undo-data (group-undo-data group))) + (if undo-data + (undo-mark-previous! undo-data 'BOUNDARY group + (mark-index point))))))))) + +(set! undo-done! +(named-lambda (undo-done! point) + (without-interrupts + (lambda () + (let ((group (mark-group point))) + (let ((undo-data (group-undo-data group))) + (if undo-data + (undo-mark-previous! undo-data 'NOT-UNDOABLE group + (mark-index point))))))))) + +(define (undo-mark-previous! undo-data type group start) + (let ((record + (let ((records (undo-data-records undo-data)) + (next (undo-data-next-record undo-data))) + (undo-records-ref records + (-1+ (if (zero? next) + (vector-length records) + next)))))) + (if (not (eq? type (undo-record-type record))) + (new-undo! undo-data type group start 0)))) + +;;;; Undo Command + +;;; This is used to determine if we have switched buffers since the +;;; last Undo command. Actually, this may be an artifact of RMS' +;;; implementation since there should not be any way to switch buffers +;;; between two Undo commands in this editor. +(define last-undone-buffer) + +;;; These keep track of the state of the Undo command, so that +;;; subsequent invocations know where to start from. +(define last-undone-record) +(define last-undone-char) + +;;; This counts the total number of records that have been undone, so +;;; that it can be compared to the total number of records, to +;;; determine if we have run out of records. +(define number-records-undone) + +;;; This says how many chars of undo are left. It is initialized by +;;; the Undo command to the length of the chars string, and used, like +;;; NUMBER-RECORDS-UNDONE, to determine if we have run out of undo +;;; data. This, however, is kept up to date by NEW-UNDO because there +;;; is no NOT-UNDOABLE boundary in the chars array to tell us where +;;; the chars end. +(define number-chars-left 0) + +;;; Some error messages: + +(define cant-undo-more + "Cannot undo more: changes have been made since the last undo") + +(define no-more-undo + "No further undo information available") + +(define outside-visible-range + "Changes to be undone are outside the visible portion of buffer") + +(define undo-command-tag "Undo") + +(define-command ("Undo" (argument 1)) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (if (positive? argument) + (let ((buffer (current-buffer))) + (let ((undo-data (group-undo-data (buffer-group buffer)))) + (if (not undo-data) + (editor-error "Undo information not kept for this buffer")) + (without-interrupts + (lambda () + (command-message-receive undo-command-tag + (lambda () + (if (or (not (eq? last-undone-buffer buffer)) + (= -1 last-undone-record)) + (editor-error cant-undo-more))) + (lambda () + (set! last-undone-buffer buffer) + (set! number-records-undone 0) + (set! number-chars-left + (string-length (undo-data-chars undo-data))) + (set! last-undone-record (undo-data-next-record undo-data)) + (set! last-undone-char (undo-data-next-char undo-data)) + ;; This accounts for the boundary that is inserted + ;; just before this command is called. + (set! argument (1+ argument)))) + (undo-n-records undo-data + buffer + (count-records-to-undo undo-data argument)))) + (set-command-message! undo-command-tag) + (temporary-message "Undo!"))))) + +(define (count-records-to-undo undo-data argument) + (let ((records (undo-data-records undo-data))) + (define (find-nth-previous-boundary argument i n) + (define (find-previous-boundary i n any-records?) + (let ((i (-1+ (if (zero? i) (vector-length records) i))) + (n (1+ n))) + (set! number-records-undone (1+ number-records-undone)) + (if (> number-records-undone (vector-length records)) + (editor-error no-more-undo) + (case (undo-record-type (vector-ref records i)) + ((BOUNDARY) + (if (= argument 1) + n + (find-nth-previous-boundary (-1+ argument) i n))) + ((NOT-UNDOABLE) + (if (and (= argument 1) any-records?) + ;; In this case treat it as if there were a + ;; BOUNDARY just in front of this record. + (-1+ n) + (editor-error no-more-undo))) + ((INSERT) + (set! number-chars-left + (- number-chars-left + (undo-record-length (vector-ref records i)))) + (if (negative? number-chars-left) + (editor-error no-more-undo) + (find-previous-boundary i n #!TRUE))) + (else + (find-previous-boundary i n #!TRUE)))))) + (find-previous-boundary i n #!FALSE)) + (find-nth-previous-boundary argument last-undone-record 0))) + +(define (undo-n-records undo-data buffer n) + (let ((group (buffer-group buffer)) + (records (undo-data-records undo-data)) + (chars (undo-data-chars undo-data))) + (define (loop n) + (if (positive? n) + (let ((ir (-1+ (if (zero? last-undone-record) + (vector-length records) + last-undone-record)))) + (let ((type (undo-record-type (vector-ref records ir))) + (start (undo-record-start (vector-ref records ir))) + (length (undo-record-length (vector-ref records ir)))) + (cond ((eq? 'DELETE type) + (let ((end (+ start length))) + (if (or (< start (group-start-index group)) + (> end (group-end-index group))) + (editor-error outside-visible-range)) + (group-delete! group start end)) + (set-current-point! (make-mark group start))) + ((eq? 'INSERT type) + (if (or (< start (group-start-index group)) + (> start (group-end-index group))) + (editor-error outside-visible-range)) + (set-current-point! (make-mark group start)) + (let ((ic (- last-undone-char length))) + (if (not (negative? ic)) + (begin (group-insert-substring! group start + chars ic + last-undone-char) + (set! last-undone-char ic)) + (let ((l (string-length chars))) + (let ((ic* (+ l ic))) + (group-insert-substring! group start + chars ic* l) + (group-insert-substring! group (- start ic) + chars 0 + last-undone-char) + (set! last-undone-char ic*)))))) + ((eq? 'UNMODIFY type) + (buffer-not-modified! buffer)) + ((eq? 'BOUNDARY type) 'DONE) + (else + (error "Losing undo record type" type)))) + (set! last-undone-record ir) + (loop (-1+ n))))) + (loop n))) + +;;; end UNDO-PACKAGE +))) + +;;; Edwin Variables: +;;; Scheme Environment: (access undo-package edwin-package) +;;; Scheme Syntax Table: edwin-syntax-table +;;; End: diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm new file mode 100644 index 000000000..5fb99069d --- /dev/null +++ b/v7/src/edwin/utils.scm @@ -0,0 +1,101 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Editor Utilities + +(declare (usual-integrations)) + +(define (string-append-char string char) + (let ((size (string-length string))) + (let ((result (string-allocate (1+ size)))) + (substring-move-right! string 0 size result 0) + (string-set! result size char) + result))) + +(define (string-append-substring string1 string2 start2 end2) + (let ((length1 (string-length string1))) + (let ((result (string-allocate (+ length1 (- end2 start2))))) + (substring-move-right! string1 0 length1 result 0) + (substring-move-right! string2 start2 end2 result length1) + result))) + +(define (dotimes n procedure) + (define (loop i) + (if (< i n) + (begin (procedure i) + (loop (1+ i))))) + (loop 0)) + +(define char-set:null + (char-set)) + +(define char-set:return + (char-set #\Return)) + +(define char-set:not-space + (char-set-invert (char-set #\Space))) + +(define char-set:not-graphic + (char-set-invert char-set:graphic)) + +(define (read-line) + (let ((port (current-input-port))) + (let ((string ((access :read-string port) char-set:return))) + ((access :discard-char port)) + string))) + +(define (y-or-n? . strings) + (define (loop) + (let ((char (char-upcase (read-char)))) + (cond ((or (char=? char #\Y) + (char=? char #\Space)) + (write-string "Yes") + #!TRUE) + ((or (char=? char #\N) + (char=? char #\Rubout)) + (write-string "No") + #!FALSE) + (else + (beep) + (loop))))) + (newline) + (write-string (apply string-append strings)) + (loop)) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; End: diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm new file mode 100644 index 000000000..3d0f4841f --- /dev/null +++ b/v7/src/edwin/utlwin.scm @@ -0,0 +1,335 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Utility Windows + +(declare (usual-integrations) + (integrate-external "edb:window.bin.0")) +(using-syntax class-syntax-table + +;;;; String Window +;;; This "mixin" defines a common base from which 2D text string +;;; windows can be built. Mostly, it provides standard procedures +;;; from which methods can be built. + +(define-class string-base vanilla-window + (image representation)) + +(define-method string-base (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (cond ((pair? representation) + (cond ((not (cdr representation)) + ;; disable clipping. + (subscreen-clear! screen + x-start (+ x-start xu) + y-start (+ y-start yu)) +#| + (subscreen-clear! screen + (+ x-start xl) (+ x-start xu) + (+ y-start yl) (+ y-start yu))|# + ) + ((< yl yu) + (let ((start (cdr representation)) + (end (string-length (car representation))) + (ayu (+ y-start yu))) + ;; disable clipping. + (if (not (zero? start)) + (subscreen-clear! screen + x-start (+ x-start start) + y-start ayu)) + (screen-write-substring! screen + (+ x-start start) y-start + (car representation) + start end) + (subscreen-clear! screen + (+ x-start end) (+ x-start x-size) + y-start ayu)#| + (if (not (zero? start)) + (clip-window-region-1 xl xu start + (lambda (xl xu) + (subscreen-clear! screen + (+ x-start xl) (+ x-start xu) + ayl ayu)))) + (clip-window-region-1 (- xl start) (- xu start) (- end start) + (lambda (xl xu) + (let ((xl* (+ xl start))) + (screen-write-substring! screen + (+ x-start xl*) ayl + (car representation) + xl* (+ xu start))))) + (clip-window-region-1 (- xl end) (- xu end) (- x-size end) + (lambda (xl xu) + (let ((x-start (+ x-start end))) + (subscreen-clear! screen + (+ x-start xl) (+ x-start xu) + ayl ayu))))|# + )))) + (else + (screen-write-substrings! screen (+ x-start xl) (+ y-start yl) + representation xl xu yl yu))) + #!TRUE) + +(define-procedure string-base (string-base:set-size-given-x! window x) + (set! x-size x) + (set! y-size (string-base:desired-y-size window x)) + (string-base:refresh! window)) + +(define-procedure string-base (string-base:set-size-given-y! window y) + (set! x-size (string-base:desired-x-size window y)) + (set! y-size y) + (string-base:refresh! window)) + +(define-procedure string-base (string-base:desired-x-size window y-size) + (column->x-size (image-column-size image) y-size)) + +(define-procedure string-base (string-base:desired-y-size window x-size) + (column->y-size (image-column-size image) x-size)) + +(define-procedure string-base (string-base:index->coordinates window index) + (column->coordinates (image-column-size image) x-size + (image-index->column image index))) + +(define-procedure string-base (string-base:index->x window index) + (column->x (image-column-size image) x-size + (image-index->column image index))) + +(define-procedure string-base (string-base:index->y window index) + (column->y (image-column-size image) x-size + (image-index->column image index))) + +(define-procedure string-base (string-base:coordinates->index window x y) + (image-column->index image + (min (coordinates->column x y x-size) + (image-column-size image)))) + +(define (column->x-size column-size y-size) + ;; Assume Y-SIZE > 0. + (let ((qr (integer-divide column-size y-size))) + (if (zero? (integer-divide-remainder qr)) + (integer-divide-quotient qr) + (1+ (integer-divide-quotient qr))))) + +(define (column->y-size column-size x-size) + ;; Assume X-SIZE > 1. + (if (zero? column-size) + 1 + (let ((qr (integer-divide column-size (-1+ x-size)))) + (if (zero? (integer-divide-remainder qr)) + (integer-divide-quotient qr) + (1+ (integer-divide-quotient qr)))))) + +(define (column->coordinates column-size x-size column) + (let ((-1+x-size (-1+ x-size))) + (if (< column -1+x-size) + (cons column 0) + (let ((qr (integer-divide column -1+x-size))) + (if (and (zero? (integer-divide-remainder qr)) + (= column column-size)) + (cons -1+x-size + (-1+ (integer-divide-quotient qr))) + (cons (integer-divide-remainder qr) + (integer-divide-quotient qr))))))) + +(define (column->x column-size x-size column) + (let ((-1+x-size (-1+ x-size))) + (if (< column -1+x-size) + column + (let ((r (remainder column -1+x-size))) + (if (and (zero? r) (= column column-size)) + -1+x-size + r))))) + +(define (column->y column-size x-size column) + (let ((-1+x-size (-1+ x-size))) + (if (< column -1+x-size) + 0 + (let ((qr (integer-divide column -1+x-size))) + (if (and (zero? (integer-divide-remainder qr)) + (= column column-size)) + (-1+ (integer-divide-quotient qr)) + (integer-divide-quotient qr)))))) + +(define (coordinates->column x y x-size) + (+ x (* y (-1+ x-size)))) + +(define-procedure string-base + (string-base:direct-output-insert-char! window x char) + (if (pair? representation) + (begin (set-car! representation + (string-append-char (car representation) char)) + (if (and (not (cdr representation)) + (not (char=? char #\Space))) + (set-cdr! representation x))) + (string-set! (vector-ref representation (-1+ y-size)) x char))) + +(define-procedure string-base + (string-base:direct-output-insert-newline! window) + (set! y-size 1) + (set! representation (cons "" #!FALSE))) + +(define-procedure string-base + (string-base:direct-output-insert-substring! window x string + start end) + (if (pair? representation) + (begin (set-car! representation + (string-append-substring (car representation) + string start end)) + (if (not (cdr representation)) + (let ((index + (substring-find-next-char-in-set string start end + char-set:not-space))) + (if index + (set-cdr! representation (+ x index)))))) + (substring-move-right! string start end + (vector-ref representation (-1+ y-size)) x))) + +(define-procedure string-base (string-base:refresh! window) + (let ((string (image-representation image))) + (let ((column-size (string-length string))) + (if (< column-size x-size) + (let ((start + (string-find-next-char-in-set string char-set:not-space))) + (if (not (and (pair? representation) + (string=? (car representation) string) + (eqv? (cdr representation) start))) + (begin (set! representation (cons string start)) + (setup-redisplay-flags! redisplay-flags)))) + (let ((rep (vector-cons y-size '())) + (x-max (-1+ x-size))) + (define (loop start y) + (let ((s (string-allocate x-size)) + (end (+ start x-max))) + (vector-set! rep y s) + (cond ((<= column-size end) + (substring-move-right! string start column-size + s 0) + (substring-fill! s (- column-size start) x-size + #\Space)) + (else + (substring-move-right! string start end s 0) + (string-set! s x-max #\!) + (loop end (1+ y)))))) + (loop 0 0) + (set! representation rep) + (setup-redisplay-flags! redisplay-flags)))))) + +;;;; Blank Window + +(define-class blank-window vanilla-window + ()) + +(define-method blank-window (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (subscreen-clear! screen + (+ x-start xl) (+ x-start xu) + (+ y-start yl) (+ y-start yu)) + #!TRUE) + +;;;; Vertical Border Window + +(define-class vertical-border-window vanilla-window + ()) + +(define-method vertical-border-window (:initialize! window window*) + (usual=> window :initialize! window*) + (set! x-size 1)) + +(define-method vertical-border-window (:set-x-size! window x) + (error "Can't change the x-size of a vertical border window" x)) + +(define-method vertical-border-window (:set-size! window x y) + (if (not (= x 1)) + (error "x-size of a vertical border window must be 1" x)) + (set! x-size x) + (set! y-size y) + (setup-redisplay-flags! redisplay-flags)) + +(define-method vertical-border-window + (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (if (< xl xu) + (clip-window-region-1 yl yu y-size + (lambda (yl yu) + (let ((xl (+ x-start xl)) + (yu (+ y-start yu))) + (define (loop y) + (if (< y yu) + (begin (screen-write-char! screen xl y #\|) + (loop (1+ y))))) + (loop (+ y-start yl)))))) + #!TRUE) + +;;;; Cursor Window + +(define-class cursor-window vanilla-window + (enabled?)) + +(define-method cursor-window (:initialize! window window*) + (usual=> window :initialize! window*) + (set! x-size 1) + (set! y-size 1) + (set! enabled? #!FALSE)) + +(define-method cursor-window (:set-x-size! window x) + (error "Can't change the size of a cursor window" x)) + +(define-method cursor-window (:set-y-size! window y) + (error "Can't change the size of a cursor window" y)) + +(define-method cursor-window (:set-size! window x y) + (error "Can't change the size of a cursor window" x y)) + +(define-method cursor-window (:update-display! window screen x-start y-start + xl xu yl yu display-style) + (if (and enabled? (< xl xu) (< yl yu)) (screen-write-cursor! screen x-start y-start)) + #!TRUE) + +(define-method cursor-window (:enable! window) + (set! enabled? #!TRUE) + (setup-redisplay-flags! redisplay-flags)) + +(define-method cursor-window (:disable! window) + (set! enabled? #!FALSE) + (set-car! redisplay-flags #!FALSE)) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/wincom.scm b/v7/src/edwin/wincom.scm new file mode 100644 index 000000000..4080cba6b --- /dev/null +++ b/v7/src/edwin/wincom.scm @@ -0,0 +1,444 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1987 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. +;;; + +;;;; Window Commands + +(declare (usual-integrations)) +(using-syntax (access edwin-syntax-table edwin-package) + +(define-variable "Cursor Centering Point" + "The distance from the top of the window at which to center the point. +This number is a percentage, where 0 is the window's top and 100 the bottom." + 35) + +(define-variable "Cursor Centering Threshold" + "If point moves offscreen by more than this many lines, recenter. +Otherwise, the screen is scrolled to put point at the edge it moved over." + 0) + +(define-variable "Window Minimum Width" + "Delete any window less than this wide. +Do not set this variable below 2." + 2) + +(define-variable "Window Minimum Height" + "Delete any window less than this high. +The modeline is not included in this figure. +Do not set this variable below 1." + 1) + +(define-variable "Next Screen Context Lines" + "Number of lines of continuity when scrolling by screenfuls." + 2) + +(define-variable "Mode Line Inverse Video" + "If true, the mode line is highlighted." + true) + +(define-command ("^R New Window" argument) + "Choose new window putting point at center, top or bottom. +With no argument, chooses a window to put point at the center +\(\"Cursor Centering Point\" says where). +An argument gives the line to put point on; +negative args count from the bottom. +C-U as argument redisplays the line containing point." + (let ((window (current-window))) + (let ((size (window-y-size window))) + (if (not argument) + (window-redraw! window false) + (window-scroll-y-absolute! window + (let ((n (remainder argument size))) + (if (negative? n) + (+ n size) + n))))))) + +(define-command ("^R Move to Screen Edge" argument) + "Jump to top or bottom of screen. +Like \\[^R New Window] except that point is changed instead of the window. +With no argument, jumps to the center, according to \"Cursor Centering Point\". +An argument specifies the number of lines from the top; +negative args count from the bottom." + (let ((window (current-window))) + (let ((mark + (or (window-coordinates->mark + window 0 + (if (not argument) + (window-y-center window) + (let ((y-size (window-y-size window))) + (let ((n (remainder argument y-size))) + (if (negative? n) + (+ n y-size) + n))))) + (window-coordinates->mark + window 0 + (window-mark->y window + (buffer-end (window-buffer window))))))) + (set-current-point! (if (group-start? mark) + (group-start mark) + mark))))) + +(define-command ("^R Next Screen" argument) + "Move down to display next screenful of text. +With argument, moves window down that many lines (negative moves up). +Just minus as an argument moves up a full screen." + (let ((window (current-window))) + (scroll-window window + (standard-scroll-window-argument window argument 1)))) + +(define-command ("^R Previous Screen" argument) + "Move up to display previous screenful of text. +With argument, moves window up that many lines (negative moves down). +Just minus as an argument moves down a full screen." + (let ((window (current-window))) + (scroll-window window + (standard-scroll-window-argument window argument -1)))) + +(define-command ("^R Next Several Screens" argument) + "Move down to display next screenful of text. +With argument, move window down that many screenfuls (negative moves up). +Just minus as an argument moves up a full screen." + (let ((window (current-window))) + (scroll-window window + (multi-scroll-window-argument window argument 1)))) + +(define-command ("^R Previous Several Screens" argument) + "Move up to display previous screenful of text. +With argument, move window down that many screenfuls (negative moves down). +Just minus as an argument moves down full screen." + (let ((window (current-window))) + (scroll-window window + (multi-scroll-window-argument window argument -1)))) + +(define (scroll-window window n #!optional limit) + (if (unassigned? limit) (set! limit editor-error)) + (if (if (negative? n) + (mark= (window-start-mark window) + (buffer-start (window-buffer window))) + (mark= (window-end-mark window) + (buffer-end (window-buffer window)))) (limit) + (window-scroll-y-relative! window n))) + +(define (standard-scroll-window-argument window argument factor) + (* factor + (let ((quantum + (- (window-y-size window) + (ref-variable "Next Screen Context Lines")))) + (cond ((not argument) quantum) + ((command-argument-negative-only?) (- quantum)) + (else argument))))) + +(define (multi-scroll-window-argument window argument factor) + (* factor + (let ((quantum + (- (window-y-size window) + (ref-variable "Next Screen Context Lines")))) + (cond ((not argument) quantum) + ((command-argument-negative-only?) + (- quantum)) + (else (* argument quantum)))))) + +(define-command ("^R Screen Video" (argument 0)) + "Toggle the screen's use of inverse video. +With a positive argument, inverse video is forced. +With a negative argument, normal video is forced." + ((access screen-inverse-video! window-package) + (or (positive? argument) + (not (or (negative? argument) + ((access screen-inverse-video! window-package) false))))) + (update-alpha-window! true)) + +(define-command ("What Cursor Position" argument) + "Print various things about where cursor is. +Print the X position, the Y position, +the ASCII code for the following character, +point absolutely and as a percentage of the total file size, +and the virtual boundaries, if any." + (let ((buffer (current-buffer)) + (point (current-point))) + (let ((position (mark-index point)) + (total (group-length (buffer-group buffer)))) + (message (if (group-end? point) + "" + (let ((char (mark-right-char point))) + (string-append "Char: " (char->name char) + " (0" + (fluid-let ((*unparser-radix* 8)) + (write-to-string + (char->ascii char))) + ") "))) + "point=" (write-to-string position) + " of " (write-to-string total) + "(" + (write-to-string (if (zero? total) + 0 + (round (* 100 (/ position total))))) + "%) " + (let ((group (mark-group point))) + (let ((start (group-start-index group)) + (end (group-end-index group))) + (if (and (zero? start) (= end total)) + "" + (string-append "<" (write-to-string start) + " - " (write-to-string end) + "> ")))) + "x=" (write-to-string (mark-column point)))))) + +;;;; Multiple Windows + +(define-command ("^R Split Window Vertically" argument) + "Split current window into two windows, one above the other. +This window becomes the uppermost of the two, and gets +ARG lines. No arg means split equally." + (disallow-typein) + (window-split-vertically! (current-window) argument)) + +(define-command ("^R Split Window Horizontally" argument) + "Split current window into two windows side by side. +This window becomes the leftmost of the two, and gets +ARG lines. No arg means split equally." + (disallow-typein) + (window-split-horizontally! (current-window) argument)) + +(define-command ("^R Enlarge Window Vertically" (argument 1)) + "Makes current window ARG lines bigger." + (disallow-typein) + (window-grow-vertically! (current-window) argument)) + +(define-command ("^R Shrink Window Vertically" (argument 1)) + "Makes current window ARG lines smaller." + (disallow-typein) + (window-grow-vertically! (current-window) (- argument))) + +(define-command ("^R Enlarge Window Horizontally" (argument 1)) + "Makes current window ARG columns wider." + (disallow-typein) + (window-grow-horizontally! (current-window) argument)) + +(define-command ("^R Shrink Window Horizontally" (argument 1)) + "Makes current window ARG columns narrower." + (disallow-typein) + (window-grow-horizontally! (current-window) (- argument))) + +(define-command ("^R Delete Window" argument) + "Delete the current window from the screen." + (window-delete! (current-window))) + +(define-command ("^R Delete Other Windows" argument) + "Make the current window fill the screen." + (delete-other-windows (current-window))) + +(define-command ("^R Other Window" argument) + "Select the ARG'th different window." + (select-window (other-window-interactive argument))) + +(define (other-window-interactive n) + (let ((window (other-window n))) + (if (eq? window (current-window)) + (editor-error "No other window") + window))) + +(define (disallow-typein) + (if (typein-window? (current-window)) + (editor-error "Not implemented for typein window"))) + +(define-command ("^R Scroll Other Window" argument) + "Scroll text of next window up ARG lines, or near full screen if no arg." + (let ((window (other-window-interactive 1))) + (scroll-window window + (standard-scroll-window-argument window argument 1)))) + +(define-command ("^R Scroll Other Window Several Screens" argument) + "Scroll other window up several screenfuls. +Specify the number as a numeric argument, negative for down. +The default is one screenful up. Just minus as an argument +means scroll one screenful down." + (let ((window (other-window-interactive 1))) + (scroll-window window + (multi-scroll-window-argument window argument 1)))) + +;;;; Pop-up Buffers + +(define-variable "Pop Up Windows" + "If false, this disables the use of pop-up windows." + true) + +(define-variable "Preserve Window Arrangement" + "If true, commands that normally change the window arrangement do not." + false) + +(define-variable "Split Height Threshold" + "Pop-up windows prefer to split the largest window if it is this large. +If there is only one window, it is split regardless of this value." + 500) + +(define-command ("Kill Pop Up Buffer" argument) + "Kills the most recently popped up buffer, if one exists. +Also kills any pop up window it may have created." + (let ((buffer (object-unhash *previous-popped-up-buffer*)) + (window (object-unhash *previous-popped-up-window*))) + (if (and window (window-visible? window)) + (window-delete! window)) + (if (and buffer (buffer-alive? buffer)) + (kill-buffer-interactive buffer) + (editor-error "No previous pop up buffer")))) + +(define *previous-popped-up-buffer* + (object-hash false)) + +(define *previous-popped-up-window* + (object-hash false)) + +(define (pop-up-buffer buffer #!optional select?) + ;; If some new window is created by this procedure, it is returned + ;; as the value. Otherwise the value is false. + + (if (unassigned? select?) (set! select? false)) + + (define (pop-up-window window) + (let ((window (window-split-vertically! window false))) + (pop-into-window window) + window)) + + (define (pop-into-window window) + (set-window-buffer! window buffer) + (if select? (select-window window)) + false) + + (if (< (ref-variable "Window Minimum Height") 2) + (set-variable! "Window Minimum Height" 2)) + (let ((window + (let ((window (get-buffer-window buffer))) + (if window + (begin (set-window-point! window (buffer-point buffer)) + (if select? (select-window window)) + false) + (let ((limit (* 2 (ref-variable "Window Minimum Height")))) + (if (< (ref-variable "Split Height Threshold") limit) + (set-variable! "Split Height Threshold" limit)) + (cond ((ref-variable "Preserve Window Arrangement") + (pop-into-window (largest-window))) + ((ref-variable "Pop Up Windows") + (or (let ((window (largest-window))) + (and (>= (window-y-size window) + (ref-variable "Split Height Threshold")) + (not + (window-has-horizontal-neighbor? window)) + (pop-up-window window))) + (let ((window (lru-window)) + (current (current-window))) + (if (and (or (eq? window current) + (and (typein-window? current) + (eq? window + (window1+ window)))) + (>= (window-y-size window) limit)) + (pop-up-window window) + (pop-into-window window))))) + (else + (pop-into-window (lru-window))))))))) + (set! *previous-popped-up-window* (object-hash window)) + (set! *previous-popped-up-buffer* (object-hash buffer)) + window)) + +(define (get-buffer-window buffer) + (let ((start (window0))) + (define (loop window) + (and (not (eq? window start)) + (if (eq? buffer (window-buffer window)) + window + (loop (window1+ window))))) + (if (eq? buffer (window-buffer start)) + start + (loop (window1+ start))))) + +(define (largest-window) + (let ((start (window0))) + (define (loop window largest largest-area) + (if (eq? window start) + largest + (let ((area (* (window-x-size window) (window-y-size window)))) + (if (> area largest-area) + (loop (window1+ window) window area) + (loop (window1+ window) largest largest-area))))) + (loop (window1+ start) + start + (* (window-x-size start) (window-y-size start))))) + +(define (lru-window) + (let ((start (window0))) + (define (search-full-width window smallest smallest-time) + (let ((next (window1+ window)) + (time (window-select-time window))) + (let ((consider-window? + (and (not (window-has-horizontal-neighbor? window)) + (or (not smallest) + (< time smallest-time))))) + (if (eq? window start) + (if consider-window? + window + (or smallest + (search-all next + start + (window-select-time start)))) + (if consider-window? + (search-full-width next window time) + (search-full-width next smallest smallest-time)))))) + + (define (search-all window smallest smallest-time) + (if (eq? window start) + smallest + (let ((time (window-select-time window))) + (if (< time smallest-time) + (search-all (window1+ window) window time) + (search-all (window1+ window) smallest smallest-time))))) + + (search-full-width (window1+ start) false false))) + +(define (delete-other-windows start) + (define (loop window) + (if (not (eq? window start)) + (begin (window-delete! window) + (loop (window1+ window))))) + (loop (window1+ start))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: edwin-package +;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package) +;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package) +;;; End: diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm new file mode 100644 index 000000000..8f8dccabb --- /dev/null +++ b/v7/src/edwin/window.scm @@ -0,0 +1,452 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Window System + +(declare (usual-integrations) + (integrate-external "edb:class.bin.0")) +(using-syntax class-syntax-table + +;;; Based on WINDOW-WIN, designed by RMS. +;;; See ED:-WINOPS.TXT for more information. + +;;; The convention of using method names like :FOO is somewhat +;;; arbitrary. However, methods without the prefix ":" are intended +;;; to be internal (non-public) methods. + +;;; Procedural covers are used as the ultimate outside interface to +;;; the window system, since that minimizes dependence on the +;;; syntactic details of the class/object system. + +;;; It is assumed in several places that all windows keep the +;;; following instance variables updated: SUPERIOR, X-SIZE, and +;;; Y-SIZE. Thus these are normally accessed using procedure calls or +;;; instance variable references, rather than the more cumbersome +;;; method invocation. However, these instance variables are always +;;; set by a method defined on the window itself. + +;;;; Vanilla Window + +(define-class vanilla-window () + (superior x-size y-size redisplay-flags inferiors)) + +(declare (integrate window-superior + window-x-size %set-window-x-size! + window-y-size %set-window-y-size! + window-redisplay-flags window-inferiors + window-inferior? window-inferior)) + +(define-procedure vanilla-window (window-initialize! window window*) + (set! superior window*) + (set! redisplay-flags (=> superior :inferior-redisplay-flags window)) + (set! inferiors '())) + +(define-procedure vanilla-window (window-kill! window) + (for-each (lambda (inferior) (=> (inferior-window inferior) :kill!)) + inferiors)) + +(define-procedure vanilla-window (window-superior window) + (declare (integrate window)) + superior) + +(define-procedure vanilla-window (set-window-superior! window window*) + (set! superior window*) + (set! redisplay-flags (=> window* :inferior-redisplay-flags window)) + (setup-redisplay-flags! redisplay-flags) + (for-each (lambda (inferior) + (set-inferior-redisplay-flags! inferior + (cons #!FALSE redisplay-flags)) + (=> (inferior-window inferior) :set-superior! window)) + inferiors)) + +(define-procedure vanilla-window (window-x-size window) + (declare (integrate window)) + x-size) + +(define-procedure vanilla-window (%set-window-x-size! window x) + (declare (integrate window x)) + (set! x-size x)) + +(define-procedure vanilla-window (set-window-x-size! window x) + (%set-window-x-size! window x) + (setup-redisplay-flags! redisplay-flags)) + +(define-procedure vanilla-window (window-y-size window) + (declare (integrate window)) + y-size) + +(define-procedure vanilla-window (%set-window-y-size! window y) + (declare (integrate window y)) + (set! y-size y)) + +(define-procedure vanilla-window (set-window-y-size! window y) + (%set-window-y-size! window y) + (setup-redisplay-flags! redisplay-flags)) + +(define-procedure vanilla-window (window-size window receiver) + (receiver x-size y-size)) + +(define-procedure vanilla-window (set-window-size! window x y) + (set! x-size x) + (set! y-size y) + (setup-redisplay-flags! redisplay-flags)) + +(define-procedure vanilla-window (window-redisplay-flags window) + (declare (integrate window)) + redisplay-flags) + +(define-procedure vanilla-window (window-inferiors window) + (declare (integrate window)) + inferiors) + +(define-procedure vanilla-window (window-inferior? window window*) + (declare (integrate window window*)) + (find-inferior? inferiors window*)) + +(define-procedure vanilla-window (window-inferior window window*) + (declare (integrate window window*)) + (find-inferior inferiors window*)) + +(define-procedure vanilla-window (make-inferior window class) + (let ((window* (make-object class))) + (let ((inferior + (cons window* + (vector #!FALSE #!FALSE + (cons #!FALSE redisplay-flags))))) + (set! inferiors (cons inferior inferiors)) + (=> window* :initialize! window) + inferior))) + +(define-procedure vanilla-window (add-inferior! window window*) + (set! inferiors + (cons (cons window* + (vector #!FALSE #!FALSE + (cons #!FALSE redisplay-flags))) + inferiors)) + (=> window* :set-superior! window)) + +(define-procedure vanilla-window (delete-inferior! window window*) + (set! inferiors + (delq! (find-inferior inferiors window*) + inferiors))) + +(define-procedure vanilla-window (replace-inferior! window old new) + (set-inferior-window! (find-inferior inferiors old) new) + (=> new :set-superior! window)) + +;;; Returns #!TRUE if the redisplay finished, #!FALSE if aborted. +;;; Notice that the :update-display! operation is assumed to return +;;; the same value. This is used to control the setting of the +;;; redisplay flags. + +(define-procedure vanilla-window + (update-inferiors! window screen x-start y-start + xl xu yl yu display-style) + (define (loop inferiors) + (or (null? inferiors) + (let ((window (inferior-window (car inferiors))) + (xi (inferior-x-start (car inferiors))) + (yi (inferior-y-start (car inferiors))) + (flags (inferior-redisplay-flags (car inferiors)))) + (declare (compilable-primitive-functions + (keyboard-active? tty-read-char-ready?))) + (if (and (or display-style (car flags)) + xi yi) + (and (or display-style (not (keyboard-active? 0))) + (clip-window-region xl xu yl yu + xi (window-x-size window) + yi (window-y-size window) + (lambda (xl xu yl yu) + (=> window :update-display! + screen (+ x-start xi) (+ y-start yi) + xl xu yl yu display-style))) + (begin (set-car! flags #!FALSE) + (loop (cdr inferiors)))) + (begin (set-car! flags #!FALSE) + (loop (cdr inferiors))))))) + (loop inferiors)) + +(define (clip-window-region xl xu yl yu xi xs yi ys receiver) + (clip-window-region-1 (- xl xi) (- xu xi) xs + (lambda (xl xu) + (clip-window-region-1 (- yl yi) (- yu yi) ys + (lambda (yl yu) + (receiver xl xu yl yu)))))) + +(define (clip-window-region-1 al au bs receiver) + (if (positive? al) + (if (<= al bs) + (receiver al (if (< bs au) bs au)) + #!TRUE) + (if (positive? au) + (receiver 0 (if (< bs au) bs au)) + #!TRUE))) + +(define-procedure vanilla-window (salvage-inferiors! window) + (define (loop inferiors) + (if (not (null? inferiors)) + (begin (=> (inferior-window (car inferiors)) :salvage!) + (loop (cdr inferiors))))) + (loop inferiors)) + +;;;; Standard Methods +;;; All windows should support these operations + +(define-method vanilla-window :initialize! window-initialize!) +(define-method vanilla-window :kill! window-kill!) +(define-method vanilla-window :superior window-superior) +(define-method vanilla-window :set-superior! set-window-superior!) +(define-method vanilla-window :x-size window-x-size) +(define-method vanilla-window :set-x-size! set-window-x-size!) +(define-method vanilla-window :y-size window-y-size) +(define-method vanilla-window :set-y-size! set-window-y-size!) +(define-method vanilla-window :size window-size) +(define-method vanilla-window :set-size! set-window-size!) + +(define-method vanilla-window (:make-inferior window class) + (inferior-window (make-inferior window class))) + +(define-method vanilla-window :add-inferior! add-inferior!) +(define-method vanilla-window :delete-inferior! delete-inferior!) +(define-method vanilla-window :replace-inferior! replace-inferior!) +(define-method vanilla-window :update-display! update-inferiors!) +(define-method vanilla-window :salvage! salvage-inferiors!) + +;;;; Operations on Inferiors + +(define-method vanilla-window (:inferior-redisplay-flags window window*) + (inferior-redisplay-flags (find-inferior inferiors window*))) + +(define-method vanilla-window (:inferior-needs-redisplay! window window*) + (inferior-needs-redisplay! (find-inferior inferiors window*))) + +(define-method vanilla-window (:inferior-position window window*) + (inferior-position (find-inferior inferiors window*))) + +(define-method vanilla-window (:set-inferior-position! window window* position) + (set-inferior-position! (find-inferior inferiors window*) position)) + +(define-method vanilla-window (:inferior-x-start window window*) + (inferior-x-start (find-inferior inferiors window*))) + +(define-method vanilla-window (:set-inferior-x-start! window window* x-start) + (set-inferior-x-start! (find-inferior inferiors window*) x-start)) + +(define-method vanilla-window (:inferior-x-end window window*) + (inferior-x-end (find-inferior inferiors window*))) + +(define-method vanilla-window (:set-inferior-x-end! window window* x-end) + (set-inferior-x-end! (find-inferior inferiors window*) x-end)) + +(define-method vanilla-window (:inferior-y-start window window*) + (inferior-y-start (find-inferior inferiors window*))) + +(define-method vanilla-window (:set-inferior-y-start! window window* y-start) + (set-inferior-y-start! (find-inferior inferiors window*) y-start)) + +(define-method vanilla-window (:inferior-y-end window window*) + (inferior-y-end (find-inferior inferiors window*))) + +(define-method vanilla-window (:set-inferior-y-end! window window* y-end) + (set-inferior-y-end! (find-inferior inferiors window*) y-end)) + +(define-method vanilla-window (:inferior-start window window* receiver) + (inferior-start (find-inferior inferiors window*) receiver)) + +(define-method vanilla-window (:set-inferior-start! window window* x y) + (set-inferior-start! (find-inferior inferiors window*) x y)) + +;;;; Inferiors + +(define (inferior-position inferior) + (and (inferior-x-start inferior) + (inferior-y-start inferior) + (cons (inferior-x-start inferior) + (inferior-y-start inferior)))) + +(define (set-inferior-position! inferior position) + (if (not position) + (set-inferior-start! inferior #!FALSE #!FALSE) + (set-inferior-start! inferior (car position) (cdr position)))) + +(define (inferior-needs-redisplay! inferior) + (if (and (inferior-x-start inferior) + (inferior-y-start inferior)) + (setup-redisplay-flags! (inferior-redisplay-flags inferior)) + (set-car! (inferior-redisplay-flags inferior) #!FALSE))) + +(define (setup-redisplay-flags! flags) + (if (not (or (null? flags) (car flags))) + (begin (set-car! flags #!TRUE) + (setup-redisplay-flags! (cdr flags))))) + +(declare (integrate inferior-x-size %set-inferior-x-size! set-inferior-x-size! + inferior-y-size %set-inferior-y-size! set-inferior-y-size! + inferior-size set-inferior-size!)) + +(define (inferior-x-size inferior) + (declare (integrate inferior)) + (window-x-size (inferior-window inferior))) + +(define (%set-inferior-x-size! inferior x) + (declare (integrate inferior x)) + (%set-window-x-size! (inferior-window inferior) x)) + +(define (set-inferior-x-size! inferior x) + (declare (integrate inferior x)) + (=> (inferior-window inferior) :set-x-size! x)) + +(define (inferior-y-size inferior) + (declare (integrate inferior)) + (window-y-size (inferior-window inferior))) + +(define (%set-inferior-y-size! inferior y) + (declare (integrate inferior y)) + (%set-window-y-size! (inferior-window inferior) y)) + +(define (set-inferior-y-size! inferior y) + (declare (integrate inferior y)) + (=> (inferior-window inferior) :set-y-size! y)) + +(define (inferior-size inferior receiver) + (declare (integrate inferior receiver)) + (window-size (inferior-window inferior) receiver)) + +(define (set-inferior-size! inferior x y) + (declare (integrate inferior x y)) + (=> (inferior-window inferior) :set-size! x y)) + +(declare (integrate find-inferior find-inferior? + inferior-window set-inferior-window! + inferior-x-start %set-inferior-x-start! + inferior-y-start %set-inferior-y-start! + inferior-redisplay-flags set-inferior-redisplay-flags!)) + +(define (find-inferior? inferiors window) + (declare (integrate inferiors window)) + (assq window inferiors)) + +(define (find-inferior inferiors window) + (declare (integrate inferiors window)) + (or (find-inferior? inferiors window) + (error "Window is not an inferior" window))) + +(define inferior-window + car) + +(define set-inferior-window! + set-car!) + +(define (inferior-x-start inferior) + (declare (integrate inferior)) + (vector-ref (cdr inferior) 0)) + +(define (%set-inferior-x-start! inferior x-start) + (vector-set! (cdr inferior) 0 x-start)) + +(define (set-inferior-x-start! inferior x-start) + (%set-inferior-x-start! inferior x-start) + (inferior-needs-redisplay! inferior)) + +(define (inferior-x-end inferior) + (let ((x-start (inferior-x-start inferior))) + (and x-start (+ x-start (inferior-x-size inferior))))) + +(define (set-inferior-x-end! inferior x-end) + (set-inferior-x-start! inferior (- x-end (inferior-x-size inferior)))) + +(define (inferior-y-start inferior) + (declare (integrate inferior)) + (vector-ref (cdr inferior) 1)) + +(define (%set-inferior-y-start! inferior y-start) + (vector-set! (cdr inferior) 1 y-start)) + +(define (set-inferior-y-start! inferior y-start) + (%set-inferior-y-start! inferior y-start) + (inferior-needs-redisplay! inferior)) + +(define (inferior-y-end inferior) + (let ((y-start (inferior-y-start inferior))) + (and y-start (+ y-start (inferior-y-size inferior))))) + +(define (set-inferior-y-end! inferior y-end) + (set-inferior-y-start! inferior (- y-end (inferior-y-size inferior)))) +(define (inferior-start inferior receiver) + (receiver (inferior-x-start inferior) + (inferior-y-start inferior))) + +(define (set-inferior-start! inferior x-start y-start) + (vector-set! (cdr inferior) 0 x-start) + (vector-set! (cdr inferior) 1 y-start) + (inferior-needs-redisplay! inferior)) + +(define (inferior-redisplay-flags inferior) + (declare (integrate inferior)) + (vector-ref (cdr inferior) 2)) + +(define (set-inferior-redisplay-flags! inferior flags) + (declare (integrate inferior flags)) + (vector-set! (cdr inferior) 2 flags)) + +;;;; Root Window + +(define the-alpha-window) + +(define (reset-alpha-window!) + (set! the-alpha-window (make-object vanilla-window)) + (with-instance-variables vanilla-window the-alpha-window + (set! superior #!FALSE) + (set! x-size (screen-x-size the-alpha-screen)) + (set! y-size (screen-y-size the-alpha-screen)) + (set! redisplay-flags (list #!FALSE)) + (set! inferiors '()))) + +(define (update-alpha-window! #!optional display-style) + (with-instance-variables vanilla-window the-alpha-window + (if (and (or display-style (car redisplay-flags)) + (=> the-alpha-window :update-display! the-alpha-screen 0 0 + 0 x-size 0 y-size display-style)) + (set-car! redisplay-flags #!FALSE)))) + +;;; end USING-SYNTAX +) + +;;; Edwin Variables: +;;; Scheme Environment: (access window-package edwin-package) +;;; Scheme Syntax Table: class-syntax-table +;;; End: diff --git a/v7/src/edwin/xform.scm b/v7/src/edwin/xform.scm new file mode 100644 index 000000000..b6dd63fe6 --- /dev/null +++ b/v7/src/edwin/xform.scm @@ -0,0 +1,177 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1985 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. +;;; + +;;;; Instance Variable Transformation + +(declare (usual-integrations)) + +(define transform-instance-variables) +(let () + +(set! transform-instance-variables +(named-lambda (transform-instance-variables transforms name expression) + (fluid-let ((name-of-self name)) + (transform-expression transforms expression)))) + +(define name-of-self) + +(define (transform-expression transforms expression) + ((transform-dispatch expression) transforms expression)) + +(define (transform-expressions transforms expressions) + (define (transform-expression-loop expressions) + (if (null? expressions) + '() + (cons (transform-expression transforms (car expressions)) + (transform-expression-loop (cdr expressions))))) + (transform-expression-loop expressions)) + +(define (remove-transforms transforms names) + (define (loop transforms) + (cond ((null? transforms) '()) + ((memq (caar transforms) names) + (loop (cdr transforms))) + (else + (cons (car transforms) + (loop (cdr transforms)))))) + (loop transforms)) + +(define (transform-constant transforms constant) + constant) + +(define (transform-variable transforms variable) + (let ((entry (assq (variable-name variable) transforms))) + (if (not entry) + variable + (make-combination vector-ref + (list (make-variable name-of-self) + (cdr entry)))))) + +(define (transform-assignment transforms assignment) + (assignment-components assignment + (lambda (name value) + (let ((entry (assq name transforms)) + (value (transform-expression transforms value))) + (if (not entry) + (make-assignment name value) + (make-combination vector-set! + (list (make-variable name-of-self) + (cdr entry) + value))))))) + +(define (transform-combination transforms combination) + (combination-components combination + (lambda (operator operands) + (make-combination (transform-expression transforms operator) + (transform-expressions transforms operands))))) + +(define (transform-lambda transforms lambda) + (lambda-components** lambda + (lambda (pattern bound body) + (make-lambda** pattern bound + (transform-expression (remove-transforms transforms bound) + body))))) + +(define (transform-open-block transforms open-block) + (open-block-components open-block + (lambda (names declarations body) + (make-open-block names declarations + (transform-expression (remove-transforms transforms + names) + body))))) + +(define (transform-definition transforms definition) + (definition-components definition + (lambda (name value) + (error "Free definition encountered:" name) + (make-definition name (transform-expression transforms value))))) + +(define (transform-sequence transforms sequence) + (make-sequence (transform-expressions transforms + (sequence-actions sequence)))) + +(define (transform-conditional transforms conditional) + (conditional-components conditional + (lambda (predicate consequent alternative) + (make-conditional (transform-expression transforms predicate) + (transform-expression transforms consequent) + (transform-expression transforms alternative))))) + +(define (transform-disjunction transforms disjunction) + (disjunction-components disjunction + (lambda (predicate alternative) + (make-disjunction (transform-expression transforms predicate) + (transform-expression transforms alternative))))) + +(define (transform-comment transforms comment) + (comment-components comment + (lambda (text expression) + (make-comment text (transform-expression transforms expression))))) + +(define (transform-delay transforms delay) + (make-delay (transform-expression transforms (delay-expression delay)))) + +(define (transform-access transforms access) + (access-components access + (lambda (environment name) + (make-access (transform-expression transforms environment) + name)))) + +(define (transform-in-package transforms in-package) + (in-package-components in-package + (lambda (environment expression) + (make-in-package (transform-expression transforms environment) + expression)))) + +(define transform-dispatch + (make-type-dispatcher + `((,variable-type ,transform-variable) + (,assignment-type ,transform-assignment) + (,definition-type ,transform-definition) + (,sequence-type ,transform-sequence) + (,conditional-type ,transform-conditional) + (,disjunction-type ,transform-disjunction) + (,comment-type ,transform-comment) + (,delay-type ,transform-delay) + (,access-type ,transform-access) + (,in-package-type ,transform-in-package) + (,lambda-type ,transform-lambda) + (,open-block-type ,transform-open-block) + (,combination-type ,transform-combination)) + transform-constant)) + +) \ No newline at end of file diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm new file mode 100644 index 000000000..b1aa6d906 --- /dev/null +++ b/v7/src/runtime/rgxcmp.scm @@ -0,0 +1,815 @@ +;;; -*-Scheme-*- +;;; +;;; Copyright (c) 1986 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. +;;; + +;;;; Regular Expression Pattern Compiler +;;; Translated from GNU (thank you RMS!) + +(declare (usual-integrations)) + +;;;; Compiled Opcodes + +(let-syntax ((define-enumeration + (macro (name prefix . suffixes) + (define (loop n suffixes) + (if (null? suffixes) + '() + (cons `(DEFINE ,(string->symbol + (string-append prefix + (symbol->string + (car suffixes)))) + ,n) + (loop (1+ n) (cdr suffixes))))) + `(BEGIN ,@(loop 0 suffixes) + (DEFINE ,name + (VECTOR ,@(map (lambda (suffix) `',suffix) + suffixes))))))) + (define-enumeration re-codes "RE-CODE:" + unused ;Zero bytes may appear in the compiled regular + ;expression. + + exact-1 ;Followed by a single literal byte. + + exact-n ;Followed by one byte giving n, and then by n + ;literal bytes. + + line-start ;Fails unless at start of line. + line-end ;Fails unless at end of line. + + jump ;Followed by two bytes giving relative address + ;to jump to. + + on-failure-jump ;Followed by two bytes giving relative address + ;of place to result at in case of failure. + + finalize-jump ;Throw away latest failure point and then jump + ;to address. + + maybe-finalize-jump ;Like jump but finalize if safe to do so. + ;This is used to jump back to the beginning of + ;a repeat. If the command that follows this + ;jump is clearly incompatible with the one at + ;the beginning of the repeat, such that we can + ;be sure that there is no use backtracing out + ;of repetitions already completed, then we + ;finalize. + + dummy-failure-jump ;Jump, and push a dummy failure point. This + ;failure point will be thrown away if an + ;attempt is made to use it for a failure. A + + ;construct makes this before the first repeat. + + any-char ;Matches any one character except for newline. + + char-set ;Matches any one char belonging to specified + ;set. First following byte is # bitmap bytes. + ;Then come bytes for a bit-map saying which + ;chars are in. Bits in each byte are ordered + ;low-bit-first. A character is in the set if + ;its bit is 1. A character too large to have + ;a bit in the map is automatically not in the + ;set. + + not-char-set ;Similar but match any character that is NOT + ;one of those specified. + + start-memory ;Starts remembering the text that is matches + ;and stores it in a memory register. Followed + ;by one byte containing the register number. + ;Register numbers must be in the range 0 + ;through re-number-of-registers. + + stop-memory ;Stops remembering the text that is matched + ;and stores it in a memory register. Followed + ;by one byte containing the register number. + ;Register numbers must be in the range 0 + ;through re-number-of-registers. + + duplicate ;Match a duplicate of something remembered. + ;Followed by one byte containing the index of + ;the memory register. + + buffer-start ;Succeeds if at beginning of buffer. + buffer-end ;Succeeds if at end of buffer. + word-char ;Matches any word-constituent character. + not-word-char ;Matches any char that is not a word-constituent. + word-start ;Succeeds if at word beginning. + word-end ;Succeeds if at word end. + word-bound ;Succeeds if at a word boundary. + not-word-bound ;Succeeds if not at a word boundary. + + syntax-spec ;Matches any character whose syntax is + ;specified. Followed by a byte which contains + ;a syntax code. + + not-syntax-spec ;Matches any character whose syntax differs + ;from the specified. + + )) + +;;;; String Compiler + +(define (re-compile-char char case-fold?) + (let ((result (string-allocate 2))) + (vector-8b-set! result 0 re-code:exact-1) + (string-set! result 1 (if case-fold? (char-upcase char) char)) + result)) + +(define (re-compile-string string case-fold?) + (if case-fold? (set! string (string-upcase string))) + (let ((n (string-length string))) + (if (zero? n) + string + (let ((result + (string-allocate + (let ((qr (integer-divide n 255))) + (+ (* 257 (integer-divide-quotient qr)) + (cond ((zero? (integer-divide-remainder qr)) 0) + ((= 1 (integer-divide-remainder qr)) 2) + (else (+ (integer-divide-remainder qr) 2)))))))) + (define (loop n i p) + (cond ((= n 1) + (vector-8b-set! result p re-code:exact-1) + (vector-8b-set! result (1+ p) (vector-8b-ref string i)) + result) + ((< n 256) + (vector-8b-set! result p re-code:exact-n) + (vector-8b-set! result (1+ p) n) + (substring-move-right! string i n result (+ p 2)) + result) + (else + (vector-8b-set! result p re-code:exact-n) + (vector-8b-set! result (1+ p) 255) + (substring-move-right! string i 255 result (+ p 2)) + (loop (- n 255) (+ i 255) (+ p 257))))) + (loop n 0 0))))) + +;;;; Char-Set Compiler + +(define re-compile-char-set) +(let () + +(set! re-compile-char-set +(named-lambda (re-compile-char-set pattern negate?) + (let ((length (string-length pattern)) + (char-set (string-allocate 256))) + (define (kernel start background foreground) + (define (loop pattern) + (cond ((null? pattern) 'DONE) + ((null? (cdr pattern)) (adjoin! (char->ascii (car pattern)))) + ((char=? (cadr pattern) #\-) + (if (not (null? (cddr pattern))) + (begin ((adjoin-range! (char->ascii (caddr pattern))) + (char->ascii (car pattern))) + (loop (cdddr pattern))) + (error "RE-COMPILE-CHAR-SET: Terminating hyphen"))) + (else + (adjoin! (char->ascii (car pattern))) + (loop (cdr pattern))))) + + (define (adjoin! ascii) + (vector-8b-set! char-set ascii foreground)) + + (define (adjoin-range! end) + (define (adjoin-loop index) + (if (< index end) + (begin (vector-8b-set! char-set index foreground) + (adjoin-loop (1+ index))))) + adjoin-loop) + + (vector-8b-fill! char-set 0 256 background) + (loop (quote-pattern (substring->list pattern start length)))) + (if (and (not (zero? length)) + (char=? (string-ref pattern 0) #\^)) + (if negate? + (kernel 1 0 1) + (kernel 1 1 0)) + (if negate? + (kernel 0 1 0) + (kernel 0 0 1))) + char-set))) + +(define (quote-pattern pattern) + (cond ((null? pattern) '()) + ((not (char=? (car pattern) #\\)) + (cons (car pattern) + (quote-pattern (cdr pattern)))) + ((null? (cdr pattern)) + (error "RE-COMPILE-CHAR-SET: Terminating backslash")) + (else + (cons (cadr pattern) + (quote-pattern (cddr pattern)))))) + +) + +;;;; Translation Tables + +(define re-translation-table) +(let () + +(set! re-translation-table +(named-lambda (re-translation-table case-fold?) + (if case-fold? upcase-table normal-table))) + +(define normal-table + (make-string 256)) + +(let loop ((n 0)) + (if (< n 256) + (begin (vector-8b-set! normal-table n n) + (loop (1+ n))))) + +(define upcase-table + (string-copy normal-table)) + +(let loop ((n #x61)) + (if (< n #x7B) + (begin (vector-8b-set! upcase-table n (- n #x20)) + (loop (1+ n))))) + +) + +;;;; Pattern Compiler + +(define re-number-of-registers 10) +(define re-compile-pattern) +(let () +(let-syntax () ;capture DEFINE-MACRO inside. + +(declare (integrate stack-maximum-length)) + +(define stack-maximum-length re-number-of-registers) + +(define input-list) +(define current-byte) +(define translation-table) +(define output-head) +(define output-tail) +(define output-length) +(define stack) + +(define fixup-jump) +(define register-number) +(define begin-alternative) +(define pending-exact) +(define last-start) + +(set! re-compile-pattern +(named-lambda (re-compile-pattern pattern case-fold?) + (let ((output (list 'OUTPUT))) + (fluid-let ((input-list (map char->ascii (string->list pattern))) + (current-byte) + (translation-table (re-translation-table case-fold?)) + (output-head output) + (output-tail output) + (output-length 0) + (stack '()) + (fixup-jump #!FALSE) + (register-number 1) + (begin-alternative) + (pending-exact #!FALSE) + (last-start #!FALSE)) + (set! begin-alternative (output-pointer)) + (compile-pattern-loop))))) + +(define (compile-pattern-loop) + (if (input-end?) + (begin (if fixup-jump + (store-jump! fixup-jump re-code:jump (output-position))) + (if (not (stack-empty?)) + (error "Unmatched \\(")) + (list->string (map ascii->char (cdr output-head)))) + (begin (compile-pattern-char) + (compile-pattern-loop)))) + +;;;; Input + +(declare (integrate input-end? input-end+1? input-peek input-peek+1 + input-discard! input! input-raw! input-peek-1 + input-read!)) + +(define (input-end?) + (null? input-list)) + +(define (input-end+1?) + (null? (cdr input-list))) + +(define (input-peek) + (vector-8b-ref translation-table (car input-list))) + +(define (input-peek+1) + (vector-8b-ref translation-table (cadr input-list))) + +(define (input-discard!) + (set! input-list (cdr input-list))) + +(define (input!) + (set! current-byte (input-peek)) + (input-discard!)) + +(define (input-raw!) + (set! current-byte (car input-list)) + (input-discard!)) + +(define (input-peek-1) + current-byte) + +(define (input-read!) + (if (input-end?) + (premature-end) + (let ((char (input-peek))) + (input-discard!) + char))) + +;; Maxi-bummed. +(define-macro (input-match? byte . chars) + (if (null? (cdr chars)) + `(EQ? ,byte ,(char->ascii (car chars))) + `(MEMQ ,byte ',(map char->ascii chars)))) + +;;;; Output + +(declare (integrate output! output-re-code! output-start! output-position + output-pointer pointer-position pointer-ref + pointer-operate!)) + +(define (output! byte) + (declare (integrate byte)) + (let ((tail (list byte))) + (set-cdr! output-tail tail) + (set! output-tail tail)) + (set! output-length (1+ output-length))) + +(define (output-re-code! code) + (declare (integrate code)) + (set! pending-exact #!FALSE) + (output! code)) + +(define (output-start! code) + (declare (integrate code)) + (set! last-start (output-pointer)) + (output-re-code! code)) + +(define (output-position) + output-length) + +(define (output-pointer) + (cons output-length output-tail)) + +(define (pointer-position pointer) + (declare (integrate pointer)) + (car pointer)) + +(define (pointer-ref pointer) + (declare (integrate pointer)) + (caddr pointer)) + +(define (pointer-operate! pointer operator) + (declare (integrate pointer operator)) + (set-car! (cddr pointer) + (operator (caddr pointer)))) + +(define (store-jump! from opcode to) + (let ((p (cddr from))) + (set-car! p opcode) + (compute-jump (pointer-position from) to + (lambda (low high) + (set-car! (cdr p) low) + (set-car! (cddr p) high))))) + +(define (insert-jump! from opcode to) + (compute-jump (pointer-position from) to + (lambda (low high) + (set-cdr! (cdr from) + (cons* opcode low high (cddr from))) + (set! output-length (+ output-length 3))))) + +(define (compute-jump from to receiver) + (let ((n (- to (+ from 3)))) + (let ((qr (integer-divide (if (negative? n) (+ n #x10000) n) + #x100))) + (receiver (integer-divide-remainder qr) + (integer-divide-quotient qr))))) + +;;;; Stack + +(declare (integrate stack-empty? stack-full? stack-length + stack-ref-register-number)) + +(define (stack-empty?) + (null? stack)) + +(define (stack-full?) + (>= (stack-length) stack-maximum-length)) + +(define (stack-length) + (length stack)) + +(define (stack-push! . args) + (set! stack (cons args stack))) + +(define (stack-pop! receiver) + (let ((frame (car stack))) + (set! stack (cdr stack)) + (apply receiver frame))) + +(define (stack-ref-register-number i) + (declare (integrate i)) + (caddr (list-ref stack i))) + +;;; Randomness + +(define (ascii->syntax-entry ascii) + (primitive-datum (string->syntax-entry (char->string (ascii->char ascii))))) + +(define string->syntax-entry + (make-primitive-procedure 'STRING->SYNTAX-ENTRY)) + +;;;; Pattern Dispatch + +(declare (integrate compile-pattern-char)) + +(define (compile-pattern-char) + (input!) + ((vector-ref pattern-chars (input-peek-1)))) + +(define (premature-end) + (error "Premature end of regular expression")) + +(define (normal-char) + (if (if (input-end?) + (not pending-exact) + (input-match? (input-peek) #\* #\+ #\? #\^)) + (begin (output-start! re-code:exact-1) + (output! (input-peek-1))) + (begin (if (or (not pending-exact) + (= (pointer-ref pending-exact) #x7F)) + (begin (set! last-start (output-pointer)) + (output! re-code:exact-n) + (set! pending-exact (output-pointer)) + (output! 0))) + (output! (input-peek-1)) + (pointer-operate! pending-exact 1+)))) + +(define (define-pattern-char char procedure) + (vector-set! pattern-chars (char->ascii char) procedure)) + +(define pattern-chars + (make-vector 256 normal-char)) + +(define-pattern-char #\\ + (lambda () + (if (input-end?) + (premature-end) + (begin (input-raw!) + ((vector-ref backslash-chars (input-peek-1))))))) + +(define (define-backslash-char char procedure) + (vector-set! backslash-chars (char->ascii char) procedure)) + +(define backslash-chars + (make-vector 256 normal-char)) + +(define-pattern-char #\$ + ;; $ means succeed if at end of line, but only in special contexts. + ;; If randomly in the middle of a pattern, it is a normal character. + (lambda () + (if (or (input-end?) + (input-end+1?) + (and (input-match? (input-peek) #\\) + (input-match? (input-peek+1) #\) #\|))) + (output-re-code! re-code:line-end) + (normal-char)))) + +(define-pattern-char #\^ + ;; ^ means succeed if at beginning of line, but only if no preceding + ;; pattern. + (lambda () + (if (not last-start) + (output-re-code! re-code:line-start) + (normal-char)))) + +(define-pattern-char #\. + (lambda () + (output-start! re-code:any-char))) + +(define (define-trivial-backslash-char char code) + (define-backslash-char char + (lambda () + (output-re-code! code)))) + +(define-trivial-backslash-char #\< re-code:word-start) +(define-trivial-backslash-char #\> re-code:word-end) +(define-trivial-backslash-char #\b re-code:word-bound) +(define-trivial-backslash-char #\B re-code:not-word-bound) +(define-trivial-backslash-char #\` re-code:buffer-start) +(define-trivial-backslash-char #\' re-code:buffer-end) + +(define (define-starter-backslash-char char code) + (define-backslash-char char + (lambda () + (output-start! code)))) + +(define-starter-backslash-char #\w re-code:word-char) +(define-starter-backslash-char #\W re-code:not-word-char) + +(define-backslash-char #\s + (lambda () + (output-start! re-code:syntax-spec) + (output! (ascii->syntax-entry (input-read!))))) + +(define-backslash-char #\S + (lambda () + (output-start! re-code:not-syntax-spec) + (output! (ascii->syntax-entry (input-read!))))) + +;;;; Repeaters + +(define (define-repeater-char char zero? many?) + (define-pattern-char char + ;; If there is no previous pattern, char not special. + (lambda () + (if (not last-start) + (normal-char) + (repeater-loop zero? many?))))) + +(define (repeater-loop zero? many?) + ;; If there is a sequence of repetition chars, collapse it down to + ;; equivalent to just one. + (cond ((input-end?) + (repeater-finish zero? many?)) + ((input-match? (input-peek) #\*) + (input-discard!) + (repeater-loop zero? many?)) + ((input-match? (input-peek) #\+) + (input-discard!) + (repeater-loop #!FALSE many?)) + ((input-match? (input-peek) #\?) + (input-discard!) + (repeater-loop zero? #!FALSE)) + (else + (repeater-finish zero? many?)))) + +(define (repeater-finish zero? many?) + (if many? + ;; More than one repetition allowed: put in a backward jump at + ;; the end. + (compute-jump (output-position) + (- (pointer-position last-start) 3) + (lambda (low high) + (output-re-code! re-code:maybe-finalize-jump) + (output! low) + (output! high)))) + (insert-jump! last-start + re-code:on-failure-jump + (+ (output-position) 3)) + (if (not zero?) + ;; At least one repetition required: insert before the loop a + ;; skip over the initial on-failure-jump instruction. + (insert-jump! last-start + re-code:dummy-failure-jump + (+ (pointer-position last-start) 6)))) + +(define-repeater-char #\* #!TRUE #!TRUE) +(define-repeater-char #\+ #!FALSE #!TRUE) +(define-repeater-char #\? #!TRUE #!FALSE) + +;;;; Character Sets + +(define-pattern-char #\[ + (lambda () + (output-start! (cond ((input-end?) (premature-end)) + ((input-match? (input-peek) #\^) + (input-discard!) + re-code:not-char-set) + (else re-code:char-set))) + (let ((charset (string-allocate 32))) + (define (loop) + (cond ((input-end?) (premature-end)) + ((input-match? (input-peek) #\]) + (input-discard!) + (trim 31)) + (else (element)))) + + (define (element) + (let ((char (input-peek))) + (input-discard!) + (cond ((input-end?) (premature-end)) + ((input-match? (input-peek) #\-) + (input-discard!) + (if (input-end?) + (premature-end) + (let ((char* (input-peek))) + (define (loop char) + (if (<= char char*) + (begin (re-char-set-adjoin! charset char) + (loop (1+ char))))) + (input-discard!) + (loop char)))) + (else (re-char-set-adjoin! charset char)))) + (loop)) + + ;; Discard any bitmap bytes that are all 0 at the end of + ;; the map. Decrement the map-length byte too. + (define (trim n) + (define (loop i) + (output! (vector-8b-ref charset i)) + (if (< i n) + (loop (1+ i)))) + (cond ((not (zero? (vector-8b-ref charset n))) + (output! (1+ n)) + (loop 0)) + ((zero? n) (output! 0)) + (else (trim (-1+ n))))) + + (vector-8b-fill! charset 0 32 0) + (cond ((input-end?) (premature-end)) + ((input-match? (input-peek) #\]) (element)) + (else (loop)))))) + +(define re-char-set-adjoin! + (make-primitive-procedure 'RE-CHAR-SET-ADJOIN!)) + +;;;; Alternative Groups + +(define-backslash-char #\( + (lambda () + (if (stack-full?) + (error "Nesting too deep")) + (if (< register-number re-number-of-registers) + (begin (output-re-code! re-code:start-memory) + (output! register-number))) + (stack-push! (output-pointer) + fixup-jump + register-number + begin-alternative) + (set! last-start #!FALSE) + (set! fixup-jump #!FALSE) + (set! register-number (1+ register-number)) + (set! begin-alternative (output-pointer)))) + +(define-backslash-char #\) + (lambda () + (if (stack-empty?) + (error "Unmatched close paren")) + (if fixup-jump + (store-jump! fixup-jump re-code:jump (output-position))) + (stack-pop! + (lambda (op fj rn bg) + (set! last-start op) + (set! fixup-jump fj) + (set! begin-alternative bg) + (if (< rn re-number-of-registers) + (begin (output-re-code! re-code:stop-memory) + (output! rn))))))) + +(define-backslash-char #\| + (lambda () + (insert-jump! begin-alternative + re-code:on-failure-jump + (+ (output-position) 6)) + (if fixup-jump + (store-jump! fixup-jump re-code:jump (output-position))) + (set! fixup-jump (output-pointer)) + (output! re-code:unused) + (output! re-code:unused) + (output! re-code:unused) + (set! pending-exact #!FALSE) + (set! last-start #!FALSE) + (set! begin-alternative (output-pointer)))) + +(define (define-digit-char digit) + (let ((char (digit->char digit))) + (define-backslash-char char + (lambda () + (if (>= digit register-number) + (normal-char) + (let ((n (stack-length))) + (define (search-stack i) + (if (< i n) + (if (= (stack-ref-register-number i) digit) + (normal-char) + (search-stack (1+ i))) + (begin (output-start! re-code:duplicate) + (output! digit)))) + (search-stack 0))))))) + +(for-each define-digit-char '(1 2 3 4 5 6 7 8 9)) + +;;; end %RE-COMPILE-PATTERN +)) + +;;;; Compiled Pattern Disassembler +#| +(define (re-disassemble-pattern compiled-pattern) + (let ((n (string-length compiled-pattern))) + (define (loop i) + (newline) + (write i) + (write-string " (") + (if (< i n) + (let ((re-code (vector-8b-ref compiled-pattern i))) + (let ((re-code-name (vector-ref re-codes re-code))) + (write re-code-name) + (case re-code-name + ((unused line-start line-end any-char + buffer-start buffer-end + word-char not-word-char word-start word-end + word-bound not-word-bound) + (write-string ")") + (loop (1+ i))) + + ((exact-1) + (write-string " ") + (let ((end (+ i 2))) + (write (substring compiled-pattern (1+ i) end)) + (write-string ")") + (loop end))) + + ((exact-n) + (write-string " ") + (let ((start (+ i 2)) + (n (vector-8b-ref compiled-pattern (1+ i)))) + (let ((end (+ start n))) + (write (substring compiled-pattern start end)) + (write-string ")") + (loop end)))) + + ((jump on-failure-jump maybe-finalize-jump dummy-failure-jump) + (write-string " ") + (let ((end (+ i 3)) + (offset + (+ (* 256 (vector-8b-ref compiled-pattern (+ i 2))) + (vector-8b-ref compiled-pattern (1+ i))))) + (write (+ end + (if (< offset #x8000) + offset + (- offset #x10000)))) + (write-string ")") + (loop end))) + + ((char-set not-char-set) + (let ((end (+ (+ i 2) + (vector-8b-ref compiled-pattern (1+ i))))) + (define (spit i) + (if (< i end) + (begin (write-string " ") + (let ((n (vector-8b-ref compiled-pattern i))) + (if (< n 16) (write-char #\0)) + (fluid-let ((*unparser-radix* 16)) + (write n))) + (spit (1+ i))) + (begin (write-string ")") + (loop i)))) + (spit (+ i 2)))) + + ((start-memory stop-memory duplicate) + (write-string " ") + (write (vector-8b-ref compiled-pattern (1+ i))) + (write-string ")") + (loop (+ i 2))) + + ((syntax-spec not-syntax-spec) + (write-string " ") + (write (string-ref " w_()'\"$\\/<>." + (vector-8b-ref compiled-pattern (1+ i)))) + (write-string ")") + (loop (+ i 2))) + + ))) + (write-string "END)"))) + (loop 0))) +|# \ No newline at end of file -- 2.25.1