--- /dev/null
+;;; -*-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)
+\f
+;;;; 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
+\f
+;;;; 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)))))
+\f
+;;;; 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 "")))))
+\f
+;;;; 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)
+\f
+;;;; 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?*)
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)))))
+\f
+;;;; 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)))
+\f
+;;;; 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)))))
+\f
+;;;; 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.")
+\f
+(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.")
+\f
+;;;; 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.")
+\f
+;;;; 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)
+\f
+;;;; 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)
+\f
+(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)
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+(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"))
+\f
+(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")))
+\f
+(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))))))
+\f
+;;;; 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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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)))))
+\f
+(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)))
+\f
+(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)))
+\f
+;;; 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:
--- /dev/null
+;;; -*-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
+\f
+(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))))
+\f
+(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)))
+\f
+(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))
+\f
+(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 '()))
+\f
+;;;; 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))))))
+\f
+;;;; 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*) "]"))))))
+\f
+;;;; 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)))\f
+;;;; 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)))))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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)))
+\f
+(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))
+\f
+(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")))
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+(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)))
+\f
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access window-package edwin-package)
+;;; Scheme Syntax Table: class-syntax-table
+;;; End:
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+(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")
+\f
+(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))
+\f
+(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))
+\f
+(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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)))
+\f
+(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)))
+\f
+;;;; 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))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+;;;; 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))))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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))))
+\f
+(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))
+\f
+(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")))))
+\f
+;;;; 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)))))
+\f
+(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!))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)))
+\f
+(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!)))
+\f
+(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!))
+\f
+(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!))
+\f
+)
+(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!))
+
+)))))
+\f
+;;;; 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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))))
+\f
+(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))))))))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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)
+\f
+(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"))))
+\f
+(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))))
+\f
+(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)))
+\f
+(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)))
+\f
+(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)))))))))
+\f
+(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)))
+\f
+(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))
+\f
+(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))
+\f
+ (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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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:
--- /dev/null
+;;; -*-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.
+;;; ******************************************************************
+\f
+(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)))
+\f
+(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
+))
+\f
+(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)))
+\f
+(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))))
+
+)
+\f
+(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))))
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+(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 "\"")))))
+\f
+(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
--- /dev/null
+;;; -*-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)
+\f
+(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
+\f
+(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)))
+\f
+;;; 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)))
+\f
+(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))))))
+\f
+(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:
--- /dev/null
+;;; -*-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))
+\f
+(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)))))))
+\f
+(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)))
+\f
+(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))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;; 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.
+\f
+(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))
+\f
+(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)))
+\f
+;;;; 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))))
+\f
+(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))
+\f
+(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)))))
+\f
+(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)))))
+\f
+;;;; 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)))))))
+\f
+(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)))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+;;;; 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))))))))
+\f
+(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))
+\f
+(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!)
+\f
+(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)))
+\f
+ (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
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)))))
+\f
+(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))
+\f
+;;;; 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))
+\f
+(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))
+\f
+;;;; 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))
+\f
+;;;; 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)))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+(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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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)))))
+\f
+(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")
+\f
+(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"))
+\f
+(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))))
+\f
+(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))))))
+\f
+;;;; 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)))))))))
+\f
+(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)))))
+\f
+(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<?)))
+ (cdr name-entry))
+ (set-cdr! name-entry
+ (sort (cdr name-entry) car-type<?)))
+ name-alist)
+ (sort name-alist car-name<?)))
+
+(define (extract-elements name-alist)
+ (mapcan (lambda (name-entry)
+ (mapcan (lambda (type-entry)
+ (map cdr (cdr type-entry)))
+ (cdr name-entry)))
+ name-alist))
+
+(define (extract-newest name-alist)
+ (mapcan (lambda (name-entry)
+ (map (lambda (type-entry)
+ (cdar (last-pair (cdr type-entry))))
+ (cdr name-entry)))
+ name-alist))
+\f
+(define ((component<? <) x y)
+ (cond ((not x) y)
+ ((eq? 'UNSPECIFIC x) (and y (not (eq? 'UNSPECIFIC y))))
+ (else (and y (not (eq? 'UNSPECIFIC y)) (< x y)))))
+
+(define ((component=? =) x y)
+ (cond ((not x) (not y))
+ ((not y) #!FALSE)
+ ((eq? 'UNSPECIFIC x) (eq? 'UNSPECIFIC y))
+ (else (= x y))))
+
+(define ass-name
+ (association-procedure string=? car))
+
+(define ass-type
+ (association-procedure (component=? string=?) car))
+
+(define (car-name<? x y)
+ (string<? (car x) (car y)))
+
+(define (car-type<? x y)
+ (type<? (car x) (car y)))
+
+(define type<?
+ (component<? string<?))
+
+(define (car-version<? x y)
+ (version<? (car x) (car y)))
+
+(define version<?
+ (component<? <))
+
+)
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access dired-package edwin-package)
+;;; Scheme Syntax Table: edwin-syntax-table
+;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package)
+;;; End:
--- /dev/null
+;;; -*-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 Abstraction
+
+(declare (usual-integrations))
+(using-syntax edwin-syntax-table
+\f
+(define edwin-editor)
+(define restrict-editor-x-size #!FALSE)
+
+(define edwin-reset)
+(define edwin-reset-windows)
+(in-package window-package
+
+(set! edwin-reset
+(named-lambda (edwin-reset)
+ (cond ((unassigned? the-alpha-window)
+ (reset-alpha-window!))
+ ((not (unassigned? edwin-editor))
+ (delete-inferior! the-alpha-window
+ (editor-frame-window edwin-editor))))
+ (set! edwin-editor
+ (let ((x-size (window-x-size the-alpha-window))
+ (y-size (window-y-size the-alpha-window)))
+ (if (> 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!)))
+
+)
+\f
+(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))
+
+)
+\f
+(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))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;; 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*)))
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+(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)))
+\f
+(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)))
+\f
+(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"))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+(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)))))
+\f
+(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))))
+\f
+(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)))))
+\f
+(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))))))))
+\f
+(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))))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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*))))))
+\f
+(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:
--- /dev/null
+;;; -*-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)
+\f
+;;;; 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)))))
+\f
+;;;; 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))))))
+
+)
+\f
+;;;; 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))
+\f
+(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))))
+
+)
+\f
+;;;; 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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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")
+ "\""))))
+\f
+(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)))))))
+\f
+(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))
+
+)
+\f
+(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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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")
+\f
+;;;; 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"))
+\f
+;;;; 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"))))
+\f
+;;;; 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))))))
+\f
+(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)))
+\f
+(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:
--- /dev/null
+;;; -*-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))
+\f
+;;; 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.
+\f
+(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)))
+\f
+(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))
+\f
+;;;; 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)))
+\f
+(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)))))
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+(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)))
+\f
+(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 "^\1f\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))
+\f
+(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)))
+\f
+(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)))))
+\f
+;;;; 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))
+\f
+(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)))))
+\f
+;;;; 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))
+\f
+;;;; 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)))
+\f
+(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))
+\f
+;;;; 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))))))))
+\f
+(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)))
+\f
+(define (node-start start end)
+ (let ((mark (search-backward "\n\1f" 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\1f]" 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\1f" 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:"))
+\f
+;;;; 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)))))))
+\f
+(define tag-table-start-string
+ "\1f\f\nTag table:\n")
+
+(define tag-table-end-string
+ "\1f\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:
--- /dev/null
+;;; -*-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
+\f
+(define editor-input-port)
+
+(define (set-editor-input-port! port)
+ (set! editor-input-port port))
+
+(define (with-editor-input-port new-port thunk)
+ (fluid-let ((editor-input-port new-port))
+ (thunk)))
+
+(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
+\f
+#|
+
+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
+
+|#
+\f
+(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))))
+\f
+(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))
+
+))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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.")
+\f
+(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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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<? (car a) (car b)))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access command-summary-package edwin-package)
+;;; Scheme Environment: edwin-syntax-table
+;;; End:
--- /dev/null
+;;; -*-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.
+;;;
+
+;;;; Kill Commands
+
+(declare (usual-integrations))
+(using-syntax edwin-syntax-table
+\f
+(define (delete-region mark)
+ (if (not mark)
+ (editor-error "Delete exceeds buffer bounds")
+ (delete-string mark (current-point))))
+
+(define (kill-region mark)
+ (if (not mark)
+ (editor-error "Kill exceeds buffer bounds")
+ (kill-string mark (current-point))))
+
+(define (copy-region mark)
+ (if (not mark)
+ (editor-error "Copy exceeds buffer bounds")
+ (copy-string mark (current-point))))
+
+(define (kill-string mark #!optional point)
+ (if (unassigned? point) (set! point (current-point)))
+ (kill-ring-save (extract-string mark point)
+ (mark<= point mark))
+ (delete-string mark point))
+
+(define (copy-string mark #!optional point)
+ (if (unassigned? point) (set! point (current-point)))
+ (kill-ring-save (extract-string mark point)
+ (mark<= point mark)))
+
+(define (unkill string)
+ (let ((end (current-point)))
+ (let ((start (mark-right-inserting end)))
+ (insert-string string end)
+ (set-current-point! start))
+ (push-current-mark! end)))
+
+(define (unkill-reversed string)
+ (let ((end (current-point)))
+ (push-current-mark! (mark-right-inserting end))
+ (insert-string string end)))
+
+(define append-next-kill-tag
+ "Append Next Kill")
+
+(define (kill-ring-save string forward?)
+ (let ((ring (current-kill-ring)))
+ (command-message-receive append-next-kill-tag
+ (lambda ()
+ (if (ring-empty? ring) (editor-error "No previous kill"))
+ (ring-set! ring 0
+ (if forward?
+ (string-append (ring-ref ring 0) string)
+ (string-append string (ring-ref ring 0)))))
+ (lambda ()
+ (ring-push! ring string))))
+ (set-command-message! append-next-kill-tag))
+
+(define-command ("^R Append Next Kill" argument)
+ "Cause following command, if kill, to append to previous kill."
+ (set-command-message! append-next-kill-tag))
+\f
+;;;; Deletion
+
+(define-command ("^R Backward Delete Character" argument)
+ "Delete character before point.
+With argument, kills several characters (saving them).
+Negative args kill characters forward."
+ (if (not argument)
+ (delete-region (mark-1+ (current-point)))
+ (kill-region (mark- (current-point) argument))))
+
+(define-command ("^R Delete Character" argument)
+ "Delete character after point.
+With argument, kill than many characters (saving them).
+Negative args kill characters backward."
+ (if (not argument)
+ (delete-region (mark1+ (current-point)))
+ (kill-region (mark+ (current-point) argument))))
+
+(define-command ("^R Kill Line" argument)
+ "Kill to end of line, or kill an end of line.
+At the end of a line (only blanks following) kill through the newline.
+Otherwise, kill the rest of the line but not the newline.
+With argument (positive or negative), kill specified number of lines.
+An argument of zero means kill to beginning of line, nothing if at beginning.
+Killed text is pushed onto the kill ring for retrieval."
+ (let ((point (current-point)))
+ (kill-region
+ (cond ((not argument)
+ (let ((end (line-end point 0)))
+ (if (region-blank? (make-region point end))
+ (mark1+ end)
+ end)))
+ ((positive? argument)
+ (and (not (group-end? point))
+ (line-start point argument 'LIMIT)))
+ ((zero? argument)
+ (line-start point 0))
+ (else
+ (and (not (group-start? point))
+ (line-start point
+ (if (line-start? point)
+ argument
+ (1+ argument))
+ 'LIMIT)))))))
+\f
+(define-command ("^R Backward Delete Hacking Tabs" argument)
+ "Delete character before point, turning tabs into spaces.
+Rather than deleting a whole tab, the tab is converted into the
+appropriate number of spaces and then one space is deleted."
+ (define (back n)
+ (let ((m1 (mark- (current-point) n 'LIMIT)))
+ (if (not (char-search-backward #\Tab (current-point) m1))
+ m1
+ (begin (convert-tab-to-spaces! (re-match-start 0))
+ (back n)))))
+ (define (forth n)
+ (let ((m1 (mark+ (current-point) n 'LIMIT)))
+ (if (not (char-search-forward #\Tab (current-point) m1))
+ m1
+ (begin (convert-tab-to-spaces! (re-match-start 0))
+ (forth n)))))
+ (cond ((not argument)
+ (if (char-match-backward #\Tab)
+ (convert-tab-to-spaces! (mark-1+ (current-point))))
+ (delete-region (mark-1+ (current-point))))
+ ((positive? argument)
+ (kill-region (back argument)))
+ ((negative? argument)
+ (kill-region (forth (- argument))))))
+
+(define (convert-tab-to-spaces! m1)
+ (let ((at-point? (mark= m1 (current-point)))
+ (m2 (mark-left-inserting (mark1+ m1))))
+ (define (perform-replacement)
+ (let ((n (- (mark-column m2) (mark-column m1))))
+ (delete-string m1 m2)
+ (insert-string (make-string n #\Space) m2)))
+ (if at-point?
+ (let ((start (mark-right-inserting m1)))
+ (perform-replacement)
+ (set-current-point! start))
+ (perform-replacement))))
+\f
+;;;; Un/Killing
+
+(define-command ("^R Kill Region" argument)
+ "Kill from point to mark.
+Use \\[^R Un-Kill] and \\[^R Un-Kill Pop] to get it back."
+ (kill-region (current-mark)))
+
+(define-command ("^R Copy Region" argument)
+ "Stick region into kill-ring without killing it.
+Like killing and getting back, but doesn't mark buffer modified."
+ (copy-region (current-mark))
+ (temporary-message "Region saved"))
+
+(define un-kill-tag
+ "Un-kill")
+
+(define-command ("^R Un-Kill" (argument 1))
+ "Re-insert the last stuff killed.
+Puts point after it and the mark before it.
+A positive argument N says un-kill the N'th most recent
+string of killed stuff (1 = most recent). A null
+argument (just C-U) means leave point before, mark after."
+ (let ((ring (current-kill-ring)))
+ (define (pop-loop n)
+ (if (> 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))
+\f
+;;;; 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)))
+\f
+;;;; 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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+(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))))
+\f
+(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))
+\f
+(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))))
+\f
+(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))))
+\f
+;;; 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:
--- /dev/null
+;;; -*-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
+\f
+;;;; 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))))
+\f
+;;;; 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*))))))
+\f
+(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))))
+\f
+;;;; 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))
+\f
+(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))
+\f
+(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 #\)))
+\f
+(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))))))))
+\f
+(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))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;; 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)))))
+\f
+;;;
+;;; 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)))))))
+\f
+;;;; 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.
+;;; <n> 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))))))))
+\f
+;;; 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)))))))
+\f
+;;;; 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)))
+\f
+;;;; 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 '()))))
+\f
+(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))))
+\f
+;;;; 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
+))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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)
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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))))
+\f
+;;;; 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)))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+;;; 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)))))))
+\f
+(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))))))
+\f
+(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)))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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")
+\f
+(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")
+\f
+(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")
+\f
+(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")
+\f
+;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:
--- /dev/null
+;;; -*-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
+\f
+(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
--- /dev/null
+;;; -*-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)
+\f
+(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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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)))
+\f
+(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))))
+\f
+(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:
--- /dev/null
+;;; -*-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"))
+\f
+;;;; 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)))
+\f
+(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)))))
+
+)
+\f
+;;;; 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)))
+\f
+(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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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
--- /dev/null
+;;; -*-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
+\f
+(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")
+\f
+(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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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
+\f
+(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))))
+\f
+;;; 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)))
+\f
+(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!))))
+\f
+;;;; 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")
+\f
+(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))))
+\f
+(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))))
+\f
+(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))
+\f
+(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))
+\f
+;;;; 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 '()))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+(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:
--- /dev/null
+;;; -*-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)
+\f
+(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)))))
+\f
+(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))))
+\f
+(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)))))))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+(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")))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+(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
+)))
+\f
+;;;; 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)))))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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"))
+\f
+;;;; 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)))
+\f
+(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))))
+\f
+;;;; 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))))
+\f
+;;;; 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)))
+\f
+;;; 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)))))
+\f
+(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*))))
+\f
+(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.")))
+\f
+;;;; 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))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))))
+\f
+(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))
+\f
+ (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)))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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))
+\f
+(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
--- /dev/null
+;;; -*-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
+\f
+(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")
+\f
+;;;; 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 #\) ")( ")
+\f
+;;;; 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)
+\f
+ (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:
--- /dev/null
+;;; -*-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))
+\f
+(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))))
+\f
+;;; 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)))
+\f
+#| 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)))))))
+\f
+(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)))))))))
+
+|#
+\f
+))
+
+(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:
--- /dev/null
+;;; -*-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"))
+\f
+;;;; 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)))))))
+\f
+;;;; 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))))
+|#
+\f
+(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)))))))
+\f
+;;;; 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)))
+\f
+(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)))))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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)
+\f
+;;;; 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)))))
+\f
+;;;; 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))
+
+)
+\f
+;;;; 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)))
+\f
+(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")
+\f
+(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)))
+\f
+(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))))
+\f
+(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))))
+\f
+(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)))))
+\f
+(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
+))
+\f
+;;; 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:
--- /dev/null
+;;; -*-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))
+\f
+(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))))
+\f
+(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))))
+\f
+(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)
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+(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))))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+(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<? (car x) (car y)))))))
+ (vector string-table-tag v (vector-length v))))
+
+(define string-table-tag
+ "String Table")
+
+(declare (integrate string-table-vector set-string-table-vector!
+ string-table-size set-string-table-size!))
+
+(define (string-table-vector table)
+ (declare (integrate table))
+ (vector-ref table 1))
+
+(define (string-table-size table)
+ (declare (integrate table))
+ (vector-ref table 2))
+
+(define (set-string-table-vector! table vector)
+ (declare (integrate table vector))
+ (vector-set! table 1 vector))
+
+(define (set-string-table-size! table size)
+ (declare (integrate table size))
+ (vector-set! table 2 size))
+
+(define (make-string-table-entry string value)
+ (cons string value))
+
+(declare (integrate string-table-entry-string set-string-table-entry-string!
+ string-table-entry-value set-string-table-entry-value!))
+
+(define (string-table-entry-string entry)
+ (declare (integrate entry))
+ (car entry))
+
+(define (set-string-table-entry-string! entry string)
+ (declare (integrate entry string))
+ (set-car! entry string))
+
+(define (string-table-entry-value entry)
+ (declare (integrate entry))
+ (cdr entry))
+
+(define (set-string-table-entry-value! entry value)
+ (declare (integrate entry value))
+ (set-cdr! entry value))
+\f
+(define (string-table-search table string1 if-found if-not-found)
+ (let ((vector (string-table-vector table)))
+ (define (loop low high)
+ (if (< high low)
+ (if-not-found low)
+ (let ((index (quotient (+ high low) 2)))
+ (let ((entry (vector-ref vector index)))
+ (string-compare-ci string1 (string-table-entry-string entry)
+ (lambda ()
+ (if-found index entry))
+ (lambda ()
+ (loop low (-1+ index)))
+ (lambda ()
+ (loop (1+ index) high)))))))
+ (loop 0 (-1+ (string-table-size table)))))
+
+(define (string-table-get table string #!optional if-not-found)
+ (string-table-search table string
+ (lambda (index entry)
+ (string-table-entry-value entry))
+ (if (unassigned? if-not-found)
+ (lambda (index) #!FALSE)
+ if-not-found)))
+
+(define (string-table-put! table string value)
+ (string-table-search table string
+ (lambda (index entry)
+ (set-string-table-entry-string! entry string)
+ (set-string-table-entry-value! entry value))
+ (lambda (index)
+ (let ((vector (string-table-vector table))
+ (size (string-table-size table))
+ (entry (make-string-table-entry string value)))
+ (let ((max-size (vector-length vector)))
+ (if (= size max-size)
+ (let ((new-vector (vector-grow vector (* max-size 2))))
+ (set-string-table-vector! table new-vector)
+ (set! vector new-vector)))
+ (subvector-move-right! vector index size vector (1+ index))
+ (vector-set! vector index entry))
+ (set-string-table-size! table (1+ size))))))
+
+(define (string-table-remove! table string)
+ (string-table-search table string
+ (lambda (index entry)
+ (let ((vector (string-table-vector table))
+ (size (string-table-size table)))
+ (subvector-move-left! vector (1+ index) size vector index)
+ (let ((new-size (-1+ size)))
+ (vector-set! vector new-size '())
+ (set-string-table-size! table new-size)))
+ #!TRUE)
+ (lambda (index)
+ #!FALSE)))
+\f
+(define string-table-complete)
+(define string-table-completions)
+(let ()
+
+(set! string-table-complete
+(named-lambda (string-table-complete table string
+ if-unambiguous if-ambiguous if-not-found)
+ (string-table-complete* table string
+ if-unambiguous
+ (lambda (close-match gcs lower upper)
+ (if-ambiguous close-match gcs))
+ if-not-found)))
+
+(set! string-table-completions
+(named-lambda (string-table-completions table string)
+ (string-table-complete* table string
+ list
+ (lambda (close-match gcs lower upper)
+ (define (loop index)
+ (if (= index upper)
+ '()
+ (cons (string-table-entry-string
+ (vector-ref (string-table-vector table) index))
+ (loop (1+ index)))))
+ (loop lower))
+ (lambda ()
+ '()))))
+\f
+(define (string-table-complete* table string
+ if-unambiguous if-ambiguous if-not-found)
+ (let ((size (string-length string))
+ (table-size (string-table-size table)))
+ (define (entry-string index)
+ (string-table-entry-string (vector-ref (string-table-vector table)
+ index)))
+ (define (perform-search index)
+ (let ((close-match (entry-string index)))
+ (define (match-entry index)
+ (string-match-forward-ci close-match (entry-string index)))
+
+ (define (scan-up gcs receiver)
+ (define (loop gcs index)
+ (if (= index table-size)
+ (receiver gcs table-size)
+ (let ((match (match-entry index)))
+ (if (< match size)
+ (receiver gcs index)
+ (loop (min gcs match) (1+ index))))))
+ (loop gcs (1+ index)))
+
+ (define (scan-down gcs receiver)
+ (define (loop gcs index)
+ (if (zero? index)
+ (receiver gcs 0)
+ (let ((new-index (-1+ index)))
+ (let ((match (match-entry new-index)))
+ (if (< match size)
+ (receiver gcs index)
+ (loop (min gcs match) new-index))))))
+ (loop gcs index))
+
+ (if (string-prefix-ci? string close-match)
+ (scan-up (string-length close-match)
+ (lambda (gcs upper)
+ (scan-down gcs
+ (lambda (gcs lower)
+ (if (= lower (-1+ upper))
+ (if-unambiguous (entry-string lower))
+ (if-ambiguous close-match gcs lower upper))))))
+ (if-not-found))))
+ (string-table-search table string
+ (lambda (index entry)
+ (perform-search index))
+ (lambda (index)
+ (if (= index table-size)
+ (if-not-found)
+ (perform-search index))))))
+
+)
+\f
+(define (string-table-apropos table string)
+ (let ((end (string-table-size table)))
+ (define (loop index)
+ (if (= index end)
+ '()
+ (let ((entry (vector-ref (string-table-vector table) index)))
+ (if (substring-ci? string (string-table-entry-string entry))
+ (cons (string-table-entry-value entry) (loop (1+ index)))
+ (loop (1+ index))))))
+ (loop 0)))
+
+(define (substring-ci? string1 string2)
+ (or (string-null? string1)
+ (let ((char (string-ref string1 0))
+ (end1 (string-length string1))
+ (end2 (string-length string2)))
+ (define (loop start2)
+ (let ((index (substring-find-next-char-ci string2 start2 end2 char)))
+ (and index
+ (if (= (-1+ end1)
+ (substring-match-forward-ci string1 1 end1
+ string2 (1+ index) end2))
+ index
+ (loop (1+ index))))))
+ (loop 0))))
+
+;;; Edwin Variables:
+;;; Scheme Environment: edwin-package
+;;; End:
--- /dev/null
+;;; -*-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.
+;;;
+
+;;;; Text Data Structures
+
+(declare (usual-integrations))
+(using-syntax edwin-syntax-table
+\f
+;;; This file describes the data structures used to represent and
+;;; manipulate text within the editor.
+
+;;; The basic unit of text is the GROUP, which is essentially a type
+;;; of character string with some special operations. Normally a
+;;; group is modified by side effect; unlike character strings, groups
+;;; will grow and shrink appropriately under such operations. Also,
+;;; it is possible to have pointers into a group, called MARKs, which
+;;; continue to point to the "same place" under these operations; this
+;;; would not be true of a string, elements of which are pointed at by
+;;; indices.
+
+;;; As is stressed in the EMACS manual, marks point between characters
+;;; rather than directly at them. This perhaps counter-intuitive
+;;; concept may aid understanding.
+
+;;; Besides acting as pointers into a group, marks may be compared.
+;;; All of the marks within a group are totally ordered, and the
+;;; standard order predicates are supplied for them. In addition,
+;;; marks in different groups are unordered with respect to one
+;;; another. The standard predicates have been extended to be false
+;;; in this case, and another predicate, which indicates whether they
+;;; are related, is supplied.
+
+;;; Marks may be paired into units called REGIONs. Each region has a
+;;; START mark and an END mark, and it must be the case that START is
+;;; less than or equal to END in the mark ordering. While in one
+;;; sense this pairing of marks is trivial, it can also be used to
+;;; reduce overhead in the implementation since a region guarantees
+;;; that its marks satisfy this very basic relation.
+
+;;; As in most other editors of this type, there is a distinction
+;;; between "temporary" and "permanent" marks. The purpose for this
+;;; distinction is that temporary marks require less overhead to
+;;; create. Conversely, temporary marks do not remain valid when
+;;; their group is modified. They are intended for local use when it
+;;; is known that the group will remain unchanged.
+
+;;; The implementation of marks is different from previous
+;;; implementations. In particular, it is not possible to tell
+;;; whether a mark is temporary or permanent. Instead, a "caller
+;;; saves"-like convention is used. Whenever any given mark needs to
+;;; be permanent, one merely calls a procedure which "permanentizes"
+;;; it. All marks are created temporary by default.
+\f
+;;;; Groups
+
+(define-named-structure "Group"
+ text gap-start gap-length gap-end
+ marks start-mark end-mark read-only?
+ display-start display-end
+ insert-daemons delete-daemons clip-daemons
+ undo-data modified? point)
+
+(define-unparser %group-tag
+ (lambda (group)
+ (write-string "Group ")
+ (write (primitive-datum group))))
+
+(define (make-group string)
+ (let ((group (%make-group))
+ (n (string-length string)))
+ (vector-set! group group-index:text string)
+ (vector-set! group group-index:gap-start n)
+ (vector-set! group group-index:gap-length 0)
+ (vector-set! group group-index:gap-end n)
+ (vector-set! group group-index:marks '())
+ (let ((start (%make-permanent-mark group 0 #!FALSE)))
+ (vector-set! group group-index:start-mark start)
+ (vector-set! group group-index:display-start start))
+ (let ((end (%make-permanent-mark group n #!TRUE)))
+ (vector-set! group group-index:end-mark end)
+ (vector-set! group group-index:display-end end))
+ (vector-set! group group-index:read-only? #!FALSE)
+ (vector-set! group group-index:insert-daemons '())
+ (vector-set! group group-index:delete-daemons '())
+ (vector-set! group group-index:clip-daemons '())
+ (vector-set! group group-index:undo-data #!FALSE)
+ (vector-set! group group-index:modified? #!FALSE)
+ (vector-set! group group-index:point (%make-permanent-mark group 0 #!TRUE))
+ group))
+\f
+(declare (integrate group-start-index group-end-index
+ group-start-index? group-end-index?))
+
+(define (group-length group)
+ (- (string-length (group-text group)) (group-gap-length group)))
+
+(define (group-start-index group)
+ (declare (integrate group))
+ (mark-index (group-start-mark group)))
+
+(define (group-end-index group)
+ (declare (integrate group))
+ (mark-index (group-end-mark 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 (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)))
+\f
+(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))))
+\f
+(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))))
+\f
+;;;; 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))))
+\f
+;;; 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)))
+\f
+(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)))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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))))
+\f
+;;;; 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)))))
+\f
+(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
+)
+\f
+;;;; 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)))))
+\f
+(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
+)
+\f
+;;;; 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)))))
+\f
+(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)))
+\f
+(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)))
+\f
+(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))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+(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))))
+\f
+(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))))
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+\f
+;;;; 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"))))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+(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))
+\f
+;;;; 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))
+\f
+;;;; 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)))))
+\f
+;;;; 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))
+\f
+;;;; 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
--- /dev/null
+;;; -*-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
+\f
+;;;; 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))
+\f
+;;;; 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))))
+\f
+;;;; 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)))
+\f
+(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))))))
+\f
+;;;; 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))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)))
+\f
+;;;; 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)))
+
+)
+\f
+(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)))
+
+)
+\f
+(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*))))))))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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)
+\f
+(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 "^\b\\|^@[a-z]*[ \n]\\|"
+ (ref-variable "Paragraph Start")))
+ (local-set-variable! "Paragraph Separate"
+ (string-append "^\b\\|^@[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:
--- /dev/null
+;;; -*-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
+\f
+(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)))
+\f
+;;;; 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))
+\f
+(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)))))))
+\f
+;;;; 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))))))
+\f
+(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))))
+\f
+;;;; 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")
+\f
+(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!")))))
+\f
+(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)))
+\f
+(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:
--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;;; 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)
+\f
+(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))))
+\f
+(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))))
+\f
+(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))))))
+\f
+;;;; 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)
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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)
+\f
+(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)
+\f
+(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)))))
+\f
+(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))))
+\f
+(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))))))
+\f
+(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))))))
+\f
+;;;; 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)))
+\f
+(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))))
+\f
+;;;; 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))
+\f
+(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))
+\f
+(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)))
+\f
+(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:
--- /dev/null
+;;; -*-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
+\f
+;;; 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.
+\f
+;;;; 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))
+\f
+(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))
+\f
+;;; 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))
+\f
+;;;; 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!)
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+(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))))
+\f
+(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))
+\f
+;;;; 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:
--- /dev/null
+;;; -*-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))
+\f
+(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))
+\f
+(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)))))
+\f
+(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
--- /dev/null
+;;; -*-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))
+\f
+;;;; 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.
+\f
+ 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.
+
+ ))
+\f
+;;;; 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)))))
+\f
+;;;; 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))))))
+
+)
+\f
+;;;; 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)))))
+
+)
+\f
+;;;; 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))))
+\f
+;;;; 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))))
+\f
+;;;; 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))))
+\f
+(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)))))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+(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!)))))
+\f
+;;;; 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)
+\f
+;;;; 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!))
+\f
+;;;; 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))))
+\f
+(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
+))
+\f
+;;;; 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)))
+\f
+ ((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
projects / mit-scheme.git / commitdiff