;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/argred.scm,v 1.27 1989/03/14 07:58:32 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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
;;; 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:
+;;; 2. From these, it can compute:
;;;
-;;; [] VALUE = (* MAGNITUDE MULTIPLIER-EXPONENT MULTIPLIER-BASE).
+;;; [] VALUE = (* MAGNITUDE (EXPT 4 MULTIPLIER-EXPONENT)).
;;; 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)
+(define-command ("^R Universal Argument")
"Increments the argument multiplier and enters Autoarg mode.
In Autoarg mode, - negates the numeric argument, and the
digits 0, ..., 9 accumulate it."
(update-argument-prompt!)
(read-and-dispatch-on-char))
-(define-command ("^R Argument Digit" argument)
+(define-command ("^R Argument Digit")
"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
+Several such digits typed consecutively accumulate 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)
+(define-command ("^R Negative 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)
+(define (command-argument-self-insert? procedure)
+ (and (or (eq? procedure ^r-autoargument-digit-command)
(and (eq? procedure ^r-auto-negative-argument-command)
- (command-argument-beginning?))))))
+ (command-argument-beginning?)))
+ (not *autoargument-mode?*)))
(define-command ("^R Autoargument Digit" argument)
"In Autoargument mode, sets numeric argument to the next command.
\f
;;;; Primitives
-(set! with-command-argument-reader
-(named-lambda (with-command-argument-reader thunk)
+(define (with-command-argument-reader thunk)
(fluid-let ((*magnitude*)
(*negative?*)
(*multiplier-exponent*)
+ (*multiplier-value*)
(*autoargument-mode?*)
(*previous-prompt*))
- (thunk))))
+ (thunk)))
-(set! reset-command-argument-reader!
-(named-lambda (reset-command-argument-reader!)
+(define (reset-command-argument-reader!)
;; Call this at the beginning of a command cycle.
(set! *magnitude* false)
(set! *negative?* false)
(set! *multiplier-exponent* 0)
+ (set! *multiplier-value* 1)
(set! *autoargument-mode?* false)
- (set! *previous-prompt* "")))
+ (set! *previous-prompt* ""))
-(set! command-argument-prompt
-(named-lambda (command-argument-prompt)
- (or *previous-prompt* (%command-argument-prompt))))
+(define (command-argument-prompt)
+ (or *previous-prompt* (%command-argument-prompt)))
(define *previous-prompt*)
(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*)
+ (set! *multiplier-value* 1)
+ (let ((digit (or (char->digit digit-char 10)
(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))
+ (+ digit (* 10 *magnitude*))))))
(define (command-argument-negate!)
(set! *multiplier-exponent* 0)
+ (set! *multiplier-value* 1)
(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)
+(define (command-argument-negative?)
+ *negative?*)
\f
;;;; Argument Multiplier
(define *multiplier-exponent*)
-(define *multiplier-base*)
+(define *multiplier-value*)
(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*)
+ (set! *multiplier-exponent* (1+ *multiplier-exponent*))
+ (set! *multiplier-value* (* 4 *multiplier-value*)))
-(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)
+(define (command-argument-multiplier-exponent)
+ *multiplier-exponent*)
;;;; Autoargument Mode
(define (autoargument-mode?)
*autoargument-mode?*)
-\f
+
;;;; Value
-(set! command-argument-standard-value
-(named-lambda (command-argument-standard-value)
+(define (command-argument-standard-value)
(or (command-argument-value)
- (and *negative?* -1))))
+ (and *negative?* -1)))
-(set! command-argument-value
-(named-lambda (command-argument-value)
+(define (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*)))
+ *multiplier-value*))
((not (zero? *multiplier-exponent*))
- (if *negative?*
- (- (expt *multiplier-base* *multiplier-exponent*))
- (expt *multiplier-base* *multiplier-exponent*)))
- (else false))))
+ (if *negative?* (- *multiplier-value*) *multiplier-value*))
+ (else false)))
-(set! command-argument-multiplier-only?
-(named-lambda (command-argument-multiplier-only?)
+(define (command-argument-multiplier-only?)
(and (not *magnitude*)
(not (zero? *multiplier-exponent*))
- *multiplier-exponent*)))
+ *multiplier-exponent*))
-(set! command-argument-negative-only?
-(named-lambda (command-argument-negative-only?)
+(define (command-argument-negative-only?)
(and (not *magnitude*)
(zero? *multiplier-exponent*)
- *negative?*)))
+ *negative?*))
-(set! command-argument-beginning?
-(named-lambda (command-argument-beginning?)
+(define (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:
+ (< *multiplier-exponent* 2)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.39 1989/03/14 07:58:35 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Autoloads for Edwin
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
;;;; Definitions
+(define (define-autoload-procedure package name library-name)
+ (let ((environment (->environment package)))
+ (local-assignment environment
+ name
+ (make-autoloading-procedure
+ library-name
+ (lambda () (lexical-reference environment name))))))
+
+(define (make-autoloading-procedure library-name get-procedure)
+ (define entity
+ (make-entity (lambda arguments
+ (load-library library-name)
+ (let ((procedure (get-procedure)))
+ (set-entity-procedure! entity procedure)
+ (apply procedure (cdr arguments))))
+ (cons autoloading-procedure-tag library-name)))
+ entity)
+
+(define autoloading-procedure-tag
+ "autoloading-procedure-tag")
+
+(define (autoloading-procedure? object)
+ (and (entity? object)
+ (eq? autoloading-procedure-tag (car (entity-extra object)))))
+
(define (define-autoload-major-mode name super-mode-name library-name
description)
(define mode
- (make-mode name #!TRUE
+ (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))))
+ (make-autoloading-procedure library-name
+ (lambda ()
+ (mode-initialization mode)))))
mode)
(define (define-autoload-minor-mode name library-name description)
(define mode
- (make-mode name #!FALSE '()
+ (make-mode name
+ false
+ '()
description
- (lambda arguments
- (load-library library-name)
- (apply (mode-initialization mode) arguments))))
+ (make-autoloading-procedure library-name
+ (lambda ()
+ (mode-initialization mode)))))
mode)
(define (autoloading-mode? mode)
- (or (autoloading-procedure? (mode-initialization mode)
- define-autoload-major-mode)
- (autoloading-procedure? (mode-initialization mode)
- define-autoload-minor-mode)))
+ (autoloading-procedure? (mode-initialization 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))))
+ (make-command name
+ description
+ (make-autoloading-procedure library-name
+ (lambda ()
+ (command-procedure command)))))
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)))))
+ (autoloading-procedure? (command-procedure command)))
\f
;;;; Libraries
+(define known-libraries
+ '())
+
+(define (define-library name . entries)
+ (let ((entry (assq name known-libraries)))
+ (if entry
+ (set-cdr! entry entries)
+ (set! known-libraries
+ (cons (cons name entries)
+ known-libraries))))
+ name)
+
(define loaded-libraries
'())
(define (load-library name)
(if (not (library-loaded? name))
- (let ((entry (assq name (access :libraries edwin-system))))
+ (let ((entry (assq name known-libraries)))
(if entry
(%load-library entry)
(error "LOAD-LIBRARY: Unknown library name" name)))))
(define (%load-library library)
- (apply load-edwin-file (cdr library))
+ (for-each (lambda (entry)
+ (apply load-edwin-file entry))
+ (cdr library))
(if (not (memq (car library) loaded-libraries))
(set! loaded-libraries (cons (car library) loaded-libraries)))
(run-library-load-hooks! (car library)))
\f
;;;; Loading
-(define load-edwin-file)
-(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 (load-edwin-file filename package #!optional purify?)
+ (temporary-message "Loading file \""
+ (pathname->string (->pathname filename))
+ "\"")
+ (let ((scode (fasload filename)))
+ (append-message " -- done")
+ (if (or (default-object? purify?) purify?) (purify scode))
+ (temporary-message "Evaluate...")
+ (scode-eval scode (->environment package)))
+ (temporary-message "Done"))
(define-variable "Load File Default"
"Pathname given as default for \\[Load File]."
- (string->pathname "EDB:FOO.BIN.0"))
+ (merge-pathnames (string->pathname "FOO.BIN.0") edwin-binary-directory))
(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"))))
+ (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)))
+ (load-edwin-file pathname '(EDWIN) argument)))
-(define-command ("Load Library" argument)
+(define-command ("Load Library")
"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)
- ;; But there was a third possibility
- ;; we didn't think about ...
- ((char=? #\E char)
- ((access standard-error-hook error-system)
- environment message irritant
- substitute-environment?)
- (loop))
- (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:
+ known-libraries))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autosv.scm,v 1.18 1989/03/14 07:58:41 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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)
+ false)
(define-variable "Auto Save Default"
"If not false, auto save all visited files."
- #!TRUE)
+ true)
(define-variable "Auto Save Interval"
"The number of keystrokes between auto saves."
(define-variable "Delete Auto Save Files"
"If not false, delete auto save files when normal saves happen."
- #!FALSE)
+ false)
(define-command ("Auto Save Mode" argument)
"Toggle Auto Save mode.
(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)))))))
+ (set-buffer-auto-save-pathname!
+ buffer
+ (let ((pathname (buffer-pathname buffer)))
+ (if (and pathname
+ (ref-variable "Auto Save Visited File"))
+ pathname
+ (os/auto-save-pathname pathname (buffer-name buffer))))))
(define (disable-buffer-auto-save! buffer)
- (set-buffer-auto-save-pathname! buffer #!FALSE))
-\f
+ (set-buffer-auto-save-pathname! buffer false))
+
(define *auto-save-keystroke-count*)
(define (do-auto-save)
(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
+ (delete-file (buffer-auto-save-pathname buffer))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.95 1989/03/14 07:58:42 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Basic Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("^R Bad Command" argument)
+(define-command ("^R Bad Command")
"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."
"Reads a character and inserts it."
(define (read-char)
(let ((char (keyboard-read-char)))
- (set-command-prompt! (string-append (command-prompt) (char->name char)))
+ (set-command-prompt! (string-append (command-prompt) (char-name char)))
char))
(define (read-digit)
(define (xchar->name char)
(if (pair? char)
(chars->name char)
- (char->name char)))
+ (char-name char)))
(define (chars->name chars)
(if (null? chars)
""
- (string-append-separated (char->name (car chars))
+ (string-append-separated (char-name (car chars))
(chars->name (cdr chars)))))
(define (string-append-separated x y)
(define (editor-error . strings)
(if (not (null? strings)) (apply temporary-message strings))
- (screen-beep the-alpha-screen)
+ (editor-beep)
(abort-current-command))
(define (editor-failure . strings)
(cond ((not (null? strings)) (apply temporary-message strings))
(*defining-keyboard-macro?* (clear-message)))
- (screen-beep the-alpha-screen)
+ (editor-beep)
(keyboard-macro-disable))
+(define-integrable (editor-beep)
+ (screen-beep (current-screen)))
+
(define (not-implemented)
(editor-error "Not yet implemented"))
\f
-(define-command ("^R Prefix Control" argument)
+(define-command ("^R Prefix Control")
"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)
+(define-command ("^R Prefix Meta")
"Sets Meta-bit of following character.
Turns a following A into a Meta-A.
If the Metizer character is Altmode, it turns ^A
(lambda (char)
(char-metafy (char-base char))))))
-(define-command ("^R Prefix Control-Meta" argument)
+(define-command ("^R Prefix Control-Meta")
"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))
(set-command-prompt-prefix! prefix-string))
(let ((char (modifier (keyboard-read-char))))
(if execute-extended-chars?
- (dispatch-on-char (current-comtab) char)
+ (dispatch-on-char (current-comtabs) char)
char)))
(define (set-command-prompt-prefix! prefix-string)
(string-append-separated (command-argument-prompt)
prefix-string)))
-(define-command ("^R Prefix Character" argument)
+(define-command ("^R Prefix Character")
"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)
+ (dispatch-on-char (current-comtabs)
((if (pair? prefix-char) append cons)
prefix-char
(list (keyboard-read-char))))))
-(define-command ("^R Extended Command" argument)
+(define-command ("^R Extended Command")
"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
With argument, saves visited file first."
(if argument (^r-save-file-command))
(quit)
- (update-alpha-window! true))
+ (update-screens! true))
-(define-command ("^R Scheme" argument)
+(define-command ("^R Scheme")
"Stop Edwin and return to Scheme."
(editor-abort *the-non-printing-object*))
-(define-command ("^R Exit" argument)
+(define-command ("^R Exit")
"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)
+(define-command ("Abort Recursive Edit")
"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)
+(define-command ("^R Narrow Bounds to Region")
"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)
+(define-command ("^R Widen Bounds")
"Remove restrictions from current buffer.
Allows full text to be seen and edited."
(buffer-widen! (current-buffer)))
-(define-command ("Set Key" argument)
+(define-command ("Set Key")
"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."
(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)
+(define-command ("^R Indent for Comment")
"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")
on new line, with no new terminator or starter."
false)
-(define-command ("^R Indent New Comment Line" argument)
+(define-command ("^R Indent New Comment Line")
"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 "Comment End"))
(set-current-point! point)))
-(define-command ("^R Kill Comment" argument)
+(define-command ("^R Kill Comment")
"Kill the comment on this line, if any."
(if (not (ref-variable "Comment Locator Hook"))
(editor-error "No comment syntax defined")
(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:
+ (kill-string (horizontal-space-start (car com)) end))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufcom.scm,v 1.80 1989/03/14 07:58:45 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("^R Buffer Not Modified" argument)
+(define-command ("^R Buffer Not Modified")
"Pretend that this buffer hasn't been altered."
(buffer-not-modified! (current-buffer)))
-(define-command ("Select Buffer" argument)
+(define-command ("Select Buffer")
"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)
+(define-command ("Select Buffer Other Window")
"Select buffer in another window."
(select-buffer-other-window
(prompt-for-select-buffer "Select Buffer Other Window")))
prompt-for-buffer prompt-for-existing-buffer)
prompt (previous-buffer)))
-(define-command ("Create Buffer" argument)
+(define-command ("Create Buffer")
"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)
+(define-command ("Insert Buffer")
"Insert the contents of a specified buffer at point."
(let ((point (mark-right-inserting (current-point))))
(region-insert-string!
(push-current-mark! (current-point))
(set-current-point! point)))
-(define-command ("^R Twiddle Buffers" argument)
+(define-command ("^R Twiddle Buffers")
"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)
+(define-command ("Bury Current Buffer")
"Deselect the current buffer, putting it at the end of the buffer list."
(let ((buffer (current-buffer))
(previous (previous-buffer)))
(begin (select-buffer previous)
(bury-buffer buffer)))))
\f
-(define-command ("Kill Buffer" argument)
+(define-command ("Kill Buffer")
"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."
(save-buffer-changes buffer)
(kill-buffer buffer))
-(define-command ("Kill Some Buffers" argument)
+(define-command ("Kill Some Buffers")
"For each buffer, ask whether to kill it."
(kill-some-buffers true))
(kill-buffer dummy)))))
(buffer-list)))
-(define-command ("Rename Buffer" argument)
+(define-command ("Rename Buffer")
"Change the name of the current buffer.
Reads the new name in the echo area."
(let ((buffer (current-buffer)))
(editor-error "Buffer named " name " already exists"))
(rename-buffer buffer name))))
-(define-command ("Normal Mode" argument)
+(define-command ("Normal Mode")
"Reset mode and local variable bindings to their default values.
Just like what happens when the file is first visited."
(initialize-buffer! (current-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:
+ 'STRICT-COMPLETION)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.127 1989/03/14 07:58:47 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Abstraction
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-named-structure "Buffer"
name
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)
-
+ save-length
+ backed-up?
+ modification-time
+ )
(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)
+ 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)))
+ (let ((mode (if (default-object? mode) fundamental-mode 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)
+ (vector-set! buffer buffer-index:backed-up? false)
+ (vector-set! buffer buffer-index:modification-time false)
+ (let ((hook (ref-variable "Buffer Creation Hook")))
+ (if hook (hook buffer)))
+ buffer))))
\f
+(define (buffer-modeline-event! buffer type)
+ (let loop ((windows (buffer-windows buffer)))
+ (if (not (null? windows))
+ (begin
+ (window-modeline-event! (car windows) type)
+ (loop (cdr windows))))))
+
(define (buffer-reset! buffer)
(set-buffer-writeable! buffer)
(region-delete! (buffer-region 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)
+ (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))))
+ (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)
+ unspecific)))
(define (set-buffer-name! buffer name)
(vector-set! buffer buffer-index:name name)
(buffer-modeline-event! buffer 'BUFFER-TRUENAME))
(define-integrable (set-buffer-auto-save-pathname! buffer pathname)
- (vector-set! buffer buffer-index:auto-save-pathname pathname))
+ (vector-set! buffer buffer-index:auto-save-pathname pathname)
+ unspecific)
(define-integrable (set-buffer-auto-saved! buffer)
- (vector-set! buffer buffer-index:auto-save-modified? #!FALSE))
+ (vector-set! buffer buffer-index:auto-save-modified? false)
+ unspecific)
(define-integrable (set-buffer-save-length! buffer)
- (vector-set! buffer buffer-index:save-length (buffer-length buffer)))
+ (vector-set! buffer buffer-index:save-length (buffer-length buffer))
+ unspecific)
+
+(define-integrable (set-buffer-backed-up?! buffer flag)
+ (vector-set! buffer buffer-index:backed-up? flag)
+ unspecific)
+
+(define-integrable (set-buffer-modification-time! buffer flag)
+ (vector-set! buffer buffer-index:modification-time flag)
+ unspecific)
(define-integrable (set-buffer-comtabs! buffer comtabs)
- (vector-set! buffer buffer-index:comtabs comtabs))
+ (vector-set! buffer buffer-index:comtabs comtabs)
+ unspecific)
(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)
+(define-integrable (minibuffer? buffer)
(char=? (string-ref (buffer-name buffer) 0) #\Space))
(define-integrable (buffer-region buffer)
(group-region (buffer-group buffer)))
+(define-integrable (buffer-string buffer)
+ (region->string (buffer-region buffer)))
+
(define-integrable (buffer-unclipped-region buffer)
(group-unclipped-region (buffer-group 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))))
+ (vector-set! buffer
+ buffer-index:windows
+ (cons window (vector-ref buffer buffer-index:windows)))
+ unspecific)
(define (remove-buffer-window! buffer window)
- (vector-set! buffer buffer-index:windows
- (delq! window (vector-ref buffer buffer-index:windows))))
+ (vector-set! buffer
+ buffer-index:windows
+ (delq! window (vector-ref buffer buffer-index:windows)))
+ unspecific)
(define-integrable (set-buffer-cursor-y! buffer cursor-y)
- (vector-set! buffer buffer-index:cursor-y cursor-y))
+ (vector-set! buffer buffer-index:cursor-y cursor-y)
+ unspecific)
(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))))
+ (and entry
+ (cdr entry))))
(define (buffer-put! buffer key value)
(let ((entry (assq key (vector-ref buffer buffer-index:alist))))
(set-cdr! entry value)
(vector-set! buffer buffer-index:alist
(cons (cons key value)
- (vector-ref buffer buffer-index:alist))))))
+ (vector-ref buffer buffer-index:alist)))))
+ unspecific)
(define (buffer-remove! buffer key)
- (vector-set! buffer buffer-index:alist
- (del-assq! key
- (vector-ref buffer buffer-index:alist))))
+ (vector-set! buffer
+ buffer-index:alist
+ (del-assq! key (vector-ref buffer buffer-index:alist)))
+ unspecific)
(define-integrable (reset-buffer-alist! buffer)
- (vector-set! buffer buffer-index:alist '()))
+ (vector-set! buffer buffer-index:alist '())
+ unspecific)
\f
;;;; Modification Flags
(group-modified? (buffer-group buffer)))
(define-integrable (buffer-not-modified! buffer)
- (set-buffer-modified! buffer #!FALSE))
+ (set-buffer-modified! buffer false))
(define-integrable (buffer-modified! buffer)
- (set-buffer-modified! buffer #!TRUE))
+ (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 (buffer-modification-daemon buffer)
+ (lambda (group start end)
+ ;; Open coded for speed.
+ start end ;ignore
+ (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)
+ unspecific))
(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)
+ (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)
+ (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)
+ (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?)
+ (let ((group (mark-group mark))
+ (read-only?))
(dynamic-wind (lambda ()
(set! read-only? (group-read-only? group))
- (if read-only?
- (set-group-writeable! group)))
+ (if read-only? (set-group-writeable! group)))
thunk
(lambda ()
- (if read-only?
- (set-group-read-only! group))))))
+ (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)))
+;;;; Buffer Display Name
(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*) "]"))))))
+ (pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
+ (let ((display-string
+ (lambda (name)
+ (if (pathname-version pathname)
+ (let ((version
+ (pathname-version
+ (or (buffer-truename buffer) pathname))))
+ (if (integer? version)
+ (string-append name " (" (number->string version) ")")
+ name))
+ name))))
+ (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
(without-interrupts
(lambda ()
(let ((buffer (current-buffer))
- (value (lexical-assignment edwin-package name (set! new-value))))
+ (value (lexical-assignment variable-environment
+ name
+ (if (default-object? new-value)
+ (unmap-reference-trap
+ (make-unassigned-reference-trap))
+ 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)))))))))
+ (vector-set! buffer
+ buffer-index:local-bindings
+ (cons (cons name value) bindings))))))
+ unspecific)))
(define (unmake-local-binding! name)
(without-interrupts
(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))))))))))
+ (begin
+ (lexical-assignment variable-environment
+ name
+ (cdr binding))
+ (vector-set! buffer
+ buffer-index:local-bindings
+ (delq! binding bindings)))))))
+ unspecific)))
(define (undo-local-bindings!)
(without-interrupts
(lambda ()
(let ((buffer (current-buffer)))
(for-each (lambda (binding)
- (lexical-assignment edwin-package
+ (lexical-assignment variable-environment
(car binding)
(cdr binding)))
(buffer-local-bindings buffer))
- (vector-set! buffer buffer-index:local-bindings '())))))
+ (vector-set! buffer buffer-index:local-bindings '()))
+ unspecific)))
(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
+ (lexical-assignment variable-environment
(car binding)
- (cdr binding))))
+ (cdr binding)))
+ unspecific)
(buffer-local-bindings buffer)))\f
;;;; Modes
(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))))))))
+ (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))
(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
+ (begin
+ (set-cdr! modes (delq! mode (cdr modes)))
+ (set-buffer-comtabs! buffer
+ (delq! (mode-comtab mode)
+ (buffer-comtabs buffer)))
+ (buffer-modeline-event! buffer 'BUFFER-MODES)))))))
+
(define (add-buffer-initialization! buffer thunk)
(if (eq? buffer (current-buffer))
(thunk)
- (vector-set! buffer buffer-index:initializations
+ (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 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:
+ (begin
+ (vector-set! buffer buffer-index:initializations (cdr thunks))
+ ((car thunks))
+ (loop))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffrm.scm,v 1.29 1989/03/14 07:58:54 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Frames
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
(define-class buffer-frame combination-leaf-window
(text-inferior border-inferior modeline-inferior last-select-time))
-(define (buffer-frame? object)
+(define-integrable (buffer-frame? object)
(object-of-class? buffer-frame object))
(define (make-buffer-frame superior new-buffer modeline?)
(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))
+ (set! last-select-time 0)
+ unspecific)
;;; **** Kludge: The text-inferior will generate modeline events, so
;;; if the modeline gets redisplayed first it will be left with its
;;; redisplay-flag set but its superior's redisplay-flag cleared.
-(define-procedure buffer-frame (initial-modeline! frame modeline?)
- (if modeline?
- (begin (set! modeline-inferior (make-inferior frame modeline-window))
- (set! inferiors
- (append! (delq! modeline-inferior inferiors)
- (list modeline-inferior))))
- (set! modeline-inferior #!FALSE)))
+(define (initial-modeline! frame modeline?)
+ (with-instance-variables buffer-frame 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))
+ unspecific))
+
+(define-integrable (window-cursor frame)
+ (%window-cursor (frame-text-inferior frame)))
+
+(define-integrable (frame-text-inferior frame)
+ (with-instance-variables buffer-frame frame ()
+ (inferior-window text-inferior)))
+
+(define (frame-modeline-inferior frame)
+ (with-instance-variables buffer-frame frame ()
+ (and modeline-inferior
+ (inferior-window modeline-inferior))))
\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 (window-select-time frame)
+ (with-instance-variables buffer-frame frame ()
+ last-select-time))
+
+(define (set-window-select-time! frame time)
+ (with-instance-variables buffer-frame frame (time)
+ (set! last-select-time time)
+ unspecific))
+
+(define (set-buffer-frame-size! window x y)
+ (with-instance-variables buffer-frame 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!)
(+ (ref-variable "Window Minimum Height")
(inferior-y-size modeline-inferior))
(ref-variable "Window Minimum Height")))
+
+(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
;;;; External Entries
-(define (window-buffer frame)
+(define-integrable (window-buffer frame)
(%window-buffer (frame-text-inferior frame)))
(define (set-window-buffer! frame buffer)
(buffer-reset! buffer))
(%set-window-buffer! (frame-text-inferior frame) buffer))
-(define (window-point frame)
+(define-integrable (window-point frame)
(%window-point (frame-text-inferior frame)))
(define (set-window-point! frame point)
(%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?
+ (if (and (not (default-object? preserve-point?))
+ 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-integrable (window-redraw-preserving-point! window)
+ (window-redraw! window true))
-(define-procedure buffer-frame (window-needs-redisplay? frame)
- (car (inferior-redisplay-flags text-inferior)))
+(define-integrable (window-needs-redisplay? frame)
+ (with-instance-variables buffer-frame frame ()
+ (car (inferior-redisplay-flags text-inferior))))
-(define (direct-output-insert-char! frame char)
+(define (window-modeline-event! frame type)
+ (with-instance-variables buffer-frame frame (type)
+ (if modeline-inferior
+ (=> (inferior-window modeline-inferior) :event! type))))
+
+(define-integrable (window-set-override-message! window message)
+ (set-override-message! (frame-text-inferior window) message))
+
+(define-integrable (window-clear-override-message! window)
+ (clear-override-message! (frame-text-inferior window)))
+
+(define-integrable (window-home-cursor! window)
+ (home-cursor! (frame-text-inferior window)))
+\f
+(define-integrable (window-direct-update! frame display-style)
+ (%window-direct-update! (frame-text-inferior frame) display-style))
+
+(define (window-direct-output-insert-char! frame char)
+ (let ((point (window-point frame)))
+ (%group-insert-char! (mark-group point) (mark-index point) char))
(%direct-output-insert-char! (frame-text-inferior frame) char))
-(define (direct-output-insert-newline! frame)
+(define (window-direct-output-insert-newline! frame)
+ (let ((point (window-point frame)))
+ (%group-insert-char! (mark-group point) (mark-index point) #\newline))
(%direct-output-insert-newline! (frame-text-inferior frame)))
-(define (direct-output-insert-substring! frame string start end)
+(define (window-direct-output-insert-substring! frame string start end)
+ (let ((point (window-point frame)))
+ (%group-insert-substring! (mark-group point) (mark-index point)
+ string start end))
(%direct-output-insert-substring! (frame-text-inferior frame)
string start end))
-(define (direct-output-forward-character! frame)
+(define-integrable (window-direct-output-forward-char! frame)
(%direct-output-forward-character! (frame-text-inferior frame)))
-(define (direct-output-backward-character! frame)
+(define-integrable (window-direct-output-backward-char! 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)
(maybe-recompute-image! window)
(%window-scroll-y-relative! window delta)))
-(define (window-y-center frame)
+(define-integrable (window-y-center frame)
(%window-y-center (frame-text-inferior frame)))
(define (window-start-mark frame)
(define (window-end-mark frame)
(let ((window (frame-text-inferior frame)))
(maybe-recompute-image! window)
- (%window-end-mark window)))
+ (%window-end-mark window)))\f
(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)
(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:
+ (%window-coordinates->mark window x y)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufmnu.scm,v 1.108 1989/03/14 07:58:57 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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
+ false)
-(define-command ("List Buffers" argument)
+(define-command ("List Buffers")
"Display a list of names of existing buffers."
- (pop-up-buffer (update-buffer-list) #!FALSE))
+ (pop-up-buffer (update-buffer-list) false))
-(define-command ("Buffer Menu" argument)
+(define-command ("Buffer Menu")
"Display a list of names of existing buffers."
- (pop-up-buffer (update-buffer-list) #!TRUE)
+ (pop-up-buffer (update-buffer-list) true)
(message "Commands: d, s, x; 1, 2, m, u, q; rubout; ? for help."))
(define (update-buffer-list)
buffer))
(define (revert-buffer-menu argument)
+ argument ;ignore
(let ((buffer (current-buffer)))
(set-buffer-writeable! buffer)
(region-delete! (buffer-region buffer))
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)))
+C-] -- abort Buffer-Menu edit, killing *Buffer-List*.")
(define-key "Buffer-Menu" #\M "^R Buffer Menu Mark")
(define-key "Buffer-Menu" #\Q "^R Buffer Menu Quit")
"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)
+(define-command ("^R Buffer Menu Quit")
"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))
(others (map buffer-menu-buffer (find-buffers-marked 0 #\>))))
(if (and (ref-variable "Preserve Window Arrangement")
(null? others))
- (buffer-menu-select menu buffer #!FALSE)
+ (buffer-menu-select menu buffer false)
(begin
(delete-other-windows window)
(buffer-menu-select menu buffer (memq menu others))
(define (loop window buffers)
(let ((new (window-split-vertically! window height)))
(if new
- (begin (set-window-buffer! new (car buffers))
- (loop new (cdr buffers))))))
+ (begin
+ (set-window-buffer! new (car buffers) true)
+ (loop new (cdr buffers))))))
(loop window others))))))
(clear-message))
-(define-command ("^R Buffer Menu 1 Window" argument)
+(define-command ("^R Buffer Menu 1 Window")
"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))
+ false))
(clear-message))
-(define-command ("^R Buffer Menu 2 Window" argument)
+(define-command ("^R Buffer Menu 2 Window")
"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))
+ false)
+ (fluid-let (((ref-variable "Pop Up Windows") true))
(pop-up-buffer (previous-buffer)))
(clear-message))
\f
-(define-command ("^R Buffer Menu Find" argument)
+(define-command ("^R Buffer Menu Find")
"Select this line's buffer."
(buffer-menu-find select-buffer))
-(define-command ("^R Buffer Menu Find Other Window" argument)
+(define-command ("^R Buffer Menu Find Other Window")
"Select this line's buffer in another window."
(buffer-menu-find select-buffer-other-window))
(select-buffer buffer)))
(clear-message))
-(define-command ("^R Buffer Menu Not Modified" argument)
+(define-command ("^R Buffer Menu Not Modified")
"Mark buffer on this line as unmodified (no changes to save)."
(buffer-not-modified! (buffer-menu-buffer (current-lstart)))
(let ((lstart (current-lstart)))
"Mark buffer on this line to be killed by X command."
(set-multiple-marks! 0 #\K argument))
-(define-command ("^R Buffer Menu Execute" argument)
+(define-command ("^R Buffer Menu Execute")
"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)
+(define-command ("^R Buffer Menu Unmark")
"Remove all marks from this line."
(let ((lstart (mark-right-inserting (current-lstart))))
(let ((buffer (buffer-menu-buffer lstart)))
(if (buffer-modified? buffer) #\* #\Space))))
(set-current-point! (next-lstart)))
-(define-command ("^R Buffer Menu Backup Unmark" argument)
+(define-command ("^R Buffer Menu Backup Unmark")
"Remove all marks from the previous line."
(set-current-point! (previous-lstart))
(^r-buffer-menu-unmark-command)
"Move down to the next line."
(set-current-point! (line-start (current-point) argument 'BEEP)))
-(define-command ("^R Buffer Menu Abort" argument)
+(define-command ("^R Buffer Menu Abort")
"Abort buffer menu edit."
(kill-buffer-interactive (current-buffer))
(clear-message))
(define (set-multiple-marks! column char n)
(dotimes n
(lambda (i)
+ i ;ignore
(set-buffer-menu-mark! (current-lstart) column char)
(set-current-point! (next-lstart)))))
\f
(define list-buffers-header
(string-append
- (list-buffers-format " " "M" "R" "Buffer" "Size" "Mode" "File") "
-"
- (list-buffers-format " " "-" "-" "------" "----" "----" "----") "
-"))
+ (list-buffers-format " " "M" "R" "Buffer" "Size" "Mode" "File")
+ "\n"
+ (list-buffers-format " " "-" "-" "------" "----" "----" "----")
+ "\n"))
(define (find-buffers-marked column char)
(define (loop lstart)
((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:
+ (loop (line-start (buffer-start (current-buffer)) 2)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufset.scm,v 1.6 1989/03/14 07:59:00 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Set Abstraction
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-named-structure "Bufferset"
buffer-list
(define (bufferset-select-buffer! bufferset buffer)
(if (memq buffer (bufferset-buffer-list bufferset))
- (vector-set! bufferset bufferset-index:buffer-list
+ (vector-set! bufferset
+ bufferset-index:buffer-list
(cons buffer
- (delq! buffer (bufferset-buffer-list bufferset))))))
+ (delq! buffer (bufferset-buffer-list bufferset)))))
+ unspecific)
(define (bufferset-bury-buffer! bufferset buffer)
(if (memq buffer (bufferset-buffer-list bufferset))
- (vector-set! bufferset bufferset-index:buffer-list
+ (vector-set! bufferset
+ bufferset-index:buffer-list
(append! (delq! buffer (bufferset-buffer-list bufferset))
- (list buffer)))))
+ (list buffer))))
+ unspecific)
(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))))))
+ (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)))))
+ unspecific)
(define (bufferset-find-buffer bufferset name)
(string-table-get (bufferset-names 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)))
+ (vector-set! bufferset
+ bufferset-index:buffer-list
+ (append! (bufferset-buffer-list bufferset) (list buffer)))
buffer))
(define (bufferset-find-or-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
+ (vector-set! bufferset
+ bufferset-index:buffer-list
(delq! buffer (bufferset-buffer-list bufferset)))
(string-table-remove! (bufferset-names bufferset) (buffer-name buffer)))
(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
+ (string-table-put! names new-name buffer)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwfs.scm,v 1.4 1989/03/14 07:59:02 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Windows: Fill and Scroll
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\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) '())
+(define (fill-top! window inferiors start fill-bottom?)
+ (with-instance-variables buffer-window 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 (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)))))
+ (let loop
+ ((y-start (inferior-y-start (car inferiors)))
+ (start start)
+ (inferiors 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 (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)))
+ (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 (fill-bottom window y-end end-index)
+ (with-instance-variables buffer-window 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)))
+ (let loop ((y-start y-end) (end end-index))
+ (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))))))))))
+
+(define (fill-middle! window y-end end-index tail tail-start-index)
+ (with-instance-variables buffer-window 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)))
+ (let loop ((y-end y-end) (end end-index))
+ (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)))))))))))
\f
;;;; Scroll
(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))
+ (begin
+ (%window-scroll-y-relative! window start-y)
+ true))))
+
+(define (%window-scroll-y-absolute! window y-point)
+ (with-instance-variables buffer-window window (y-point)
+ (%window-scroll-y-relative! window (- (%window-point-y window) y-point))))
+
+(define (%window-scroll-y-relative! window y-delta)
+ (with-instance-variables buffer-window window (y-delta)
+ (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
+ (lambda (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))))))
+
+(define (redraw-at! window mark)
+ (with-instance-variables buffer-window window (mark)
+ (%set-buffer-point! buffer mark)
+ (set! point (buffer-point buffer))
+ (redraw-screen! window 0)))
\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)
-
- ;; Returns new list of new inferiors.
-
- ;; "Fast scroll" can be invoked if the lines in the buffer are
- ;; the full width of the screen and the screen image is correct.
- ;; If the buffer-window width is the same size as the-alpha-window width
- ;; then it is assumed that the line windows can be simply scrolled.
- ;; If the redisplay flag for the buffer-window is off, then the image
- ;; on the screen should be correct.
-
- (let ((absolute-start (inferior-absolute-position (car inferiors)
- (lambda (x y) y)
- (lambda () #f))))
- (let ((fast-scroll? (and (= x-size (window-x-size the-alpha-window))
- (false? (car (inferior-redisplay-flags
- (car inferiors))))
- (not (false? absolute-start))))
- (starting-line (inferior-y-start (car inferiors))))
-
- (define (loop inferiors y-start)
- (if (or (null? inferiors)
- (>= y-start y-size))
- '()
- (begin ((if fast-scroll?
- set-inferior-start-no-redisplay!
- set-inferior-start!)
- (car inferiors) 0 y-start)
- (cons (car inferiors)
- (loop (cdr inferiors)
- (inferior-y-end (car inferiors)))))))
-
- (let ((value (loop inferiors y-start)))
- ;; Now update the display
- (if fast-scroll?
- (screen-scroll-region-down! the-alpha-screen
- (- y-start starting-line)
- absolute-start
- (+ absolute-start
- (- y-size starting-line))))
- value))))
-
-(define-procedure buffer-window
- (scroll-lines-up! window inferiors y-start start-index)
-
- (let ((absolute-start (inferior-absolute-position (car inferiors)
- (lambda (x y) y)
- (lambda () #f))))
- (let ((fast-scroll? (and (= x-size (window-x-size the-alpha-window))
- (false? (car (inferior-redisplay-flags
- (car inferiors))))
- (not (false? absolute-start))))
- (starting-line (inferior-y-start (car inferiors))))
-
- (define (loop inferiors y-start start-index)
- ((if fast-scroll?
- set-inferior-start-no-redisplay!
- 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))))))))
- (let ((value (loop inferiors y-start start-index)))
- (if fast-scroll?
- (screen-scroll-region-up! the-alpha-screen
- (- starting-line y-start)
- (- absolute-start
- (- starting-line y-start))
- (+ absolute-start
- (- y-size starting-line))))
- value))))
-
-;;; end USING-SYNTAX
-)
-
-;;; Edwin Variables:
-;;; Scheme Environment: (access window-package edwin-package)
-;;; Scheme Syntax Table: class-syntax-table
-;;; End:
+(define (scroll-lines-down! window inferiors y-start)
+ (with-instance-variables buffer-window window (inferiors y-start)
+ ;; Returns new list of new inferiors.
+ (let loop ((inferiors inferiors) (y-start 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)))))))))
+
+(define (scroll-lines-up! window inferiors y-start start-index)
+ (with-instance-variables buffer-window window (inferiors y-start start-index)
+ ;; Returns new list of new inferiors.
+ (let loop
+ ((inferiors inferiors) (y-start y-start) (start-index 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))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.275 1989/03/14 07:59:06 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Windows: Base
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
(define-class buffer-window vanilla-window
(buffer point changes-daemon clip-daemon
(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))
+ (set! override-inferior false)
+ unspecific)
(define-method buffer-window (:kill! window)
(delete-window-buffer! window)
(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 (set-buffer-window-size! window x y)
+ (with-instance-variables buffer-window 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!)
;;; 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))
+(define-integrable (group-start-index group)
(mark-index (group-display-start group)))
-(define (group-end-index group)
- (declare (integrate group))
+(define-integrable (group-end-index group)
(mark-index (group-display-end group)))
-(define (group-start-index? group index)
- (declare (integrate group index))
+(define-integrable (group-start-index? group index)
(<= index (group-start-index group)))
-(define (group-end-index? group index)
- (declare (integrate group index))
+(define-integrable (group-end-index? 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)))
+ (let ((limit (group-start-index group)))
+ (or (%find-previous-newline group index limit)
+ limit)))
(define (line-end-index group index)
- (or (%find-next-newline group index (group-end-index group))
- (group-end-index group)))
+ (let ((limit (group-end-index group)))
+ (or (%find-next-newline group index limit)
+ limit)))
(define (line-start-index? group index)
(or (group-start-index? group index)
- (char=? (group-left-char group index) char:newline)))
+ (char=? (group-left-char group index) #\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))))
+ (char=? (group-right-char group index) #\newline)))
+
+(define (clip-mark-to-display window mark)
+ (with-instance-variables buffer-window 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-integrable (%window-buffer window)
+ (with-instance-variables buffer-window window ()
+ buffer))
+
+(define (%set-window-buffer! window new-buffer)
+ (with-instance-variables buffer-window 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 (initial-buffer! window new-buffer)
+ (with-instance-variables buffer-window 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))
+ unspecific))
+
+(define (delete-window-buffer! window)
+ (with-instance-variables buffer-window 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-integrable (%window-point window)
+ (with-instance-variables buffer-window window ()
+ point))
+
+(define (%set-window-point! window mark)
+ (with-instance-variables buffer-window window (mark)
+ (%set-buffer-point! buffer mark)
+ (set! point (buffer-point buffer))
+ (set! point-moved? true)
+ (setup-redisplay-flags! redisplay-flags)))
+
+(define-integrable (%window-cursor window)
+ (with-instance-variables buffer-window window ()
+ (inferior-window cursor-inferior)))
(define-method buffer-window (:salvage! window)
(%set-buffer-point! buffer
(group-start-index (buffer-group buffer))))
(set! point (buffer-point buffer))
(window-modeline-event! superior 'SALVAGE)
- (%window-redraw! window #!FALSE))
+ (%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))
+(define (set-override-message! window message)
+ (with-instance-variables buffer-window 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 (clear-override-message! window)
+ (with-instance-variables buffer-window 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 (home-cursor! window)
+ (with-instance-variables buffer-window window ()
+ (screen-write-cursor! saved-screen saved-x-start saved-y-start)
+ (screen-flush! saved-screen)))
\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 (make-line-inferior window start end)
+ (with-instance-variables buffer-window 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)))
-(define-procedure buffer-window (first-line-inferior window)
- (declare (integrate window))
- (car line-inferiors))
+(define-integrable (first-line-inferior window)
+ (with-instance-variables buffer-window window ()
+ (car line-inferiors)))
-(define (line-inferior-length inferiors)
- (declare (integrate inferiors))
+(define-integrable (line-inferior-length 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))
+(define-integrable (blank-inferior-changed! window)
+ (with-instance-variables buffer-window window ()
+ (if (not override-inferior)
+ (set-blank-inferior-start! window
+ (inferior-y-end last-line-inferior)))))
+
+(define-integrable (set-blank-inferior-start! window y-end)
+ (with-instance-variables buffer-window window (y-end)
+ (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-integrable (set-line-inferiors! window inferiors start)
+ (with-instance-variables buffer-window window (inferiors start)
+ (set! line-inferiors inferiors)
+ (set! start-line-mark
+ (%make-permanent-mark (buffer-group buffer) start false))
+ unspecific))
+
+(define (line-inferiors-changed! window)
+ (with-instance-variables buffer-window 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)
- (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")))))
+ (+ 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)))
+ unspecific))
+\f
+(define (y->inferiors window y)
+ (with-instance-variables buffer-window 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 (index->inferiors window index)
+ (with-instance-variables buffer-window 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 (inferiors->index window inferiors)
+ (with-instance-variables buffer-window 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 (y->inferiors&index window y receiver)
+ (with-instance-variables buffer-window window (y receiver)
+ ;; This is used for scrolling.
+ (define (loop inferiors start previous-inferiors previous-start)
+ (cond ((< y (inferior-y-start (car inferiors)))
+ (receiver previous-inferiors previous-start))
+ ((null? (cdr inferiors))
+ (and (< y (inferior-y-end (car inferiors)))
+ (receiver inferiors start)))
+ (else
+ (loop (cdr inferiors) (+ start (line-inferior-length inferiors))
+ inferiors start))))
+ (loop line-inferiors (mark-index start-line-mark) false false)))
+
+(define (start-changes-inferiors window)
+ (with-instance-variables buffer-window 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 (end-changes-inferiors window)
+ (with-instance-variables buffer-window window ()
+ ;; Assumes that (MARK<= END-CHANGES-MARK END-LINE-MARK).
+ ;; Guarantees to return non-'() result.
+ (let ((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)
+ end ;ignore
+ (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)
+(define (update-cursor! window if-not-visible)
+ (with-instance-variables buffer-window window (if-not-invisible)
+ (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 (maybe-recenter! window)
+ (with-instance-variables buffer-window window ()
+ (let ((threshold (ref-variable "Cursor Centering Threshold")))
+ (if (zero? threshold)
+ (%window-redraw! window (%window-y-center window))
+ (if (< (mark-index point) (mark-index start-mark))
+ (let ((limit
+ (%window-coordinates->index window 0 (- 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)
+ 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 (%window-redraw! window y)
+ (with-instance-variables buffer-window 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 (redraw-screen! window y)
+ (with-instance-variables buffer-window 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)))))
+ (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)))
+(define (everything-changed! window if-not-visible)
+ (with-instance-variables buffer-window 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 (maybe-marks-changed! window inferiors y-end)
+ (with-instance-variables buffer-window 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 (no-outstanding-changes! window)
+ (with-instance-variables buffer-window window ()
+ (set! start-changes-mark false)
+ (set! end-changes-mark false)
+ (set! start-clip-mark false)
+ (set! end-clip-mark false) unspecific))
+
+(define (start-mark-changed! window)
+ (with-instance-variables buffer-window window ()
+ (set! start-mark
(%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:
+ (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 (end-mark-changed! window)
+ (with-instance-variables buffer-window 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!)))
+
+(define-integrable (%window-start-mark window)
+ (with-instance-variables buffer-window window ()
+ start-mark))
+
+(define-integrable (%window-end-mark window)
+ (with-instance-variables buffer-window window ()
+ end-mark))
+(define-integrable (%window-mark-visible? window mark)
+ (with-instance-variables buffer-window window (mark)
+ (and (mark<= start-mark mark)
+ (mark<= mark end-mark))))
+
+(define (%window-y-center window)
+ (with-instance-variables buffer-window 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))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwiu.scm,v 1.5 1989/03/14 07:59:18 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
;;;; Insert/Delete/Clip
;;; 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)))
+(define (make-changes-daemon window)
+ (lambda (group start end)
+ (with-instance-variables buffer-window window (group start end)
+ (cond ((not start-changes-mark)
+ (set! start-changes-mark (%make-permanent-mark group start false))
+ (set! end-changes-mark (%make-permanent-mark group end true)))
+ ((< 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))))
+ (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 (make-clip-daemon window)
+ (lambda (group start end)
+ (with-instance-variables buffer-window 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)
(recompute-image! window)
(update-inferiors! window screen x-start y-start xl xu yl yu display-style))
-(define-procedure buffer-window (maybe-recompute-image! window)
- ;; Used to guarantee everything updated before certain operations.
- (if (car redisplay-flags)
- (recompute-image! window)))
+(define (maybe-recompute-image! window)
+ (with-instance-variables buffer-window 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 (recompute-image! window)
+ (with-instance-variables buffer-window window ()
+ (without-interrupts (lambda () (%recompute-image! window)))))
-(define-procedure buffer-window (%recompute-image! window)
- (let ((group (mark-group start-mark))
- (start-line (mark-index start-line-mark))
- (start (mark-index start-mark))
- (end (mark-index end-mark))
- (point-index (mark-index point)))
- (if start-clip-mark
- (let ((new-clip-start (group-start-index group))
- (new-clip-end (group-end-index group)))
- (cond ((< point-index new-clip-start)
- (%set-buffer-point! buffer (group-display-start group))
- (set! point (buffer-point buffer)))
- ((> point-index new-clip-end)
- (%set-buffer-point! buffer (group-display-end group))
- (set! point (buffer-point buffer))))
- (cond ((> new-clip-start start-line)
- (%window-redraw! window #!FALSE))
- ((or (< new-clip-end end)
- (and (< new-clip-start start-line)
- (= start-line (mark-index start-clip-mark)))
- (and (> new-clip-end end)
- (= end (mark-index end-clip-mark))))
- (%window-redraw!
- window
- (and (not start-changes-mark)
- (>= point-index start)
- (<= point-index end)
- (%window-point-y window))))
- (else
- (set! start-clip-mark #!FALSE)
- (set! end-clip-mark #!FALSE)))))
- (if start-changes-mark
- (let ((start-changes (mark-index start-changes-mark))
- (end-changes (mark-index end-changes-mark)))
- (if (and (>= end-changes start-line)
- (<= start-changes end))
- (cond ((<= start-changes start)
- (cond ((< end-changes end)
- (recompute-image!:top-changed window))
- (else
- (%window-redraw! window #!FALSE))))
- ((>= end-changes end)
- (recompute-image!:bottom-changed window))
- (else
- (recompute-image!:middle-changed window)))
- (begin (set! start-changes-mark #!FALSE)
- (set! end-changes-mark #!FALSE))))))
- (if point-moved?
- (update-cursor! window maybe-recenter!)))
+(define (%recompute-image! window)
+ (with-instance-variables buffer-window 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))
+ (if (<= start-changes start)
+ (if (< end-changes end)
+ (recompute-image!:top-changed window)
+ (%window-redraw! window false))
+ (if (>= end-changes end)
+ (recompute-image!:bottom-changed window)
+ (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 (recompute-image!:top-changed window)
+ (with-instance-variables buffer-window window ()
+ (let ((inferiors (end-changes-inferiors window))
+ (group (mark-group end-changes-mark))
+ (index (mark-index end-changes-mark)))
+ (let ((start-index (line-start-index group index)))
+ (set-line-window-string!
+ (inferior-window (car inferiors))
+ (group-extract-string group start-index (line-end-index group index)))
+ (fill-top! window inferiors start-index true)))
+ (everything-changed! window maybe-recenter!)))
-(define-procedure buffer-window (recompute-image!:bottom-changed window)
- (let ((inferiors (start-changes-inferiors window))
- (group (mark-group start-changes-mark))
- (index (mark-index start-changes-mark)))
- (let ((end-index (line-end-index group index)))
- (set-line-window-string!
- (inferior-window (car inferiors))
- (group-extract-string group
- (line-start-index group index)
- end-index))
- (set-cdr! inferiors
- (fill-bottom window
- (inferior-y-end (car inferiors))
- end-index))))
- (everything-changed! window maybe-recenter!))
+(define (recompute-image!:bottom-changed window)
+ (with-instance-variables buffer-window 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)
+(define (recompute-image!:middle-changed window)
+ (with-instance-variables buffer-window 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!)))))
+ ;; 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!))
+ ;; 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!))
+ )
+;;; continued on next page...
\f
-)
-(if (= start-start end-start)
+;;; ...continued from previous page
-;;; 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!))
+ (if (= start-start end-start)
-;;; 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!))
+ ;; 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
;;; 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 (%window-direct-update! window display-style)
+ (with-instance-variables buffer-window 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 (%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 (%direct-output-forward-character! window)
+ (with-instance-variables buffer-window 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))
+ (screen-flush! saved-screen)
+ (%set-inferior-x-start! cursor-inferior x-start))))))
-(define-procedure buffer-window (%direct-output-backward-character! window)
- (without-interrupts
- (lambda ()
- (%set-buffer-point! buffer (mark-1+ point))
- (set! point (buffer-point buffer))
- (let ((x-start (-1+ (inferior-x-start cursor-inferior)))
- (y-start (inferior-y-start cursor-inferior)))
- (screen-write-cursor! saved-screen
- (+ saved-x-start x-start)
- (+ saved-y-start y-start))
- (%set-inferior-x-start! cursor-inferior x-start)))))
+(define (%direct-output-backward-character! window)
+ (with-instance-variables buffer-window 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))
+ (screen-flush! saved-screen)
+ (%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))))))
+(define (%direct-output-insert-char! window char)
+ (with-instance-variables buffer-window 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)
+ (screen-flush! saved-screen))
+ (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)))))))
-;;; end USING-SYNTAX
-)
+(define (%direct-output-insert-newline! window)
+ (with-instance-variables buffer-window 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))
+ (screen-flush! saved-screen))))))
-;;; Edwin Variables:
-;;; Scheme Environment: (access window-package edwin-package)
-;;; Scheme Syntax Table: class-syntax-table
-;;; End:
+(define (%direct-output-insert-substring! window string start end)
+ (with-instance-variables buffer-window 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)
+ (screen-flush! saved-screen))
+ (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)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Buffer Windows: Mark <-> Coordinate Maps
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
-(define-procedure buffer-window (%window-mark->x window mark)
+(define-integrable (%window-mark->x window mark)
(car (%window-mark->coordinates window mark)))
-(define-procedure buffer-window (%window-mark->y window mark)
+(define-integrable (%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 (%window-point-x window)
+ (with-instance-variables buffer-window window ()
+ (car (%window-mark->coordinates window point))))
-(define-procedure buffer-window (%window-point-y window)
- (cdr (%window-mark->coordinates window point)))
+(define (%window-point-y window)
+ (with-instance-variables buffer-window window ()
+ (cdr (%window-mark->coordinates window point))))
-(define-procedure buffer-window (%window-point-coordinates window)
- (%window-mark->coordinates window point))
+(define (%window-point-coordinates window)
+ (with-instance-variables buffer-window window ()
+ (%window-mark->coordinates window point)))
-(declare (integrate %window-mark->coordinates))
-
-(define-procedure buffer-window (%window-mark->coordinates window mark)
- (declare (integrate window mark))
+(define-integrable (%window-mark->coordinates 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)
+(define (%window-coordinates->mark window x y)
+ (with-instance-variables buffer-window window (x y)
+ (let ((index (%window-coordinates->index window x y)))
+ (and index (make-mark (buffer-group buffer) index)))))
+
+(define (%window-index->coordinates window index)
+ (with-instance-variables buffer-window 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-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))))))))))
+ (search-downwards (1+ end)
+ (+ y-start
+ (column->y-size columns x-size)))))))
+
+ (define-integrable (done 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:
+(define (%window-coordinates->index window x y)
+ (with-instance-variables buffer-window 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)))))))
+
+ (define-integrable (y-delta start end)
+ (column->y-size (group-column-length group start end 0) x-size))
+
+ (define-integrable (done 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)))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/c-mode.scm,v 1.41 1989/03/14 07:59:30 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; C Mode (from GNU Emacs)
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("C Mode" argument)
+(define-command ("C Mode")
"Enter C mode."
(set-current-major-mode! c-mode))
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! "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! "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")
(line-end? point)
(or (line-blank? point)
(and (ref-variable "C Auto Newline")
- (begin (c-indent-line-command #!FALSE)
+ (begin (c-indent-line-command false)
(insert-newline)
- #!TRUE))))
- (begin (^r-insert-self-command #!FALSE)
- (c-indent-line-command #!FALSE)
+ 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))))
+ (c-indent-line-command false))))
(^r-insert-self-command argument))))
(define-command ("Electric C Semi" argument)
(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))))
+ (begin
+ (^r-insert-self-command false)
+ (c-indent-line-command false)
+ (if (and (ref-variable "C Auto Newline")
+ (not (c-inside-parens? point)))
+ (begin
+ (insert-newline)
+ (c-indent-line-command false))))
(^r-insert-self-command argument))))
-\f
-(define-command ("Mark C Procedure" argument)
+
+(define-command ("Mark C Procedure")
"Put mark at end of C procedure, point at beginning."
(push-current-mark! (current-point))
(let ((end (forward-definition-end (current-point) 1 'LIMIT)))
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 ((indentation (c-indent-line:indentation 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 "#")))
+ (indent-code-rigidly 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)
+(define-command ("C Indent Expression")
"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:
+ (c-indent-expression (current-point)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/calias.scm,v 1.3 1989/03/14 07:59:34 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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*)
+(define (define-alias-char char alias)
(let ((entry (assq char alias-characters)))
(if entry
- (set-cdr! entry char*)
- (set! alias-characters (cons (cons char char*) alias-characters)))))
+ (set-cdr! entry alias)
+ (set! alias-characters (cons (cons char alias) alias-characters))))
+ unspecific)
(define (undefine-alias-char char)
- (set! alias-characters (del-assq! char alias-characters)))
+ (set! alias-characters (del-assq! char alias-characters))
+ unspecific)
-(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-k #\VT)
-(define-alias-char #\C-K #\VT)
-(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-z #\Call)
-(define-alias-char #\C-Z #\Call)
-(define-alias-char #\C-[ #\Altmode)
-(define-alias-char #\C-- #\Backnext)
-
-(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-k #\M-VT)
-(define-alias-char #\C-M-K #\M-VT)
-(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-z #\M-Call)
-(define-alias-char #\C-M-Z #\M-Call)
-(define-alias-char #\C-M-[ #\M-Altmode)
-(define-alias-char #\C-M-- #\M-Backnext)
-
-;;; 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
+(define (remap-alias-char char)
+ (let ((entry (assq char alias-characters)))
+ (cond (entry
+ (remap-alias-char (cdr entry)))
+ ((odd? (quotient (char-bits char) 2)) ;Control bit is set
+ (let ((code (char-code char))
+ (remap
+ (lambda (code)
+ (make-char code (- (char-bits char) 2)))))
+ (cond ((<= #x40 code #x5F) (remap (- code #x40)))
+ ((<= #x61 code #x7A) (remap (- code #x60)))
+ (else char))))
+ (else char))))
-;;; 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
+(define (unmap-alias-char char)
+ (let ((code (char-code char))
+ (bits (char-bits char)))
+ (if (or (>= code #x20)
+ (memv code '(#x09 #x0A #x0C #x0D #x1B))
+ (odd? (quotient bits 2)))
+ (let ((entry
+ (list-search-positive alias-characters
+ (lambda (entry)
+ (eqv? (cdr entry) char)))))
+ (if entry
+ (unmap-alias-char (car entry))
+ char))
+ (unmap-alias-char
+ (make-char (+ code (if (<= #x01 code #x1A) #x60 #x40))
+ (+ bits 2))))))
-;;; end USING-SYNTAX
-)
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; Scheme Syntax Table: edwin-syntax-table
-;;; End:
+(define-integrable (char-name char)
+ (char->name (unmap-alias-char char)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/class.scm,v 1.67 1989/03/14 07:59:37 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;; 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-root-environment)
- ;; **** Because IN-PACKAGE NULL-ENVIRONMENT broken.
- (let ((methods (make-environment)))
- ((access system-environment-remove-parent! environment-package)
- methods)))
-
-(define make-class)
-(define class?)
-(define name->class)
-(let ()
+(define-structure (class (type vector)
+ (constructor false)
+ (initial-offset 1))
+ (name false read-only true)
+ (superclass false read-only true)
+ (object-size false read-only true)
+ (instance-transforms false read-only true)
+ (methods false read-only true))
-(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-empty-methods superclass))))
- ((access add-unparser-special-object! unparser-package)
- class object-unparser)
- (local-assignment class-descriptors name class)
- class)))))
-
-(define (make-empty-methods superclass)
- (if superclass
- (in-package (class-methods superclass)
- (make-environment))
- (make-root-environment)))
-
-(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-root-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-method class name)
+ (class-methods/ref (class-methods class) name))
-(define (class-methods class)
- (declare (integrate class))
- (vector-ref class 5))
+(define (class-methods/ref methods name)
+ (or (method-lookup methods name)
+ (error "unknown method" name)))
-(define (class-method class name)
- (declare (integrate class name))
- (lexical-reference (class-methods class) name))
+(define (method-lookup methods name)
+ (let loop ((methods methods))
+ (and methods
+ (let ((entry (assq name (car methods))))
+ (if entry
+ (cdr entry)
+ (loop (cdr methods)))))))
(define (class-method-define class name method)
- (local-assignment (class-methods class) name method))
-
-(define (usual-method class name)
- (declare (integrate class name))
+ (let ((methods (class-methods class)))
+ (let ((entry (assq name (car methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-car! methods (cons (cons name method) (car methods))))))
+ name)
+
+(define-integrable (usual-method 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))
+ (let loop ((class (class-superclass class)))
+ (and class
+ (or (eq? class class*)
+ (loop (class-superclass class)))))))
(define (make-object class)
- (if (not (class? class)) (error "MAKE-OBJECT: Not a class" class))
- (let ((object (vector-cons (class-object-size class) #!FALSE)))
+ (if (not (class? class))
+ (error "not a class" class))
+ (let ((object (make-vector (class-object-size class) false)))
(vector-set! object 0 class)
object))
(not (zero? (vector-length object)))
(eq? class (vector-ref object 0))))
-(define (object-class object)
- (declare (integrate object))
+(define-integrable (object-class object)
(vector-ref object 0))
-(define (object-methods object)
- (declare (integrate object))
+(define-integrable (object-methods object)
(class-methods (object-class object)))
-(define (object-method object name)
- (declare (integrate object name))
+(define-integrable (object-method 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))))
+ (let ((method (method-lookup (object-methods object) operation)))
+ (and method (apply method object args))))
(define (send-usual class object operation . args)
(apply (usual-method class operation) object args))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.56 1989/03/14 07:59:42 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Commands and Variables
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-named-structure "Command"
name
(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 ""
+ (make-command name
+ ""
(lambda (#!optional argument)
+ argument ;ignore
(editor-error "Undefined command: \"" name "\"")))))
-\f
+
(define-named-structure "Variable"
name
description
(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-integrable (variable-ref variable)
+ (lexical-reference variable-environment (variable-symbol variable)))
(define (variable-set! variable #!optional value)
- (lexical-assignment edwin-package (variable-symbol variable) (set! value)))
+ (lexical-assignment variable-environment
+ (variable-symbol variable)
+ (if (default-object? value)
+ (unmap-reference-trap
+ (make-unassigned-reference-trap))
+ value)))
+
+(define-integrable (variable-unbound? variable)
+ (lexical-unbound? variable-environment (variable-symbol variable)))
+
+(define-integrable (variable-unassigned? variable)
+ (lexical-unassigned? variable-environment (variable-symbol variable)))
-;;; end USING-SYNTAX
-)
\ No newline at end of file
+(define variable-environment
+ (->environment '(EDWIN)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.71 1989/03/14 07:59:44 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Command Reader
-(declare (usual-integrations)
- )
-(using-syntax (access edwin-syntax-table edwin-package)
+(declare (usual-integrations))
\f
(define (top-level-command-reader)
- (fluid-let ((*auto-save-keystroke-count* 0))
- (define (^G-loop)
- (call-with-current-continuation
- (lambda (continuation)
- (fluid-let ((*^g-interrupt-continuation* continuation))
- (with-keyboard-macro-disabled
- (lambda ()
- (catching-^g
- (lambda ()
- (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
+ (let loop ()
+ (with-keyboard-macro-disabled
+ (lambda ()
+ (intercept-^G-interrupts (lambda () unspecific)
+ command-reader)))
+ (loop)))
+
(define *command-continuation*) ;Continuation of current command
(define *command-char*) ;Character read to find current command
(define *command*) ;The current command
(define *next-message*) ;Message to next command
(define *non-undo-count*) ;# of self-inserts since last undo boundary
-(let ()
+(define (command-reader)
+ (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 ((char (keyboard-read-char)))
+ (set! *command-char* char)
+ (set-command-prompt! (char-name char))
+ (let ((window (current-window)))
+ (%dispatch-on-command window
+ (comtab-entry (buffer-comtabs
+ (window-buffer window))
+ char))))
+ (start-next-command))
-(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))
-
-)
+ (with-command-argument-reader command-reader-loop)))
(define (reset-command-state!)
(reset-command-argument-reader!)
;;; 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.
+;;; C-4, since they want arguments, messages, etc. to be passed on.
-(set! execute-char
-(named-lambda (execute-char comtab char)
+(define-integrable (execute-char comtab char)
(reset-command-state!)
- (dispatch-on-char comtab char)))
+ (dispatch-on-char comtab char))
-(set! execute-command
-(named-lambda (execute-command command)
+(define-integrable (execute-command command)
(reset-command-state!)
- (dispatch-on-command command)))
+ (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))))
+(define-integrable (read-and-dispatch-on-char)
+ (dispatch-on-char (current-comtabs) (keyboard-read-char)))
-(set! dispatch-on-char
-(named-lambda (dispatch-on-char comtab char)
+(define (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))))
+ (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))
+(define-integrable (dispatch-on-command command)
+ (%dispatch-on-command (current-window) command))
+
+(define (abort-current-command #!optional value)
(keyboard-macro-disable)
- (*command-continuation* value)))
+ (*command-continuation* (if (default-object? value) 'ABORT value)))
-(set! current-command-char
-(named-lambda (current-command-char)
- *command-char*))
+(define-integrable (current-command-char)
+ *command-char*)
-(set! current-command
-(named-lambda (current-command)
- *command*))
+(define-integrable (current-command)
+ *command*)
-(set! set-command-message!
-(named-lambda (set-command-message! tag . arguments)
- (set! *next-message* (cons tag arguments))))
+(define (set-command-message! tag . arguments)
+ (set! *next-message* (cons tag arguments))
+ unspecific)
-(set! command-message-receive
-(named-lambda (command-message-receive tag if-received if-not-received)
+(define (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:
+ (if-not-received)))
+\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))
+ (let ((point (window-point window))
+ (point-x (window-point-x window)))
+ (if (or (eq? procedure ^r-insert-self-command)
+ (and (eq? procedure ^r-auto-fill-space-command)
+ (not (auto-fill-break? point)))
+ (command-argument-self-insert? procedure))
+ (if (let ((buffer (window-buffer window)))
+ (and (buffer-auto-save-modified? buffer)
+ (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (char-graphic? *command-char*)
+ (< point-x (-1+ (window-x-size window)))))
+ (begin
+ (if (or (zero? *non-undo-count*)
+ (>= *non-undo-count* 20))
+ (begin
+ (undo-boundary! point)
+ (set! *non-undo-count* 0)))
+ (set! *non-undo-count* (1+ *non-undo-count*))
+ (window-direct-output-insert-char! window *command-char*))
+ (region-insert-char! point *command-char*))
+ (begin
+ (set! *non-undo-count* 0)
+ (cond ((eq? procedure ^r-forward-character-command)
+ (if (and (not (group-end? point))
+ (char-graphic? (mark-right-char point))
+ (< point-x (- (window-x-size window) 2)))
+ (window-direct-output-forward-char! window)
+ (procedure argument)))
+ ((eq? procedure ^r-backward-character-command)
+ (if (and (not (group-start? point))
+ (char-graphic? (mark-left-char point))
+ (positive? point-x))
+ (window-direct-output-backward-char! window)
+ (procedure argument)))
+ (else
+ (if (not (typein-window? window))
+ (undo-boundary! point))
+ (procedure argument)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comtab.scm,v 1.50 1989/03/14 07:59:53 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(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-structure (comtab (constructor make-comtab ()))
+ (dispatch-alists (cons '() '()) read-only true))
(define (remap-char char)
(char-upcase (remap-alias-char char)))
(let ((entry (assq char (cdr alists))))
(if entry
(set-cdr! entry command)
- (set-cdr! alists (cons (cons char command) (cdr alists)))))))
+ (set-cdr! alists (cons (cons char command) (cdr alists))))))
+ unspecific)
(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
+ (set-car! alists (cons (cons char alists*) (car alists))))))
+ unspecific)
+
(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 (null? (cddr chars))
(receiver (cdr entry) (cadr chars))
(loop (cadr entry) (cdr chars)))
- (if (unassigned? if-undefined)
+ (if (default-object? if-undefined)
(error "Not a prefix character" (car chars))
(if-undefined)))))
(cond ((char? 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)))
+\f
+(define (comtab-entry comtabs xchar)
+ (let ((continue
+ (lambda ()
+ (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)
+(define (prefix-char-list? comtabs chars)
+ (let loop
+ ((char->alist (car (comtab-dispatch-alists (car comtabs))))
+ (chars 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)
+ (prefix-char-list? (cdr comtabs) chars)))))))
+
+(define (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))
((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))
+ (else
+ (error "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)
+(define (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)
+ (if (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 '() '()))))
+ (error "not a character" char)))
+ char)
+
+(define (define-default-key mode-name command-name)
(let ((comtabs (mode-comtabs (name->mode mode-name))))
(if (not (or (null? (cdr comtabs)) (command? (cadr comtabs))))
(error "Can't define default key for this mode" mode-name))
- (set-cdr! comtabs (list (name->command command-name)))) 'DEFAULT-KEY))
+ (set-cdr! comtabs (list (name->command command-name)))) 'DEFAULT-KEY)
\f
-(set! comtab-key-bindings
-(named-lambda (comtab-key-bindings comtabs command)
+(define (comtab-key-bindings comtabs command)
(define (search-comtabs comtabs)
(let ((bindings
(search-comtab '() (comtab-dispatch-alists (car comtabs)))))
(search-prefix-map (cdr alist)))))
(define (search-command-map alist)
- (cond ((null? alist) '())
+ (cond ((null? alist)
+ '())
((eq? command (cdar alist))
(cons (caar alist) (search-command-map (cdr alist))))
(else
;; 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:
+ (eq? command (comtab-entry comtabs xchar)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comwin.scm,v 1.134 1989/03/14 07:59:55 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Combination Windows
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
;;; Combination windows are used to split a window into vertically or
;;; horizontally divided areas. That window's initial superior must
;;; 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-integrable (window-next window)
+ (with-instance-variables combination-leaf-window window ()
+ next-window))
-(define-procedure combination-leaf-window (window-next window)
- (declare (integrate window))
- next-window)
+(define-integrable (set-window-next! window window*)
+ (with-instance-variables combination-leaf-window window (window*)
+ (set! next-window window*)
+ unspecific))
-(define-procedure combination-leaf-window (set-window-next! window window*)
- (declare (integrate window window*))
- (set! next-window window*))
+(define-integrable (window-previous window)
+ (with-instance-variables combination-leaf-window window ()
+ previous-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-integrable (set-window-previous! window window*)
+ (with-instance-variables combination-leaf-window window (window*)
+ (set! previous-window window*)
+ unspecific))
(define (link-windows! previous next)
(set-window-previous! next previous)
(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-integrable (combination-vertical? window)
+ (with-instance-variables combination-window window ()
+ vertical?))
-(define-procedure combination-window (set-combination-vertical! window v)
- (declare (integrate window v))
- (set! vertical? v))
+(define-integrable (set-combination-vertical! window v)
+ (with-instance-variables combination-window window (v)
+ (set! vertical? v)
+ unspecific))
-(define-procedure combination-window (combination-child window)
- (declare (integrate window))
- child)
+(define-integrable (combination-child window)
+ (with-instance-variables combination-window window ()
+ child))
-(define-procedure combination-window (set-combination-child! window window*)
- (set! child window*)
- (set-window-previous! window* #!FALSE))
+(define (set-combination-child! window window*)
+ (with-instance-variables combination-window window (window*)
+ (set! child window*)
+ (set-window-previous! window* false)))
-(define (combination? window)
- (declare (integrate window))
+(define-integrable (combination? window)
(object-of-class? combination-window window))
-(define (leaf? window)
- (declare (integrate window))
+(define-integrable (leaf? 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))
+(define-integrable (check-leaf-window window name)
(if (not (leaf? window))
(error "Not a leaf window" name window)))
\f
;;;; Leaf Ordering
-(set! window+
-(named-lambda (window+ leaf n)
+(define (window+ leaf n)
(check-leaf-window leaf 'WINDOW+)
(cond ((positive? n) (%window+ leaf n))
((negative? n) (%window- leaf (- n)))
- (else leaf))))
+ (else leaf)))
-(set! window-
-(named-lambda (window- leaf n)
+(define (window- leaf n)
(check-leaf-window leaf 'WINDOW-)
(cond ((positive? n) (%window- leaf n))
((negative? n) (%window+ leaf (- n)))
- (else leaf))))
+ (else leaf)))
(define (%window+ leaf n)
(if (= n 1)
(%window-1+ leaf)
(%window- (%window-1+ leaf) (-1+ n))))
-(set! window1+
-(named-lambda (window1+ leaf)
+(define (window1+ leaf)
(check-leaf-window leaf 'WINDOW1+)
- (%window1+ leaf)))
+ (%window1+ leaf))
-(set! window-1+
-(named-lambda (window-1+ leaf)
+(define (window-1+ leaf)
(check-leaf-window leaf 'WINDOW-1+)
- (%window-1+ leaf)))
+ (%window-1+ leaf))
-(set! window0
-(named-lambda (window0 window)
+(define (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))))
+ (window-leftmost-leaf (window-root window)))
\f
(define (%window1+ leaf)
(window-leftmost-leaf
(window-rightmost-leaf (window-last (combination-child window)))
window))
\f
-(set! window-has-no-neighbors?
-(named-lambda (window-has-no-neighbors? leaf)
+(define (window-has-no-neighbors? leaf)
(check-leaf-window leaf 'WINDOW-HAS-NO-NEIGHBORS?)
- (not (combination? (window-superior leaf)))))
+ (not (combination? (window-superior leaf))))
-(set! window-has-horizontal-neighbor?
-(named-lambda (window-has-horizontal-neighbor? leaf)
+(define (window-has-horizontal-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-HORIZONTAL-NEIGHBOR?)
- (%window-has-horizontal-neighbor? leaf)))
+ (%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)))))
+ (let ((superior (window-superior window)))
+ (and (combination? superior)
+ (or (not (combination-vertical? superior))
+ (%window-has-horizontal-neighbor? superior)))))
-(set! window-has-vertical-neighbor?
-(named-lambda (window-has-vertical-neighbor? leaf)
+(define (window-has-vertical-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-VERTICAL-NEIGHBOR?)
- (%window-has-vertical-neighbor? leaf)))
+ (%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)
+ (let ((superior (window-superior window)))
+ (and (combination? superior)
+ (or (combination-vertical? superior)
+ (%window-has-vertical-neighbor? superior)))))
+
+(define (window-has-right-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-RIGHT-NEIGHBOR?)
- (%window-has-right-neighbor? leaf)))
+ (%window-has-right-neighbor? leaf))
(define (%window-has-right-neighbor? window)
(and (combination? (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)
+(define (window-has-left-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-LEFT-NEIGHBOR?)
- (%window-has-left-neighbor? leaf)))
+ (%window-has-left-neighbor? leaf))
(define (%window-has-left-neighbor? window)
(and (combination? (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)
+(define (window-has-up-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-UP-NEIGHBOR?)
- (%window-has-up-neighbor? leaf)))
+ (%window-has-up-neighbor? leaf))
(define (%window-has-up-neighbor? window)
(and (combination? (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)
+(define (window-has-down-neighbor? leaf)
(check-leaf-window leaf 'WINDOW-HAS-DOWN-NEIGHBOR?)
- (%window-has-down-neighbor? leaf)))
+ (%window-has-down-neighbor? leaf))
(define (%window-has-down-neighbor? window)
(and (combination? (window-superior window))
\f
;;;; Creation
-(set! window-split-horizontally!
-(named-lambda (window-split-horizontally! leaf #!optional n)
+(define (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))
+ (let ((n
+ (if (or (default-object? n) (not n))
+ (quotient (window-x-size leaf) 2)
+ n))
+ (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)
+ (let ((n* (- x n))
+ (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)))))
+
+(define (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))
+ (let ((n
+ (if (or (default-object? n) (not n))
+ (quotient (window-y-size leaf) 2)
+ n))
+ (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)))))))
+ (let ((n* (- y n))
+ (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)))
(set-combination-vertical! combination v)
(window-replace! leaf combination)
(set-combination-child! combination leaf)
- (set-window-next! leaf #!FALSE)
+ (set-window-next! leaf false)
(=> superior :delete-inferior! leaf)
(add-inferior! combination leaf)
(set-inferior-start! (window-inferior combination leaf) 0 0)
\f
;;;; Deletion
-(set! window-delete!
-(named-lambda (window-delete! leaf)
+(define (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)))))
-
+ (let ((superior (window-superior leaf))
+ (next (window-next leaf))
+ (previous (window-previous leaf))
+ (x-size (window-x-size leaf))
+ (y-size (window-y-size leaf)))
(if (not (combination? superior))
- (error "Attempt to delete top window"))
+ (editor-error "Window has no neighbors; can't delete"))
(unlink-leaf! leaf)
(let ((value
- (cond ((window-next leaf)
- (adjust-size! (window-next leaf))
- (let ((inferior
- (window-inferior superior (window-next leaf))))
+ (let ((adjust-size!
+ (lambda (window)
(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)))))
+ (=> window :set-y-size!
+ (+ (window-y-size window) y-size))
+ (=> window :set-x-size!
+ (+ (window-x-size window) x-size))))))
+ (cond (next
+ (adjust-size! next)
+ (let ((inferior (window-inferior superior next)))
+ (if (combination-vertical? superior)
+ (set-inferior-y-start! inferior
+ (- (inferior-y-start inferior)
+ y-size))
+ (set-inferior-x-start! inferior
+ (- (inferior-x-start inferior)
+ x-size))))
+ next)
+ (previous
+ (adjust-size! previous)
+ previous)
+ (else
+ (error "combination with single child" superior))))))
(maybe-delete-combination! superior)
- value))))
+ (if (current-window? leaf)
+ (select-window value)))))
\f
(define (unlink-leaf! leaf)
(let ((combination (window-superior leaf))
(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)))
+ (begin
+ (delete-inferior! combination child)
+ (=> (window-superior combination) :replace-inferior!
+ combination
+ child)
+ (window-replace! combination child)))))
+
+(define (window-replace! old new)
+ (with-instance-variables combination-leaf-window 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! (window-last first) next-window))
+ (link-windows! new 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)))))
+ (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!)
+ vertical? size min-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 ((leaf
+ (let loop ((leaf leaf))
+ (let ((combination (window-superior leaf)))
+ (cond ((not (combination? combination))
+ (editor-error "Can't grow this window "
+ (if vertical? "vertically" "horizontally")))
+ ((boolean=? vertical? (combination-vertical? combination))
+ leaf)
+ (else
+ (loop combination)))))))
(let ((new-size (+ (size leaf) delta))
+ (combination (window-superior leaf))
(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)))))
+ (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)))
(else
(scale-combination-inferiors! combination
(- (size combination) new-size)
- leaf v size min-size
- set-c-size! set-w-size!
- set-start!)
+ leaf vertical? size min-size
+ set-w-size! set-start!)
;; Scaling may have deleted all other inferiors.
;; If so, leaf has replaced combination.
(set-w-size! leaf
new-size
(size combination))))))))
\f
-(set! window-grow-horizontally!
-(named-lambda (window-grow-horizontally! leaf delta)
- (window-grow! leaf delta #!FALSE
+(define (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!)))
+ 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
+(define (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!)))
+ 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
+ (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!))
+ send-window-x-size! set-inferior-x-start!))
(define (scale-combination-inferiors-y! combination y except)
- (scale-combination-inferiors! combination y except #!TRUE
+ (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!))
+ send-window-y-size! set-inferior-y-start!))
(define (window-min-x-size window)
(=> window :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)
+ (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)
+ (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)
+ (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-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!)
+ v size min-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.
;; 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)
+ (let ((kernel
+ (lambda (old-room collect-deletions change-inferiors)
+ (cond ((< old-room new-room)
+ (change-inferiors))
+ ((> old-room new-room)
+ (for-each window-delete! (collect-deletions))
+ (if (not (null? (window-inferiors combination)))
+ (change-inferiors))))))
+ (child (combination-child combination))
+ (c-size (size combination)))
+ (if (not (eq? (combination-vertical? combination) v))
+ (kernel
+ c-size
+ (lambda ()
+ (let loop ((window child))
+ (let ((deletions
+ (if (window-next window)
+ (loop (window-next window))
+ '())))
+ (if (< new-room (min-size window))
+ (cons window deletions)
+ deletions))))
+ (lambda ()
+ (let loop ((window child))
+ (set-w-size! window new-room)
+ (if (window-next window)
+ (loop (window-next window))))))
+ (let ((old-room (if except (- c-size (size except)) c-size)))
+ (kernel
+ old-room
+ (lambda ()
+ (let loop ((window child) (old-room old-room) (new-room new-room))
+ (cond ((eq? window except)
+ (if (window-next window)
+ (loop (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))
+ (new-s (quotient (* old-s new-room) old-room))
+ (deletions
+ (loop (window-next window)
+ (- old-room old-s)
+ (- new-room new-s))))
+ (if (< new-s (min-size window))
+ (cons window deletions)
+ deletions))))))
+ (lambda ()
+ (let loop
+ ((window child)
+ (start 0)
+ (old-room old-room)
+ (new-room new-room))
+ (set-start! (window-inferior combination window) start)
+ (cond ((eq? window except)
+ (if (window-next window)
+ (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))
+ (new-s (quotient (* old-s new-room) old-room)))
+ (set-w-size! window new-s)
+ (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
+ (- new-room new-s))))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.80 1989/03/14 08:00:13 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Current State
-(declare (usual-integrations)
- )
-(using-syntax edwin-syntax-table
+(declare (usual-integrations))
\f
;;;; Windows
-(define (current-window)
- ((access editor-frame-selected-window window-package) (current-frame)))
+(define-integrable (current-window)
+ (editor-frame-selected-window (current-editor-frame)))
+
+(define-integrable (current-window? window)
+ (eq? window (current-window)))
-(define (window0)
- ((access editor-frame-window0 window-package) (current-frame)))
+(define-integrable (window0)
+ (editor-frame-window0 (current-editor-frame)))
-(define (typein-window)
- ((access editor-frame-typein-window window-package) (current-frame)))
+(define-integrable (typein-window)
+ (editor-frame-typein-window (current-editor-frame)))
-(define (typein-window? window)
+(define-integrable (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))))))
+ (let ((frame (current-editor-frame)))
+ (%wind-local-bindings!
+ (window-buffer (editor-frame-selected-window frame)))
+ (editor-frame-select-window! frame window))
+ (let ((buffer (window-buffer window)))
+ (%wind-local-bindings! buffer)
+ (perform-buffer-initializations! buffer)
+ (bufferset-select-buffer! (current-bufferset) buffer)))))
+
+(define-integrable (select-cursor window)
+ (editor-frame-select-cursor! (current-editor-frame) window))
(define (window-list)
(let ((window0 (window0)))
- (define (loop window)
- (if (eq? window window0)
- (list window)
- (cons window (loop (window1+ window)))))
- (loop (window1+ window0))))
+ (let loop ((window (window1+ window0)))
+ (cons window
+ (if (eq? window window0)
+ '()
+ (loop (window1+ window)))))))
(define (window-visible? window)
(or (typein-window? window)
(let ((window0 (window0)))
- (define (loop window*)
+ (let loop ((window* (window1+ window0)))
(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)))
+ (loop (window1+ window*))))))))
+
+(define (other-window #!optional n)
+ (let ((n (if (or (default-object? n) (not n)) 1 n))
+ (window (current-window)))
+ (cond ((positive? n)
+ (let loop ((n n) (window 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)))))))
+ ((negative? n)
+ (let loop ((n n) (window window))
+ (if (zero? n)
+ window
+ (loop (1+ n)
(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))
+ (window-1+ (if (typein-window? window)
+ (window0)
+ window)))))))
+ (else
+ window))))
\f
;;;; Buffers
(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)
+ (let loop ((less-preferred false) (buffers (buffer-list)))
(cond ((null? buffers)
less-preferred)
((or (eq? buffer (car buffers))
((buffer-visible? (car buffers))
(loop (or less-preferred (car buffers)) (cdr buffers)))
(else
- (car buffers))))
- (loop #!FALSE (buffer-list)))
+ (car buffers)))))
+
+(define-integrable (bury-buffer buffer)
+ (bufferset-bury-buffer! (current-bufferset) buffer))
(define-integrable (find-buffer name)
(bufferset-find-buffer (current-bufferset) name))
(define-integrable (find-or-create-buffer name)
(bufferset-find-or-create-buffer (current-bufferset) name))
+(define-integrable (rename-buffer buffer new-name)
+ (bufferset-rename-buffer (current-bufferset) buffer new-name))
+
(define (kill-buffer buffer)
(if (buffer-visible? buffer)
(let ((new-buffer
(or (other-buffer buffer)
(error "Buffer to be killed has no replacement" buffer))))
(for-each (lambda (window)
- (set-window-buffer! window new-buffer))
+ (set-window-buffer! window new-buffer false))
(buffer-windows buffer)))) (bufferset-kill-buffer! (current-bufferset) buffer))
+\f
+(define-integrable (select-buffer buffer)
+ (set-window-buffer! (current-window) buffer true))
-(define-integrable (rename-buffer buffer new-name)
- (bufferset-rename-buffer (current-bufferset) buffer new-name))
+(define-integrable (select-buffer-no-record buffer)
+ (set-window-buffer! (current-window) buffer false))
+
+(define-integrable (select-buffer-in-window buffer window)
+ (set-window-buffer! window buffer true))
+
+(define (set-window-buffer! window buffer record?)
+ (without-interrupts
+ (lambda ()
+ (if (current-window? window)
+ (begin
+ (%wind-local-bindings! (window-buffer window))
+ (%set-window-buffer! window buffer)
+ (%wind-local-bindings! buffer)
+ (perform-buffer-initializations! buffer) (if record? (bufferset-select-buffer! (current-bufferset) buffer)))
+ (%set-window-buffer! window buffer)))))
+(define (with-selected-buffer buffer thunk)
+ (let ((old-buffer))
+ (dynamic-wind (lambda ()
+ (let ((window (current-window)))
+ (set! old-buffer (window-buffer window))
+ (if (buffer-alive? buffer)
+ (set-window-buffer! window buffer true)))
+ (set! buffer)
+ unspecific)
+ thunk
+ (lambda ()
+ (let ((window (current-window)))
+ (set! buffer (window-buffer window))
+ (if (buffer-alive? old-buffer)
+ (set-window-buffer! window old-buffer true)))
+ (set! old-buffer)
+ unspecific))))
+
+(define (select-buffer-other-window buffer)
+ (let ((window
+ (let ((window (current-window)))
+ (if (window-has-no-neighbors? window)
+ (window-split-vertically! window false)
+ (or (list-search-negative (buffer-windows buffer)
+ (lambda (window*)
+ (eq? window window*)))
+ (window1+ window))))))
+ (select-window window)
+ (set-window-buffer! window buffer true)))
\f
;;;; Point
(%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))
+ (let ((old-point))
+ (dynamic-wind (lambda ()
+ (let ((window (current-window)))
+ (set! old-point (window-point window))
+ (set-window-point! window point))
+ (set! point)
+ unspecific)
+ thunk
+ (lambda ()
+ (let ((window (current-window)))
+ (set! point (window-point window))
+ (set-window-point! window old-point))
+ (set! old-point)
+ unspecific))))
+
+(define-integrable (current-column)
+ (mark-column (current-point)))
\f
;;;; Mark and Region
(define (buffer-mark buffer)
(let ((ring (buffer-mark-ring buffer)))
- (if (ring-empty? ring) (editor-error))
- (ring-ref ring 0)))
+ (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))
+ (guarantee-mark mark 'SET-CURRENT-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-integrable (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))
+ (guarantee-mark mark 'PUSH-CURRENT-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"))))
+ (let ((notification (ref-variable "Auto Push Point Notification")))
+ (if (and notification
+ (not *executing-keyboard-macro?*)
+ (not (typein-window? (current-window))))
+ (temporary-message notification))))
-(define (push-buffer-mark! buffer mark)
- (ring-push! (buffer-mark-ring buffer)
- (mark-right-inserting mark)))
+(define-integrable (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)
+(define-integrable (pop-buffer-mark! buffer)
(ring-pop! (buffer-mark-ring buffer)))
(define-integrable (current-region)
(define-integrable (current-major-mode)
(buffer-major-mode (current-buffer)))
-(define-integrable (current-comtab) ;**** misnamed, should be plural.
+(define-integrable (current-comtabs)
(buffer-comtabs (current-buffer)))
-(define (set-current-major-mode! mode)
+(define-integrable (set-current-major-mode! mode)
(set-buffer-major-mode! (current-buffer) mode))
-(define (current-minor-mode? mode)
+(define-integrable (current-minor-mode? mode)
(buffer-minor-mode? (current-buffer) mode))
-(define (enable-current-minor-mode! mode)
+(define-integrable (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:
+(define-integrable (disable-current-minor-mode! mode)
+ (disable-buffer-minor-mode! (current-buffer) mode))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/debuge.scm,v 1.35 1989/03/14 08:00:20 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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))))
+ (bufferset-buffer-list (editor-bufferset edwin-editor))))
(define (debug-save-buffer buffer)
(if (and (buffer-modified? buffer)
(and (y-or-n? "Save buffer "
(buffer-name buffer)
" (Y or N)? ")
- (begin (newline)
- (write-string "Filename: ")
- (string->pathname (read-line)))))
+ (begin
+ (newline)
+ (write-string "Filename: ")
+ (->pathname (read)))))
((integer? (pathname-version pathname))
(pathname-new-version pathname 'NEWEST))
- (else pathname)))))
+ (else
+ pathname)))))
(if pathname
(let ((truename (pathname->output-truename pathname)))
(let ((filename (pathname->string truename)))
(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)))))))))
+ (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 ("Redraw Display")
+ "Redraws the entire display from scratch."
+ (update-screens! true))
-(define-command ("Debug Show Rings" argument) ""
+(define-command ("Debug Show Rings")
+ ""
(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) ""
+
+(define-command ("Debug Count Marks")
+ ""
(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)
+ (let loop ((marks (group-marks group)) (receiver receiver))
+ (if (weak-pair? marks)
+ (loop (weak-cdr marks)
(lambda (n-existing n-gced)
- (if (object-unhash (car marks))
+ (if (weak-pair/car? marks)
(receiver (1+ n-existing) n-gced)
- (receiver n-existing (1+ n-gced)))))))
- (loop (group-marks group) receiver))
+ (receiver n-existing (1+ n-gced)))))
+ (receiver 0 0))))\f
+;;;; Object System Debugging
(define (po object)
(for-each (lambda (entry)
- (format "~%~o: ~40@o"
- (car entry)
- (vector-ref object (cdr entry))))
+ (newline)
+ (write (car entry))
+ (write-string ": ")
+ (write (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-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:
+ (error "Not a valid instance-variable name" name))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.97 1989/03/14 08:00:23 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Directory Editor
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Dired" argument)
+(define-command ("Dired")
"Edit a directory. You type the directory name."
(select-buffer (make-dired-buffer "Dired")))
-(define-command ("Dired Other Window" argument)
+(define-command ("Dired Other Window")
"Edit a directory in another window. You type the directory name."
(select-buffer-other-window (make-dired-buffer "Dired Other Window")))
(lambda (buffer)
(and (eq? dired-mode (buffer-major-mode buffer))
(pathname=? pathname (buffer-truename buffer)))))
- (new-buffer (pathname->string pathname))))
+ (new-buffer (pathname-name-string pathname))))
(define (revert-dired-buffer argument)
+ argument ;ignore
(fill-dired-buffer! (current-buffer)))
(define (fill-dired-buffer! buffer)
(write-string (pathname->string pathname))
(newline)
(newline)
- (for-each (lambda (element) (apply write-dired-line element))
- (generate-dired-elements pathname)))))
+ (for-each (lambda (pathname)
+ (write-string (os/make-dired-line pathname))
+ (newline))
+ (directory-read pathname)))))
(buffer-not-modified! buffer)
(set-buffer-read-only! buffer)
(add-buffer-initialization! buffer
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! "Case Fold Search" true)
(local-set-variable! "Cursor Centering Threshold" 0)
(local-set-variable! "Cursor Centering Point" 10))
(define-key "Dired" #\C-\] "^R Dired Abort")
(define-key "Dired" #\? "^R Dired Summary")
\f
-(define-command ("^R Dired Find File" argument)
+(define-command ("^R Dired Find File")
"Read the current file into a buffer."
(find-file (dired-current-pathname)))
-(define-command ("^R Dired Find File Other Window" argument)
+(define-command ("^R Dired Find File Other Window")
"Read the current file into a buffer in another window."
(find-file-other-window (dired-current-pathname)))
"Move down to the next line."
(set-current-point! (line-start (current-point) argument 'BEEP)))
-(define-command ("^R Dired Execute" argument)
+(define-command ("^R Dired Execute")
"Kill all marked files."
(dired-kill-files))
-(define-command ("^R Dired Quit" argument)
+(define-command ("^R Dired Quit")
"Exit Dired, offering to kill any files first."
(dired-kill-files)
(kill-buffer-interactive (current-buffer)))
-(define-command ("^R Dired Abort" argument)
+(define-command ("^R Dired Abort")
"Exit Dired."
(kill-buffer-interactive (current-buffer)))
-(define-command ("^R Dired Summary" argument)
+(define-command ("^R Dired Summary")
"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)
(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)
+ i ;ignore
(let ((lstart (line-start (current-point) 0)))
(guarantee-dired-filename-line lstart)
(delete-right-char lstart)
(pathname-directory-path
(or (buffer-pathname (current-buffer))
(working-directory-pathname))))))
- (let ((elements (generate-dired-elements pathname))
+ (let ((pathnames (directory-read pathname))
(directory (pathname->string pathname)))
(with-output-to-temporary-buffer "*Directory*"
(lambda ()
(newline)
(newline)
(cond (argument
- (for-each (lambda (element) (apply write-dired-line element))
- elements))
+ (for-each (lambda (pathname)
+ (write-string (os/make-dired-line pathname))
+ (newline))
+ pathnames))
((ref-variable "List Directory Unpacked")
- (for-each (lambda (element)
- (write-string
- (pathname-name-string (car element)))
+ (for-each (lambda (pathname)
+ (write-string (pathname-name-string pathname))
(newline))
- elements))
+ pathnames))
(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:
+ (map pathname-name-string pathnames)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.183 1989/03/14 08:00:27 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
+;;;; Editor Top Level
(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)
-(define edwin-get-input-port)
-(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 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!)))
-
-(set! edwin-get-input-port
-(named-lambda (edwin-get-input-port)
- (the-alpha-screen->input-port)))
-)
\f
(define (edwin)
- (if (or (unassigned? edwin-editor)
- (not edwin-editor))
+ (if (not edwin-editor)
(edwin-reset))
- (with-editor-input-port (edwin-get-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)
+ (with-editor-input-port edwin-input-port
+ (lambda ()
+ (with-editor-interrupts
+ (lambda ()
+ (within-editor edwin-editor
+ (lambda ()
+ (perform-buffer-initializations! (current-buffer))
+ (update-screens! true)
+ (if edwin-initialization (edwin-initialization))
+ (let ((message (cmdl-message/null)))
+ (push-cmdl (lambda (cmdl)
+ cmdl ;ignore
+ (top-level-command-reader)
+ message)
+ false
+ message))))))))
+ (if edwin-finalization (edwin-finalization))
+ unspecific)
+
+;; Set this before entering the editor to get something done after the
+;; editor's dynamic environment is initialized, but before the command
+;; loop is started. [Should this bind the ^G interrupt also? -- CPH](define edwin-initialization false)
+
+;; Set this while in the editor to get something done after leaving
+;; the editor's dynamic environment; for example, this can be used to
+;; reset and then reenter the editor.
+(define edwin-finalization false)
(define (within-editor editor thunk)
(call-with-current-continuation
(lambda (continuation)
(fluid-let ((editor-continuation continuation)
- (recursive-edit-continuation #!FALSE)
+ (recursive-edit-continuation false)
(recursive-edit-level 0)
(current-editor editor)
- (saved-error-hook (access *error-hook* error-system)))
+ (*auto-save-keystroke-count* 0))
(thunk)))))
+(define editor-continuation)
+(define recursive-edit-continuation)
+(define recursive-edit-level)
+(define current-editor)
+\f
(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!))))))
+ (let ((recursive-edit-event!
+ (lambda ()
+ (for-each (lambda (window)
+ (window-modeline-event! window
+ 'RECURSIVE-EDIT))
+ (window-list)))))
+ (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)))
+ (begin
+ (reset-command-prompt!)
+ value))))
(define (exit-recursive-edit value)
(if recursive-edit-continuation
(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:
+(define *^G-interrupt-continuations*
+ '())
+
+(define (^G-signal)
+ (let ((continuations *^G-interrupt-continuations*))
+ (if (pair? continuations)
+ ((car continuations))
+ (error "can't signal ^G interrupt"))))
+
+(define (intercept-^G-interrupts interceptor thunk)
+ (let ((signal-tag "signal-tag"))
+ (let ((value
+ (call-with-current-continuation
+ (lambda (continuation)
+ (fluid-let ((*^G-interrupt-continuations*
+ (cons (lambda () (continuation signal-tag))
+ *^G-interrupt-continuations*)))
+ (thunk))))))
+ (if (eq? value signal-tag)
+ (interceptor)
+ value))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edtfrm.scm,v 1.73 1989/03/14 08:00:30 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Editor Frame
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
;;; Editor Frame
(define-class editor-frame vanilla-window
- (root-inferior typein-inferior selected-window cursor-window select-time))
+ (screen
+ 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
+(define (make-editor-frame root-screen main-buffer typein-buffer)
+ (let ((window (make-object editor-frame)))
+ (with-instance-variables editor-frame
+ window
+ (root-screen main-buffer typein-buffer)
+ (set! superior false)
+ (set! x-size (screen-x-size root-screen))
+ (set! y-size (screen-y-size root-screen))
+ (set! redisplay-flags (list false))
+ (set! inferiors '())
+ (let ((main-window (make-buffer-frame window main-buffer true))
+ (typein-window (make-buffer-frame window typein-buffer false)))
+ (set! screen root-screen)
(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)
+ (set! select-time 2)
+ (set-window-select-time! main-window 1)
+ (=> (window-cursor main-window) :enable!))
+ (set-editor-frame-size! window x-size y-size))
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-method editor-frame (:update-root-display! window display-style)
+ (with-instance-variables editor-frame window (display-style)
+ (with-screen-in-update! screen
+ (lambda ()
+ (if (and (or display-style (car redisplay-flags))
+ (update-inferiors! window screen 0 0
+ 0 x-size 0 y-size
+ display-style))
+ (set-car! redisplay-flags false))))))
+
+(define (set-editor-frame-size! window x y)
+ (with-instance-variables editor-frame 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-method editor-frame :set-size!
+ set-editor-frame-size!)
(define typein-y-size 1)
(define-method editor-frame (:new-root-window! window window*)
- (set! root-inferior (find-inferior inferiors window*)))
+ (set! root-inferior (find-inferior inferiors window*))
+ unspecific)
\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-integrable (editor-frame-window0 window)
+ (with-instance-variables editor-frame window ()
+ (window0 (inferior-window root-inferior))))
-(define-procedure editor-frame (editor-frame-selected-window window)
- selected-window)
+(define-integrable (editor-frame-typein-window window)
+ (with-instance-variables editor-frame window ()
+ (inferior-window typein-inferior)))
-(define-procedure editor-frame (editor-frame-cursor-window window)
- cursor-window)
+(define-integrable (editor-frame-selected-window window)
+ (with-instance-variables editor-frame window ()
+ selected-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-integrable (editor-frame-cursor-window window)
+ (with-instance-variables editor-frame window ()
+ cursor-window))
-(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!))
+(define (editor-frame-select-window! window window*)
+ (with-instance-variables editor-frame 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!)))
-;;; end USING-SYNTAX
-)
\ No newline at end of file
+(define (editor-frame-select-cursor! window window*)
+ (with-instance-variables editor-frame 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!)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.11 1989/03/14 08:00:33 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Evaluation Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-variable "Scheme Environment"
"The environment used by the evaluation commands, or 'DEFAULT.
(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 Environment")
+ "Sets the environment for the editor and any inferior REP loops."
+ (set-repl/environment! (nearest-repl)
+ (->environment
+ (prompt-for-expression-value
+ "REP environment"
+ (ref-variable "Previous Evaluation Environment")))))
-(define-command ("Set Syntax Table" argument)
+(define-command ("Set Syntax Table")
"Sets the current syntax table (for the syntaxer, not the editor)."
- (set-rep-base-syntax-table!
- (prompt-for-expression-value "Set Syntax Table" false)))
+ (set-repl/syntax-table! (nearest-repl)
+ (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 (eval-with-history expression environment)
(let ((scode (syntax expression (evaluation-syntax-table))))
- (with-new-history
- (lambda ()
- (scode-eval scode environment)))))
-
+ (bind-condition-handler '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (editor-error "Error while evaluating expression")))
+ (lambda ()
+ (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
+ default-string
+ (if (default-object? default-type)
+ 'VISIBLE-DEFAULT
+ default-type)
false 'NO-COMPLETION
prompt-for-expression-mode))
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)))
+\\[^R Yank Default String] yanks the default string, if there is one.")
(define-key "Prompt for Expression" #\Return "^R Terminate Input")
(define-key "Prompt for Expression" #\C-M-Y "^R Yank Default String")
(define (evaluation-syntax-table)
(or (ref-variable "Scheme Syntax Table")
- (rep-syntax-table)))
+ (nearest-repl/syntax-table)))
(define (evaluation-environment argument)
(cond (argument
"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"))))
+ (->environment (eval (with-input-from-string string read)
+ (evaluation-environment false)))))
+ ((eq? 'DEFAULT (ref-variable "Scheme Environment"))
+ (nearest-repl/environment))
+ (else
+ (->environment (ref-variable "Scheme Environment")))))
\f
;;;; Transcript Buffer
(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:
+ (output-port/copy transcript-output-port-template (transcript-buffer)))
+
+(define (operation/write-char port char)
+ (region-insert-char! (buffer-end (output-port/state port)) char))
+
+(define (operation/write-string port string)
+ (region-insert-string! (buffer-end (output-port/state port)) string))
+
+(define (operation/flush-output port)
+ (let ((buffer (output-port/state port)))
+ (let ((end (buffer-end buffer)))
+ (for-each (lambda (window)
+ (set-window-point! window end)
+ (window-direct-update! window false))
+ (buffer-windows buffer)))))
+
+(define (operation/print-self state port)
+ (unparse-string state "to transcript buffer ")
+ (unparse-object state (output-port/state port)))
+
+(define transcript-output-port-template
+ (make-output-port `((FLUSH-OUTPUT ,operation/flush-output)
+ (PRINT-SELF ,operation/print-self)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-STRING ,operation/write-string))
+ false))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.130 1989/03/14 08:00:36 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; File Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Toggle Read Only" argument)
+(define-command ("Toggle Read Only")
"Change whether this buffer is visiting its file read-only."
(let ((buffer (current-buffer)))
((if (buffer-writeable? buffer)
set-buffer-writeable!)
buffer)))
-(define-command ("Find File" argument)
+(define-command ("Find File")
"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)
+(define-command ("Find File Other Window")
"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)
+(define-command ("^R Find Alternate File")
"Find a file in its own buffer, killing the current buffer.
Like \\[Kill Buffer] followed by \\[Find File]."
(let ((buffer (current-buffer)))
(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)))
+ "Save current buffer in visited file if modified. Versions described below.
+
+By default, makes the previous version into a backup file
+ if previously requested or if this is the first save.
+With 1 or 3 \\[^R Universal Argument]'s, marks this version
+ to become a backup when the next save is done.
+With 2 or 3 \\[^R Universal Argument]'s,
+ unconditionally makes the previous version into a backup file.
+With argument of 0, never makes the previous version into a backup file.
+
+If a file's name is FOO, the names of its numbered backup versions are
+ FOO.~i~ for various integers i. A non-numbered backup file is called FOO~.
+Numeric backups (rather than FOO~) will be made if value of
+ `Version Control' is not the atom `never' and either there are already
+ numeric versions of the file being backed up, or `Version Control' is
+ not #F.
+We don't want excessive versions piling up, so there are variables
+ `Kept Old Versions', which tells Edwin how many oldest versions to keep,
+ and `Kept New Versions', which tells how many newest versions to keep.
+ Defaults are 2 old versions and 2 new.
+If `Trim Versions Without Asking' is false, system will query user
+ before trimming versions. Otherwise it does it silently."
+ (let ((do-it (lambda () (save-file (current-buffer)))))
+ (if (eqv? argument 0)
+ (fluid-let (((ref-variable "Make Backup Files") false))
+ (do-it))
+ (do-it))))
(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))
+ (let ((exponent (command-argument-multiplier-only?)))
+ (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)))
+ (if (memv exponent '(2 3)) (set-buffer-backed-up?! buffer false))
+ (write-buffer-interactive buffer)
+ (if (memv exponent '(1 3)) (set-buffer-backed-up?! buffer false)))
(temporary-message "(No changes need to be written)")))
(define-command ("Save Some Buffers" argument)
(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)
(temporary-message "(No buffers need saving)")
(for-each (lambda (buffer)
(save-buffer-prepare-version buffer)
- (if (or no-confirmation?
+ (if (or (and (not (default-object? no-confirmation?))
+ no-confirmation?)
(prompt-for-confirmation?
(string-append
"Save file '"
"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)))))
+ (set-visited-pathname
+ (current-buffer)
+ (and (not argument)
+ (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)
+ (set-buffer-truename! buffer false)
(if pathname
(begin (let ((name (pathname->buffer-name pathname)))
(if (not (find-buffer name))
(buffer-modified! buffer))
(disable-buffer-auto-save! buffer)))
-(define-command ("Write File" argument)
+(define-command ("Write File")
"Store buffer in specified file.
This file becomes the one being visited."
(write-file (current-buffer)
(set-visited-pathname buffer pathname)
(write-buffer-interactive buffer))
-(define-command ("Write Region" argument)
+(define-command ("Write Region")
"Store the region in specified file."
(write-region (current-region)
(prompt-for-pathname "Write Region"
(define-variable "Previous Inserted File"
"Pathname of the file that was most recently inserted."
- #!FALSE)
+ false)
-(define-command ("Insert File" argument)
+(define-command ("Insert File")
"Insert contents of file into existing text.
Leaves point at the beginning, mark at the end."
(let ((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))))))))
+ (revert-buffer (current-buffer) argument false))
+
+(define (revert-buffer buffer argument dont-confirm?)
+ (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD)))
+ (if method
+ (method argument)
+ (let ((pathname (buffer-pathname buffer)))
+ (cond ((not pathname)
+ (editor-error
+ "Buffer does not seem to be associated with any file"))
+ ((not (file-exists? pathname))
+ (editor-error "File "
+ (pathname-name-string pathname)
+ " no longer exists!"))
+ ((or dont-confirm?
+ (prompt-for-yes-or-no?
+ (string-append "Revert buffer from file "
+ (pathname-name-string pathname))))
+ (let ((where (mark-index (buffer-point buffer))))
+ (read-buffer buffer pathname)
+ (set-current-point!
+ (mark+ (buffer-start buffer) where 'LIMIT)))))))))
\f
-(define-command ("Copy File" argument)
+(define-command ("Copy File")
"Copy a file; the old and new names are read in the typein window.
If a file with the new name already exists, confirmation is requested first."
(let ((old (prompt-for-input-truename "Copy File"
(message "Copied '" (pathname->string old)
"' => '" (pathname->string new) "'"))))))
-(define-command ("Rename File" argument)
+(define-command ("Rename File")
"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"
(begin (delete-file new) (do-it)))
(do-it)))))
-(define-command ("Delete File" argument)
+(define-command ("Delete File")
"Delete a file; the name is read in the typein window."
(let ((old (prompt-for-input-truename "Delete File"
(buffer-pathname (current-buffer)))))
\f
;;;; Printer Support
-(define-command ("Print File" argument)
+(define-command ("Print File")
"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)
+(define-command ("Print Buffer")
"Print the current buffer on the local printer."
(print-region (buffer-region (current-buffer))))
-(define-command ("Print Page" argument)
+(define-command ("Print Page")
"Print the current page on the local printer."
(print-region (page-interior-region (current-point))))
-(define-command ("Print Region" argument)
+(define-command ("Print Region")
"Print the current region on the local printer."
(print-region (current-region)))
(define translate-file
(make-primitive-procedure 'TRANSLATE-FILE))
-|#
+|#
\f
;;;; Supporting Stuff
(define *default-pathname*)
-(define-command ("^R Complete Filename" argument)
+(define-command ("^R Complete Filename")
"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)
+ (let ((region (buffer-region (current-buffer))))
+ (let ((string (region->string region)))
+ (if (string-null? string)
+ (insert-string
+ (pathname->string
+ (or (pathname->input-truename *default-pathname*)
+ *default-pathname*)))
+ (complete-pathname (prompt-string->pathname string)
+ *default-pathname*
+ (lambda (pathname)
+ (region-delete! region)
+ (insert-string (pathname->string pathname)))
+ (lambda (string start end)
+ (region-delete! region)
+ (insert-string (substring string start end)))
+ editor-beep)))))
+
+(define-command ("^R List Filename Completions")
"List the possible completions for the filename being input."
- ((access list-completions prompt-package)
+ (list-completions
(map pathname->string
(pathname-completions
- (string->pathname (region->string (buffer-region (current-buffer))))
+ (prompt-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))
+ (pathname->string
+ (make-pathname false false false
+ (pathname-name pathname)
+ (pathname-type pathname)
+ false)))
+
+(define-integrable (prompt-string->pathname string)
+ (string->pathname (os/trim-pathname-string string)))
\f
;;;; Prompting
(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*))))))
+ (let ((default
+ (or (and (not (default-object? default)) default)
+ (current-default-pathname))))
+ (prompt-string->pathname
+ (fluid-let ((*default-pathname* default))
+ (prompt-for-completed-string prompt
+ (pathname-directory-string default)
+ 'INSERTED-DEFAULT
+ false
+ 'NO-COMPLETION
+ prompt-for-pathname-mode)))))
\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 (current-default-pathname)
+ (newest-pathname (buffer-pathname (current-buffer))))
-(define-variable "Default Pathname"
- "Pathname to use for default when no other is available"
- (string->pathname "FOO.SCM.0"))
+(define (newest-pathname pathname)
+ (pathname-new-version (or pathname (working-directory-pathname))
+ (and pathname-newest 'NEWEST)))
(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)
+\\[^R Yank Default String] will insert the default (if there is one.)")
(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:
+(define-key "Prompt for Pathname" #\? "^R List Filename Completions")
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.86 1989/03/14 08:00:41 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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)))
+ (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-truename! buffer truename)
+ (set-buffer-modification-time! buffer (file-modification-time truename))
+ (if (not (file-writable? truename))
+ (set-buffer-file-read-only! buffer)))
(set-buffer-pathname! buffer pathname)
(setup-buffer-auto-save! buffer)
(set-buffer-save-length! buffer)
(let ((truename (pathname->input-truename pathname)))
(if truename
(region-insert! mark (file->region-interactive truename))
- (editor-error "File '" (pathname->string pathname) "' not found"))))
+ (editor-error "File \"" (pathname->string pathname) "\" not found"))))
(define (file->region-interactive truename)
(let ((filename (pathname->string truename)))
- (temporary-message "Reading file '" filename "'")
+ (temporary-message "Reading file \"" filename "\"")
(let ((region (file->region truename)))
(append-message " -- done")
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)))))
+ (let ((rest->string (input-port/operation port 'REST->STRING)))
+ (if rest->string
+ (rest->string port)
+ (read-string char-set:null port))))))
\f
;;;; Buffer Mode Initialization
(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 (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))
+ (let ((prefix? (not (string-null? prefix)))
(suffix? (not (string-null? suffix))))
(define (loop mark)
(let ((start (line-start mark 1)))
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))))))))
+ (bind-condition-handler '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ (begin
+ (editor-beep)
+ (message "Error while processing local variable: "
+ var)
+ (continuation false))))
+ (lambda ()
+ (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-variable "Make Backup Files"
+ "*Create a backup of each file when it is saved for the first time.
+This can be done by renaming the file or by copying.
+
+Renaming means that Edwin renames the existing file so that it is a
+backup file, then writes the buffer into a new file. Any other names
+that the old file had will now refer to the backup file.
+The new file is owned by you and its group is defaulted.
+
+Copying means that Edwin copies the existing file into the backup
+file, then writes the buffer on top of the existing file. Any other
+names that the old file had will now refer to the new (edited) file.
+The file's owner and group are unchanged.
+
+The choice of renaming or copying is controlled by the variables
+Backup By Copying, Backup By Copying When Linked and
+Backup By Copying When Mismatch."
+ true)
+
+(define-variable "Backup By Copying"
+ "*True means always use copying to create backup files.
+See documentation of variable Make Backup Files."
+ false)
+
+(define-variable "Trim Versions Without Asking"
+ "*If true, deletes excess backup versions silently.
+Otherwise asks confirmation."
+ false)
+\f
+(define (write-buffer-interactive buffer)
+ ;; Need to check for correct modification time here.
+ (let ((truename (pathname->output-truename (buffer-pathname buffer))))
+ (let ((writable? (file-writable? truename)))
+ (if (or writable?
+ (prompt-for-yes-or-no?
+ (string-append "File \""
+ (pathname-name-string truename)
+ "\" is write-protected; try to save anyway"))
+ (editor-error
+ "Attempt to save to a file which you aren't allowed to write"))
+ (begin
+ (if (not (or (verify-visited-file-modification-time buffer)
+ (not (file-exists? truename))
+ (prompt-for-yes-or-no?
+ "Disk file has changed since visited or saved. Save anyway")))
+ (editor-error "Save not confirmed"))
+ (let ((modes
+ (and (not (buffer-backed-up? buffer))
+ (backup-buffer! buffer truename))))
+ (require-newline buffer)
+ (if (not (or writable? modes))
+ (begin
+ (set! modes (file-modes truename))
+ (set-file-modes! truename #o777)))
+ (write-buffer buffer)
+ (if modes
+ (bind-condition-handler '()
+ (lambda (condition)
+ (and (not (condition/internal? condition))
+ (error? condition)
+ ((condition/continuation condition) unspecific)))
+ (lambda ()
+ (set-file-modes! truename modes))))))))))
+
+(define (verify-visited-file-modification-time buffer)
+ (let ((truename (buffer-truename buffer))
+ (modification-time (buffer-modification-time buffer)))
+ (or (not truename)
+ (not modification-time)
+ (let ((new-time (file-modification-time truename)))
+ (and new-time
+ (or (= modification-time new-time)
+ (and (positive? modification-time)
+ (positive? new-time)
+ (= 1 (abs (- modification-time new-time))))))))))
(define (write-buffer buffer)
- (let ((truename (write-region (buffer-unclipped-region buffer)
- (buffer-pathname 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
+ (begin
+ (set-buffer-truename! buffer truename)
+ (delete-auto-save-file! buffer)
+ (set-buffer-save-length! buffer)
+ (buffer-not-modified! buffer)
+ (set-buffer-modification-time! buffer
+ (file-modification-time truename))))))
+
(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)))))
+ (temporary-message "Writing file \"" (pathname->string truename) "\"")
+ (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:
+ (write-string (region->string region) port))))
+\f
+(define (require-newline buffer)
+ (let ((require-final-newline? (ref-variable "Require Final Newline")))
+ (if require-final-newline?
+ (without-group-clipped! (buffer-group buffer)
+ (lambda ()
+ (let ((end (buffer-end buffer)))
+ (if (let ((last-char (extract-left-char end)))
+ (and last-char
+ (not (eqv? #\newline last-char))
+ (or (eq? 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 (backup-buffer! buffer truename)
+ (let (;; This isn't the correct set of types, but it will do for now.
+ (error-types (list (microcode-error-type 'EXTERNAL-RETURN)))
+ (continue-with-false
+ (lambda (condition) ((condition/continuation condition) false))))
+ (and truename
+ (ref-variable "Make Backup Files")
+ (not (buffer-backed-up? buffer))
+ (file-exists? truename)
+ (os/backup-buffer? truename)
+ (bind-condition-handler error-types continue-with-false
+ (lambda ()
+ (with-values (lambda () (os/buffer-backup-pathname truename))
+ (lambda (backup-pathname targets)
+ (let ((modes
+ (bind-condition-handler error-types
+ (lambda (condition)
+ (let ((filename (os/default-backup-filename)))
+ (temporary-message
+ "Cannot write backup file; backing up in \""
+ filename
+ "\"")
+ (copy-file truename
+ (string->pathname filename))
+ (continue-with-false condition)))
+ (lambda ()
+ (if (or (file-symbolic-link? truename)
+ (ref-variable "Backup By Copying")
+ (os/backup-by-copying? truename))
+ (begin
+ (copy-file truename backup-pathname)
+ false)
+ (begin
+ (bind-condition-handler error-types
+ continue-with-false
+ (lambda ()
+ (delete-file backup-pathname)))
+ (rename-file truename backup-pathname)
+ (file-modes backup-pathname)))))))
+ (set-buffer-backed-up?! buffer true)
+ (if (and (not (null? targets))
+ (or (ref-variable "Trim Versions Without Asking")
+ (prompt-for-confirmation?
+ (string-append
+ "Delete excess backup versions of "
+ (pathname->string
+ (buffer-pathname buffer))))))
+ (for-each (lambda (target)
+ (bind-condition-handler error-types
+ continue-with-false
+ (lambda ()
+ (delete-file target))))
+ targets))
+ modes))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fill.scm,v 1.41 1989/03/14 08:00:45 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Text Fill Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("^R Fill Paragraph" argument)
+(define-command ("^R Fill Paragraph")
"Fill this (or next) paragraph.
Point stays the same."
(fill-region (paragraph-text-region (current-point))))
-(define-command ("^R Fill Region" argument)
+(define-command ("^R Fill Region")
"Fill text from point to mark."
(fill-region (current-region)))
(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)
+ "String for Auto Fill to insert at start of new line, or #F."
+ false)
-(define-command ("^R Set Fill Prefix" argument)
+(define-command ("^R Set Fill Prefix")
"Set fill prefix to text between point and start of line."
(if (line-start? (current-point))
- (begin (local-set-variable! "Fill Prefix" #!FALSE)
+ (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)
(re-match-end 0))
((char-search-forward #\Space target)
(re-match-start 0))
- (else #!FALSE))))
+ (else false))))
(if end
(let ((start (mark-left-inserting end)))
(delete-horizontal-space start)
(fill-region-loop start)))))))))
(define (canonicalize-sentence-endings mark)
- (let ((ending (forward-sentence mark 1 #!FALSE)))
+ (let ((ending (forward-sentence mark 1 false)))
(if (and ending (not (group-end? ending)))
- (if (char=? char:newline (mark-right-char ending))
+ (if (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)
+ (if (char-search-forward #\newline mark)
(let ((mark (mark-left-inserting (re-match-start 0))))
(replace-next-char mark #\Space)
(remove-fill-prefix mark)
(^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")
(and (> (mark-column point) (ref-variable "Fill Column"))
(line-end? (horizontal-space-end point))))
\f
-(define-command ("^R Center Line" argument)
+(define-command ("^R Center Line")
"Center this line's text within the line.
The width is Fill Column."
(center-line (current-point)))
(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:
+ (line-start mark 0)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.85 1989/03/14 08:00:50 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Help Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("^R Help Prefix" argument)
+(define-command ("^R Help Prefix")
"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")))
+ (let ((char (prompt-for-char "A C D I K L M T V W or C-h for more help")))
(dispatch-on-char
- (current-comtab)
+ (current-comtabs)
(list #\Backspace
(if (or (char=? char #\Backspace)
(char=? char #\?))
(scroll-window window
(standard-scroll-window-argument
window false 1)
- beep)
+ editor-beep)
(loop))
((or (char=? char #\Rubout)
(char=? char #\M-V))
(scroll-window window
(standard-scroll-window-argument
window false -1)
- beep)
+ editor-beep)
(loop))
(else char))))
(loop)))
\f
;;;; Commands and Keys
-(define-command ("Command Apropos" argument)
+(define-command ("Command Apropos")
"Prompts for a string, lists all commands containing it."
- (let ((string (or (prompt-for-string "Command apropos" #!FALSE) "")))
+ (let ((string (or (prompt-for-string "Command apropos" false) "")))
(with-output-to-help-display
(lambda ()
(for-each (lambda (command)
(print-short-description (command-description command)))
(string-table-apropos editor-commands string))))))
-(define-command ("Describe Command" argument)
+(define-command ("Describe Command")
"Prompts for a command, and describes it.
Prints the full documentation for the given command."
(let ((command (prompt-for-command "Describe Command")))
(print-key-bindings command)
(write-description (command-description command))))))
-(define-command ("Where Is" argument)
+(define-command ("Where Is")
"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)))
+ (let ((bindings (comtab-key-bindings (current-comtabs) 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)
+(define-command ("Describe Key Briefly")
"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)))
+ (let ((char (prompt-for-key "Describe key briefly" (current-comtabs))))
+ (let ((command (comtab-entry (current-comtabs) char)))
(if (eq? command (name->command "^R Bad Command"))
(help-describe-unbound-key char)
(message (xchar->name char)
(command-name command)
"\"")))))
-(define-command ("Describe Key" argument)
+(define-command ("Describe Key")
"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)))
+ (let ((char (prompt-for-key "Describe key" (current-comtabs))))
+ (let ((command (comtab-entry (current-comtabs) char)))
(if (eq? command (name->command "^R Bad Command"))
(help-describe-unbound-key char)
(with-output-to-help-display
\f
;;;; Variables
-(define-command ("Variable Apropos" argument)
+(define-command ("Variable Apropos")
"Prompts for a string, lists all variables containing it."
- (let ((string (or (prompt-for-string "Variable apropos" #!FALSE) "")))
+ (let ((string (or (prompt-for-string "Variable apropos" false) "")))
(with-output-to-help-display
(lambda ()
(for-each (lambda (variable)
(print-short-description (variable-description variable)))
(string-table-apropos editor-variables string))))))
-(define-command ("Describe Variable" argument)
+(define-command ("Describe Variable")
"Prompts for a variable, and describes it.
Prints the full documentation for the given variable."
(let ((variable (prompt-for-variable "Describe Variable")))
(write-to-string (variable-ref variable))))
(else argument)))))
-(define-command ("Kill Local Variable" argument)
+(define-command ("Kill Local Variable")
"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)
+(define-command ("View Lossage")
"Print the keyboard history."
(with-output-to-help-display
(lambda ()
(for-each (lambda (char)
- (write-string (string-append (char->name char) " ")))
+ (write-string (string-append (char-name char) " ")))
(reverse (ring-list (current-char-history)))))))
-(define-command ("Describe Mode" argument)
+(define-command ("Describe Mode")
"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)
+(define-command ("Teach Emacs")
"Visit the Emacs learn-by-doing tutorial."
(delete-other-windows (current-window))
(let ((pathname (string->pathname "*TUTORIAL")))
(write-string (substitute-command-keys description)))
(define (print-key-bindings command)
- (let ((bindings (comtab-key-bindings (current-comtab) command)))
+ (let ((bindings (comtab-key-bindings (current-comtabs) command)))
(if (not (null? bindings))
(begin (write-string " which is bound to: ")
(write-string (char-list-string bindings))
(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)))))
+ (cond ((variable-unbound? variable)
+ (write-string "unbound"))
+ ((variable-unassigned? variable)
+ (write-string "unassigned"))
+ (else
+ (write-string "bound to: ")
+ (write (variable-ref variable))))
(newline))
(define (print-short-description description)
(newline))
(define (string-first-line string)
- (let ((index (string-find-next-char string char:newline)))
+ (let ((index (string-find-next-char string #\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)))
+ (let ((start (if (default-object? start) 0 start))
+ (end (if (default-object? end) (string-length string) end)))
+
+ (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)))
+ (let ((bindings (comtab-key-bindings (current-comtabs) 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:
+ (xchar->name (car bindings)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/image.scm,v 1.122 1989/03/14 08:00:53 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;; *** 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.
+;;; such a string will be represented by the string "^N" (or perhaps
+;;; "^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.
;;; [] The association of string indices and image columns is very
;;; straightforward.
-\f
+
+(define-structure (image (type vector) (constructor false))
+ (string false read-only true)
+ (parse false read-only true)
+ (column-size false read-only true))
+
+(define (make-null-image)
+ (vector "" '() 0))
+
(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-integrable (image-index-size image)
+ (string-length (image-string image)))
(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))))
+ (vector-set! image 2 (1+ (vector-ref image 2)))
+ unspecific)
(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)))
-
+ (vector-set! image 2 (+ (vector-ref image 2) (- end start)))
+ unspecific)
+\f
(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)
+ (let loop ((parse (image-parse image)) (string-start 0) (result-start 0))
(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))))
+ (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)
(+ 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)
+ (let loop ((parse (image-parse image)) (start 0) (column 0))
(cond ((null? parse)
(+ column (- index start)))
((string? (car parse))
(car parse)
(+ column (- (car parse) start)))))
(else
- (error "Bad parse element" (car parse)))))
-
- (loop (image-parse image) 0 0))
+ (error "Bad parse element" (car parse))))))
(define (image-column->index image column)
- (define (loop parse start c)
+ (let loop ((parse (image-parse image)) (start 0) (c 0))
(cond ((null? parse)
(+ start (- column c)))
((string? (car parse))
(+ start (- column c))
(loop (cdr parse) (car parse) new-c))))
(else
- (error "Bad parse element" (car parse)))))
-
- (loop (image-parse image) 0 0))
+ (error "Bad parse element" (car parse))))))
\f
;;;; Parsing
(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)))
+ char-set:not-graphic)))
(if (not index)
(receiver '() (+ column (- end start)))
(let ((column (+ column (- index start))))
(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)))
+ char-set:not-graphic)))
(if (not index)
(+ c (- end i))
(let ((c (+ c (- index i))))
column #!optional if-lose)
(define (loop i c left)
(let ((index (substring-find-next-char-in-set string i end
- non-graphic-chars)))
+ char-set:not-graphic)))
(if (not index)
(let ((n (- end i)))
- (cond ((<= left n) (+ left i))
- ((unassigned? if-lose) end)
+ (cond ((<= left n) (+ i left))
+ ((default-object? if-lose) end)
(else (if-lose (+ c n)))))
(let ((n (- index i)))
(if (<= left n)
- (+ left i)
- (let ((left (- left n))
- (c (+ c n)))
+ (+ i left)
+ (let ((c (+ c n)) (left (- left n)))
(let ((n (string-length (char-rep string index c))))
(cond ((< left n) index)
((= left n) (1+ index))
start
(loop start start-column (- column start-column)))))
\f
-(declare (integrate char-rep))
-(define (char-rep string index column)
- (declare (integrate string index column))
+(define-integrable (char-rep string index column)
(char-representation (string-ref string index) column))
(set! char-representation
(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
#(" " " " " " " " " " " " " " " "))
"@" "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" "{" "|" "}" "~" "^?"))
+ "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "{" "|" "}" "~" "^?"
+ "\200" "\201" "\202" "\203" "\204" "\205" "\206" "\207"
+ "\210" "\211" "\212" "\213" "\214" "\215" "\216" "\217"
+ "\220" "\221" "\222" "\223" "\224" "\225" "\226" "\227"
+ "\230" "\231" "\232" "\233" "\234" "\235" "\236" "\237"
+ "\240" "\241" "\242" "\243" "\244" "\245" "\246" "\247"
+ "\250" "\251" "\252" "\253" "\254" "\255" "\256" "\257"
+ "\260" "\261" "\262" "\263" "\264" "\265" "\266" "\267"
+ "\270" "\271" "\272" "\273" "\274" "\275" "\276" "\277"
+ "\300" "\301" "\302" "\303" "\304" "\305" "\306" "\307"
+ "\310" "\311" "\312" "\313" "\314" "\315" "\316" "\317"
+ "\320" "\321" "\322" "\323" "\324" "\325" "\326" "\327"
+ "\330" "\331" "\332" "\333" "\334" "\335" "\336" "\337"
+ "\340" "\341" "\342" "\343" "\344" "\345" "\346" "\347"
+ "\350" "\351" "\352" "\353" "\354" "\355" "\356" "\357"
+ "\360" "\361" "\362" "\363" "\364" "\365" "\366" "\367"
+ "\370" "\371" "\372" "\373" "\374" "\375" "\376" "\377"))
)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.88 1989/03/14 08:00:57 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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 current-file false)
+(define current-node false)
(define-major-mode "Info" "Fundamental"
"Info mode provides commands for browsing through the Info documentation tree.
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)
+ (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)
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)))
+ (ref-variable "Page Delimiter"))))
(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)
+(define-command ("^R Info Edit")
"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"))
(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)
+(define-command ("^R Info Cease Edit")
"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)
+(define-command ("Info")
"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)
+ (begin (set! current-file false)
+ (set! current-node false)
(set! history '())
(^r-info-directory-command)))))
-(define-command ("^R Info Directory" argument)
+(define-command ("^R Info Directory")
"Go to the Info directory node."
(find-node "dir" "Top"))
-(define-command ("^R Info Help" argument)
+(define-command ("^R Info Help")
"Enter the Info tutorial."
(find-node "info"
(if (< (window-y-size (current-window)) 23)
"Help-Small-Screen"
"Help")))
-(define-command ("^R Info Next" argument)
+(define-command ("^R Info Next")
"Go to the next node of this node."
(follow-pointer extract-node-next "Next"))
-(define-command ("^R Info Previous" argument)
+(define-command ("^R Info Previous")
"Go to the previous node of this node."
(follow-pointer extract-node-previous "Previous"))
-(define-command ("^R Info Up" argument)
+(define-command ("^R Info Up")
"Go to the superior node of this node."
(follow-pointer extract-node-up "Up"))
(goto-node (or (extractor (buffer-start (current-buffer)))
(editor-error "Node has no " name))))
-(define-command ("^R Info Last" argument)
+(define-command ("^R Info Last")
"Go back to the last node visited."
(if (null? history)
(editor-error "This is the first Info node you have looked at"))
(mark+ (region-start (buffer-unclipped-region (current-buffer)))
(vector-ref entry 2)))))
-(define-command ("^R Info Exit" argument)
+(define-command ("^R Info Exit")
"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)
+(define-command ("^R Info Goto Node")
"Go to Info node of given name. Give just NODENAME or (FILENAME)NODENAME."
- (goto-node (prompt-for-string "Goto node" #!FALSE)))
+ (goto-node (prompt-for-string "Goto node" false)))
-(define-command ("^R Info Search" argument)
+(define-command ("^R Info Search")
"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")))
(select-node buffer mark))
(editor-failure)))))
-(define-command ("^R Info Summary" argument)
+(define-command ("^R Info Summary")
"Display a brief summary of all Info commands."
(let ((buffer (temporary-buffer "*Help*")))
(with-output-to-mark (buffer-point buffer)
(buffer-not-modified! buffer)
(with-selected-buffer buffer
(lambda ()
- (define (loop)
- (update-alpha-window! #!FALSE)
+ (let loop ()
+ (update-screens! 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)))
+ (let ((char (keyboard-peek-char)))
(if (char=? char #\Space)
- (begin (keyboard-read-char)
- (if (not end-visible?)
- (begin (^r-next-screen-command)
- (loop))))))))
- (loop)
+ (begin
+ (keyboard-read-char)
+ (if (not end-visible?)
+ (begin
+ (^r-next-screen-command)
+ (loop))))))))
(clear-message)))))
\f
;;;; Menus
-(define-command ("^R Info Menu" argument)
+(define-command ("^R Info Menu")
"Go to node for menu item of given name."
(let ((menu (find-menu)))
(if (not menu)
(goto-node (prompt-for-alist-value "Menu item"
(collect-menu-items menu))))))
-(define-command ("^R Info First Menu Item" argument)
+(define-command ("^R Info First Menu Item")
"Go to the node of the first menu item."
(nth-menu-item 0))
-(define-command ("^R Info Second Menu Item" argument)
+(define-command ("^R Info Second Menu Item")
"Go to the node of the second menu item."
(nth-menu-item 1))
-(define-command ("^R Info Third Menu Item" argument)
+(define-command ("^R Info Third Menu Item")
"Go to the node of the third menu item."
(nth-menu-item 2))
-(define-command ("^R Info Fourth Menu Item" argument)
+(define-command ("^R Info Fourth Menu Item")
"Go to the node of the fourth menu item."
(nth-menu-item 3))
-(define-command ("^R Info Fifth Menu Item" argument)
+(define-command ("^R Info Fifth Menu Item")
"Go to the node of the fifth menu item."
(nth-menu-item 4))
\f
;;;; Cross References
-(define-command ("^R Info Follow Reference" argument)
+(define-command ("^R Info Follow Reference")
"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)))))
(define (%cref-item-keyword item colon)
(let ((string (extract-string item colon)))
- (string-replace! string char:newline #\Space)
+ (string-replace! string #\newline #\Space)
(string-trim string)))
(define (cref-item-name item)
\f
;;;; Validation
-(define-command ("Info Validate" argument)
+(define-command ("Info Validate")
"Check that every node pointer points to an existing node."
(let ((nodes (current-nodes-list))
(losers '()))
(receiver filename
(if (string-null? nodename) "Top" nodename)))
(error "PARSE-NODE-NAME: Missing close paren" name)))
- (receiver #!FALSE (if (string-null? name) "Top" name)))))
+ (receiver false (if (string-null? name) "Top" name)))))
(define (record-current-node)
(if current-file
(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)
+ ((char=? (extract-left-char (re-match-start 0)) #\newline)
(mark-1+ (re-match-start 0)))
(else (loop mark)))))
(loop node)))
\f
;;;; Tag Tables
-(define-command ("Info Tagify" argument)
+(define-command ("Info Tagify")
"Create or update tag table of current info file."
(let ((buffer (current-buffer)))
(without-group-clipped! (buffer-group buffer)
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))))))
+ (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"))
(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:
+ (buffer-start buffer))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.77 1989/03/14 08:01:01 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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? delay)
- (char-ready? editor-input-port delay))
-
-(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
#|
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
+abcd Hex Description
+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:
4: clear-message
5: timeout
-Transition table:
+Transition table. Each row is labeled with initial state, each column
+with a transition operation. Each element is the new state for the
+given starting state and transition operation.
012345
0 082300
|#
\f
-(define command-prompt-string false)
-(define command-prompt-displayed? false)
-(define message-string false)
-(define message-should-be-erased? false)
+(define command-prompt-string)
+(define command-prompt-displayed?)
+(define message-string)
+(define message-should-be-erased?)
+
+(define (initialize-typeout!)
+ (set! command-prompt-string false)
+ (set! command-prompt-displayed? false)
+ (set! message-string false)
+ (set! message-should-be-erased? false)
+ unspecific)
-;;; 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!)
+(define (reset-command-prompt!)
+ ;; Should only be called by the command reader. This prevents
+ ;; carryover from one command to the next.
(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)))))
+ (begin
+ (set! command-prompt-displayed? false)
+ (set! message-should-be-erased? true))))
-(set! command-prompt
-(named-lambda (command-prompt)
- (or command-prompt-string "")))
+(define-integrable (command-prompt)
+ (or command-prompt-string ""))
+
+(define (set-command-prompt! string)
+ (if (not (string-null? string))
+ (begin
+ (set! command-prompt-string string)
+ (if command-prompt-displayed?
+ (set-message! string)))))
-(set! set-command-prompt!
-(named-lambda (set-command-prompt! string)
+(define (append-command-prompt! string)
(if (not (string-null? string))
- (begin (set! command-prompt-string string)
- (if command-prompt-displayed?
- ((access set-message! prompt-package) string))))))
+ (set-command-prompt! (string-append (command-prompt) string))))
+
+(define (message . args)
+ (%message (apply string-append args) false))
-(define ((message-writer temporary?) . args)
+(define (temporary-message . args)
+ (%message (apply string-append args) true))
+
+(define (%message string temporary?)
(if command-prompt-displayed?
- (begin (set! command-prompt-string false)
- (set! command-prompt-displayed? false)))
- (set! message-string (apply string-append args))
+ (begin
+ (set! command-prompt-string false)
+ (set! command-prompt-displayed? false)))
+ (set! message-string string)
(set! message-should-be-erased? temporary?)
- ((access set-message! prompt-package) message-string))
+ (set-message! string))
-(set! message (message-writer false))
-(set! temporary-message (message-writer true))
-
-(set! append-message
-(named-lambda (append-message . args)
+(define (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)))
+ (let ((string (string-append message-string (apply string-append args))))
+ (set! message-string string)
+ (set-message! string)))
-(set! clear-message
-(named-lambda (clear-message)
+(define (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))))
+ (clear-message!))
\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))))))
- (let loop ()
- (if (screen-damaged? the-alpha-screen)
- (begin (screen-not-damaged! the-alpha-screen)
- (update-alpha-window! #t)))
- (if (keyboard-active? 50) (read-char) (loop))))))
-
-(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 editor-input-port)
-(define (metafy i)
- (if (>= (remainder i #x4) #x2) i (+ #x2 i)))
+(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-integrable (keyboard-active? delay)
+ (char-ready? editor-input-port delay))
-;;; end USING-SYNTAX
-)
+(define (keyboard-peek-char)
+ (if *executing-keyboard-macro?*
+ (keyboard-macro-peek-char)
+ (begin
+ (read-char-preface)
+ (remap-alias-char (peek-char editor-input-port)))))
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; Scheme Syntax Table: edwin-syntax-table
-;;; Tags Table Pathname: (access edwin-tags-pathname edwin-package)
-;;; End:
+(define (keyboard-read-char)
+ (if *executing-keyboard-macro?*
+ (keyboard-macro-read-char)
+ (begin
+ (read-char-preface)
+ (let ((char (remap-alias-char (read-char editor-input-port))))
+ (set! *auto-save-keystroke-count* (1+ *auto-save-keystroke-count*))
+ (ring-push! (current-char-history) char)
+ (if *defining-keyboard-macro?* (keyboard-macro-write-char char))
+ char))))
+
+(define read-char-timeout/fast 500)
+(define read-char-timeout/slow 2000)
+
+(define-integrable (read-char-preface)
+ (if (not (keyboard-active? 0))
+ (begin
+ (update-screens! false)
+ (if (let ((interval (ref-variable "Auto Save Interval"))
+ (count *auto-save-keystroke-count*))
+ (and (positive? interval)
+ (> count interval)
+ (> count 20)))
+ (begin
+ (do-auto-save)
+ (set! *auto-save-keystroke-count* 0)))))
+ (cond ((within-typein-edit?)
+ (if message-string
+ (begin
+ (keyboard-active?
+ (if message-should-be-erased?
+ read-char-timeout/fast
+ read-char-timeout/slow))
+ (set! message-string false)
+ (set! message-should-be-erased? false)
+ (clear-message!))))
+ ((and (or message-should-be-erased?
+ (and command-prompt-string
+ (not command-prompt-displayed?)))
+ (not (keyboard-active? read-char-timeout/fast)))
+ (set! message-string false)
+ (set! message-should-be-erased? false)
+ (if command-prompt-string
+ (begin
+ (set! command-prompt-displayed? true)
+ (set-message! command-prompt-string))
+ (clear-message!)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/intmod.scm,v 1.30 1989/03/14 08:01:05 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Interaction Mode
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-major-mode "Interaction" "Scheme"
"Major mode for evaluating Scheme expressions interactively.
(local-set-variable! "Scheme Environment"
(ref-variable "Scheme Environment"))
(local-set-variable! "Scheme Syntax-table"
- (ref-variable "Scheme Syntax-table"))
- ((mode-initialization scheme-mode)))
+ (ref-variable "Scheme Syntax-table")))
(define-key "Interaction" #\Return "^R Interaction Execute")
(define-prefix-key "Interaction" #\C-C "^R Prefix Character")
(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)
+(define-command ("Interaction Mode")
"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))))
+ (insert-interaction-prompt false))))
(define (insert-interaction-prompt #!optional newlines?)
- (if (unassigned? newlines?) (set! newlines? #!TRUE))
- (if newlines? (insert-newlines 2))
+ (if (or (default-object? newlines?) newlines?)
+ (insert-newlines 2))
(insert-string "1 ")
(insert-string (ref-variable "Interaction Prompt"))
(insert-string " ")
(dynamic-wind
(lambda () 'DONE)
(lambda ()
- (^G-interceptor (lambda (continuation)
- (lambda (value)
- (newline)
- (write-string "Abort!")
- (continuation 'EXIT)))
+ (intercept-^G-interrupts (lambda ()
+ (newline)
+ (write-string "Abort!"))
(lambda ()
- (let ((environment (evaluation-environment #!FALSE)))
+ (let ((environment (evaluation-environment false)))
(with-output-to-current-point
(lambda ()
(write-line (eval-with-history (with-input-from-mark mark
environment))))))))
insert-interaction-prompt))))
\f
-(define-command ("^R Interaction Refresh" argument)
+(define-command ("^R Interaction Refresh")
"Delete the contents of the buffer, then prompt for input.
Preserves the current `editing area'."
(let ((buffer (current-buffer)))
(extract-string (buffer-get buffer interaction-mode:buffer-mark-tag)
(buffer-end buffer))))
(region-delete! (buffer-region buffer))
- (insert-interaction-prompt #!FALSE)
+ (insert-interaction-prompt false)
(insert-string edit-area))))
(define interaction-mode:yank-command-message
"Yank")
-(define-command ("^R Interaction Yank" argument)
+(define-command ("^R Interaction Yank")
"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)
+(define-command ("^R Interaction Yank Pop")
"Yank the last input expression."
(command-message-receive interaction-mode:yank-command-message
(lambda ()
(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:
+ (editor-error "No previous yank to replace"))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/keymap.scm,v 1.5 1989/03/14 08:01:09 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Command Summary
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Make Command Summary" argument)
+(define-command ("Make Command Summary")
"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))))))
+ (write-keymap
+ ""
+ (comtab-dispatch-alists (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 (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))
+ (char-name (car element))
" ")
(cdr element)))
(sort-by-char (car da))))
(string=? name "^R Autoargument Digit")
(string=? name "^R Autoargument")))))
-(define filter-uninteresting
- (negative-list-transformer uninteresting-element? '()))
+(define (filter-uninteresting items)
+ (list-transform-negative items 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:
+ (char<? (car a) (car b)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kilcom.scm,v 1.56 1989/03/14 08:01:10 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Kill Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define (delete-region mark)
(if (not mark)
(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))
+ (let ((point (if (default-object? point) (current-point) 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)))
+ (let ((point (if (default-object? point) (current-point) point)))
+ (kill-ring-save (extract-string mark point) (mark<= point mark))))
(define (unkill string)
(let ((end (current-point)))
(ring-push! ring string))))
(set-command-message! append-next-kill-tag))
-(define-command ("^R Append Next Kill" argument)
+(define-command ("^R Append Next Kill")
"Cause following command, if kill, to append to previous kill."
(set-command-message! append-next-kill-tag))
\f
(kill-region
(cond ((not argument)
(let ((end (line-end point 0)))
- (if (region-blank? (make-region point end))
+ (if (and (region-blank? (make-region point end))
+ (not (group-end? point)))
(mark1+ end)
end)))
((positive? argument)
\f
;;;; Un/Killing
-(define-command ("^R Kill Region" argument)
+(define-command ("^R Kill Region")
"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)
+(define-command ("^R Copy Region")
"Stick region into kill-ring without killing it.
Like killing and getting back, but doesn't mark buffer modified."
(copy-region (current-mark))
it later will not affect existing buffers."
16)
-(define-command ("^R Set/Pop Mark" argument)
+(define-command ("^R Set/Pop Mark")
"Sets or pops the mark.
With no C-U's, pushes point as the mark.
With one C-U, pops the mark into point.
((= n 2) (pop-current-mark!))
(else (editor-error)))))
-(define-command ("^R Mark Beginning" argument)
+(define-command ("^R Mark Beginning")
"Set mark at beginning of buffer."
(push-current-mark! (buffer-start (current-buffer))))
-(define-command ("^R Mark End" argument)
+(define-command ("^R Mark End")
"Set mark at end of buffer."
(push-current-mark! (buffer-end (current-buffer))))
((if (not argument) set-current-region! set-current-region-reversed!)
(buffer-region (current-buffer))))
-(define-command ("^R Exchange Point and Mark" argument)
+(define-command ("^R Exchange Point and Mark")
"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)
+(define-command ("^R Get Q-reg")
"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)
+(define-command ("^R Put Q-reg")
"Put point to mark into Q-reg (reads name from tty).
With an argument, the text is also deleted."
(not-implemented))
(region-insert! m* (region-extract! (make-region (mark-1+ m1 'ERROR) m1)))
(set-current-point! m*)))
-(define-command ("^R Transpose Regions" argument)
+(define-command ("^R Transpose Regions")
"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
+ (not-implemented))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/kmacro.scm,v 1.28 1989/03/14 08:01:12 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Keyboard Macros
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define *defining-keyboard-macro?* false)
(define *executing-keyboard-macro?* false)
(define (keyboard-macro-define name macro)
(string-table-put! named-keyboard-macros name last-keyboard-macro)
- (make-command name "Command defined by 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))))
+ (keyboard-macro-execute macro
+ (if (or (default-object? argument)
+ (not argument))
+ 1
+ argument)))))
\f
(define-command ("Start Keyboard Macro" argument)
"Record subsequent keyboard input, defining a 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)
+(define-command ("Name Last Keyboard Macro")
"Assign a name to the last keyboard macro defined."
(if *defining-keyboard-macro?*
(editor-error "Can't name a keyboard macro while defining one."))
(window-redraw! (current-window) false)
(loop))
(else
- (beep)
+ (editor-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:
+ (*executing-keyboard-macro?* (loop))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lincom.scm,v 1.101 1989/03/14 08:01:14 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Line/Indentation Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
;;;; Lines
-(define-command ("^R Count Lines Region" argument)
+(define-command ("^R Count Lines Region")
"Type number of lines from point to mark."
(message "Region has "
(write-to-string (region-count-lines (current-region)))
(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)
+(define-command ("^R Narrow Bounds to Page")
"Make text outside current page invisible."
(region-clip! (page-interior-region (current-point))))
end
end*))))))
\f
-(define-command ("^R Count Lines Page" argument)
+(define-command ("^R Count Lines Page")
"Report number of lines on current page."
(let ((point (current-point)))
(let ((end
(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) ")")))))
+ " + " (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)
+(define-command ("What Page")
"Report page and line number of point."
(without-group-clipped! (buffer-group (current-buffer))
(lambda ()
;;;; Indentation
(define (indent-to-left-margin argument)
+ argument ;ignore
(maybe-change-indentation (ref-variable "Left Margin")
(line-start (current-point) 0)))
(region-insert-string! (current-point) (ref-variable "Fill Prefix"))
(^r-indent-according-to-mode-command argument)))
-(define-command ("Reindent then Newline and Indent" argument)
+(define-command ("Reindent then Newline and Indent")
"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-indent-according-to-mode-command false)
(^r-newline-command)
- (^r-indent-according-to-mode-command #!FALSE))
+ (^r-indent-according-to-mode-command false))
\f
(define-command ("^R Newline" argument)
"Insert newline, or move onto blank line.
(insert-horizontal-space (mark-column m*))
(set-current-point! m*)))
-(define-command ("^R Back to Indentation" argument)
+(define-command ("^R Back to Indentation")
"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)
+(define-command ("^R Delete Horizontal Space")
"Delete all spaces and tabs around point."
(delete-horizontal-space))
-(define-command ("^R Just One Space" argument)
+(define-command ("^R Just One Space")
"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)
+(define-command ("^R Delete Blank Lines")
"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
(char-set #\)))
\f
(define-variable "Indent Tabs Mode"
- "If #!FALSE, do not use tabs for indentation or horizontal spacing."
- #!TRUE)
+ "If #F, do not use tabs for indentation or horizontal spacing."
+ true)
(define-command ("Indent Tabs Mode" argument)
"Enables or disables use of tabs as indentation.
"Distance between tab stops (for display of tab characters), in columns."
8)
-(define-command ("Untabify" argument)
+(define-command ("Untabify")
"Convert all tabs in region to multiple spaces, preserving column.
The variable Tabs Width controls action."
(untabify-region (current-region)))
(loop next))))
(loop (region-start region))))
-(define-command ("Tabify" argument)
+(define-command ("Tabify")
""
(not-implemented))
\f
-(define-command ("^R Indent Relative" argument)
+(define-command ("^R Indent Relative")
"Indents the current line directly below the previous non blank line."
(let ((point (current-point)))
(let ((indentation (indentation-of-previous-non-blank-line point)))
(let ((start (find-previous-non-blank-line mark)))
(if start (current-indentation start) 0)))
-(define-command ("^R Tab to Tab Stop" argument)
+(define-command ("^R Tab to Tab Stop")
""
(not-implemented))
-(define-command ("Edit Indented Text" argument)
+(define-command ("Edit Indented Text")
""
(not-implemented))
-(define-command ("Edit Tab Stops" argument)
+(define-command ("Edit Tab Stops")
""
(not-implemented))
-(define-command ("Edit Tabular Text" argument)
+(define-command ("Edit Tabular Text")
""
- (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:
+ (not-implemented))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/linden.scm,v 1.115 1989/03/14 08:01:17 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Lisp Indentation
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
-
-(define lisp-indentation-package
- (make-environment
\f
+(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)
+
;;; 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
;;; 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)))
+ (find-outer-container (if (default-object? parse-start)
+ (or (backward-one-definition-start mark)
+ (group-start mark))
+ 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-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)
(find-inner-container peek container last-sexp
indent-point)))
(simple-indent state container last-sexp indent-point))))))
-
+\f
(define (simple-indent state container last-sexp indent-point)
(cond ((parse-state-in-string? state)
(mark-column (horizontal-space-end indent-point)))
(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)))
normal-indent))
(method
(method state indent-point normal-indent))
- (else #f)))))))
-\f
+ (else
+ false)))))))
+
;;; Indent the first subform in a definition at the body indent.
;;; Indent subsequent subforms normally.
(define (lisp-indent-definition state indent-point normal-indent)
+ indent-point normal-indent ;ignore
(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)))))
(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)))))))
+ (cond ((mark< second-sexp indent-point)
+ (let loop ((n n) (mark second-sexp))
+ (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))))))
+ ((zero? n)
+ body-indent)
+ (else
+ (cons normal-indent container)))))))
\f
;;;; Indent Line
(if (not (match-forward ";;;" start))
(let ((indentation
(let ((indent (calculate-lisp-indentation start)))
- (if (pair? indent) (car indent) indent))))
+ (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)))
+ (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 loop ((start start) (state false))
(let ((start* (line-start start 1 'LIMIT)))
(if (mark< start* end)
- (phi2 start*
- (parse-partial-sexp start start* #!FALSE #!FALSE state)))))
+ (let ((start start*)
+ (state (parse-partial-sexp start start* false false 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)))
+ (cond ((line-end? start)
+ (delete-horizontal-space start))
+ ((not (match-forward ";;;" start))
+ (change-indentation (max 0
+ (+ (mark-column start)
+ shift-amount))
+ start)))))
+ (loop start 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))
+;;;; 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))))
- (phi1 start #!FALSE)))
+(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))))
\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)
+ (if (mark< point end)
+ (let loop ((index point) (stack '()))
+ (let next-line-start ((index index) (state false))
+ (let ((start (line-start index 1)))
+ (let ((state (parse-partial-sexp index start false false state)))
+ (if (or (not (or (parse-state-in-string? state)
+ (parse-state-in-comment? state)))
+ (mark= start end))
+ (let ((stack
+ (adjust-stack (parse-state-depth state) stack)))
+ (cond ((mark= start end)
+ (if (not (or (parse-state-in-string? state)
+ (parse-state-in-comment? state)))
+ (indent-expression-line start stack)))
+ ((indent-comment-line start stack)
+ (loop start stack))
+ ((line-blank? start)
+ (delete-horizontal-space start)
+ (loop start stack))
+ (else
+ (indent-expression-line start stack)
+ (loop start stack))))
+ (next-line-start start state)))))))))
+
+(define (indent-comment-line start 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)
+ (begin
+ (maybe-change-indentation
+ (cond ((match-forward ";;;" mark) (mark-column mark))
+ ((match-forward ";;" mark) (compute-indentation start stack))
+ (else comment-column))
+ mark)
+ true))))
+
+(define (indent-expression-line start stack)
+ (maybe-change-indentation (compute-indentation start stack) start))
+
+(define (compute-indentation start stack)
+ (cond ((null? stack)
(let ((indent (calculate-lisp-indentation start)))
(if (pair? indent)
(car indent)
indent)))
- ((and (car indent-stack)
- (integer? (car indent-stack)))
- (car indent-stack))
+ ((and (car stack)
+ (integer? (car stack)))
+ (car stack))
(else
(let ((indent
(calculate-lisp-indentation
start
- (or (car indent-stack)
+ (or (car 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))))
+ (begin
+ (set-car! stack (cdr indent))
+ (car indent))
+ (begin
+ (set-car! stack indent)
+ indent))))))
+
+(define (adjust-stack depth-delta stack)
+ (cond ((zero? depth-delta) stack)
+ ((positive? depth-delta) (up-stack depth-delta stack))
+ (else (down-stack depth-delta stack))))
(define (down-stack n stack)
- (if (= -1 n)
- (cdr stack)
- (down-stack (1+ n) (cdr 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:
+ (if (= 1 n) (cons false stack) (up-stack (-1+ n) (cons false stack))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/lspcom.scm,v 1.148 1989/03/14 08:01:23 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Lisp Commands
(declare (usual-integrations))
-(using-syntax (access edwin-syntax-table edwin-package)
\f
;;;; S-expression Commands
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))
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)
+(define-command ("^R Mark Definition")
"Put mark at end of definition, point at beginning."
(let ((point (current-point)))
(let ((end (forward-definition-end point 1 'ERROR)))
(or (re-search-backward "^\n" start (mark-1+ start))
start))))))
-(define-command ("^R Reposition Window" argument)
+(define-command ("^R Reposition Window")
"Reposition window so current definition is at the top.
If this would place point off screen, nothing happens."
(reposition-window-top (current-definition-start)))
"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))
+ (lisp-indent-line argument))
-(define-command ("^R Indent Sexp" argument)
+(define-command ("^R Indent Sexp")
"Indent each line of the expression starting just after the point."
- ((access lisp-indent-sexp lisp-indentation-package) (current-point)))
-\f
+ (lisp-indent-sexp (current-point)))
+
;;;; Motion Covers
(define forward-sexp)
(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:
+ (set! backward-definition-end b)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/macros.scm,v 1.43 1989/03/14 08:01:25 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Editor Macros
(declare (usual-integrations))
-
+\f
(define edwin-syntax-table
- (make-syntax-table system-global-syntax-table))
+ (make-syntax-table syntax-table/system-internal))
-(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
;;; 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)
+ (lambda (name . slots)
(define ((make-symbols x) y)
(make-symbol x y))
`(BEGIN (DEFINE ,tag-name ,name)
(DEFINE (,constructor-name)
(LET ((,structure-name
- (VECTOR-CONS ,(1+ (length slots)) '())))
+ (MAKE-VECTOR ,(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))))
+ (UNPARSER/SET-TAGGED-VECTOR-METHOD!
+ ,tag-name
+ (UNPARSER/STANDARD-METHOD ',structure-name))
,@(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)
+ (lambda (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
+ (bvl (cdr bvl)))
+ (let ((pname (symbol-append (canonicalize-name name) '-COMMAND)))
+ `(BEGIN
+ ,(if (null? bvl)
+ (let ((argument (string->uninterned-symbol "ARGUMENT")))
+ `(DEFINE (,pname #!OPTIONAL ,argument)
+ ,argument ;ignore
+ ,@body))
+ (let ((arg-names
+ (map (lambda (arg) (if (pair? arg) (car arg) arg))
+ bvl)))
+ `(DEFINE (,pname #!OPTIONAL ,@arg-names)
+ (LET* ,(map (lambda (name arg)
+ (let ((init (and (pair? arg) (cadr arg))))
+ `(,name
+ (IF ,(if (not init)
+ `(DEFAULT-OBJECT? ,name)
+ `(OR (DEFAULT-OBJECT? ,name)
+ (NOT ,name)))
+ ,init
+ ,name))))
+ arg-names
+ bvl)
+ ,@body))))
+ (MAKE-COMMAND ',name ',description ,pname))))))
+
(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)))))
+ (lambda (name description . tail)
+ (let ((variable-name (canonicalize-name name)))
+ `(BEGIN
+ (DEFINE ,variable-name ,@tail)
+ (MAKE-VARIABLE ',name ',description ',variable-name)))))
(syntax-table-define edwin-syntax-table 'REF-VARIABLE
- (macro (name)
- (string->symbol (canonicalize-name-string name))))
+ (lambda (name)
+ (canonicalize-name name)))
(syntax-table-define edwin-syntax-table 'SET-VARIABLE!
- (macro (name #!optional value)
- `(SET! ,(string->symbol (canonicalize-name-string name))
- ,@(if (unassigned? value) '() `(,value)))))
+ (lambda (name . tail)
+ `(BEGIN
+ (SET! ,(canonicalize-name name) ,@tail)
+ UNSPECIFIC)))
(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)))))))
+ (lambda (name . tail)
+ (let ((variable-name (canonicalize-name name)))
+ `(BEGIN
+ (UNMAKE-LOCAL-BINDING! ',variable-name)
+ (SET! ,variable-name ,@tail)
+ UNSPECIFIC))))
(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)))))
+ (lambda (name . tail)
+ `(MAKE-LOCAL-BINDING! ',(canonicalize-name name) ,@tail)))
\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"))))
+ (lambda (name super-mode-name description . initialization)
+ (let ((vname (mode-name->variable name)))
`(DEFINE ,vname
- (MAKE-MODE ,name TRUE
+ (MAKE-MODE ',name
+ TRUE
,(if super-mode-name
- `(MODE-COMTABS (NAME->MODE ,super-mode-name))
+ `(MODE-COMTABS (NAME->MODE ',super-mode-name))
''())
- ,description
- (LAMBDA () ,@initialization))))))
+ ',description
+ (LAMBDA ()
+ ,@(let ((initialization
+ (if super-mode-name
+ `(((MODE-INITIALIZATION
+ ,(mode-name->variable super-mode-name)))
+ ,@initialization)
+ initialization)))
+ (if (null? initialization)
+ `(',unspecific)
+ 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"))))
+ (lambda (name description . initialization)
+ (let ((vname (mode-name->variable name)))
`(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:
+ (MAKE-MODE ',name
+ FALSE
+ '()
+ ',description
+ (LAMBDA ()
+ ,@(if (null? initialization)
+ `(',unspecific)
+ initialization)))))))
+
+(define-integrable (mode-name->variable name)
+ (symbol-append (canonicalize-name name) '-MODE))
+
+(define (canonicalize-name name)
+ (cond ((symbol? name) name)
+ ((string? name) (intern (string-replace name #\Space #\-)))
+ (else (error "illegal name" name))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/midas.scm,v 1.12 1989/03/14 08:01:31 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Midas Mode
(declare (usual-integrations))
-
-(using-syntax edwin-syntax-table
\f
-(define-command ("Midas Mode" argument)
+(define-command ("Midas Mode")
"Enter Midas mode."
(set-current-major-mode! midas-mode))
"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 Locator Hook" lisp-comment-locate)
(local-set-variable! "Comment Indent Hook" midas-comment-indentation)
(local-set-variable! "Comment Start" ";")
(local-set-variable! "Comment End" "")
(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 #\newline "> ")
(modify-syntax-entry! midas-mode:syntax-table #\. "w ")
(modify-syntax-entry! midas-mode:syntax-table #\' "' ")
(modify-syntax-entry! midas-mode:syntax-table #\$ "' ")
(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:
+ comment-column)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.114 1989/03/14 08:01:33 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Fundamental Mode
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Fundamental Mode" argument)
+(define-command ("Fundamental Mode")
"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
+(define-major-mode "Fundamental" #F
"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")
(define-variable "Fundamental Mode Hook"
"If not false, a thunk to call when entering Fundamental mode."
- #!FALSE)
+ false)
(define-variable "Editor Default Mode"
"The default major mode for new buffers."
;|
(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:
+(define-key "Fundamental" '(#\C-X #\Rubout) "^R Backward Kill Sentence")
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.21 1989/03/14 08:01:35 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Modes
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-named-structure "Mode"
name
comtabs
description
initialization
- alist)
-
+ 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:alist '())
mode))
-(define (mode-comtab mode)
+(define-integrable (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
+ (make-mode name
+ true
+ '()
+ ""
+ (lambda () (error "Undefined mode" name)))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modwin.scm,v 1.27 1989/03/14 08:01:37 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Modeline Window
-(declare (usual-integrations)
- )
-(using-syntax (access class-syntax-table edwin-package)
+(declare (usual-integrations))
\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))
+ (set! old-buffer-modified? 'UNKNOWN)
+ unspecific)
(define-method modeline-window (:update-display! window screen x-start y-start
xl xu yl yu display-style)
+ display-style ;ignore
(if (< yl yu)
- (with-inverse-video! (ref-variable "Mode Line Inverse Video")
+ (with-inverse-video! screen (ref-variable "Mode Line Inverse Video")
(lambda ()
(screen-write-substring!
screen x-start y-start
- (string-pad-right (modeline-string superior)
- x-size #\-)
+ (string-pad-right (modeline-string superior) x-size #\-)
xl xu))))
true)
-(define (with-inverse-video! flag? thunk)
+(define (with-inverse-video! screen flag? thunk)
(if flag?
- (let ((inverse? (screen-inverse-video! false)))
+ (let ((old-inverse? (screen-inverse-video! screen false))
+ (new-inverse? true))
+ (screen-inverse-video! screen old-inverse?)
(dynamic-wind (lambda ()
- (screen-inverse-video! (not inverse?)))
+ (set! old-inverse?
+ (screen-inverse-video! screen new-inverse?)))
thunk
(lambda ()
- (screen-inverse-video! inverse?))))
+ (set! new-inverse?
+ (screen-inverse-video! screen old-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))))
+ (case 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)))))
+ ((NEW-BUFFER)
+ (set! old-buffer-modified? 'UNKNOWN))
+ ((CURSOR-MOVED)
+ unspecific)
+ (else
+ (setup-redisplay-flags! redisplay-flags)))
+ unspecific)
\f
(define (modeline-string window)
((or (buffer-get (window-buffer window) 'MODELINE-STRING)
(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 #\]))))
+ (string-append
+ (make-string recursive-edit-level #\[)
+ "("
+ (let loop ((modes (buffer-modes buffer)))
+ (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)))))
+ ")"
+ (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))
+ (string-pad-left
+ (number->string
+ (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))))))
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:
+ "%")))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motcom.scm,v 1.37 1989/03/14 08:01:39 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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."
(define-variable "Goal Column"
"Semipermanent goal column for vertical motion,
as set by \\[^R Set Goal Column], or false, indicating no goal column."
- #!FALSE)
+ false)
(define temporary-goal-column-tag
"Temporary Goal Column")
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)))
+ (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)))
(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:
+ (set-command-message! temporary-goal-column-tag column)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/motion.scm,v 1.79 1989/03/14 08:01:41 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Motion within Groups
-(declare (usual-integrations)
- )
+(declare (usual-integrations))
\f
;;;; Motion by Characters
(define (limit-mark-motion limit? limit)
(cond ((eq? limit? 'LIMIT) limit)
- ((eq? limit? 'BEEP) (beep) limit)
+ ((eq? limit? 'BEEP) (editor-beep) limit)
((eq? limit? 'FAILURE) (editor-failure) limit)
((eq? limit? 'ERROR) (editor-error))
- ((not limit?) #!FALSE)
+ ((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))
+ (limit-mark-motion (and (not (default-object? limit?)) 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))
+ (limit-mark-motion (and (not (default-object? limit?)) limit?)
+ (group-start-mark group))
(make-mark group (-1+ index)))))
(define (region-count-chars region)
- (- (region-end-index region)
- (region-start-index region)))
-\f
+ (- (region-end-index region) (region-start-index region)))
+
(define mark+)
(define mark-)
(let ()
(set! mark+
(named-lambda (mark+ mark n #!optional limit?)
- (if (unassigned? limit?) (set! limit? #!FALSE))
- (cond ((positive? n) (%mark+ mark n limit?))
- ((negative? n) (%mark- mark (- n) limit?))
- (else mark))))
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (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))))
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (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)))))
+ (let ((group (mark-group mark))
+ (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)))))
+ (let ((group (mark-group mark))
+ (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
(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 loop ((i index) (n 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)))
+ (else (loop (1+ j) (-1+ n))))))))
((negative? n)
(let ((limit (group-start-index group)))
- (define (loop- i n)
+ (let loop ((i index) (n 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 (loop (-1+ j) (1+ n))))))))
(else
- (if-ok (let ((limit (group-start-index group)))
- (or (%find-previous-newline group index limit)
- limit))))))
+ (if-ok (line-start-index group index)))))
(define (line-start-index group index)
- (or (%find-previous-newline group index (group-start-index group))
- (group-start-index group)))
+ (let ((limit (group-start-index group)))
+ (or (%find-previous-newline group index limit)
+ limit)))
(define (line-end-index group index)
- (or (%find-next-newline group index (group-end-index group))
- (group-end-index group)))
+ (let ((limit (group-end-index group)))
+ (or (%find-next-newline group index limit)
+ limit)))
(define (line-start-index? group index)
(or (group-start-index? group index)
- (char=? (group-left-char group index) char:newline)))
+ (char=? (group-left-char group index) #\newline)))
(define (line-end-index? group index)
(or (group-end-index? group index)
- (char=? (group-right-char group index) char:newline)))
+ (char=? (group-right-char group index) #\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)))))
+ (limit-mark-motion (and (not (default-object? limit?)) 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))))
+ (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)))))
+ (limit-mark-motion (and (not (default-object? limit?)) limit?)
+ mark)))))
(define (line-start? mark)
(line-start-index? (mark-group mark) (mark-index mark)))
(region-end-index region)))
(define (group-count-lines group start end)
- (define (phi1 start n)
+ (let loop ((start start) (n 0))
(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))
+ (let ((i (%find-next-newline group start end))
+ (n (1+ n)))
+ (if (not i)
+ n
+ (loop (1+ i) n))))))
\f
;;;; Motion by Columns
(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))
+ (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)))
(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))
+ (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)))
(- (substring-column->index text start end start-column column)
(group-gap-length group)))
(else
- (substring-column->index text start gap-start start-column
- column
+ (substring-column->index text start gap-start
+ start-column column
(lambda (gap-column)
- (- (substring-column->index text gap-end end gap-column
- column)
+ (- (substring-column->index text gap-end end
+ gap-column column)
(group-gap-length group)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/nvector.scm,v 1.6 1989/03/14 08:01:43 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(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))))
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/pasmod.scm,v 1.40 1989/03/14 08:01:46 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Pascal Mode
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Pascal Mode" argument)
+(define-command ("Pascal Mode")
"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! "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)
(define-key "Pascal" #\C-\) "^R Pascal Shift Right")
(define-key "Pascal" #\Rubout "^R Backward Delete Hacking Tabs")
\f
-(define-command ("^R Pascal Indent" argument)
+(define-command ("^R Pascal Indent")
"Indents the current line for Pascal code."
(let ((point (current-point)))
(let ((indentation (calculate-pascal-indentation point)))
(line-start start 1)))))))
(define (find-statement-start mark)
(let ((start (find-previous-non-blank-line mark)))
- (cond ((not start) #!FALSE)
+ (cond ((not start) false)
((mark< start def-start) def-start)
(else
(let ((container
start))
(+ indentation
(ref-variable "Pascal Shift Increment"))
- indentation))))))))))
-
-;;; end USING-SYNTAX
-)
-
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; Scheme Syntax Table: edwin-syntax-table
-;;; End:
+ indentation))))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.130 1989/03/14 08:01:48 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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-edit-continuation)
+(define typein-edit-depth)
+(define typein-saved-buffers)
(define typein-saved-window)
-(set! within-typein-edit
-(named-lambda (within-typein-edit thunk)
+(define (initialize-typein!)
+ (set! typein-edit-continuation false)
+ (set! typein-edit-depth -1)
+ (set! typein-saved-buffers '())
+ (set! typein-saved-window)
+ unspecific)
+
+(define (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"))
(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!))
+ (let ((window (typein-window)))
+ (select-window window)
+ (select-buffer
+ (find-or-create-buffer
+ (string-append " *Typein-"
+ (number->string typein-edit-depth)
+ "*")))
+ (buffer-reset! (current-buffer))
+ (reset-command-prompt!)
+ (window-clear-override-message! window)))
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!)
+ (let ((window (typein-window)))
+ (select-window window)
+ (let ((buffer (car typein-saved-buffers)))
+ (bufferset-guarantee-buffer! (current-bufferset) buffer)
+ (select-buffer buffer))
+ (reset-command-prompt!)
+ (window-clear-override-message! window))
(if (zero? typein-edit-depth)
(buffer-reset! (current-buffer)))
(cond ((window-visible? typein-saved-window)
(select-window (other-window)))))))))))
(if (eq? value typein-edit-abort-flag)
(abort-current-command)
- value))))
+ value)))
-(set! within-typein-edit?
-(named-lambda (within-typein-edit?)
- (not (false? typein-edit-continuation))))
+(define-integrable (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))
+ (let ((window (typein-window)))
+ (window-set-override-message! window message)
+ (window-direct-update! 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))))
+ (let ((window (typein-window)))
+ (window-clear-override-message! window)
+ (window-direct-update! window true)))
(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)
+(define (prompt-for-typein prompt-string thunk)
(within-typein-edit
(lambda ()
(insert-string prompt-string)
(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))))
+ (intercept-^G-interrupts
+ (lambda ()
+ (cond ((not (eq? (current-window) (typein-window)))
+ (abort-current-command))
+ (typein-edit-continuation
+ (typein-edit-continuation typein-edit-abort-flag))
+ (else
+ (error "illegal ^G signaled in typein window"))))
+ thunk))))))
(define ((typein-editor-thunk mode))
(let ((buffer (current-buffer)))
(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)))
+ (let ((window (current-window)))
+ (window-home-cursor! window)
+ (typein-edit-continuation (buffer-string (window-buffer window)))))
-(define (typein-string)
- (region->string (buffer-region (current-buffer))))
+(define-integrable (typein-string)
+ (buffer-string (current-buffer)))
(define (set-typein-string! string #!optional update?)
- (if (unassigned? update?) (set! update? true))
(let ((dont-update?
- (or (not update?)
+ (or (not (or (default-object? update?) 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?)
+ (or (not (or (default-object? update?) update?))
(window-needs-redisplay? (typein-window)))))
(region-delete! (buffer-region (current-buffer)))
(insert-substring string start end)
(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))
+(define (prompt-for-completed-string prompt
+ default-string
+ default-type
+ completion-string-table
+ completion-type
+ #!optional 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 () unspecific)
(lambda ()
(prompt-for-typein
(string-append
prompt
(if (or (memq default-type
- '(NO-DEFAULT NULL-DEFAULT INVISIBLE-DEFAULT))
+ '(NO-DEFAULT NULL-DEFAULT
+ INVISIBLE-DEFAULT
+ INSERTED-DEFAULT))
(not default-string))
""
- (string-append " (Default is: '" default-string "')"))
+ (string-append " (Default is: \"" default-string "\")"))
": ")
- (typein-editor-thunk mode)))
+ (let ((thunk
+ (typein-editor-thunk
+ (if (default-object? mode) prompt-for-string-mode mode))))
+ (if (eq? default-type 'INSERTED-DEFAULT)
+ (begin
+ (set! *default-string* false)
+ (lambda ()
+ (insert-string default-string)
+ ((thunk))))
+ thunk))))
(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))))))))))
+ (let ((windows (buffer-windows buffer)))
+ (if (not (null? windows))
+ (let ((replacement (other-buffer buffer)))
+ (for-each (lambda (window)
+ (set-window-buffer! window
+ replacement
+ false))
+ windows)
+ (bury-buffer buffer)))))))))))
+
+(define (prompt-for-string prompt default-string #!optional default-type)
+ (prompt-for-completed-string prompt
+ default-string
+ (if (default-object? default-type)
+ 'VISIBLE-DEFAULT
+ default-type)
+ false
+ 'NO-COMPLETION))
+
+(define (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)))
+
+(define (prompt-for-alist-value prompt alist)
+ (prompt-for-string-table-value prompt (alist->string-table alist)))
+
+(define (prompt-for-command prompt)
+ (prompt-for-string-table-value prompt editor-commands))
+
+(define (prompt-for-variable prompt)
+ (prompt-for-string-table-value prompt editor-variables))
+\f
+;;;; PROMPT-FOR-STRING Mode
(define-major-mode "Prompt for String" "Fundamental"
"Major mode for editing solicited input strings.
\\[^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)
+\\[^R List Completions] displays possible completions of the input.")
(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)
+
+(define-command ("^R Yank Default String")
"Insert the default string at point."
(if *default-string*
(insert-string *default-string*)
(editor-failure)))
-(define-command ("^R Complete Input" argument)
+(define-command ("^R Complete Input")
"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))
+ (dispatch-on-command (comtab-entry (cdr (current-comtabs))
(current-command-char))))
((not (complete-input-string *completion-string-table* true))
(editor-failure))))
-(define-command ("^R Complete Input Space" argument)
+(define-command ("^R Complete Input Space")
"Attempt to complete the input string, up to the next space."
(cond ((not *completion-string-table*)
- (dispatch-on-command (comtab-entry (cdr (current-comtab))
+ (dispatch-on-command (comtab-entry (cdr (current-comtabs))
(current-command-char))))
((not (complete-input-string-to-char *completion-string-table*
#\Space))
(editor-failure))))
-
-(define-command ("^R List Completions" argument)
+\f
+(define-command ("^R List Completions")
"List the possible completions for the given input."
(if *completion-string-table*
(list-completions
- (string-table-completions *completion-string-table*
- (typein-string)))
+ (string-table-completions *completion-string-table* (typein-string)))
(^r-insert-self-command)))
(define (list-completions strings)
(if (null? strings)
(write-string
"There are no valid completions for this input.")
- (begin (write-string "Possible completions:")
- (newline)
- (write-strings-densely strings)))))))
+ (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)
+ (set! *pop-up-window* window)))
+ unspecific)
+
+(define-command ("^R Terminate Input")
"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))))
+ (let ((string (typein-string)))
+ (cond ((string-null? 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* 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
+;;;; Completion Primitives
+
(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))
+ (lambda (string) (set-typein-string! string update?))
+ (lambda (string limit) (set-typein-substring! string 0 limit update?))
+ (lambda () unspecific))
(string-table-get string-table (typein-string)))
(define (complete-input-string-to-char string-table char)
true)
(lambda (string limit)
(and (> limit (string-length original))
- (begin (set-typein-substring! string 0 limit)
- true)))
- (lambda ()
- false))))
+ (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)
(lambda (new-string)
(if-unambiguous new-string (string-length string)))
(lambda (new-string limit)
+ limit ;ignore
(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)
+(define (prompt-for-char prompt)
(set-command-prompt! (string-append prompt ": "))
- (let ((char (read-char)))
- (set-command-prompt! (string-append (command-prompt) (char->name char)))
+ (let ((char (keyboard-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)
+(define (prompt-for-char-without-interrupts prompt)
+ (with-editor-interrupts-disabled (lambda () (prompt-for-char prompt))))
-(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)
+(define (prompt-for-key prompt #!optional comtab)
+ (let ((comtab (if (default-object? comtab) (current-comtabs) comtab))
+ (string (string-append prompt ": ")))
+ (set-command-prompt! string)
+ (let outer-loop ((prefix '()))
+ (let inner-loop ((char (keyboard-read-char)))
(let ((chars (append! prefix (list char))))
(set-command-prompt! (string-append string (xchar->name chars)))
(if (prefix-char-list? 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
+ chars))))))))
+
;;;; Confirmation Prompts
-(set! prompt-for-confirmation?
-(named-lambda (prompt-for-confirmation? prompt)
- (define (loop)
+(define (prompt-for-confirmation? prompt)
+ (set-command-prompt! (string-append prompt " (y or n)? "))
+ (let loop ()
(let ((char (char-upcase (keyboard-read-char))))
(cond ((or (char=? char #\Y)
(char=? char #\Space))
(set-command-prompt! (string-append (command-prompt) "Yes"))
+ (sit-for 500)
true)
((or (char=? char #\N)
(char=? char #\Rubout))
(set-command-prompt! (string-append (command-prompt) "No"))
+ (sit-for 500)
false)
(else
(editor-failure)
- (loop)))))
- (set-command-prompt! (string-append prompt " (Y or N)? "))
- (loop)))
+ (loop))))))
-(set! prompt-for-yes-or-no?
-(named-lambda (prompt-for-yes-or-no? prompt)
+(define (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)))))
+ (prompt-for-typein (string-append prompt " (yes or no)? ")
+ (typein-editor-thunk prompt-for-yes-or-no-mode))))
+
+(define-major-mode "Prompt for Yes or No" "Fundamental"
+ "Enter either ``Yes'' or ``No''.")
+
+(define-key "Prompt for Yes or No" #\Return "^R Terminate Yes or No")
-(define-command ("^R Terminate Yes or No" argument)
+(define-command ("^R Terminate Yes or No")
"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:
+ (editor-error "Please enter ``Yes'' or ``No''"))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/reccom.scm,v 1.10 1989/03/14 08:01:58 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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 (delete-rectangle mark1 mark2 #!optional fill-flag move?) ;mark2 is always "point"
+ (let ((fill-flag (and (not (default-object? fill-flag)) fill-flag))
+ (move? (and (not (default-object? move?)) move?)))
+ (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)))
+ (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))
+(define-command ("Kill Rectangle")
"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))
+(define-command ("Delete Rectangle")
"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))
+(define-command ("Open Rectangle")
"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))
+ (delete-rectangle (current-mark) (current-point) true true))
-(define-command ("Clear Rectangle" (argument 1))
+(define-command ("Clear Rectangle")
"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))
+ (delete-rectangle (current-mark) (current-point) true))
(define (make-space-to-column column mark) ;new make-space-to-column
(mark-permanent! mark)
(line-end mark 0))
(define (yank-rectangle rectangle point)
- (let ((goal (mark-column point))
- (newline$ (make-string 1 CHAR:NEWLINE)))
+ (let ((goal (mark-column point)))
(if (null? (cdr rectangle))
(editor-error "No rectangle to yank.")
(let ((columns (cadr rectangle)))
(cdr insert$)))))
(iter (line-end point 0) point (cddr rectangle))))))
-(define-command ("Yank Rectangle" (argument 1))
+(define-command ("Yank Rectangle")
"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:
+ (yank-rectangle rectangle-ring (current-point)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regcom.scm,v 1.15 1989/03/14 08:02:00 cph Exp $
+;;;
+;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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)
+(define-command ("Point to Register")
"Store current location of point in a register."
- (set-register! (prompt-for-register "Point to Register")
+ (set-register! (prompt-for-char "Point to Register")
(make-buffer-position (current-point) (current-buffer))))
-(define-command ("Register to Point" argument)
+(define-command ("Register to Point")
"Move point to location stored in a register."
- (let ((register (prompt-for-register "Register to Point")))
+ (let ((register (prompt-for-char "Register to Point")))
(let ((value (get-register register)))
(if (not (buffer-position? value))
(register-error register "does not contain a buffer position."))
"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")
+ (set-register! (prompt-for-char "Number to Register")
(or argument
(let ((start (current-point))
(end (skip-chars-forward "[0-9]")))
(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 ((register (prompt-for-char "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")
+ (set-register! (prompt-for-char "Copy to Register")
(region->string region))
(if argument (region-delete! region))))
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"))))
+ (let ((value (get-register (prompt-for-char "Insert Register"))))
(cond ((string? value) value)
((integer? value) (write-to-string value))
(else (register-error "does not contain text"))))))
-
+\f
(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")))
+ (register (prompt-for-char "Append to Register")))
(let ((value (get-register register)))
(if (not (string? value))
(register-error register "does not contain text"))
"Prepend region to text in given register.
With prefix arg, delete as well."
(let ((region (current-region))
- (register (prompt-for-register "Prepend to Register")))
+ (register (prompt-for-char "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)
+
+(define-command ("View Register")
"Display what is contained in a given register."
- (let ((register (prompt-for-register "View Register")))
+ (let ((register (prompt-for-char "View Register")))
(let ((value (get-register register)))
(if (not value)
- (message "Register " (register-name register) " is empty")
+ (message "Register " (char-name register) " is empty")
(with-output-to-temporary-buffer "*Output*"
(lambda ()
(write-string "Register ")
- (write-string (register-name register))
+ (write-string (char-name register))
(write-string " contains ")
(cond ((integer? value)
(write value))
(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)
+ (apply editor-error "Register " (char-name register) " " strings))
(define (get-register char)
(let ((entry (assv char register-alist)))
(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
-)
+(define-integrable (buffer-position-mark position)
+ (cadr position))
-;;; Edwin Variables:
-;;; Scheme Environment: (access register-command-package edwin-package)
-;;; Scheme Syntax Table: (access edwin-syntax-table edwin-package)
-;;; End:
+(define-integrable (buffer-position-buffer position)
+ (unhash (cddr position)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regexp.scm,v 1.46 1989/03/14 08:02:02 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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)
+(define (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)))))))
+ (make-mark group (vector-ref registers i))))))
-(set! re-match-end
-(named-lambda (re-match-end i)
+(define (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))))))))
+ (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)))
+ (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)))
+ (make-list 32 (cons* "" "" "")))
(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))))))
+ (let ((entry
+ (cons regexp
+ (cons (re-compile-pattern regexp false)
+ (re-compile-pattern regexp true)))))
+ (set! pattern-cache
+ (cons entry
+ (except-last-pair! pattern-cache)))
+ entry)))))
(define (compile-char char)
(re-compile-char char (ref-variable "Case Fold Search")))
\f
;;;; Search
+(define-macro (define-search name key-name searcher compile-key
+ mark-limit mark-compare)
+ `(DEFINE (,name ,key-name #!OPTIONAL START END LIMIT?)
+ (LET ((START (IF (DEFAULT-OBJECT? START) (CURRENT-POINT) START)))
+ (LET ((END (IF (DEFAULT-OBJECT? END) (,mark-limit START) END)))
+ (LET ((LIMIT? (AND (NOT (DEFAULT-OBJECT? LIMIT?)) LIMIT?)))
+ (IF (NOT (,mark-compare START END))
+ (ERROR ,(string-append (symbol->string name)
+ ": Marks incorrectly related")
+ START END))
+ (OR (,searcher (MARK-GROUP START)
+ (MARK-INDEX START)
+ (MARK-INDEX END)
+ (,compile-key ,key-name))
+ (LIMIT-MARK-MOTION LIMIT? END)))))))
+
(define-search char-search-forward char
%re-search-forward compile-char 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-buffer-forward))
+ ((ucode-primitive re-search-buffer-forward)
+ pattern
+ (re-translation-table (ref-variable "Case Fold Search"))
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ registers
+ group start end)))
(define-search char-search-backward char
%re-search-backward compile-char 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-buffer-backward))
-
+ ((ucode-primitive re-search-buffer-backward)
+ pattern
+ (re-translation-table (ref-variable "Case Fold Search"))
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ registers
+ group end start)))
\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 (,name ,key-name #!OPTIONAL START END)
+ (LET ((START (IF (DEFAULT-OBJECT? START) (CURRENT-POINT) START)))
+ (LET ((END (IF (DEFAULT-OBJECT? END) (GROUP-END START) END)))
+ (IF (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-macro (define-backward-match name key-name key-length compile-key)
+ `(DEFINE (,name ,key-name #!OPTIONAL START END)
+ (LET ((START (IF (DEFAULT-OBJECT? START) (CURRENT-POINT) START)))
+ (LET ((END (IF (DEFAULT-OBJECT? END) (GROUP-START START) END)))
+ (IF (NOT (MARK>= START END))
+ (ERROR ,(string-append (symbol->string name)
+ ": Marks incorrectly related")
+ START END))
+ (LET ((GROUP (MARK-GROUP START))
+ (START-INDEX (MARK-INDEX START))
+ (END-INDEX (MARK-INDEX END)))
+ (LET ((INDEX (- START-INDEX ,key-length)))
+ (AND (<= END-INDEX INDEX)
+ (%RE-MATCH-FORWARD GROUP
+ INDEX
+ START-INDEX
+ (,compile-key ,key-name))
+ (MAKE-MARK GROUP INDEX))))))))
+
+(define-backward-match char-match-backward
+ char
+ 1
+ compile-char)
+
+(define-backward-match match-backward
+ string
+ (string-length string)
+ compile-string)
+
(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-buffer))
-
-\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
-)))
+ ((ucode-primitive re-match-buffer)
+ pattern
+ (re-translation-table (ref-variable "Case Fold Search"))
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ registers
+ group start end)))
\f
;;;; Quote
(define re-quote-string
(let ((special (char-set #\[ #\] #\* #\. #\\ #\? #\+ #\^ #\$)))
- (named-lambda (re-quote-string string)
+ (lambda (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)))
+ (let ((n
+ (let loop ((start 0) (n 0))
+ (let ((index
+ (substring-find-next-char-in-set string start end
+ special)))
+ (if index
+ (loop (1+ index) (1+ n))
+ n)))))
(if (zero? n)
string
(let ((result (string-allocate (+ end n))))
- (define (loop start i)
+ (let loop ((start 0) (i 0))
(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))))
+ (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))))
+ (let ((start (if (default-object? start) (current-point) start)))
+ (let ((end (if (default-object? end) (group-end start) end)))
+ (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
+ (if (not (mark<= start end))
+ (error "SKIP-CHARS-FORWARD: Marks incorrectly related" start end))
+ (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:
+ (let ((start (if (default-object? start) (current-point) start)))
+ (let ((end (if (default-object? end) (group-start start) end)))
+ (let ((limit? (if (default-object? limit?) 'LIMIT limit?)))
+ (if (not (mark>= start end))
+ (error "SKIP-CHARS-BACKWARD: Marks incorrectly related" start end))
+ (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)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/regops.scm,v 1.79 1989/03/14 08:02:08 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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)
- )
-\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.
-
+(declare (usual-integrations))
+\f
(define (string->region string)
(group-region (make-group (string-copy string))))
(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)))))
+ (%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 start end))
(define (region-insert-newline! mark)
- (group-insert-char! (mark-group mark) (mark-index mark) char:newline))
+ (group-insert-char! (mark-group mark) (mark-index mark) #\newline))
(define (region-insert-char! mark char)
(group-insert-char! (mark-group mark) (mark-index mark) char))
\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))))
+ (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))))
+ (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))))
+ (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))))
+ (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.
(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)))
+ (vector-set! group group-index:display-end end))
+ unspecific)
(define (group-un-clip! group)
- (let ((start (%make-permanent-mark group 0 #!FALSE))
- (end (%make-permanent-mark group (group-length group) #!TRUE)))
+ (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)))
+ (vector-set! group group-index:display-end end))
+ unspecific)
(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)))
+ (region-clip! new-region)
+ (set! new-region)
+ unspecific)
thunk
(lambda ()
(set! new-region (group-region group))
- (region-clip! (set! old-region))))))
+ (region-clip! old-region)
+ (set! old-region)
+ unspecific))))
(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)))))
+ (let ((old-region))
+ (dynamic-wind (lambda ()
+ (set! old-region (group-region group))
+ (group-un-clip! group))
+ thunk
+ (lambda ()
+ (region-clip! old-region)
+ (set! old-region)
+ unspecific))))
(define (group-clipped? group)
(not (and (zero? (group-start-index 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:
+ (make-mark group (group-length group))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/replaz.scm,v 1.63 1989/03/14 08:02:12 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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."
(perform-query start end replaced?))
(else
(if clear-on-exit? (clear-message))
- (execute-char (current-comtab) char)
+ (execute-char (current-comtabs) char)
true))))
(set-message)
\f
;;;; Occurrence Commands
-(define-command ("Count Occurrences" argument)
+(define-command ("Count Occurrences")
"Print the number of occurrences of a given regexp following point."
(let ((regexp (prompt-for-string "Count Occurrences (regexp)" false)))
(define (loop start n)
(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:
+ (loop (current-point))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1984 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/ring.scm,v 1.8 1989/03/14 08:02:39 cph Exp $
+;;;
+;;; Copyright (c) 1984, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(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!))
+ (let loop ((l l) (i i))
+ (cond ((null? l) (error "index too large" i))
((zero? i) (set-car! l o))
(else (list-ref (cdr l) (-1+ i)))))
- (loop l i))
+ unspecific)
(define (list-truncate! l i)
- (cond ((null? l) 'DONE)
+ (cond ((null? l) unspecific)
((= i 1) (set-cdr! l '()))
- (else (list-truncate! (cdr l) (-1+ i)))))
+ (else (list-truncate! (cdr l) (-1+ i))))
+ unspecific)
(set! make-ring
(named-lambda (make-ring size)
(set! ring-clear!
(named-lambda (ring-clear! ring)
- (vector-set! ring 2 '())))
+ (vector-set! ring 2 '())
+ unspecific))
(set! ring-empty?
(named-lambda (ring-empty? ring)
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/schmod.scm,v 1.7 1989/03/14 08:02:40 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Scheme Mode
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Scheme Mode" argument)
+(define-command ("Scheme Mode")
"Enter Scheme mode."
(set-current-major-mode! scheme-mode))
\\[^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! "Syntax Ignore Comments Backwards" false)
+ (local-set-variable! "Lisp Indent Hook" standard-lisp-indent-hook)
(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 Locator Hook" lisp-comment-locate)
+ (local-set-variable! "Comment Indent Hook" lisp-comment-indentation)
(local-set-variable! "Comment Start" ";")
(local-set-variable! "Comment End" "")
(local-set-variable! "Paragraph Start" "^$")
(define-variable "Scheme Mode Hook"
"If not false, a thunk to call when entering Scheme mode."
- #!FALSE)
+ false)
(define-key "Scheme" #\Rubout "^R Backward Delete Hacking Tabs")
(define-key "Scheme" #\) "^R Lisp Insert Paren")
(define scheme-mode:syntax-table (make-syntax-table))
-(modify-syntax-entries! scheme-mode:syntax-table #\C-\@ #\/ "_ ")
+(modify-syntax-entries! scheme-mode:syntax-table #\NUL #\/ "_ ")
(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 #\| " 23")
(modify-syntax-entry! scheme-mode:syntax-table #\; "< ")
-(modify-syntax-entry! scheme-mode:syntax-table char:newline "> ")
+(modify-syntax-entry! scheme-mode:syntax-table #\newline "> ")
(modify-syntax-entry! scheme-mode:syntax-table #\' "' ")
(modify-syntax-entry! scheme-mode:syntax-table #\` "' ")
;;;; Indentation
(define (scheme-mode:indent-let-method state indent-point normal-indent)
- ((access lisp-indent-special-form lisp-indentation-package)
+ (lisp-indent-special-form
(let ((m (parse-state-containing-sexp state)))
(let ((start (forward-to-sexp-start (forward-one-sexp (mark1+ m)
indent-point)
`((CASE . 1)
(DO . 2)
(FLUID-LET . 1)
- (IN-PACKAGE . 1)
(LAMBDA . 1)
(LET . ,scheme-mode:indent-let-method)
(LET* . 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-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:
+ ))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/screen.scm,v 1.78 1989/03/14 08:02:42 cph Exp $
+;;;
+;;; Copyright (c) 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
+;;;; 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:
+(define-structure (screen
+ (constructor make-screen
+ (state
+ operation/beep
+ operation/finish-update!
+ operation/flush!
+ operation/inverse-video!
+ operation/start-update!
+ operation/subscreen-clear!
+ operation/write-char!
+ operation/write-cursor!
+ operation/write-substring!
+ operation/write-substrings!
+ operation/x-size
+ operation/y-size)))
+ (state false read-only true)
+ (operation/beep false read-only true)
+ (operation/finish-update! false read-only true)
+ (operation/flush! false read-only true)
+ (operation/inverse-video! false read-only true)
+ (operation/start-update! false read-only true)
+ (operation/subscreen-clear! false read-only true)
+ (operation/write-char! false read-only true)
+ (operation/write-cursor! false read-only true)
+ (operation/write-substring! false read-only true)
+ (operation/write-substrings! false read-only true)
+ (operation/x-size false read-only true)
+ (operation/y-size false read-only true)
+ (window false)
+ (in-update? false))
+
+(define (with-screen-in-update! screen thunk)
+ (let ((old-flag)
+ (new-flag true))
+ (dynamic-wind (lambda ()
+ ((screen-operation/start-update! screen) screen)
+ (set! old-flag (screen-in-update? screen))
+ (set-screen-in-update?! screen new-flag))
+ thunk
+ (lambda ()
+ (set! new-flag (screen-in-update? screen))
+ (set-screen-in-update?! screen old-flag)
+ ((screen-operation/finish-update! screen) screen)))))
+
+(define (screen-x-size screen)
+ ((screen-operation/x-size screen) screen))
+
+(define (screen-y-size screen)
+ ((screen-operation/y-size screen) screen))
+
+(define (screen-beep screen)
+ ((screen-operation/beep screen) screen))
+
+(define (screen-flush! screen)
+ ((screen-operation/flush! screen) screen))
+
+(define (screen-inverse-video! screen highlight?)
+ ((screen-operation/inverse-video! screen) screen highlight?))
+
+(define (subscreen-clear! screen xl xu yl yu)
+ ((screen-operation/subscreen-clear! screen) screen xl xu yl yu))
+
+(define (screen-write-cursor! screen x y)
+ ((screen-operation/write-cursor! screen) screen x y))
+
+(define (screen-write-char! screen x y char)
+ ((screen-operation/write-char! screen) screen x y char))
+
+(define (screen-write-substring! screen x y string start end)
+ ((screen-operation/write-substring! screen) screen x y string start end))
+
+(define (screen-write-substrings! screen x y strings bil biu bjl bju)
+ ((screen-operation/write-substrings! screen)
+ screen x y strings bil biu bjl bju))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/search.scm,v 1.145 1989/03/14 08:02:45 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;; the user level search and match primitives, see the regular
;;; expression search and match procedures.
-(declare (usual-integrations)
- )
+(declare (usual-integrations))
\f
;;;; Character Search
#|
|#
(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))
+ (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)))
+ (text (group-text group))
+ (char #\newline))
(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))))))
+ (or (substring-find-next-char text start gap-start char)
+ (substring-find-next-char text gap-end end char))
+ (substring-find-next-char text start end char))))
+ (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))
+ (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)))
+ (text (group-text group))
+ (char #\newline))
(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)))))))
+ (or (substring-find-previous-char text gap-end start char)
+ (substring-find-previous-char text end gap-start char))
+ (substring-find-previous-char text end start char))))
+ (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)))
+ (limit-mark-motion (and (not (default-object? limit?)) 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)))
+ (limit-mark-motion (and (not (default-object? limit?)) limit?) end)))
(define (find-next-char-in-set start end char-set)
(if (not (mark<= start end))
(mark-index start)
(mark-index end)
char-set)))
- (and index (make-mark (mark-group start) index))))
+ (and index
+ (make-mark (mark-group start) index))))
(define (find-previous-char-in-set start end char-set)
(if (not (mark>= start end))
(mark-index start)
(mark-index end)
char-set)))
- (and index (make-mark (mark-group start) index))))
+ (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))
+ (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)))
(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))
+ (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)))
(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)))))
;;;; String Match
(define (match-next-strings start end strings)
- (define (loop strings)
+ (let loop ((strings strings))
(and (not (null? strings))
(or (match-next-string start end (car strings))
- (loop (cdr strings)))))
- (loop strings))
+ (loop (cdr 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))
+ (error "marks incorrectly related" 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))))
+ (and index
+ (make-mark (mark-group start-mark) index))))
(define (match-previous-strings start end strings)
- (define (loop strings)
+ (let loop ((strings strings))
(and (not (null? strings))
(or (match-previous-string start end (car strings))
- (loop (cdr strings)))))
- (loop strings))
+ (loop (cdr 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))
+ (error "marks incorrectly related" 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
+ (and index
+ (make-mark (mark-group start-mark) index))))
+
(define (%match-next-string group start-index end-index string)
(%match-next-substring group start-index end-index
string 0 (string-length string)))
(define (%%match-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))
+ (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)))
(and (> start end)
(char-set-member? char-set (group-left-char group start))
(-1+ start)))
-|#
-
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; End:
+|#
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sercom.scm,v 1.52 1989/03/14 08:02:48 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Search Commands
(declare (usual-integrations))
-(using-syntax (access edwin-syntax-table edwin-package)
\f
;;;; Character Search
;;; JAR Special
"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)
+(define-command ("Search Forward")
"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)
+(define-command ("Search Backward")
"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)
+(define-command ("RE Search Forward")
"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)
+(define-command ("RE Search Backward")
"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 (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-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))))
+(define (search-prompt prompt)
+ (let ((string (prompt-for-string prompt
+ (ref-variable "Previous Search String"))))
+ (set-variable! "Previous Search String" string)
+ string))
-;;; 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:
+(define (re-search-prompt prompt)
+ (let ((regexp (prompt-for-string prompt
+ (ref-variable "Previous Search Regexp"))))
+ (set-variable! "Previous Search Regexp" regexp)
+ regexp))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/simple.scm,v 1.26 1989/03/14 08:02:53 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(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))
+ (let ((point (if (default-object? point) (current-point) 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))))
+ (let ((point (if (default-object? point) (current-point) 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))
+ (let ((point (if (default-object? point) (current-point) point)))
+ (group-insert-char! (mark-group point) (mark-index point) #\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))))
+ (let ((point (if (default-object? point) (current-point) point)))
+ (cond ((= n 1)
+ (group-insert-char! (mark-group point) (mark-index point)
+ #\newline))
+ ((> n 1)
+ (group-insert-substring! (mark-group point) (mark-index point)
+ (make-string n #\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))))
+ (let ((point (if (default-object? point) (current-point) 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))))
+ (let ((point (if (default-object? point) (current-point) 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))))
+ (let ((point (if (default-object? point) (current-point) 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
+ (let ((point (if (default-object? point) (current-point) point)))
+ (let ((group (mark-group point))
+ (index (mark-index point)))
+ (if (group-end-index? group index)
+ (editor-error "Attempt to delete past end of buffer")
+ (group-delete-right-char! group index)))))
+
(define (insert-string string #!optional point)
- (if (unassigned? point) (set! point (current-point)))
- (group-insert-string! (mark-group point) (mark-index point) string))
+ (let ((point (if (default-object? point) (current-point) 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))
+ (let ((point (if (default-object? point) (current-point) 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))))
+ (let ((point (if (default-object? point) (current-point) 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)))))
\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 (delete-string mark #!optional point)
+ (let ((point (if (default-object? point) (current-point) point)))
+ (let ((group (mark-group mark))
+ (index1 (mark-index mark))
+ (index2 (mark-index point)))
+ (if (not (eq? group (mark-group point)))
+ (error "DELETE-STRING: Marks not related" mark point))
+ (if (< index1 index2)
+ (group-delete! group index1 index2)
+ (group-delete! group index2 index1)))))
-(define (upcase-area mark #!optional point)
- (if (unassigned? point) (set! point (current-point)))
- (region-transform! (make-region mark point) uppercase-string!))
+(define (match-string string mark #!optional point)
+ (let ((point (if (default-object? point) (current-point) 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 (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)
+ (region-transform!
+ (make-region mark (if (default-object? point) (current-point) point))
+ (lambda (string)
+ (string-downcase! string)
+ string)))
-(define (lowercase-string! string)
- (string-downcase! string)
- string)
+(define (upcase-area mark #!optional point)
+ (region-transform!
+ (make-region mark (if (default-object? point) (current-point) point))
+ (lambda (string)
+ (string-upcase! 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 (capitalize-area mark #!optional point)
+ (region-transform!
+ (make-region mark (if (default-object? point) (current-point) point))
+ (lambda (string)
+ (string-downcase! string)
+ (string-set! string 0 (char-upcase (string-ref string 0)))
+ string)))
(define (mark-flash mark #!optional type)
- (if (unassigned? type) (set! type #!FALSE))
- (cond (*executing-keyboard-macro?*)
- ((not mark) (beep))
+ (cond (*executing-keyboard-macro?* unspecific)
+ ((not mark) (editor-beep))
((window-mark-visible? (current-window) mark)
- (update-alpha-window! #!FALSE)
(with-current-point mark
(lambda ()
- (keyboard-active? 50))))
+ (sit-for 500))))
(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))))))))
+ (case (and (not (default-object? type)) type)
+ ((RIGHT) (extract-string mark end))
+ ((LEFT) (extract-string start mark))
+ (else (extract-string start end))))))))
+
+(define (sit-for interval)
+ (if (not (keyboard-active? 0))
+ (begin
+ (update-screens! false)
+ (keyboard-active? interval))))
(define (reposition-window-top mark)
- (if (not (and mark (set-window-start-mark! (current-window) mark #!FALSE)))
- (beep)))
\ No newline at end of file
+ (if (not (and mark (set-window-start-mark! (current-window) mark false)))
+ (editor-beep)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/strpad.scm,v 1.3 1989/03/14 08:02:56 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(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))))
+ (let ((lr (+ l n)))
+ (let ((result (string-allocate lr)))
+ (substring-move-right! string 0 l result 0)
+ (substring-fill! result l lr #\space)
+ result)))))
(define (add-padding-on-left string n)
(if (zero? n)
string
(let ((l (string-length string)))
- (let ((result (make-string (+ l n) #\Space)))
+ (let ((result (string-allocate (+ l n))))
+ (substring-fill! result 0 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)))
+ (let ((result (string-allocate n)))
(substring-move-right! string 0 l result 0)
+ (substring-fill! result l n #\space)
result)
string)))
(let ((l (string-length string)))
(let ((delta (- n l)))
(if (positive? delta)
- (let ((result (make-string n #\Space)))
+ (let ((result (string-allocate n)))
+ (substring-fill! result 0 delta #\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)
+ (let loop ((strings strings) (i 1))
(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)))))
+ (begin
+ (write-string " ")
+ (write-string (car strings))
+ (if (= i n-per-line)
+ (begin
+ (newline)
+ (loop (cdr strings) 1))
+ (loop (cdr strings) (1+ i))))))))))
(define ((pad-strings-to-max-column pad) strings receiver)
(define (max-loop strings n acc)
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/strtab.scm,v 1.39 1989/03/14 08:02:58 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(declare (usual-integrations))
\f
+(define-structure (string-table (constructor %make-string-table))
+ vector
+ size)
+
(define (make-string-table #!optional initial-size)
- (if (unassigned? initial-size) (set! initial-size 10))
- (vector string-table-tag
- (vector-cons initial-size '())
- 0))
+ (%make-string-table (make-vector (if (default-object? initial-size)
+ 16
+ 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!))
+ (let ((v
+ (list->vector
+ (sort alist (lambda (x y) (string-ci<? (car x) (car y)))))))
+ (%make-string-table v (vector-length v))))
-(define (string-table-entry-string entry)
- (declare (integrate entry))
- (car entry))
+(define-integrable make-string-table-entry cons)
+(define-integrable string-table-entry-string car)
+(define-integrable string-table-entry-value cdr)
+(define-integrable set-string-table-entry-string! set-car!)
+(define-integrable set-string-table-entry-value! set-cdr!)
-(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)
+ (let loop ((low 0) (high (-1+ (string-table-size table))))
(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)))))
+ (lambda () (if-found index entry))
+ (lambda () (loop low (-1+ index)))
+ (lambda () (loop (1+ index) high)))))))))
(define (string-table-get table string #!optional if-not-found)
(string-table-search table string
(lambda (index entry)
+ index ;ignore
(string-table-entry-value entry))
- (if (unassigned? if-not-found)
- (lambda (index) #!FALSE)
+ (if (default-object? if-not-found)
+ (lambda (index) index false)
if-not-found)))
(define (string-table-put! table string value)
(string-table-search table string
(lambda (index entry)
+ index ;ignore
(set-string-table-entry-string! entry string)
(set-string-table-entry-value! entry value))
(lambda (index)
(define (string-table-remove! table string)
(string-table-search table string
(lambda (index entry)
+ entry ;ignore
(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)))
+ true)
+ (lambda (index) index false)))
\f
-(define string-table-complete)
-(define string-table-completions)
-(let ()
-
-(set! string-table-complete
-(named-lambda (string-table-complete table string
+(define (string-table-complete table string
if-unambiguous if-ambiguous if-not-found)
- (string-table-complete* table string
+ (%string-table-complete table string
if-unambiguous
(lambda (close-match gcs lower upper)
+ lower upper ;ignore
(if-ambiguous close-match gcs))
- if-not-found)))
+ if-not-found))
-(set! string-table-completions
-(named-lambda (string-table-completions table string)
- (string-table-complete* table string
+(define (string-table-completions table string)
+ (%string-table-complete table string
list
(lambda (close-match gcs lower upper)
- (define (loop index)
+ close-match gcs ;ignore
+ (let loop ((index lower))
(if (= index upper)
'()
(cons (string-table-entry-string
(vector-ref (string-table-vector table) index))
- (loop (1+ index)))))
- (loop lower))
+ (loop (1+ index))))))
(lambda ()
- '()))))
-\f
-(define (string-table-complete* table string
+ '())))
+
+(define (%string-table-complete table string
if-unambiguous if-ambiguous if-not-found)
(let ((size (string-length string))
(table-size (string-table-size table)))
(if-not-found))))
(string-table-search table string
(lambda (index entry)
+ entry ;ignore
(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)
+ (let loop ((index 0))
(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)))
+ (loop (1+ index))))))))
(define (substring-ci? string1 string2)
(or (string-null? string1)
string2 (1+ index) end2))
index
(loop (1+ index))))))
- (loop 0))))
-
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; End:
+ (loop 0))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/struct.scm,v 1.65 1989/03/14 08:03:01 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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.
;;;; 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))))
+ 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 (make-group string)
(let ((group (%make-group))
(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)))
+ (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)))
+ (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: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))
+ (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))
+(define-integrable (group-start-index group)
(mark-index (group-start-mark group)))
-(define (group-end-index group)
- (declare (integrate group))
+(define-integrable (group-end-index group)
(mark-index (group-end-mark group)))
-(define (group-start-index? group index)
- (declare (integrate group index))
+(define-integrable (group-start-index? group index)
(<= index (group-start-index group)))
-(define (group-end-index? group index)
- (declare (integrate group index))
+(define-integrable (group-end-index? group index)
(>= index (group-end-index group)))
-(define (set-group-read-only! group)
- (vector-set! group group-index:read-only? #!TRUE))
+(define-integrable (set-group-read-only! group)
+ (vector-set! group group-index:read-only? true)
+ unspecific)
-(define (set-group-writeable! group)
- (vector-set! group group-index:read-only? #!FALSE))
+(define-integrable (set-group-writeable! group)
+ (vector-set! group group-index:read-only? false)
+ unspecific)
(define (group-region group)
(%make-region (group-start-mark group) (group-end-mark group)))
(- position (group-gap-length group)))
((> position (group-gap-start group))
(group-gap-start group))
- (else position)))
+ (else
+ position)))
(define (group-index->position group index left-inserting?)
(cond ((> index (group-gap-start group))
(if left-inserting?
(group-gap-end group)
(group-gap-start group)))
- (else index)))
+ (else
+ index)))
\f
-(define (set-group-undo-data! group undo-data)
- (vector-set! group group-index:undo-data undo-data))
+(define-integrable (set-group-undo-data! group undo-data)
+ (vector-set! group group-index:undo-data undo-data)
+ unspecific)
-(define (set-group-modified! group sense)
- (vector-set! group group-index:modified? sense))
+(define-integrable (set-group-modified! group sense)
+ (vector-set! group group-index:modified? sense)
+ unspecific)
-(define (set-group-point! group point)
- (vector-set! group group-index:point (mark-left-inserting point)))
+(define-integrable (set-group-point! group point)
+ (vector-set! group group-index:point (mark-left-inserting point))
+ unspecific)
(define (with-narrowed-region! region thunk)
(with-group-text-clipped! (region-group 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))))
+ (let ((old-text-start)
+ (old-text-end)
+ (new-text-start (%make-permanent-mark group start false))
+ (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)
+ unspecific)
+ 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)
+ unspecific))))
\f
-(define (record-insertion! group start end)
- (define (loop daemons)
+(define (invoke-group-daemons! daemons group start end)
+ (let loop ((daemons daemons))
(if (not (null? daemons))
- (begin ((car daemons) group start end)
- (loop (cdr daemons)))))
- (loop (group-insert-daemons group)))
+ (begin
+ ((car daemons) group start end)
+ (loop (cdr daemons))))))
+
+(define (record-insertion! group start end)
+ (invoke-group-daemons! (group-insert-daemons group) group start end))
(define (add-group-insert-daemon! group daemon)
- (vector-set! group group-index:insert-daemons
- (cons daemon (vector-ref group group-index:insert-daemons))))
+ (vector-set! group
+ group-index:insert-daemons
+ (cons daemon (vector-ref group group-index:insert-daemons)))
+ unspecific)
(define (remove-group-insert-daemon! group daemon)
- (vector-set! group group-index:insert-daemons
- (delq! daemon (vector-ref group group-index:insert-daemons))))
+ (vector-set! group
+ group-index:insert-daemons
+ (delq! daemon (vector-ref group group-index:insert-daemons)))
+ unspecific)
(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)))
+ (invoke-group-daemons! (group-delete-daemons group) group start end))
(define (add-group-delete-daemon! group daemon)
- (vector-set! group group-index:delete-daemons
- (cons daemon (vector-ref group group-index:delete-daemons))))
+ (vector-set! group
+ group-index:delete-daemons
+ (cons daemon (vector-ref group group-index:delete-daemons)))
+ unspecific)
(define (remove-group-delete-daemon! group daemon)
- (vector-set! group group-index:delete-daemons
- (delq! daemon (vector-ref group group-index:delete-daemons))))
+ (vector-set! group
+ group-index:delete-daemons
+ (delq! daemon (vector-ref group group-index:delete-daemons)))
+ unspecific)
(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)))
+ (invoke-group-daemons! (group-clip-daemons group) group start end))
(define (add-group-clip-daemon! group daemon)
- (vector-set! group group-index:clip-daemons
- (cons daemon (vector-ref group group-index:clip-daemons))))
+ (vector-set! group
+ group-index:clip-daemons
+ (cons daemon (vector-ref group group-index:clip-daemons)))
+ unspecific)
(define (remove-group-clip-daemon! group daemon)
- (vector-set! group group-index:clip-daemons
- (delq! daemon (vector-ref group group-index:clip-daemons))))
+ (vector-set! group
+ group-index:clip-daemons
+ (delq! daemon (vector-ref group group-index:clip-daemons)))
+ unspecific)
\f
;;;; Marks
(define-named-structure "Mark"
group position left-inserting?)
-(declare (integrate make-mark %make-permanent-mark %%make-mark
- %set-mark-position! mark~))
+(define (guarantee-mark mark procedure-name)
+ (if (not (mark? mark)) (error "not a mark" mark procedure-name)))
-(define (make-mark group index)
- (declare (integrate group index))
- (%make-temporary-mark group index #!TRUE))
+(define-integrable (make-mark group index)
+ (%make-temporary-mark group index true))
-(define (%make-permanent-mark group index left-inserting?)
- (declare (integrate group index left-inserting?))
+(define-integrable (%make-permanent-mark group index left-inserting?)
(mark-permanent! (%make-temporary-mark group index left-inserting?)))
(define (%make-temporary-mark group index left-inserting?)
(group-index->position group index left-inserting?)
left-inserting?))
-(define (%%make-mark group position left-inserting?)
- (declare (integrate group position left-inserting?))
+(define-integrable (%%make-mark group position left-inserting?)
(let ((mark (%make-mark)))
(vector-set! mark mark-index:group group)
(vector-set! mark mark-index:position position)
(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-integrable (%set-mark-position! mark position)
+ (vector-set! mark mark-index:position position)
+ unspecific)
-(define (mark~ mark1 mark2)
- (declare (integrate mark1 mark2))
+(define-integrable (mark~ mark1 mark2)
(eq? (mark-group mark1) (mark-group mark2)))
+(define-integrable (mark/~ mark1 mark2)
+ (not (mark~ mark1 mark2)))
+
(define (mark-right-inserting mark)
(mark-permanent!
(if (mark-left-inserting? mark)
- (%make-temporary-mark (mark-group mark) (mark-index mark) #!FALSE)
+ (%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
+ (%make-temporary-mark (mark-group mark) (mark-index mark) true))))
+
;;; The marks list is cleaned every time that FOR-EACH-MARK! is
;;; called. It may be necessary to do this a little more often.
-;;; Group marks is a weak list of marks.
-
-(define weak-cons
- (let ((weak-cons-type (microcode-type 'WEAK-CONS)))
- (named-lambda (weak-cons car cdr)
- (system-pair-cons weak-cons-type car cdr))))
-
-(define %weak-car system-pair-car)
-(define %weak-cdr system-pair-cdr)
-(define %weak-set-cdr! system-pair-set-cdr!)
-
-(define (weak-member? object weak-list)
- (declare (integrate %weak-car %weak-cdr))
- (cond ((null? weak-list) #f)
- ((eq? object (%weak-car weak-list)) #t)
- (else (weak-member? object (%weak-cdr weak-list)))))
-
(define (mark-permanent! mark)
- (let ((marks (group-marks (mark-group mark))))
- (if (not (weak-member? mark marks))
- (vector-set! (mark-group mark) group-index:marks
- (weak-cons mark marks))))
+ (let ((group (mark-group mark)))
+ (let ((marks (group-marks group)))
+ (if (not (weak-memq mark marks))
+ (vector-set! group group-index:marks (weak-cons mark marks)))))
mark)
(define (for-each-mark group procedure)
- (declare (integrate %weak-car %weak-cdr %weak-set-cdr))
- (define (loop-1 marks)
+ (let loop
+ ((marks (group-marks group))
+ (set-holder!
+ (lambda (new-marks) (vector-set! group group-index:marks new-marks))))
(if (not (null? marks))
- (let ((mark (%weak-car marks)))
- (if mark
- (begin (procedure mark)
- (loop-2 marks (%weak-cdr marks)))
- (begin (vector-set! group group-index:marks (%weak-cdr marks))
- (loop-1 (%weak-cdr marks)))))))
-
- (define (loop-2 previous marks)
- (if (not (null? marks))
- (let ((mark (%weak-car marks)))
- (if mark
- (begin (procedure mark)
- (loop-2 marks (%weak-cdr marks)))
- (begin (%weak-set-cdr! previous (%weak-cdr (%weak-cdr previous)))
- (loop-2 previous (%weak-cdr previous)))))))
-
- (loop-1 (group-marks group)))
+ (loop (weak-cdr marks)
+ (let ((mark (weak-car marks)))
+ (if mark
+ (begin
+ (procedure mark)
+ (lambda (new-cdr) (weak-set-cdr! marks new-cdr)))
+ (begin
+ (set-holder! (weak-cdr marks))
+ set-holder!)))))))
\f
-(define (mark/~ mark1 mark2)
- (not (mark~ mark1 mark2)))
-
(define (mark= mark1 mark2)
(and (mark~ mark1 mark2)
(= (mark-index mark1) (mark-index mark2))))
(and (mark~ mark1 mark2)
(>= (mark-index mark1) (mark-index mark2))))
-(declare (integrate group-start group-end))
-
-(define (group-start mark)
- (declare (integrate mark))
+(define-integrable (group-start mark)
(group-start-mark (mark-group mark)))
-(define (group-end mark)
- (declare (integrate mark))
+(define-integrable (group-end mark)
(group-end-mark (mark-group mark)))
(define (group-start? mark)
(define (group-end? mark)
(group-end-index? (mark-group mark) (mark-index mark)))
-\f
-;;;; Regions
-(declare (integrate %make-region region-start region-end))
+;;;; Regions
-(define %make-region cons)
-(define region-start car)
-(define region-end cdr)
+(define-integrable %make-region cons)
+(define-integrable region-start car)
+(define-integrable 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))
+(define-integrable (region-group region)
(mark-group (region-start region)))
-(define (region-start-index region)
- (declare (integrate region))
+(define-integrable (region-start-index 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
+(define-integrable (region-end-index region)
+ (mark-index (region-end region)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/syntax.scm,v 1.66 1989/03/14 08:03:08 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; 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 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 often 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 #\\ "\\")
+This can be #T for comments that end in }, as in Pascal or C.
+It should be #F for comments that end in Newline, as in Lisp;
+this is because Newline occurs often when it doesn't indicate
+a comment ending."
+ false)
+
+(define-structure (syntax-table
+ ;; This is named to prevent reusing `syntax-table'
+ ;; variable to hold the tag (the default behavior).
+ (named (string->symbol "#[(edwin)syntax-table]"))
+ (constructor %make-syntax-table)
+ (conc-name syntax-table/))
+ (entries false read-only true))
+
+(define (guarantee-syntax-table syntax-table)
+ (if (not (syntax-table? syntax-table))
+ (error "not a syntax table" syntax-table))
+ syntax-table)
+
+(define (modify-syntax-entry! syntax-table char string)
+ (guarantee-syntax-table syntax-table)
+ (vector-set! (syntax-table/entries syntax-table)
+ (char->ascii char)
+ ((ucode-primitive string->syntax-entry) string))
+ unspecific)
+
+(define (modify-syntax-entries! syntax-table cl ch string)
+ (guarantee-syntax-table syntax-table)
+ (let ((entries (syntax-table/entries syntax-table))
+ (ah (char->ascii ch))
+ (entry ((ucode-primitive string->syntax-entry) string)))
+ (let loop ((a (char->ascii cl)))
+ (vector-set! entries a entry)
+ (if (< a ah) (loop (1+ a))))))
+
+(define make-syntax-table
+ (let ((standard-syntax-table
+ (%make-syntax-table
+ (make-vector 256 ((ucode-primitive string->syntax-entry) "")))))
+ (modify-syntax-entries! standard-syntax-table #\0 #\9 "w")
+ (modify-syntax-entries! standard-syntax-table #\A #\Z "w")
+ (modify-syntax-entries! standard-syntax-table #\a #\z "w")
+ (modify-syntax-entry! standard-syntax-table #\$ "w")
+ (modify-syntax-entry! standard-syntax-table #\% "w")
+ (modify-syntax-entry! standard-syntax-table #\( "()")
+ (modify-syntax-entry! standard-syntax-table #\) ")(")
+ (modify-syntax-entry! standard-syntax-table #\[ "(]")
+ (modify-syntax-entry! standard-syntax-table #\] ")[")
+ (modify-syntax-entry! standard-syntax-table #\{ "(}")
+ (modify-syntax-entry! standard-syntax-table #\} "){")
+ (modify-syntax-entry! standard-syntax-table #\" "\"")
+ (modify-syntax-entry! standard-syntax-table #\\ "\\")
(for-each (lambda (char)
- (modify-syntax-entry! table char "_"))
+ (modify-syntax-entry! standard-syntax-table char "_"))
(string->list "_-+*/&|<>="))
(for-each (lambda (char)
- (modify-syntax-entry! table char "."))
+ (modify-syntax-entry! standard-syntax-table char "."))
(string->list ".,;:?!#@~^'`"))
- (set! standard-syntax-table table)
- (set-variable! "Syntax Table" table)))
+ (lambda ()
+ (%make-syntax-table
+ (vector-copy (syntax-table/entries standard-syntax-table))))))
-;; **** compiler complains about assignment to unassigned variable for
-;; value unless this is here.
-'DONE
-)
+(define (initialize-syntax-table!)
+ (set-variable! "Syntax Table" (make-syntax-table)))
\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)))
+ (let loop ((start (mark-index mark)) (n n))
+ (let ((m
+ ((ucode-primitive scan-word-forward)
+ (syntax-table/entries (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)))
+ (else (loop m (-1+ 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)))
+ (let loop ((start (mark-index mark)) (n n))
+ (let ((m
+ ((ucode-primitive scan-word-backward)
+ (syntax-table/entries (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))
+ (else (loop m (-1+ n))))))))
-(define scan-forward-to-word
- (make-primitive scan-forward-to-word))
+(set! forward-word
+(named-lambda (forward-word mark n #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (%forward-word mark n limit?))
+ ((negative? n) (%backward-word mark (- n) limit?))
+ (else mark)))))
-(define scan-word-backward
- (make-primitive scan-word-backward))
+(set! backward-word
+(named-lambda (backward-word mark n #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (%backward-word mark n limit?))
+ ((negative? n) (%forward-word mark (- n) limit?))
+ (else mark)))))
-;; **** compiler complains about assignment to unassigned variable for
-;; value unless this is here.
-'DONE
)
+
+(define (forward-to-word mark #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?))
+ (index
+ ((ucode-primitive scan-forward-to-word)
+ (syntax-table/entries (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
;;;; Lisp Parsing
+(define-macro (default-end/forward start end)
+ `(COND ((DEFAULT-OBJECT? ,end) (GROUP-END ,start))
+ ((NOT (MARK<= ,start ,end)) (ERROR "END less than START" ,end))
+ (ELSE ,end)))
+
+(define-macro (default-end/backward start end)
+ `(COND ((DEFAULT-OBJECT? ,end) (GROUP-START ,start))
+ ((NOT (MARK>= ,start ,end)) (ERROR "END greater than START" ,end))
+ (ELSE ,end)))
+
+(define (backward-prefix-chars start #!optional end)
+ (make-mark (mark-group start)
+ ((ucode-primitive scan-backward-prefix-chars)
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ (mark-group start)
+ (mark-index start)
+ (mark-index (default-end/backward start end)))))
+
+(define (mark-right-char-quoted? mark)
+ ((ucode-primitive quoted-char?)
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ (mark-group mark)
+ (mark-index mark)
+ (group-start-index (mark-group mark))))
+
+(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)))
+\f
(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 ()
+(define (%forward-list start end depth sexp?)
+ (let ((index
+ ((ucode-primitive scan-list-forward)
+ (syntax-table/entries (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
+ ((ucode-primitive scan-list-backward)
+ (syntax-table/entries (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))))
+
(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)))
+ (%forward-list start (default-end/forward 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
+ (let ((end (default-end/backward start end)))
+ (let ((mark (%backward-list start end 0 true)))
+ (and mark (backward-prefix-chars mark end))))))
+
(set! forward-one-list
(named-lambda (forward-one-list start #!optional end)
- (cond ((unassigned? end) (set! end (group-end start)))
- ((not (mark<= start end)) (error "END less than START" end)))
- (%forward-list start end 0 #!FALSE)))
+ (%forward-list start (default-end/forward 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)))
+ (%backward-list start (default-end/backward 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)))
+ (%forward-list start (default-end/forward 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)))
+ (%backward-list start (default-end/backward 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)))
+ (%forward-list start (default-end/forward 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))))
+ (%backward-list start (default-end/backward start end) -1 false)))
-(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 (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 (set-parse-state-last-sexp! state value)
- (vector-set! state 4 value))
-
-(define (parse-state-containing-sexp state)
- (vector-ref state 5))
-(define (set-parse-state-containing-sexp! state value)
- (vector-set! state 5 value))
-
-(define (parse-state-location state)
- (vector-ref state 6))
-(define (set-parse-state-location! state value)
- (vector-set! state 6 value))
-
-(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 ()
+(define-structure (parse-state (type vector))
+ (depth false read-only true)
+ (in-string? false read-only true) ;#F or ASCII delimiter.
+ (in-comment? false read-only true) ;#F or 1 or 2.
+ (quoted? false read-only true)
+ (last-sexp false)
+ (containing-sexp false)
+ (location false))
-(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)))
+(define (forward-to-sexp-start mark end)
+ (parse-state-location (parse-partial-sexp mark end 0 true)))
+
+(define (parse-partial-sexp start end
+ #!optional target-depth stop-before? old-state)
+ (if (not (mark<= start end))
+ (error "Marks incorrectly related" start end))
+ (let ((target-depth
+ (if (or (default-object? target-depth) (not target-depth))
+ -1000000
+ target-depth))
+ (stop-before? (if (default-object? stop-before?) false stop-before?))
+ (old-state (if (default-object? old-state) false old-state))
+ (group (mark-group start)))
+ (let ((state
+ ((ucode-primitive scan-sexps-forward)
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ group
+ (mark-index start)
+ (mark-index end)
+ target-depth stop-before? old-state)))
;; Convert the returned indices to marks.
(if (parse-state-last-sexp state)
(set-parse-state-last-sexp!
(make-mark group (parse-state-last-sexp state))))
(if (parse-state-containing-sexp state)
(set-parse-state-containing-sexp!
- state
+ state
(make-mark group (parse-state-containing-sexp state))))
- (set-parse-state-location!
- state
- (make-mark group (parse-state-location state)))
- 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
-)
-
+ (set-parse-state-location! state
+ (make-mark group
+ (parse-state-location state)))
+ state)))
+
+(define (char->syntax-code char)
+ ((ucode-primitive char->syntax-code)
+ (syntax-table/entries (ref-variable "Syntax Table"))
+ char))
\f
;;;; Definition Start/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:
+ (and start (forward-one-definition-end start)))))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.29 1989/03/14 08:03:17 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; From GNU Emacs (thank you RMS)
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
-(define-command ("Visit Tags Table" argument)
+(define-command ("Visit Tags Table")
"Tell tags commands to use a given tags table file."
(set-variable!
"Tags Table Pathname"
"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 previous-find-tag-string
+ false)
-(define-command ("Generate Tags Table" argument)
+(define-command ("Generate Tags Table")
"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
(pathname-new-version pathname 'NEWEST)
pathname))
scheme-tag-regexp))))
+
+(define (&find-tag-command previous-tag? find-file)
+ (let ((buffer (tags-table-buffer)))
+ (if previous-tag?
+ (find-tag previous-find-tag-string
+ buffer
+ (buffer-point buffer)
+ find-file)
+ (let ((string (prompt-for-string "Find tag" previous-find-tag-string)))
+ (set! previous-find-tag-string string)
+ (find-tag string
+ buffer
+ (buffer-start buffer)
+ find-file)))))
\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))))
+ (let ((buffer
+ (or (pathname->buffer pathname)
+ (let ((buffer (new-buffer (pathname->buffer-name pathname))))
+ (read-buffer buffer pathname)
+ buffer))))
+ (if (and (not (verify-visited-file-modification-time buffer))
+ (prompt-for-yes-or-no?
+ "Tags file has changed, read new contents"))
+ (revert-buffer true true))
+ (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page))
+ (editor-error "File "
+ (pathname->string pathname)
+ " not a valid tag table")))))
(define (tag->pathname tag)
(define (loop mark)
\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))
+(define (find-tag string buffer start find-file)
+ (let ((tag
+ (let loop ((mark start))
+ (let ((mark (search-forward string mark)))
+ (and mark
+ (or (re-match-forward find-tag-match-regexp mark)
+ (loop mark)))))))
(if (not tag)
- (editor-failure "Tag not found")
- (let ((regexp
+ (editor-failure "No "
+ (if (group-start? start) "" "more ")
+ "entries containing "
+ string)
+ (let ((pathname
+ (merge-pathnames
+ (tag->pathname tag)
+ (pathname-directory-path (buffer-pathname buffer))))
+ (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"))))
+ (start
+ (-1+ (string->number (extract-string tag (line-end tag 0))))))
+ (find-file 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)))
+ (let ((mark
+ (let loop ((offset 1000))
+ (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)))))))
(if (not mark)
- (editor-failure "Tag no longer in file")
+ (editor-failure regexp
+ " not found in "
+ (pathname-name-string pathname))
(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)))
+ "[^\n\177]*\177")
\f
;;;; Tags Table Generation
\f
;;;; Tags Search
-(define-command ("Tags Search" argument)
+(define-command ("Tags Search")
"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]."
(set-variable! "Previous Search String" string)
(tags-search (re-quote-string string))))
-(define-command ("RE Tags Search" argument)
+(define-command ("RE Tags Search")
"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]."
(set-variable! "Previous Search Regexp" regexp)
(tags-search regexp)))
-(define-command ("Tags Query Replace" argument)
+(define-command ("Tags Query Replace")
"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]."
(set! tags-loop-done clear-message)
(tags-loop-start (tags-table-pathnames)))
-(define-command ("Tags Loop Continue" argument)
+(define-command ("Tags Loop Continue")
"Continue last \\[Tags Search] or \\[Tags Query Replace] command."
(let ((buffer (object-unhash tags-loop-buffer)))
(if (and (not (null? tags-loop-entry))
(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:
+ (file-finder identity-procedure))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/texcom.scm,v 1.30 1989/03/14 08:03:20 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Text Commands
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
(define-major-mode "Text" "Fundamental"
"Major mode for editing english text."
(define-variable "Text Mode Hook"
"If not false, a thunk to call when entering Text mode."
- #!FALSE)
+ false)
(define (turn-on-auto-fill)
(enable-current-minor-mode! fill-mode))
-(define-command ("Text Mode" argument)
+(define-command ("Text Mode")
"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)
+(define-command ("Indented Text Mode")
"Make the current mode be Indented Text mode."
(set-current-major-mode! indented-text-mode))
\f
\f
;;;; Case Conversion
-(define-command ("^R Uppercase Region" argument)
+(define-command ("^R Uppercase Region")
"Convert region to upper case."
(upcase-area (current-mark)))
-(define-command ("^R Lowercase Region" argument)
+(define-command ("^R Lowercase Region")
"Convert region to lower case."
(downcase-area (current-mark)))
(cond ((positive? argument)
(dotimes argument
(lambda (i)
+ i ;ignore
(capitalize-one-word))))
((negative? argument)
(let ((p (current-point)))
(set-current-point! (forward-word p argument 'ERROR))
(dotimes (- argument)
(lambda (i)
+ i ;ignore
(capitalize-one-word)))
(set-current-point! p)))))
\f
See \\[^R Forward Sentence] for more information."
(move-thing backward-sentence argument))
-(define-command ("^R Mark Sentence" (argument 1))
+(define-command ("^R Mark Sentence")
"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."
are not part of them."
(move-thing backward-paragraph argument))
-(define-command ("^R Mark Paragraph" argument)
+(define-command ("^R Mark Paragraph")
"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
+ (set-current-region! (make-region (backward-paragraph end 1 'ERROR) end))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/things.scm,v 1.75 1989/03/14 08:03:22 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Textual Entities
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
;;;; Motion Primitives
;;; 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.
+;;; the procedure should be either a mark or #F.
;;; If the number is positive, traverse that many FOOs in the given
;;; direction; if negative, in the opposite direction; and zero means
(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)))
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (%forward-thing mark n limit?))
+ ((negative? n) (%backward-thing mark (- n) limit?))
+ (else mark))))
+
+ (define (backward-thing mark n #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (%backward-thing mark n limit?))
+ ((negative? n) (%forward-thing mark (- n) limit?))
+ (else mark))))
(define (%forward-thing mark n limit?)
- (define (loop mark n)
+ (let loop ((mark mark) (n 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)))
+ (else (loop end (-1+ n)))))))
(define (%backward-thing mark n limit?)
- (define (loop mark n)
+ (let loop ((mark mark) (n 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))
+ (else (loop start (-1+ n)))))))
(receiver forward-thing backward-thing))
\f
(define (transpose-things forward-thing n)
(define (forward-once i)
+ i ;ignore
(let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR))))
(set-current-point! m4)
(let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR))))
(region-insert! m1 (region-extract! (make-region m2 m4))))))))
(define (backward-once i)
+ i ;ignore
(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))
\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)))
;; 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)))))
+ (let ((tab-width (ref-variable "Tab Width")))
+ (let ((qr1 (integer-divide c1 tab-width))
+ (qr2 (integer-divide c2 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))))
+ (let ((point
+ (if (default-object? 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)))
+ (let ((point (if (default-object? point) (current-point) 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))))))
+(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 (find-previous-blank-line mark)
+ (let ((start (line-start mark -1)))
+ (and start
+ (let loop ((mark start))
+ (cond ((line-blank? mark) mark)
+ ((group-start? mark) false)
+ (else (loop (line-start mark -1))))))))
+
+(define (find-next-blank-line mark)
+ (let ((start (line-start mark 1)))
+ (and start
+ (let loop ((mark start))
+ (cond ((line-blank? mark) mark)
+ ((group-start? mark) false)
+ (else (loop (line-start mark 1))))))))
+
+(define (find-previous-non-blank-line mark)
+ (let ((start (line-start mark -1)))
+ (and start
+ (let loop ((mark start))
+ (cond ((not (line-blank? mark)) mark)
+ ((group-start? mark) false)
+ (else (loop (line-start mark -1))))))))
+
+(define (find-next-non-blank-line mark)
+ (let ((start (line-start mark 1)))
+ (and start
+ (let loop ((mark start))
+ (cond ((not (line-blank? mark)) mark)
+ ((group-start? mark) false)
+ (else (loop (line-start mark 1))))))))
\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)))
+ (let ((point (if (default-object? point) (current-point) 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)))
+ (mark-indentation (if (default-object? point) (current-point) point)))
(define (mark-indentation mark)
(mark-column (indentation-end 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)))
+ (let ((point (if (default-object? point) (current-point) 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:
+(define forward-line)
+(define backward-line)
+(let ((%backward-line
+ (lambda (mark n limit?)
+ (line-start mark
+ (if (line-start? mark) (- n) (- 1 n))
+ limit?))))
+ (set! forward-line
+ (lambda (mark n #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (line-start mark n limit?))
+ ((negative? n) (%backward-line mark (- n) limit?))
+ (else mark)))))
+ (set! backward-line
+ (lambda (mark n #!optional limit?)
+ (let ((limit? (and (not (default-object? limit?)) limit?)))
+ (cond ((positive? n) (%backward-line mark n limit?))
+ ((negative? n) (line-start mark (- n) limit?))
+ (else mark)))))
+ unspecific)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tparse.scm,v 1.63 1989/03/14 08:03:26 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Text Parsing
(declare (usual-integrations))
-(using-syntax edwin-syntax-table
\f
;;;; Pages
(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))))
+ (let ((page-delimiter (ref-variable "Page Delimiter")))
+ (or (re-match-forward page-delimiter (line-start mark 0))
+ (if (re-search-backward 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)))
+ (set! backward-page b)
+ unspecific))
\f
;;;; 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)
+(define (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)))
-
-)
+ (let ((end (group-end mark))
+ (fill-prefix (ref-variable "Fill Prefix"))
+ (page-delimiter (ref-variable "Page Delimiter"))
+ (forward-kernel
+ (lambda (mark separator? skip-body)
+ (if (separator? (line-start mark 0))
+ (let ((para-start
+ (let skip-separators ((mark mark))
+ (let ((lstart (line-start mark 1)))
+ (and lstart
+ (if (separator? lstart)
+ (skip-separators lstart)
+ lstart))))))
+ (and para-start
+ (skip-body para-start)))
+ (skip-body mark)))))
+ (if (and fill-prefix
+ (not (string-null? fill-prefix)))
+ (let ((fill-prefix (re-quote-string fill-prefix)))
+ (let ((prefix
+ (string-append page-delimiter "\\|^" fill-prefix)))
+ (let ((start (string-append prefix "[ \t\n]"))
+ (separate (string-append prefix "[ \t]*$")))
+ (forward-kernel mark
+ (lambda (lstart)
+ (or (not (re-match-forward fill-prefix lstart))
+ (re-match-forward separate lstart)))
+ (letrec ((skip-body
+ (lambda (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)))))))
+ skip-body)))))
+ (let ((prefix (string-append page-delimiter "\\|")))
+ (let ((start
+ (string-append prefix (ref-variable "Paragraph Start")))
+ (separate
+ (string-append prefix
+ (ref-variable "Paragraph Separate"))))
+ (forward-kernel mark
+ (lambda (mark)
+ (re-match-forward separate mark))
+ (lambda (mark)
+ (if (re-search-forward start (line-end mark 0) end)
+ (re-match-start 0)
+ end)))))))))
\f
-(define backward-one-paragraph)
-(let ()
-
-(set! backward-one-paragraph
-(named-lambda (backward-one-paragraph mark)
+(define (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)))
-
-)
+ (let ((start (group-start mark))
+ (fill-prefix (ref-variable "Fill Prefix"))
+ (page-delimiter (ref-variable "Page Delimiter"))
+ (backward-kernel
+ (lambda (mark separator? skip-body)
+ (if (separator? (line-start mark 0))
+ (let ((para-start
+ (let skip-separators ((mark mark))
+ (let ((lstart (line-start mark -1)))
+ (and lstart
+ (if (separator? lstart)
+ (skip-separators lstart)
+ lstart))))))
+ (and para-start
+ (skip-body para-start)))
+ (skip-body mark)))))
+ (if (and fill-prefix
+ (not (string-null? fill-prefix)))
+ (let ((fill-prefix (re-quote-string fill-prefix)))
+ (let ((prefix
+ (string-append page-delimiter "\\|^" fill-prefix)))
+ (let ((starter (string-append prefix "[ \t\n]"))
+ (separator (string-append prefix "[ \t]*$")))
+ (backward-kernel mark
+ (lambda (lstart)
+ (or (not (re-match-forward fill-prefix lstart))
+ (re-match-forward separator lstart)))
+ (letrec ((skip-body
+ (lambda (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)))))))
+ skip-body)))))
+ (let ((prefix (string-append page-delimiter "\\|")))
+ (let ((starter
+ (string-append prefix (ref-variable "Paragraph Start")))
+ (separator
+ (string-append prefix
+ (ref-variable "Paragraph Separate"))))
+ (backward-kernel mark
+ (lambda (mark)
+ (re-match-forward separator mark))
+ (lambda (mark)
+ (if (re-search-backward starter mark start)
+ (re-match-start 0)
+ start)))))))))
\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)))
+ (set! backward-paragraph b)
+ unspecific))
(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)))
+ (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))))))))
+ (let ((fill-prefix (ref-variable "Fill Prefix")))
+ (if (and fill-prefix
+ (not (string-null? fill-prefix)))
+ (if (match-forward 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)))
(let ((mark (re-search-forward (ref-variable "Sentence End")
mark end)))
(if mark
- (skip-chars-backward " \t\n" mark (re-match-start 0) #!FALSE)
+ (skip-chars-backward " \t\n" mark (re-match-start 0) false)
end)))))
(define (backward-one-sentence mark)
(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:
+ (set! backward-sentence b)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tximod.scm,v 1.10 1989/03/14 08:03:31 cph Exp $
+;;;
+;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Texinfo Mode
(declare (usual-integrations))
-(using-syntax (access edwin-syntax-table edwin-package)
\f
-(define-command ("Texinfo Mode" argument)
+(define-command ("Texinfo Mode")
"Make the current mode be Texinfo mode."
(set-current-major-mode! texinfo-mode))
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)
(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:
+(modify-syntax-entry! texinfo-mode:syntax-table #\' "w")
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/undo.scm,v 1.43 1989/03/14 08:03:33 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Undo, translated from the GNU Emacs implementation in C.
-(declare (usual-integrations)
- )
-(using-syntax edwin-syntax-table
+(declare (usual-integrations))
\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))
+;;;; Basic Record Keeping
-(define initial-undo-records 8)
-(define initial-undo-chars 128)
-(define maximum-undo-records 512)
-(define maximum-undo-chars 8192)
+(define-integrable initial-undo-records 8)
+(define-integrable initial-undo-chars 128)
+(define-integrable maximum-undo-records 512)
+(define-integrable maximum-undo-chars 8192)
-(define-named-structure "Undo-Data"
+(define-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-structure (undo-record
+ (type vector)
+ (constructor %make-undo-record ()))
+ (type false)
+ (start false)
+ (length false))
-(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)
+(define-integrable (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)
+(define last-undo-group false)
+(define last-undo-record false)
-(set! enable-group-undo!
-(named-lambda (enable-group-undo! group)
+(define (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))))))
-
+ (set-group-undo-data!
+ group
+ (make-undo-data (let ((records (make-vector initial-undo-records false)))
+ (mark-not-undoable!
+ (let ((max-index (-1+ initial-undo-records)))
+ (undo-records-ref records max-index)))
+ records)
+ 0
+ (string-allocate initial-undo-chars)
+ 0)))))
+\f
(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))
+ (let ((records (undo-data-records undo-data))
+ (index (undo-data-next-record undo-data)))
+ (let ((undo-record (undo-records-ref records index)))
+ (set-undo-record-type! undo-record type)
+ (set-undo-record-start! undo-record start)
+ (set-undo-record-length! undo-record length)
+ (set! last-undo-record undo-record))
+ (let ((next (1+ index)))
+ (cond ((< next (vector-length records))
+ (mark-not-undoable! (undo-records-ref records next))
+ (set-undo-data-next-record! undo-data next))
((>= next maximum-undo-records)
- (vector-set! undo-data undo-data-index:next-record 0))
+ (mark-not-undoable! (vector-ref records 0))
+ (set-undo-data-next-record! undo-data 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))
+ (let ((new-records (make-vector maximum-undo-records false))
+ (length (vector-length records))
+ (new-record (%make-undo-record))
+ (max-record (%make-undo-record)))
+ (subvector-move-right! records 0 length new-records 0)
+ (mark-not-undoable! new-record)
+ (mark-not-undoable! max-record)
+ (vector-set! new-records length new-record)
+ (vector-set! new-records (-1+ maximum-undo-records) max-record)
+ (set-undo-data-records! undo-data new-records)
+ (set-undo-data-next-record! undo-data next))))))
(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-integrable (mark-not-undoable! record)
+ (set-undo-record-type! record 'NOT-UNDOABLE))
(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)))))))
+ (let loop ((start start))
+ (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)
+ (set-undo-data-next-char! undo-data (+ i needed))
+ (set! number-chars-left (- number-chars-left needed)))
+ ((= room needed)
+ (substring-move-right! string start end chars i)
+ (set-undo-data-next-char! undo-data 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)
+ (set-undo-data-chars! undo-data new-chars))
+ (set! number-chars-left
+ (+ (- maximum-undo-chars (string-length chars))
+ number-chars-left))
+ (loop start))
+ (else
+ (let ((new-start (+ start room)))
+ (substring-move-right! string start new-start chars i)
+ (set-undo-data-next-char! undo-data 0)
+ (set! number-chars-left (- number-chars-left room))
+ (loop new-start))))))))
\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
+;;; 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)
+(define (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)
+ (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 ((last last-undo-record)
+ (length (- end start)))
+ (if (and last
+ (eq? 'DELETE (undo-record-type last))
+ (= start
+ (+ (undo-record-start last)
+ (undo-record-length last))))
+ (set-undo-record-length! last
+ (+ length (undo-record-length last)))
+ (new-undo! undo-data 'DELETE group start length)))))))
+
+(define (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))))))
+ (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 ((last last-undo-record)
+ (length (- end start)))
+ (if (and last
+ (eq? 'INSERT (undo-record-type last))
+ (= start (undo-record-start last)))
+ (set-undo-record-length! last
+ (+ length (undo-record-length last)))
+ (new-undo! undo-data 'INSERT group start length)))
+ (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)))))))))
\f
-(set! undo-boundary!
-(named-lambda (undo-boundary! point)
+(define (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)))))))))
+ (undo-mark-previous! undo-data
+ 'BOUNDARY
+ group
+ (mark-index point))))))))
-(set! undo-done!
-(named-lambda (undo-done! point)
+(define (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)))))))))
+ (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))))
+(define-integrable (undo-mark-previous! undo-data type group start)
+ (let ((records (undo-data-records undo-data)))
+ (let ((index
+ (let ((next (undo-data-next-record undo-data)))
+ (-1+ (if (zero? next)
+ (vector-length records)
+ next)))))
+ (let ((record (vector-ref records index)))
+ (if record
+ (if (not (eq? type (undo-record-type record)))
+ (new-undo! undo-data type group start 0))
+ (begin
+ (vector-set! records index (%make-undo-record))
+ (new-undo! undo-data type group start 0)))))))
\f
;;;; Undo Command
(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))
(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))))
+ (set! argument (1+ argument))
+ unspecific))
(undo-n-records undo-data
buffer
(count-records-to-undo undo-data argument))))
\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 find-nth-boundary ((argument argument) (i last-undone-record) (n 0))
+ (let find-boundary ((i i) (n n) (any-records? false))
(let ((i (-1+ (if (zero? i) (vector-length records) i)))
(n (1+ n)))
(set! number-records-undone (1+ number-records-undone))
((BOUNDARY)
(if (= argument 1)
n
- (find-nth-previous-boundary (-1+ argument) i n)))
+ (find-nth-boundary (-1+ argument) i n)))
((NOT-UNDOABLE)
(if (and (= argument 1) any-records?)
;; In this case treat it as if there were a
(undo-record-length (vector-ref records i))))
(if (negative? number-chars-left)
(editor-error no-more-undo)
- (find-previous-boundary i n #!TRUE)))
+ (find-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
+ (find-boundary i n true)))))))))
+
(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)
+ (let loop ((n n))
(if (positive? n)
(let ((ir (-1+ (if (zero? last-undone-record)
(vector-length records)
(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))
+ (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
((eq? 'UNMODIFY type)
(buffer-not-modified! buffer))
((eq? 'BOUNDARY type) 'DONE)
- (else
- (error "Losing undo record type" type))))
+ (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:
+ (loop (-1+ n)))))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.10 1989/03/14 08:03:41 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
(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 (read-line #!optional port)
+ (read-string char-set:return
+ (if (default-object? port)
+ (current-input-port)
+ (guarantee-input-port port))))
(define (y-or-n? . strings)
(define (loop)
(cond ((or (char=? char #\Y)
(char=? char #\Space))
(write-string "Yes")
- #!TRUE)
+ true)
((or (char=? char #\N)
(char=? char #\Rubout))
(write-string "No")
- #!FALSE)
+ false)
(else
- (beep)
+ (editor-beep)
(loop)))))
(newline)
- (write-string (apply string-append strings))
+ (for-each write-string strings)
(loop))
-;;; Edwin Variables:
-;;; Scheme Environment: edwin-package
-;;; End:
+(define (char-controlify char)
+ (make-char (char-code char) (controlify (char-bits char))))
+
+(define (char-metafy char)
+ (make-char (char-code char) (metafy (char-bits char))))
+
+(define (char-control-metafy char)
+ (make-char (char-code char) (controlify (metafy (char-bits char)))))
+
+(define (char-base char)
+ (make-char (char-code char) 0))
+
+(define (controlify i)
+ (if (odd? (quotient i 2)) i (+ i 2)))
+
+(define (metafy i)
+ (if (odd? i) i (1+ i)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utlwin.scm,v 1.50 1989/03/14 08:03:43 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
;;;; Utility Windows
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
;;;; String Window
;;; This "mixin" defines a common base from which 2D text string
(define-method string-base (:update-display! window screen x-start y-start
xl xu yl yu display-style)
+ window display-style ;ignore
(cond ((pair? representation)
(cond ((not (cdr representation))
;; disable clipping.
(else
(screen-write-substrings! screen (+ x-start xl) (+ y-start yl)
representation xl xu yl yu)))
- #!TRUE)
+ 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))))
+(define (string-base:set-size-given-x! window x)
+ (with-instance-variables string-base window (x)
+ (set! x-size x)
+ (set! y-size (string-base:desired-y-size window x))
+ (string-base:refresh! window)))
+
+(define (string-base:set-size-given-y! window y)
+ (with-instance-variables string-base window (y)
+ (set! x-size (string-base:desired-x-size window y))
+ (set! y-size y)
+ (string-base:refresh! window)))
+
+(define-integrable (string-base:desired-x-size window y-size)
+ (with-instance-variables string-base window (y-size)
+ (column->x-size (image-column-size image) y-size)))
+
+(define-integrable (string-base:desired-y-size window x-size)
+ (with-instance-variables string-base window (x-size)
+ (column->y-size (image-column-size image) x-size)))
+
+(define (string-base:index->coordinates window index)
+ (with-instance-variables string-base window (index)
+ (column->coordinates (image-column-size image)
+ x-size
+ (image-index->column image index))))
+
+(define (string-base:index->x window index)
+ (with-instance-variables string-base window (index)
+ (column->x (image-column-size image)
+ x-size
+ (image-index->column image index))))
+
+(define (string-base:index->y window index)
+ (with-instance-variables string-base window (index)
+ (column->y (image-column-size image)
+ x-size
+ (image-index->column image index))))
+
+(define (string-base:coordinates->index window x y)
+ (with-instance-variables string-base 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.
(-1+ (integer-divide-quotient qr))
(integer-divide-quotient qr))))))
-(define (coordinates->column x y x-size)
+(define-integrable (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
+(define (string-base:direct-output-insert-char! window x char)
+ (with-instance-variables string-base 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 (string-base:direct-output-insert-newline! window)
+ (with-instance-variables string-base window ()
+ (set! y-size 1)
+ (set! representation (cons "" false))))
+
+(define (string-base:direct-output-insert-substring! window x string start end)
+ (with-instance-variables string-base 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 (string-base:refresh! window)
+ (with-instance-variables string-base 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 (make-vector 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)
+ window display-style ;ignore
(subscreen-clear! screen
(+ x-start xl) (+ x-start xu)
(+ y-start yl) (+ y-start yu))
- #!TRUE)
+ true)
;;;; Vertical Border Window
(define-method vertical-border-window (:initialize! window window*)
(usual=> window :initialize! window*)
- (set! x-size 1))
+ (set! x-size 1)
+ unspecific)
(define-method vertical-border-window (:set-x-size! window x)
+ window ;ignore
(error "Can't change the x-size of a vertical border window" x))
(define-method vertical-border-window (:set-size! window x y)
(define-method vertical-border-window
(:update-display! window screen x-start y-start
xl xu yl yu display-style)
+ display-style ;ignore
(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)
+ (let loop ((y (+ y-start yl)))
(if (< y yu)
- (begin (screen-write-char! screen xl y #\|)
- (loop (1+ y)))))
- (loop (+ y-start yl))))))
- #!TRUE)
+ (begin
+ (screen-write-char! screen xl y #\|)
+ (loop (1+ y)))))))))
+ true)
\f
;;;; Cursor Window
(usual=> window :initialize! window*)
(set! x-size 1)
(set! y-size 1)
- (set! enabled? #!FALSE))
+ (set! enabled? false)
+ unspecific)
(define-method cursor-window (:set-x-size! window x)
+ window ;ignore
(error "Can't change the size of a cursor window" x))
(define-method cursor-window (:set-y-size! window y)
+ window ;ignore
(error "Can't change the size of a cursor window" y))
(define-method cursor-window (:set-size! window x y)
+ window ;ignore
(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)
+ display-style ;ignore
(if (and enabled? (< xl xu) (< yl yu)) (screen-write-cursor! screen x-start y-start))
- #!TRUE)
+ true)
(define-method cursor-window (:enable! window)
- (set! enabled? #!TRUE)
+ (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:
+ (set! enabled? false)
+ (set-car! redisplay-flags false)
+ unspecific)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/wincom.scm,v 1.89 1989/03/14 08:03:47 cph Exp $
+;;;
+;;; Copyright (c) 1987, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; 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.
(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
(let ((window (current-window)))
(let ((size (window-y-size window)))
(if (not argument)
- (window-redraw! window false)
+ (begin
+ (window-redraw! window false)
+ (update-window-screen! window true))
(window-scroll-y-absolute! window
(let ((n (remainder argument size)))
(if (negative? n)
(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)
+ (buffer-end (window-buffer window)))) ((if (default-object? limit) editor-error limit))
(window-scroll-y-relative! window n)))
(define (standard-scroll-window-argument window argument factor)
"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)
+ (screen-inverse-video!
(or (positive? argument)
(not (or (negative? argument)
- ((access screen-inverse-video! window-package) false)))))
- (update-alpha-window! true))
+ (screen-inverse-video! false)))))
+ (update-screens! true))
-(define-command ("What Cursor Position" argument)
+(define-command ("What Cursor Position")
"Print various things about where cursor is.
Print the X position, the Y position,
the ASCII code for the following character,
(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))))))
+ ""
+ (let ((char (mark-right-char point)))
+ (string-append "Char: " (char-name char)
+ " (0"
+ (number->string (char->ascii char)
+ '(HEUR (RADIX O S)
+ (EXACTNESS S)))
+ ") ")))
+ "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
"Makes current window ARG columns narrower."
(disallow-typein)
(window-grow-horizontally! (current-window) (- argument)))
-\f
-(define-command ("^R Delete Window" argument)
+
+(define-command ("^R Delete Window")
"Delete the current window from the screen."
(window-delete! (current-window)))
-(define-command ("^R Delete Other Windows" argument)
+(define-command ("^R Delete Other Windows")
"Make the current window fill the screen."
(delete-other-windows (current-window)))
If there is only one window, it is split regardless of this value."
500)
-(define-command ("Kill Pop Up Buffer" argument)
+(define-command ("Kill Pop Up Buffer")
"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*))
(kill-buffer-interactive buffer)
(editor-error "No previous pop up buffer"))))
-(define *previous-popped-up-buffer*
- (object-hash false))
+(define *previous-popped-up-buffer* (object-hash false))
+(define *previous-popped-up-window* (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))
+ (let ((select? (and (not (default-object? select?)) select?)))
+ (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 true)
+ (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)))))
+ (let loop ((window (window1+ start)))
+ (and (not (eq? window start))
+ (if (eq? buffer (window-buffer window))
+ window
+ (loop (window1+ window))))))))
(define (largest-window)
(let ((start (window0)))
(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:
+ (loop (window1+ start)))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/window.scm,v 1.145 1989/03/14 08:03:51 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;;; Window System
-(declare (usual-integrations)
- )
-(using-syntax class-syntax-table
+(declare (usual-integrations))
\f
;;; Based on WINDOW-WIN, designed by RMS.
-;;; See ED:-WINOPS.TXT for more information.
+;;; See WINOPS.TXT for more information.
;;; The convention of using method names like :FOO is somewhat
;;; arbitrary. However, methods without the prefix ":" are intended
;;; 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
+;;; 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))
+(define (window-initialize! window window*)
+ (with-instance-variables vanilla-window window (window*)
+ (set! superior window*)
+ (set! redisplay-flags (=> superior :inferior-redisplay-flags window))
+ (set! inferiors '())
+ unspecific))
+
+(define (window-kill! window)
+ (for-each-inferior-window window (lambda (window) (=> window :kill!))))
+
+(define-integrable (window-superior window)
+ (with-instance-variables vanilla-window window () superior))
+
+(define (set-window-superior! window window*)
+ (with-instance-variables vanilla-window 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 (window-root-window window)
+ (with-instance-variables vanilla-window window ()
+ (if superior (window-root-window superior) window)))
+
+(define-integrable (window-x-size window)
+ (with-instance-variables vanilla-window window () x-size))
+
+(define (set-window-x-size! window x)
+ (with-instance-variables vanilla-window window (x)
+ (%set-window-x-size! window x)
+ (setup-redisplay-flags! redisplay-flags)))
+
+(define-integrable (%set-window-x-size! window x)
+ (with-instance-variables vanilla-window window (x)
+ (set! x-size x)
+ unspecific))
+
+(define-integrable (window-y-size window)
+ (with-instance-variables vanilla-window window () y-size))
+
+(define (set-window-y-size! window y)
+ (with-instance-variables vanilla-window window (y)
+ (%set-window-y-size! window y)
+ (setup-redisplay-flags! redisplay-flags)))
+
+(define-integrable (%set-window-y-size! window y)
+ (with-instance-variables vanilla-window window (y)
+ (set! y-size y)
+ unspecific))
\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-absolute-position window receiver
- fail)
- (if (eq? window the-alpha-window)
- (receiver 0 0)
- (=> superior :inferior-absolute-position window receiver fail)))
-
-(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))
+(define (window-size window receiver)
+ (with-instance-variables vanilla-window window (receiver)
+ (receiver x-size y-size)))
+
+(define (set-window-size! window x y)
+ (with-instance-variables vanilla-window window (x y)
+ (set! x-size x)
+ (set! y-size y)
+ (setup-redisplay-flags! redisplay-flags)))
+
+(define-integrable (window-redisplay-flags window)
+ (with-instance-variables vanilla-window window () redisplay-flags))
+
+(define-integrable (%window-needs-redisplay? window)
+ (with-instance-variables vanilla-window window () (car redisplay-flags)))
+
+(define-integrable (window-inferiors window)
+ (with-instance-variables vanilla-window window () inferiors))
+
+(define-integrable (window-inferior? window window*)
+ (with-instance-variables vanilla-window window (window*)
+ (find-inferior? inferiors window*)))
+
+(define-integrable (window-inferior window window*)
+ (with-instance-variables vanilla-window window (window*)
+ (find-inferior inferiors window*)))
+
+(define (for-each-inferior window procedure)
+ (with-instance-variables vanilla-window window (procedure)
+ (let loop ((inferiors inferiors))
+ (if (not (null? inferiors))
+ (begin
+ (procedure (car inferiors))
+ (loop (cdr inferiors)))))))
+
+(define (for-each-inferior-window window procedure)
+ (for-each-inferior window
+ (lambda (inferior) (procedure (inferior-window inferior)))))
+
+(define (make-inferior window class)
+ (with-instance-variables vanilla-window 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 (add-inferior! window window*)
+ (with-instance-variables vanilla-window window (window*)
+ (set! inferiors
+ (cons (cons window*
+ (vector false
+ false
+ (cons false redisplay-flags)))
+ inferiors))
+ (=> window* :set-superior! window)))
+
+(define (delete-inferior! window window*)
+ (with-instance-variables vanilla-window window (window*)
+ (set! inferiors
+ (delq! (find-inferior inferiors window*)
+ inferiors))))
+
+(define (replace-inferior! window old new)
+ (with-instance-variables vanilla-window 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
+;;; Returns #T if the redisplay finished, #F 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))))
- (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 (update-inferiors! window screen x-start y-start xl xu yl yu
+ display-style)
+ (with-instance-variables vanilla-window window
+ (screen x-start y-start xl xu yl yu display-style)
+ (let loop ((inferiors inferiors))
+ (if (null? inferiors)
+ true
+ (let ((window (inferior-window (car inferiors)))
+ (xi (inferior-x-start (car inferiors)))
+ (yi (inferior-y-start (car inferiors)))
+ (flags (inferior-redisplay-flags (car inferiors))))
+ (let ((continue
+ (lambda ()
+ (set-car! flags false)
+ (loop (cdr inferiors)))))
+ (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)))
+ (continue))
+ (continue))))))))
(define (clip-window-region xl xu yl yu xi xs yi ys receiver)
(clip-window-region-1 (- xl xi) (- xu xi) xs
(if (positive? al)
(if (<= al bs)
(receiver al (if (< bs au) bs au))
- #!TRUE)
+ 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))
+ true)))
+
+(define (salvage-inferiors! window)
+ (for-each-inferior-window window (lambda (window) (=> window :salvage!))))
\f
;;;; Standard Methods
-;;; All windows should support these operations
+;;; All windows support these operations
(define-method vanilla-window :initialize! window-initialize!)
(define-method vanilla-window :kill! window-kill!)
(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*)
(define-method vanilla-window (:set-inferior-start! window window* x y)
(set-inferior-start! (find-inferior inferiors window*) x y))
-
-(define-method vanilla-window (:inferior-absolute-position window window*
- receiver fail)
- (inferior-absolute-position (find-inferior inferiors window*) receiver fail))
-
\f
;;;; Inferiors
(define (set-inferior-position! inferior position)
(if (not position)
- (set-inferior-start! inferior #!FALSE #!FALSE)
+ (set-inferior-start! inferior false false)
(set-inferior-start! inferior (car position) (cdr position))))
-(define (inferior-absolute-position inferior receiver fail)
- (if (and (inferior-x-start inferior)
- (inferior-y-start inferior))
- (window-absolute-position (window-superior (inferior-window inferior))
- (lambda (x y)
- (receiver
- (+ x (inferior-x-start inferior))
- (+ y (inferior-y-start inferior))))
- fail)
- (fail)))
-
(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)))
+ (set-car! (inferior-redisplay-flags inferior) false))
+ unspecific)
(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!))
+ (begin
+ (set-car! flags true)
+ (setup-redisplay-flags! (cdr flags)))))
-(define (inferior-x-size inferior)
- (declare (integrate inferior))
+(define-integrable (inferior-x-size inferior)
(window-x-size (inferior-window inferior)))
-(define (%set-inferior-x-size! inferior x)
- (declare (integrate inferior x))
+(define-integrable (%set-inferior-x-size! inferior x)
(%set-window-x-size! (inferior-window inferior) x))
-(define (set-inferior-x-size! inferior x)
- (declare (integrate inferior x))
+(define-integrable (set-inferior-x-size! inferior x)
(=> (inferior-window inferior) :set-x-size! x))
-(define (inferior-y-size inferior)
- (declare (integrate inferior))
+(define-integrable (inferior-y-size inferior)
(window-y-size (inferior-window inferior)))
-(define (%set-inferior-y-size! inferior y)
- (declare (integrate inferior y))
+(define-integrable (%set-inferior-y-size! inferior y)
(%set-window-y-size! (inferior-window inferior) y))
-(define (set-inferior-y-size! inferior y)
- (declare (integrate inferior y))
+(define-integrable (set-inferior-y-size! inferior y)
(=> (inferior-window inferior) :set-y-size! y))
-(define (inferior-size inferior receiver)
- (declare (integrate inferior receiver))
+(define-integrable (inferior-size inferior receiver)
(window-size (inferior-window inferior) receiver))
-(define (set-inferior-size! inferior x y)
- (declare (integrate inferior x y))
+(define-integrable (set-inferior-size! 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))
+(define-integrable (find-inferior? inferiors window)
(assq window inferiors))
-(define (find-inferior inferiors window)
- (declare (integrate inferiors window))
+(define-integrable (find-inferior 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-integrable inferior-window car)
+(define-integrable set-inferior-window! set-car!)
-(define (inferior-x-start inferior)
- (declare (integrate inferior))
+(define-integrable (inferior-x-start inferior)
(vector-ref (cdr inferior) 0))
-(define (%set-inferior-x-start! inferior x-start)
- (vector-set! (cdr inferior) 0 x-start))
+(define-integrable (%set-inferior-x-start! inferior x-start)
+ (vector-set! (cdr inferior) 0 x-start)
+ unspecific)
(define (set-inferior-x-start! inferior x-start)
(%set-inferior-x-start! inferior x-start)
(define (inferior-x-end inferior)
(let ((x-start (inferior-x-start inferior)))
- (and x-start (+ x-start (inferior-x-size 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))
+
+(define-integrable (inferior-y-start inferior)
(vector-ref (cdr inferior) 1))
-(define (%set-inferior-y-start! inferior y-start)
- (vector-set! (cdr inferior) 1 y-start))
+(define-integrable (%set-inferior-y-start! inferior y-start)
+ (vector-set! (cdr inferior) 1 y-start)
+ unspecific)
(define (set-inferior-y-start! inferior y-start)
(%set-inferior-y-start! inferior y-start)
(define (inferior-y-end inferior)
(let ((y-start (inferior-y-start inferior)))
- (and y-start (+ y-start (inferior-y-size 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))))
(receiver (inferior-x-start inferior)
(inferior-y-start inferior)))
-(define (set-inferior-start-no-redisplay! inferior x-start y-start)
- (vector-set! (cdr inferior) 0 x-start)
- (vector-set! (cdr inferior) 1 y-start))
-
(define (set-inferior-start! inferior x-start y-start)
- (set-inferior-start-no-redisplay! 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))
+(define-integrable (inferior-redisplay-flags 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:
+(define-integrable (set-inferior-redisplay-flags! inferior flags)
+ (vector-set! (cdr inferior) 2 flags)
+ unspecific)
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1985 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xform.scm,v 1.4 1989/03/14 08:04:03 cph Exp $
+;;;
+;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; 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
+;;; 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
;;; 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
+;;; 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
(declare (usual-integrations))
\f
-(define transform-instance-variables)
-(let ()
-
-(set! transform-instance-variables
-(named-lambda (transform-instance-variables transforms name expression)
+(define (transform-instance-variables transforms name free expression)
(fluid-let ((name-of-self name))
- (transform-expression transforms expression))))
+ (transform-expression (remove-transforms transforms free) expression)))
(define name-of-self)
(define (transform-expression transforms expression)
- ((transform-dispatch expression) transforms expression))
+ ((scode-walk scode-walker expression) transforms expression))
(define (transform-expressions transforms expressions)
(define (transform-expression-loop expressions)
(cons (car transforms)
(loop (cdr transforms))))))
(loop transforms))
-\f
+
(define (transform-constant transforms constant)
+ transforms
constant)
(define (transform-variable transforms variable)
(lambda (operator operands)
(make-combination (transform-expression transforms operator)
(transform-expressions transforms operands)))))
-
+\f
(define (transform-lambda transforms lambda)
(lambda-components** lambda
(lambda (pattern bound body)
(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-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
+(define scode-walker
+ (make-scode-walker transform-constant
+ `((ASSIGNMENT ,transform-assignment)
+ (COMBINATION ,transform-combination)
+ (COMMENT ,transform-comment)
+ (CONDITIONAL ,transform-conditional)
+ (DEFINITION ,transform-definition)
+ (DELAY ,transform-delay)
+ (DISJUNCTION ,transform-disjunction)
+ (LAMBDA ,transform-lambda)
+ (OPEN-BLOCK ,transform-open-block)
+ (SEQUENCE ,transform-sequence)
+ (VARIABLE ,transform-variable))))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; Copyright (c) 1986 Massachusetts Institute of Technology
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.99 1989/03/14 08:02:16 cph Exp $
+;;;
+;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
\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.
-
- ))
+(define-macro (define-enumeration name prefix . suffixes)
+ `(BEGIN
+ ,@(let loop ((n 0) (suffixes suffixes))
+ (if (null? suffixes)
+ '()
+ (cons `(DEFINE-INTEGRABLE ,(symbol-append prefix (car suffixes))
+ ,n)
+ (loop (1+ n) (cdr suffixes)))))
+ (DEFINE ,name
+ (VECTOR ,@(map (lambda (suffix) `',suffix) suffixes)))))
+
+(define-enumeration re-codes re-code:
+
+ ;; Zero bytes may appear in the compiled regular expression.
+ unused
+
+ ;; Followed by a single literal byte.
+ exact-1
+
+ ;; Followed by one byte giving n, and then by n literal bytes.
+ exact-n
+
+ line-start ;Fails unless at start of line.
+ line-end ;Fails unless at end of line.
+
+ ;; Followed by two bytes giving relative address to jump to.
+ jump
+
+ ;; Followed by two bytes giving relative address of place to result
+ ;; at in case of failure.
+ on-failure-jump
+
+ ;; Throw away latest failure point and then jump to address.
+ 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.
+ maybe-finalize-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.
+ dummy-failure-jump
+
+ ;; Matches any one character except for newline.
+ any-char
+
+ ;; 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.
+ char-set
+
+ ;; Similar but match any character that is NOT one of those
+ ;; specified.
+ not-char-set
+
+ ;; 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.
+ start-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.
+ stop-memory
+
+ ;; Match a duplicate of something remembered. Followed by one byte
+ ;; containing the index of the memory register.
+ duplicate
+
+ 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.
+
+ ;; Matches any character whose syntax is specified. Followed by a
+ ;; byte which contains a syntax code.
+ syntax-spec
+
+ ;; Matches any character whose syntax differs from the specified.
+ not-syntax-spec
+ )
\f
;;;; String Compiler
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)))))
+ (let ((string (if case-fold? (string-upcase string) 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))))))))
+ (let loop ((n n) (i 0) (p 0))
+ (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 (+ i n) result (+ p 2))
+ result)
+ (else
+ (vector-8b-set! result p re-code:exact-n)
+ (vector-8b-set! result (1+ p) 255)
+ (let ((j (+ i 255)))
+ (substring-move-right! string i j result (+ p 2))
+ (loop (- n 255) j (+ p 257)))))))))))
\f
;;;; Char-Set Compiler
-(define re-compile-char-set)
-(let ()
-
-(set! re-compile-char-set
-(named-lambda (re-compile-char-set pattern negate?)
+(define (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)))
+ (let ((kernel
+ (lambda (start background foreground)
+ (let ((adjoin!
+ (lambda (ascii)
+ (vector-8b-set! char-set ascii foreground))))
+ (vector-8b-fill! char-set 0 256 background)
+ (let loop
+ ((pattern
+ (quote-pattern (substring->list pattern start length))))
+ (cond ((null? pattern)
+ unspecific)
+ ((null? (cdr pattern))
+ (adjoin! (char->ascii (car pattern))))
+ ((char=? (cadr pattern) #\-)
+ (if (not (null? (cddr pattern)))
+ (begin
+ (let ((end (char->ascii (caddr pattern))))
+ (let loop ((index (char->ascii (car pattern))))
+ (if (< index end)
+ (begin
+ (vector-8b-set! char-set
+ index
+ foreground)
+ (loop (1+ index))))))
+ (loop (cdddr pattern)))
+ (error "RE-COMPILE-CHAR-SET: Terminating hyphen")))
+ (else
+ (adjoin! (char->ascii (car pattern)))
+ (loop (cdr pattern)))))))))
+ (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"))
+ ((not (null? (cdr pattern)))
+ (cons (cadr pattern) (quote-pattern (cddr pattern))))
(else
- (cons (cadr pattern)
- (quote-pattern (cddr pattern))))))
-
-)
+ (error "RE-COMPILE-CHAR-SET: Terminating backslash"))))
\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)))))
-
-)
+(define re-translation-table
+ (let ((normal-table (make-string 256)))
+ (let loop ((n 0))
+ (if (< n 256)
+ (begin
+ (vector-8b-set! normal-table n n)
+ (loop (1+ n)))))
+ (let ((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)))))
+ (lambda (case-fold?)
+ (if case-fold? upcase-table normal-table)))))
\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 re-number-of-registers
+ 10)
-(define stack-maximum-length re-number-of-registers)
+(define-integrable stack-maximum-length
+ re-number-of-registers)
(define input-list)
(define current-byte)
(define pending-exact)
(define last-start)
-(set! re-compile-pattern
-(named-lambda (re-compile-pattern pattern case-fold?)
+(define (re-compile-pattern pattern case-fold?)
(let ((output (list 'OUTPUT)))
(fluid-let ((input-list (map char->ascii (string->list pattern)))
(current-byte)
(output-tail output)
(output-length 0)
(stack '())
- (fixup-jump #!FALSE)
+ (fixup-jump false)
(register-number 1)
(begin-alternative)
- (pending-exact #!FALSE)
- (last-start #!FALSE))
+ (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))))
+ (let 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)
+ (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?)
+(define-integrable (input-end?)
(null? input-list))
-(define (input-end+1?)
+(define-integrable (input-end+1?)
(null? (cdr input-list)))
-(define (input-peek)
+(define-integrable (input-peek)
(vector-8b-ref translation-table (car input-list)))
-(define (input-peek+1)
+(define-integrable (input-peek+1)
(vector-8b-ref translation-table (cadr input-list)))
-(define (input-discard!)
- (set! input-list (cdr input-list)))
+(define-integrable (input-discard!)
+ (set! input-list (cdr input-list))
+ unspecific)
-(define (input!)
+(define-integrable (input!)
(set! current-byte (input-peek))
(input-discard!))
-(define (input-raw!)
+(define-integrable (input-raw!)
(set! current-byte (car input-list))
(input-discard!))
-(define (input-peek-1)
+(define-integrable (input-peek-1)
current-byte)
-(define (input-read!)
+(define-integrable (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))))
+(define (input-match? byte . chars)
+ (memv (ascii->char byte) 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))
+(define-integrable (output! byte)
(let ((tail (list byte)))
(set-cdr! output-tail tail)
(set! output-tail tail))
- (set! output-length (1+ output-length)))
+ (set! output-length (1+ output-length))
+ unspecific)
-(define (output-re-code! code)
- (declare (integrate code))
- (set! pending-exact #!FALSE)
+(define-integrable (output-re-code! code)
+ (set! pending-exact false)
(output! code))
-(define (output-start! code)
- (declare (integrate code))
+(define-integrable (output-start! code)
(set! last-start (output-pointer))
(output-re-code! code))
-(define (output-position)
+(define-integrable (output-position)
output-length)
-(define (output-pointer)
+(define-integrable (output-pointer)
(cons output-length output-tail))
-(define (pointer-position pointer)
- (declare (integrate pointer))
+(define-integrable (pointer-position pointer)
(car pointer))
-(define (pointer-ref pointer)
- (declare (integrate pointer))
+(define-integrable (pointer-ref pointer)
(caddr pointer))
-(define (pointer-operate! pointer operator)
- (declare (integrate pointer operator))
- (set-car! (cddr pointer)
- (operator (caddr pointer))))
-\f
+(define-integrable (pointer-operate! pointer operator)
+ (set-car! (cddr pointer) (operator (caddr pointer)))
+ unspecific)
+
(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)))))
+ (set-car! (cddr p) high)
+ unspecific))))
(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)))))
+ (set! output-length (+ output-length 3))
+ unspecific)))
(define (compute-jump from to receiver)
(let ((n (- to (+ from 3))))
- (let ((qr (integer-divide (if (negative? n) (+ n #x10000) n)
- #x100)))
+ (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?)
+(define-integrable (stack-empty?)
(null? stack))
-(define (stack-full?)
+(define-integrable (stack-full?)
(>= (stack-length) stack-maximum-length))
-(define (stack-length)
+(define-integrable (stack-length)
(length stack))
(define (stack-push! . args)
- (set! stack (cons args stack)))
+ (set! stack (cons args stack))
+ unspecific)
(define (stack-pop! receiver)
(let ((frame (car stack)))
(set! stack (cdr stack))
(apply receiver frame)))
-(define (stack-ref-register-number i)
- (declare (integrate i))
+(define-integrable (stack-ref-register-number 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))
+ ((ucode-primitive string->syntax-entry) (char->string (ascii->char ascii))))
\f
;;;; Pattern Dispatch
-(declare (integrate compile-pattern-char))
-
-(define (compile-pattern-char)
+(define-integrable (compile-pattern-char)
(input!)
((vector-ref pattern-chars (input-peek-1))))
(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+))))
+ (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))
+ (vector-set! pattern-chars (char->ascii char) procedure)
+ unspecific)
(define pattern-chars
(make-vector 256 normal-char))
(lambda ()
(if (input-end?)
(premature-end)
- (begin (input-raw!)
- ((vector-ref backslash-chars (input-peek-1)))))))
+ (begin
+ (input-raw!)
+ ((vector-ref backslash-chars (input-peek-1)))))))
(define (define-backslash-char char procedure)
- (vector-set! backslash-chars (char->ascii char) procedure))
+ (vector-set! backslash-chars (char->ascii char) procedure)
+ unspecific)
(define backslash-chars
(make-vector 256 normal-char))
(repeater-loop zero? many?))
((input-match? (input-peek) #\+)
(input-discard!)
- (repeater-loop #!FALSE many?))
+ (repeater-loop false many?))
((input-match? (input-peek) #\?)
(input-discard!)
- (repeater-loop zero? #!FALSE))
+ (repeater-loop zero? false))
(else
(repeater-finish zero? many?))))
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)
+(define-repeater-char #\* true true)
+(define-repeater-char #\+ false true)
+(define-repeater-char #\? true false)
\f
;;;; Character Sets
(define (element)
(let ((char (input-peek)))
(input-discard!)
- (cond ((input-end?) (premature-end))
+ (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))))
+ (let loop ((char char))
+ (if (<= char char*)
+ (begin
+ ((ucode-primitive re-char-set-adjoin!) charset
+ char)
+ (loop (1+ char))))))))
+ (else
+ ((ucode-primitive 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)))))
+ (let loop ((i 0))
+ (output! (vector-8b-ref charset i))
+ (if (< i n)
+ (loop (1+ i)))))
+ ((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
(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)))
+ (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! last-start false)
+ (set! fixup-jump false)
(set! register-number (1+ register-number))
- (set! begin-alternative (output-pointer))))
+ (set! begin-alternative (output-pointer))
+ unspecific))
(define-backslash-char #\)
(lambda ()
(set! fixup-jump fj)
(set! begin-alternative bg)
(if (< rn re-number-of-registers)
- (begin (output-re-code! re-code:stop-memory)
- (output! rn)))))))
+ (begin
+ (output-re-code! re-code:stop-memory)
+ (output! rn)))))))
(define-backslash-char #\|
(lambda ()
(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
+ (set! pending-exact false)
+ (set! last-start false)
+ (set! begin-alternative (output-pointer))
+ unspecific))
+
(define (define-digit-char digit)
(let ((char (digit->char digit)))
(define-backslash-char char
(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)))))))
-
+ (let search-stack ((i 0))
+ (cond ((>= i n)
+ (output-start! re-code:duplicate)
+ (output! digit))
+ ((= (stack-ref-register-number i) digit)
+ (normal-char))
+ (else
+ (search-stack (1+ i)))))))))))
(for-each define-digit-char '(1 2 3 4 5 6 7 8 9))
-
-;;; end %RE-COMPILE-PATTERN
-))
\f
;;;; Compiled Pattern Disassembler
-#|
-(define re-compile-fastmap (make-primitive-procedure 're-compile-fastmap))
-
-(define null-translation
- (let ((v (make-string 256)))
- (let loop ((index 0))
- (if (= index 256)
- v
- (begin (vector-8b-set! v index index)
- (loop (1+ index)))))))
(define (hack-fastmap pat)
- (let ((pattern (re-compile-pattern pat #f))
+ (let ((pattern (re-compile-pattern pat false))
(cs (char-set)))
(re-disassemble-pattern pattern)
- (re-compile-fastmap pattern null-translation (make-syntax-table) cs)
+ ((ucode-primitive re-compile-fastmap)
+ pattern (re-translation-table false) (make-syntax-table) cs)
(char-set-members cs)))
(define (re-disassemble-pattern compiled-pattern)
(let ((n (string-length compiled-pattern)))
- (define (loop i)
+ (let loop ((i 0))
(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)
+ (case (let ((re-code-name
+ (vector-ref re-codes
+ (vector-8b-ref compiled-pattern i))))
+ (write re-code-name)
+ 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 (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)))
+ (loop end))))
+ ((JUMP ON-FAILURE-JUMP MAYBE-FINALIZE-JUMP DUMMY-FAILURE-JUMP)
+ (write-string " ")
+ (let ((end (+ i 3))
+ (offset
+ (+ (* 256 (vector-8b-ref compiled-pattern (+ i 2)))
+ (vector-8b-ref compiled-pattern (1+ i)))))
+ (write (+ end (if (< offset #x8000) offset (- offset #x10000))))
+ (write-string ")")
+ (loop end)))
+ ((CHAR-SET NOT-CHAR-SET)
+ (let ((end (+ (+ i 2)
(vector-8b-ref compiled-pattern (1+ i)))))
- (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
+ (let spit ((i (+ i 2)))
+ (if (< i end)
+ (begin
+ (write-string " ")
+ (let ((n (vector-8b-ref compiled-pattern i)))
+ (if (< n 16) (write-char #\0))
+ (write-string (number->string n 16)))
+ (spit (1+ i)))
+ (begin
+ (write-string ")")
+ (loop i))))))
+ ((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)")))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff