--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufinp.scm,v 1.1 1989/03/14 08:08: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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Buffer Input Ports
+
+(declare (usual-integrations))
+\f
+(define (with-input-from-mark mark thunk #!optional receiver)
+ (let ((port (make-buffer-input-port mark (group-end mark))))
+ (let ((value (with-input-from-port port thunk)))
+ (if (default-object? receiver)
+ value
+ (receiver
+ value
+ (let ((state (input-port/state port)))
+ (make-mark (buffer-input-port-state/group state)
+ (buffer-input-port-state/current-index state))))))))
+
+(define (with-input-from-region region thunk)
+ (with-input-from-port (make-buffer-input-port (region-start region)
+ (region-end region))
+ thunk))
+
+(define-structure (buffer-input-port-state
+ (conc-name buffer-input-port-state/))
+ (group false read-only true)
+ (end-index false read-only true)
+ (current-index false))
+
+(define (make-buffer-input-port mark end)
+ ;; This uses indices, so it can only be used locally
+ ;; where there is no buffer-modification happening.
+ (input-port/copy buffer-input-port-template
+ (make-buffer-input-port-state (mark-group mark)
+ (mark-index end)
+ (mark-index mark))))
+
+(define (operation/char-ready? port interval)
+ interval ;ignore
+ (let ((state (input-port/state port)))
+ (< (buffer-input-port-state/current-index state)
+ (buffer-input-port-state/end-index state))))
+
+(define (operation/peek-char port)
+ (let ((state (input-port/state port)))
+ (let ((current-index (buffer-input-port-state/current-index state)))
+ (and (< current-index (buffer-input-port-state/end-index state))
+ (group-right-char (buffer-input-port-state/group state)
+ current-index)))))
+
+(define (operation/discard-char port)
+ (let ((state (input-port/state port)))
+ (set-buffer-input-port-state/current-index!
+ state
+ (1+ (buffer-input-port-state/current-index state)))))
+\f
+(define (operation/read-char port)
+ (let ((state (input-port/state port)))
+ (let ((current-index (buffer-input-port-state/current-index state)))
+ (and (< current-index (buffer-input-port-state/end-index state))
+ (let ((char
+ (group-right-char (buffer-input-port-state/group state)
+ current-index)))
+ (set-buffer-input-port-state/current-index! state
+ (1+ current-index))
+ char)))))
+
+(define (operation/read-string port delimiters)
+ (let ((state (input-port/state port)))
+ (let ((current-index (buffer-input-port-state/current-index state))
+ (end-index (buffer-input-port-state/end-index state))
+ (group (buffer-input-port-state/group state)))
+ (if (>= current-index end-index)
+ ""
+ (let ((new-index
+ (or (%find-next-char-in-set group current-index end-index
+ delimiters)
+ end-index)))
+ (let ((string
+ (group-extract-string group current-index new-index)))
+ (set-buffer-input-port-state/current-index! state new-index)
+ string))))))
+
+(define (operation/discard-chars port delimiters)
+ (let ((state (input-port/state port)))
+ (let ((current-index (buffer-input-port-state/current-index state))
+ (end-index (buffer-input-port-state/end-index state)))
+ (if (< current-index end-index)
+ (set-buffer-input-port-state/current-index!
+ state
+ (or (%find-next-char-in-set (buffer-input-port-state/group state)
+ current-index
+ end-index
+ delimiters)
+ end-index))))))
+
+(define (operation/print-self state port)
+ (unparse-string state "from buffer at ")
+ (unparse-object
+ state
+ (let ((state (input-port/state port)))
+ (make-mark (buffer-input-port-state/group state)
+ (buffer-input-port-state/current-index state)))))
+
+(define buffer-input-port-template
+ (make-input-port `((CHAR-READY? ,operation/char-ready?)
+ (DISCARD-CHAR ,operation/discard-char)
+ (DISCARD-CHARS ,operation/discard-chars)
+ (PEEK-CHAR ,operation/peek-char)
+ (PRINT-SELF ,operation/print-self)
+ (READ-CHAR ,operation/read-char)
+ (READ-STRING ,operation/read-string))
+ false))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufout.scm,v 1.1 1989/03/14 08:08:52 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Buffer Output Ports
+
+(declare (usual-integrations))
+\f
+(define (with-output-to-mark mark thunk)
+ (with-output-to-port (mark->output-port mark)
+ thunk))
+
+(define (mark->output-port mark)
+ (output-port/copy mark-output-port-template (mark-left-inserting mark)))
+
+(define (operation/write-char port char)
+ (region-insert-char! (output-port/state port) char))
+
+(define (operation/write-string port string)
+ (region-insert-string! (output-port/state port) string))
+
+(define (operation/print-self state port)
+ (unparse-string state "to buffer at ")
+ (unparse-object state (output-port/state port)))
+
+(define mark-output-port-template
+ (make-output-port `((PRINT-SELF ,operation/print-self) (WRITE-CHAR ,operation/write-char)
+ (WRITE-STRING ,operation/write-string))
+ false))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/cinden.scm,v 1.1 1989/03/14 07:59: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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; C Indentation (from GNU Emacs)
+
+(declare (usual-integrations))
+\f
+(define (c-indent-line start)
+ (maybe-change-indentation (c-indent-line:indentation start) start))
+
+(define (c-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))
+ (indent-point (line-start mark 0)))
+ (define (find-outer-container start)
+ (let ((state (parse-partial-sexp start indent-point 0)))
+ (if (mark= (parse-state-location state) indent-point)
+ state
+ (find-outer-container (parse-state-location state)))))
+ (let ((state
+ (find-outer-container (or parse-start
+ (backward-one-definition-start mark)
+ gstart))))
+ (if (or (parse-state-in-string? state)
+ (parse-state-in-comment? state))
+ ;; Return boolean if line should not be changed.
+ (not (not (parse-state-in-comment? state)))
+ (let ((container (parse-state-containing-sexp state)))
+ (cond ((not container)
+ ;; Line is at top level. Discriminate between
+ ;; procedure definition and other cases.
+ (if (re-match-forward "[ \t]*{" indent-point)
+ 0
+ ;; May be data definition, or may be function
+ ;; argument declaration. Indent like the
+ ;; previous top level line unless that ends
+ ;; in a closeparen without semicolon, in
+ ;; which case this line is the first argument
+ ;; decl.
+ (let ((mark
+ (backward-to-noncomment indent-point
+ (or parse-start
+ gstart))))
+ (if (char-match-backward #\) mark)
+ (ref-variable "C Argdecl Indent")
+ (mark-indentation mark)))))
+ ((char-match-forward #\{ container)
+ (calculate-indentation:statement indent-point container))
+ (else
+ ;; Line is expression, not statement: indent to just
+ ;; after the surrounding open.
+ (mark-column (mark1+ container)))))))))
+
+(define (calculate-indentation:statement indent-point container)
+ (let ((mark (backward-to-noncomment indent-point container)))
+ (if (and mark
+ (re-match-forward "[^,;:{}]" (mark-1+ mark)))
+ ;; This line is continuation of preceding line's statement;
+ ;; indent C Continued Statement Offset more than the previous
+ ;; line of the statement.
+ (+ (ref-variable "C Continued Statement Offset")
+ (mark-column (backward-to-start-of-continued-exp mark container)))
+ (let ((mark (skip-comments&labels (mark1+ container) indent-point)))
+ (if (not mark)
+ ;; If this is first statement after open brace, indent
+ ;; it relative to line brace is on. For open brace in
+ ;; column zero, don't let statement start there too. If
+ ;; C Indent Level is zero, use C Brace Offset + C
+ ;; Continued Statement Offset instead. For open-braces
+ ;; not the first thing in a line, add in C Brace
+ ;; Imaginary Offset.
+ (+ (if (and (line-start? container)
+ (zero? (ref-variable "C Indent Level")))
+ (+ (ref-variable "C Brace Offset")
+ (ref-variable "C Continued Statement Offset"))
+ (ref-variable "C Indent Level"))
+ (+ (if (within-indentation? container)
+ 0
+ (ref-variable "C Brace Imaginary Offset"))
+ (mark-indentation container)))
+ ;; Otherwise, indent under that first statement.
+ (mark-column mark))))))
+\f
+(define (skip-comments&labels start end)
+ (define (phi1 mark)
+ (cond ((mark= mark end) false)
+ ((char-match-forward #\# mark)
+ (phi2 (line-start mark 1)))
+ ((match-forward "/*" mark)
+ (phi2 (search-forward "*/" mark end)))
+ ((re-match-forward "case[ \t\n]\\|[a-zA-Z0-9_$]*:" mark)
+ (phi2 (char-search-forward #\: mark end)))
+ (else mark)))
+
+ (define (phi2 mark)
+ (and mark
+ (phi1 (whitespace-end mark end))))
+
+ (phi1 (whitespace-end start end)))
+
+(define (whitespace-start start end)
+ (skip-chars-backward " \t\n" start end))
+
+(define (whitespace-end start end)
+ (skip-chars-forward " \t\n" start end))
+
+(define (c-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 (c-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))
+ (c-indent-line start))
+ (cond ((mark= start* end)
+ (receiver start* state*))
+ ((parse-state-in-comment? state*)
+ (if (not (and state (parse-state-in-comment? state)))
+ (if (re-search-forward "/\\*[ \t]*" start start*)
+ (c-mode:comment-indent (re-match-start 0))
+ (error "C-Indent-Expression: Missing comment")))
+ (loop start* state*))
+ ((parse-state-in-string? state*)
+ (loop start* state*))
+ (else
+ (receiver start* state*))))))
+ (loop start state))
+
+ (define (indent-line start indent-stack contain-stack)
+ (let ((indentation
+ (indent-line:adjust-indentation
+ start
+ (if (car indent-stack)
+ (if (char-match-forward #\{ (car contain-stack))
+ ;; Line is at statement level. Is it a new
+ ;; statement? Is it an else? Find last
+ ;; non-comment character before this line.
+ (let ((mark
+ (backward-to-noncomment
+ start expression-start)))
+ (cond ((not (memv (extract-left-char mark)
+ '(#F #\. #\; #\} #\:)))
+ (+ (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))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/clscon.scm,v 1.1 1989/03/14 07:59: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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Class/Object System: Class Constructor
+
+(declare (usual-integrations))
+
+;;; ******************************************************************
+;;; This software is intended for use in the Edwin window system only.
+;;; Don't think about using it for anything else, since it is not, and
+;;; likely will not ever, be supported as a part of the Scheme system.
+;;; ******************************************************************
+\f
+(define (make-class name superclass variables)
+ (let ((entry (assq name class-descriptors))
+ (object-size (if superclass
+ (+ (length variables) (class-object-size superclass))
+ (1+ (length variables))))
+ (transforms (make-instance-transforms superclass variables)))
+ (let ((make-class
+ (lambda ()
+ (let ((class
+ (vector class-tag
+ name
+ superclass
+ object-size
+ transforms
+ (cons '()
+ (and superclass
+ (class-methods superclass))))))
+ (unparser/set-tagged-vector-method!
+ class
+ (unparser/standard-method name))
+ class))))
+ (if (not entry)
+ (let ((class (make-class)))
+ (set! class-descriptors (cons (cons name class) class-descriptors))
+ class)
+ (let ((class (cdr entry)))
+ (if (eq? (class-superclass class) superclass)
+ (begin
+ (with-output-to-port (cmdl/output-port (nearest-cmdl))
+ (lambda ()
+ (warn "Redefining class" name)))
+ (vector-set! class 3 object-size)
+ (vector-set! class 4 transforms)
+ class)
+ (let ((class (make-class)))
+ (set-cdr! entry class)
+ class)))))))
+
+(define (class? x)
+ (and (vector? x)
+ (not (zero? (vector-length x)))
+ (eq? class-tag (vector-ref x 0))))
+
+(define (name->class name)
+ (cdr (or (assq name class-descriptors)
+ (error "unknown class name" name))))
+
+(define class-tag "Class")
+
+(define (make-instance-transforms superclass variables)
+ (define (generate variables n tail)
+ (if (null? variables)
+ tail
+ (cons (cons (car variables) n)
+ (generate (cdr variables) (1+ n) tail))))
+ (if superclass
+ (generate variables
+ (class-object-size superclass)
+ (class-instance-transforms superclass))
+ (generate variables 1 '())))
+
+(unparser/set-tagged-vector-method! class-tag
+ (unparser/standard-method 'CLASS))
+
+(define class-descriptors
+ '())
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/clsmac.scm,v 1.1 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Class/Object System
+
+(declare (usual-integrations))
+
+;;; ******************************************************************
+;;; This software is intended for use in the Edwin window system only.
+;;; Don't think about using it for anything else, since it is not, and
+;;; likely will not ever, be supported as a part of the Scheme system.
+;;; ******************************************************************
+\f
+(define class-syntax-table
+ (make-syntax-table edwin-syntax-table))
+
+(define ((scode-macro-spreader transform) expression)
+ (apply transform (cdr expression)))
+
+(syntax-table-define class-syntax-table 'DEFINE-CLASS
+ (lambda (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
+ (lambda (class bvl . body)
+ (syntax-class-definition class bvl body
+ (lambda (name expression)
+ (make-syntax-closure
+ (make-method-definition class name expression))))))
+
+(syntax-table-define class-syntax-table 'WITH-INSTANCE-VARIABLES
+ (lambda (class self free-names . body)
+ (guarantee-symbol "Self name" self)
+ (make-syntax-closure
+ (syntax-class-expression class self free-names body))))
+
+(syntax-table-define class-syntax-table '=>
+ (lambda (object operation . arguments)
+ (guarantee-symbol "Operation name" operation)
+ (let ((obname (string->uninterned-symbol "object")))
+ `(LET ((,obname ,object))
+ ((CLASS-METHODS/REF (OBJECT-METHODS ,obname) ',operation)
+ ,obname
+ ,@arguments)))))
+
+(syntax-table-define class-syntax-table 'USUAL=>
+ (lambda (object operation . arguments)
+ (guarantee-symbol "Operation name" operation)
+ (if (not *class-name*)
+ (error "Not inside class expression: USUAL=>" operation))
+ `((CLASS-METHODS/REF (CLASS-METHODS (CLASS-SUPERCLASS ,*class-name*))
+ ',operation)
+ ,object
+ ,@arguments)))
+\f
+(define (syntax-class-definition class bvl body receiver)
+ (parse-definition bvl body
+ (lambda (name expression)
+ (receiver name (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 free-names expression)
+ (guarantee-symbol "Class name" class-name)
+ (fluid-let ((*class-name* class-name))
+ (transform-instance-variables
+ (class-instance-transforms (name->class class-name))
+ self
+ free-names
+ (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)))
\ No newline at end of file
--- /dev/null
+(fluid-let ((sf/default-syntax-table syntax-table/system-internal))
+ (sf-conditionally
+ '("bufinp"
+ "bufott"
+ "bufout"
+ "comtab"
+ "class"
+ "clscon"
+ "clsmac"
+ "complt"
+ "entity"
+ "grpops"
+ "image"
+ "macros"
+ "motion"
+ "nvector"
+ "paths"
+ "regops"
+ "rename"
+ "rgxcmp"
+ "ring"
+ "screen"
+ "search"
+ "simple"
+ "strpad"
+ "strtab"
+ "utils"
+ "xform"
+ "xterm"
+ "winout"
+ "winren")))
+
+(fluid-let ((sf/default-syntax-table
+ (access edwin-syntax-table (->environment '(EDWIN)))))
+ (sf-conditionally
+ '("argred"
+ "autold"
+ "autosv"
+ "basic"
+ "bufcom"
+ "buffer"
+ "bufmnu"
+ "bufset"
+ "c-mode"
+ "calias"
+ "cinden"
+ "comman"
+ "comred"
+ "curren"
+ ;; "debug" "debuge"
+ "dired" "editor"
+ "edtstr"
+ "evlcom"
+ "filcom"
+ "fileio"
+ "fill"
+ "filser"
+ "hlpcom"
+ "info"
+ "input"
+ "intmod"
+ "iserch"
+ "keymap"
+ "kilcom"
+ "kmacro"
+ "lincom"
+ "linden"
+ "loadef"
+ "lspcom"
+ "midas"
+ "modefs"
+ "modes"
+ "motcom"
+ "pasmod"
+ "prompt"
+ "reccom"
+ "regcom"
+ "regexp"
+ "replaz"
+ "schmod"
+ "sercom"
+ "struct"
+ "syntax"
+ "tags"
+ "texcom"
+ "things"
+ "tparse"
+ "tximod"
+ "undo"
+ "unix"
+ "wincom")))
+
+(fluid-let ((sf/default-syntax-table
+ (access class-syntax-table (->environment '(EDWIN)))))
+ (sf-conditionally
+ '("window"
+ "utlwin"
+ "linwin"
+ "bufwin"
+ "bufwfs"
+ "bufwiu"
+ "bufwmc"
+ "comwin"
+ "modwin"
+ "buffrm"
+ "edtfrm"
+ "winmis"
+ "rescrn")))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Editor Data Abstraction
+
+(declare (usual-integrations))
+\f
+(define-structure (editor (constructor %make-editor))
+ (name false read-only true)
+ (screen false read-only true)
+ (frame-window false read-only true)
+ (bufferset false read-only true)
+ (kill-ring false read-only true)
+ (char-history false read-only true))
+
+(define (make-editor name screen)
+ (let ((initial-buffer (make-buffer initial-buffer-name interaction-mode)))
+ (let ((bufferset (make-bufferset initial-buffer)))
+ (let ((frame
+ (make-editor-frame screen
+ initial-buffer
+ (bufferset-create-buffer bufferset
+ " *Typein-0*"))))
+ (set-screen-window! screen frame)
+ (%make-editor name
+ screen
+ frame
+ bufferset
+ (make-ring 10)
+ (make-ring 100))))))
+
+(define initial-buffer-name
+ "*scratch*")
+
+(define-integrable (current-screen)
+ (editor-screen current-editor))
+
+(define-integrable (current-editor-frame)
+ (editor-frame-window current-editor))
+(define-integrable (current-bufferset)
+ (editor-bufferset current-editor))
+
+(define-integrable (current-kill-ring)
+ (editor-kill-ring current-editor))
+
+(define-integrable (current-char-history)
+ (editor-char-history current-editor))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+
+(for-each (lambda (pathname)
+ (let ((pathname (pathname-new-type pathname false)))
+ (if (not (file-processed? pathname "bin" "com"))
+ (compile-bin-file pathname))))
+ (directory-read "*.com"))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;; program to load package contents
+
+(declare (usual-integrations))
+
+(lambda (load key-alist)
+ key-alist
+ (let ((environment (->environment '(EDWIN))))
+ (load "utils" environment)
+ (load "nvector" environment)
+ (load "entity" environment)
+ (load "ring" environment)
+ (load "strtab" environment)
+ (load "strpad" environment)
+ (load "macros" (->environment '(EDWIN MACROS)))
+ (load "class" environment)
+ (load "clscon" (->environment '(EDWIN CLASS-CONSTRUCTOR)))
+ (load "clsmac" (->environment '(EDWIN CLASS-MACROS)))
+ (load "xform"
+ (->environment '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES)))
+ (load "complt" environment)
+ (load "paths" environment)
+ (load "struct" environment)
+ (load "grpops" (->environment '(EDWIN GROUP-OPERATIONS)))
+ (load "regops" environment)
+ (load "motion" environment)
+ (load "search" environment)
+ (load "image" environment)
+ (load "comman" environment)
+ (load "comtab" (->environment '(EDWIN COMTAB)))
+ (load "modes" environment)
+ (load "buffer" environment)
+ (load "bufset" environment)
+ (load "undo" (->environment '(EDWIN UNDO)))
+ (load "screen" (->environment '(EDWIN SCREEN)))
+ (load "xterm" (->environment '(EDWIN X-SCREEN)))
+ (load "winren" (->environment '(EDWIN)))
+ (let ((environment (->environment '(EDWIN WINDOW))))
+ (load "window" environment)
+ (load "utlwin" environment)
+ (load "linwin" environment)
+ (load "bufwin" environment)
+ (load "bufwfs" environment)
+ (load "bufwiu" environment)
+ (load "bufwmc" environment)
+ (load "comwin" (->environment '(EDWIN WINDOW COMBINATION)))
+ (load "modwin" environment)
+ (load "buffrm" environment)
+ (load "edtfrm" environment)
+ (load "winmis" environment))
+ (load "edtstr" environment)
+ (load "editor" environment)
+ (load "curren" environment)
+ (load "simple" environment)
+ (load "debuge" environment)
+ (load "calias" environment)
+ (load "input" (->environment '(EDWIN KEYBOARD)))
+ (load "prompt" (->environment '(EDWIN PROMPT)))
+ (load "comred" (->environment '(EDWIN COMMAND-READER)))
+ (load "bufinp" (->environment '(EDWIN BUFFER-INPUT-PORT)))
+ (load "bufout" (->environment '(EDWIN BUFFER-OUTPUT-PORT)))
+ (load "bufott" (->environment '(EDWIN BUFFER-OUTPUT-PORT-TRUNCATING)))
+ (load "winout" (->environment '(EDWIN WINDOW-OUTPUT-PORT)))
+ (load "things" environment)
+ (load "tparse" environment)
+ (load "syntax" environment)
+ (load "regexp" (->environment '(EDWIN REGULAR-EXPRESSION)))
+ (load "rgxcmp" (->environment '(EDWIN REGULAR-EXPRESSION-COMPILER)))
+ (load "linden" (->environment '(EDWIN LISP-INDENTATION)))
+ (load "unix" environment)
+ (load "fileio" environment)
+ (load "argred" (->environment '(EDWIN COMMAND-ARGUMENT)))
+ (load "autold" environment)
+ (load "autosv" environment)
+ (load "basic" environment)
+ (load "bufcom" environment)
+ (load "bufmnu" (->environment '(EDWIN BUFFER-MENU)))
+ (load "evlcom" environment)
+ (load "filcom" environment)
+ (load "fill" environment)
+ (load "hlpcom" environment)
+ (load "intmod" environment)
+ (load "kilcom" environment)
+ (load "kmacro" environment)
+ (load "lincom" environment)
+ (load "lspcom" environment)
+ (load "motcom" environment)
+ (load "regcom" (->environment '(EDWIN REGISTER-COMMAND)))
+ (load "replaz" environment)
+ (load "schmod" environment)
+ (load "sercom" environment)
+ (load "iserch" (->environment '(EDWIN INCREMENTAL-SEARCH)))
+ (load "texcom" environment)
+ (load "wincom" environment)
+ (load "modefs" environment)
+ (load "rename" environment)
+ (load "loadef" environment)
+ ))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.1 1989/03/14 08:12:18 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 Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Edwin Packaging
+\f
+(global-definitions "../runtime/runtim")
+
+(define-package (edwin)
+ (files "utils"
+ "nvector"
+ "entity"
+ "ring"
+ "strtab"
+ "strpad"
+ "class"
+ "complt"
+ "unix"
+
+ "paths"
+ "struct"
+ "regops"
+ "motion"
+ "search"
+ "image"
+ "comman"
+ "modes"
+ "buffer"
+ "bufset"
+ "winren" ; window system rename targets
+
+ "edtstr" ; editor abstraction
+ "editor" ; editor top level
+ "curren" ; current state
+ "simple" ; simple editing operations
+ "debuge" ; edwin debugging tools
+ "calias" ; character aliasing
+ "things" ; generic text objects
+ "tparse" ; text parsing
+ "syntax" ; word and list parsing
+ "fileio" ; file <-> buffer
+
+ "autold" ; autoloaded definitions
+ "autosv" ; auto save
+ "basic" ; basic commands
+ "bufcom" ; buffer commands
+ "evlcom" ; evaluation commands
+ "filcom" ; file commands
+ "fill" ; text fill commands
+ "hlpcom" ; help commands
+ "intmod" ; interaction mode
+ "kilcom" ; kill commands
+ "kmacro" ; keyboard macros
+ "lincom" ; line commands
+ "lspcom" ; lisp commands
+ "motcom" ; motion commands
+ "replaz" ; replace commands
+ "schmod" ; scheme mode
+ "sercom" ; search commands
+ "texcom" ; text commands
+ "wincom" ; window commands
+
+ "modefs" ; fundamental mode
+
+ "loadef"
+ "c-mode"
+ "midas"
+ "pasmod"
+ "tximod")
+ (parent ())
+ (export (edwin class-macros)
+ class-instance-transforms))
+
+(define-package (edwin class-macros)
+ (files "clsmac")
+ (parent ())
+ (export (edwin)
+ class-syntax-table))
+
+(define-package (edwin class-macros transform-instance-variables)
+ (files "xform")
+ (parent ())
+ (export (edwin class-macros)
+ transform-instance-variables))
+
+(define-package (edwin class-constructor)
+ (files "clscon")
+ (parent (edwin))
+ (export (edwin)
+ class?
+ make-class
+ name->class)
+ (export (edwin class-macros)
+ make-class
+ name->class))
+
+(define-package (edwin macros)
+ (files "macros")
+ (parent ())
+ (export (edwin)
+ edwin-syntax-table)
+ (export (edwin class-macros)
+ edwin-syntax-table))
+
+(define-package (edwin group-operations)
+ (files "grpops")
+ (parent (edwin))
+ (export (edwin)
+ %group-insert-char!
+ %group-insert-substring!
+ gap-allocation-extra
+ group-delete!
+ group-delete-left-char!
+ group-delete-right-char!
+ group-extract-string
+ group-insert-char!
+ group-insert-string!
+ group-insert-substring!
+ group-left-char
+ group-right-char))
+
+(define-package (edwin comtab)
+ (files "comtab")
+ (parent (edwin))
+ (export (edwin)
+ comtab-entry
+ comtab-dispatch-alists
+ comtab-key-bindings
+ comtab?
+ define-default-key
+ define-key
+ define-prefix-key
+ make-comtab
+ prefix-char-list?))
+
+(define-package (edwin undo)
+ (files "undo")
+ (parent (edwin))
+ (export (edwin)
+ enable-group-undo!
+ undo-boundary!
+ undo-done!
+ undo-record-deletion!
+ undo-record-insertion!))
+
+(define-package (edwin screen)
+ (files "screen")
+ (parent (edwin))
+ (export (edwin)
+ make-screen
+ screen-beep
+ screen-flush!
+ screen-in-update?
+ screen-inverse-video!
+ screen-state
+ screen-window
+ screen-write-char!
+ screen-write-cursor!
+ screen-write-substring!
+ screen-write-substrings!
+ screen-x-size
+ screen-y-size
+ set-screen-window!
+ subscreen-clear!
+ with-screen-in-update!))
+
+(define-package (edwin x-screen)
+ (files "xterm")
+ (parent (edwin))
+ (export (edwin)
+ make-xterm-input-port
+ make-xterm-screen
+ with-editor-interrupts
+ with-editor-interrupts-disabled
+ with-editor-interrupts-enabled
+ xterm-close-all-displays
+ xterm-close-display
+ xterm-close-window
+ xterm-map
+ xterm-open-display
+ xterm-open-window
+ xterm-unmap))
+
+(define-package (edwin window)
+ (files "window"
+ "utlwin"
+ "linwin"
+ "bufwin"
+ "bufwfs"
+ "bufwiu"
+ "bufwmc"
+ "modwin"
+ "buffrm"
+ "edtfrm"
+ "winmis")
+ (parent (edwin))
+ (export (edwin)
+ editor-frame-select-cursor!
+ editor-frame-select-window!
+ editor-frame-selected-window
+ editor-frame-typein-window
+ editor-frame-window0
+ edwin-discard-state!
+ edwin-editor
+ edwin-input-port
+ edwin-reset
+ edwin-reset-windows
+ make-editor-frame
+ modeline-mode-string
+ modeline-modified-string
+ modeline-percentage-string
+ set-window-point!
+ set-window-start-mark!
+ update-screen!
+ update-screens!
+ update-window-screen!
+ window-buffer
+ window-clear-override-message!
+ window-coordinates->mark
+ window-direct-output-backward-char!
+ window-direct-output-forward-char!
+ window-direct-output-insert-char!
+ window-direct-output-insert-newline!
+ window-direct-output-insert-substring!
+ window-direct-update!
+ window-end-mark
+ window-home-cursor!
+ window-mark->coordinates
+ window-mark->x
+ window-mark->y
+ window-mark-visible?
+ window-modeline-event!
+ window-needs-redisplay?
+ window-point
+ window-point-coordinates
+ window-point-x
+ window-point-y
+ window-redraw!
+ window-redraw-preserving-point!
+ window-scroll-y-absolute!
+ window-scroll-y-relative!
+ window-select-time
+ window-set-override-message!
+ window-start-mark
+ window-y-center)
+ (export (edwin prompt)
+ clear-override-message!
+ frame-text-inferior
+ home-cursor!
+ set-override-message!))
+
+(define-package (edwin window combination)
+ (files "comwin")
+ (parent (edwin window))
+ (export (edwin)
+ window+
+ window-
+ window-1+
+ window-delete!
+ window-grow-horizontally!
+ window-grow-vertically!
+ window-has-down-neighbor?
+ window-has-horizontal-neighbor?
+ window-has-left-neighbor?
+ window-has-no-neighbors?
+ window-has-right-neighbor?
+ window-has-up-neighbor?
+ window-has-vertical-neighbor?
+ window-split-horizontally!
+ window-split-vertically!
+ window1+)
+ (export (edwin window)
+ combination-leaf-window
+ window0))
+
+(define-package (edwin command-reader)
+ (files "comred")
+ (parent (edwin))
+ (export (edwin)
+ abort-current-command
+ command-message-receive
+ command-reader
+ current-command
+ current-command-char
+ dispatch-on-char
+ dispatch-on-command
+ execute-char
+ execute-command
+ read-and-dispatch-on-char
+ set-command-message!
+ top-level-command-reader))
+
+(define-package (edwin keyboard)
+ (files "input")
+ (parent (edwin))
+ (export (edwin)
+ append-command-prompt!
+ append-message
+ char-base
+ char-control-metafy
+ char-controlify
+ char-metafy
+ clear-message
+ command-prompt
+ editor-input-port
+ initialize-typeout!
+ keyboard-active?
+ keyboard-peek-char
+ keyboard-read-char
+ message
+ reset-command-prompt!
+ set-command-prompt!
+ set-editor-input-port!
+ temporary-message
+ with-editor-input-port))
+
+(define-package (edwin prompt)
+ (files "prompt")
+ (parent (edwin))
+ (export (edwin)
+ enable-recursive-minibuffers
+ initialize-typein!
+ list-completions
+ prompt-for-alist-value
+ prompt-for-char
+ prompt-for-char-without-interrupts
+ prompt-for-command
+ prompt-for-completed-string
+ prompt-for-confirmation?
+ prompt-for-key
+ prompt-for-string
+ prompt-for-string-table-value
+ prompt-for-typein
+ prompt-for-variable
+ prompt-for-yes-or-no?
+ within-typein-edit
+ within-typein-edit?)
+ (export (edwin keyboard)
+ clear-message!
+ set-message!))
+
+(define-package (edwin buffer-input-port)
+ (files "bufinp")
+ (parent (edwin))
+ (export (edwin)
+ with-input-from-mark
+ with-input-from-region))
+
+(define-package (edwin buffer-output-port)
+ (files "bufout")
+ (parent (edwin))
+ (export (edwin)
+ with-output-to-mark))
+
+(define-package (edwin buffer-output-port-truncating)
+ (files "bufott")
+ (parent (edwin))
+ (export (edwin)
+ truncation-protect
+ with-output-to-mark-truncating))
+
+(define-package (edwin window-output-port)
+ (files "winout")
+ (parent (edwin))
+ (export (edwin)
+ with-interactive-output-port
+ with-output-to-current-point
+ with-output-to-window-point))
+
+(define-package (edwin regular-expression)
+ (files "regexp")
+ (parent (edwin))
+ (export (edwin)
+ char-match-backward
+ char-match-forward
+ char-search-backward
+ char-search-forward
+ match-backward
+ match-forward
+ re-match-end
+ re-match-forward
+ re-match-start
+ re-quote-string
+ re-search-backward
+ re-search-forward
+ search-backward
+ search-forward
+ skip-chars-backward
+ skip-chars-forward))
+
+(define-package (edwin regular-expression-compiler)
+ (files "rgxcmp")
+ (parent (edwin))
+ (export (edwin)
+ re-compile-char
+ re-compile-char-set
+ re-compile-pattern
+ re-compile-string
+ re-disassemble-pattern
+ re-translation-table))
+
+(define-package (edwin lisp-indentation)
+ (files "linden")
+ (parent (edwin))
+ (export (edwin)
+ indent-code-rigidly
+ lisp-body-indent
+ lisp-comment-indentation
+ lisp-comment-locate
+ lisp-indent-definition
+ lisp-indent-hook
+ lisp-indent-line
+ lisp-indent-methods
+ lisp-indent-offset
+ lisp-indent-sexp
+ lisp-indent-special-form
+ standard-lisp-indent-hook))
+
+(define-package (edwin command-argument)
+ (files "argred")
+ (parent (edwin))
+ (export (edwin)
+ command-argument-beginning?
+ command-argument-multiplier-exponent
+ command-argument-multiplier-only?
+ command-argument-negative-only?
+ command-argument-negative?
+ command-argument-prompt
+ command-argument-self-insert?
+ command-argument-standard-value
+ command-argument-value
+ reset-command-argument-reader!
+ with-command-argument-reader))
+
+(define-package (edwin buffer-menu)
+ (files "bufmnu")
+ (parent (edwin))
+ (export (edwin)
+ buffer-menu-kill-on-quit))
+
+(define-package (edwin register-command)
+ (files "regcom")
+ (parent (edwin)))
+
+(define-package (edwin c-indentation)
+ (files "cinden")
+ (parent (edwin))
+ (export (edwin)
+ c-indent-expression
+ c-indent-line:indentation
+ c-inside-parens?))
+
+(define-package (edwin incremental-search)
+ (files "iserch")
+ (parent (edwin)))
+
+(define-package (edwin command-summary)
+ (files "keymap")
+ (parent (edwin)))
+#|
+(define-package (edwin debugger)
+ (files "debug")
+ (parent (edwin)))
+|#(define-package (edwin dired)
+ (files "dired")
+ (parent (edwin)))
+
+(define-package (edwin info)
+ (files "info")
+ (parent (edwin)))
+
+(define-package (edwin rectangle)
+ (files "reccom")
+ (parent (edwin)))
+
+(define-package (edwin tags)
+ (files "tags")
+ (parent (edwin)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+
+(if (not (name->package '(EDWIN)))
+ (begin
+ (load "edwin.bcon")
+ (load "macros" '(EDWIN MACROS))
+ (load "clsmac" '(EDWIN CLASS-MACROS))
+ (load "xform" '(EDWIN CLASS-MACROS TRANSFORM-INSTANCE-VARIABLES))
+ (load "class" '(EDWIN))
+ (load "clscon" '(EDWIN CLASS-CONSTRUCTOR))))
+(load "decls")
+
+;; Guarantee that the package modeller is loaded.
+(if (not (name->package '(CROSS-REFERENCE)))
+ (with-working-directory-pathname "/scheme/cref" (lambda () (load "make"))))
+
+(in-package (->environment '(CROSS-REFERENCE))
+ ((generate/common
+ (lambda (pathname pmodel)
+ (write-cref pathname pmodel)
+ (write-globals pathname pmodel)
+ (write-constructor pathname pmodel)))
+ "edwin"))
+(sf "edwin.con" "edwin.bcon")
+(if (not (file-processed? "edwin" "ldr" "bldr"))
+ (sf "edwin.ldr" "edwin.bldr"))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/grpops.scm,v 1.1 1989/03/14 08:00:49 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Group Operations
+
+(declare (usual-integrations))
+\f
+;;; 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-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)))
+
+;;; 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-integrable (barf-if-read-only group)
+ (if (group-read-only? group)
+ (editor-error "Trying to modify read only text.")))
+
+(define (group-insert-char! group index char)
+ (without-interrupts
+ (lambda ()
+ (group-insert-char-kernel group index char)
+ (record-insertion! group index (group-gap-start group)))))
+
+(define (%group-insert-char! group index char)
+ (without-interrupts
+ (lambda ()
+ (group-insert-char-kernel group index char))))
+
+(define-integrable (group-insert-char-kernel 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*)))
+\f
+(define (group-insert-string! group index string)
+ (group-insert-substring! group index string 0 (string-length string)))
+
+(define (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)))))
+
+(define (%group-insert-substring! group index string start end)
+ (without-interrupts
+ (lambda ()
+ (group-insert-substring-kernel group index string start end))))
+
+(define-integrable (group-insert-substring-kernel 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*))))
+
+(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)))
+
+(define (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))))))))
+\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)))
+ unspecific)
+
+(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)))
+ unspecific)
+
+(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))))
+ unspecific)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.1 1989/03/14 08:01:07 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Incremental Search Commands
+
+(declare (usual-integrations))
+\f
+(define-command ("^R Incremental Search")
+ "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")
+ "Incremental Search Backwards.
+Like \\[^R Incremental Search] but in reverse."
+ (incremental-search false))
+
+(define-command ("^R I-Search Append Char")
+ "Append this character to the current string being searched."
+ (i-search-append-char (current-command-char)))
+
+(define-command ("^R I-Search Append Newline")
+ "Append this character to the current string being searched."
+ (i-search-append-char #\Newline))
+
+(define-command ("^R I-Search Append Word")
+ "Append the next word to the current string being searched."
+ (i-search-append-string
+ (let ((end-point (search-state-end-point current-search-state)))
+ (extract-string end-point (forward-word end-point 1 'LIMIT)))))
+
+(define-command ("^R I-Search Append Line")
+ "Append the rest of the line to the current string being searched."
+ (i-search-append-string
+ (let ((end-point (search-state-end-point current-search-state)))
+ (extract-string end-point
+ (line-end end-point
+ (if (line-end? end-point) 1 0)
+ 'LIMIT)))))
+
+(define-command ("^R I-Search Quote Character")
+ "Append a quoted character to the current string being searched."
+ (i-search-append-char (with-editor-interrupts-disabled keyboard-read-char)))
+
+(define-command ("^R I-Search Editor Command")
+ "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")
+ "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")
+ "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")
+ "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")
+ "Revert to the last successful state and exit search if there is none."
+ (incremental-search:pop!))
+
+(define-command ("^R I-Search Terminate")
+ "Terminates I-Search Mode."
+ (incremental-search:terminate! current-search-state false))
+\f
+(define (i-search-append-char char)
+ (i-search-append-string (string char)))
+
+(define (i-search-append-string string)
+ (set-current-search-state!
+ (incremental-search:append-string current-search-state string))
+ (i-search-detect-failure current-search-state))
+
+(define (i-search-detect-failure search-state)
+ (if (and (not (search-state-successful? search-state))
+ (or (search-state-successful? (search-state-parent search-state))
+ (not (eq? (search-state-forward? search-state)
+ (search-state-forward?
+ (search-state-parent search-state))))))
+ (editor-failure)))
+
+(define-major-mode "Incremental Search" #F
+ "Major mode for incremental search.
+See \"^R Incremental Search\" for details.")
+
+(define-default-key "Incremental Search" "^R I-Search Editor Command")
+(define-key "Incremental Search" char-set:graphic "^R I-Search Append Char")
+(define-key "Incremental Search" #\Tab "^R I-Search Append Char")
+(define-key "Incremental Search" #\Return "^R I-Search Append Newline")
+(define-key "Incremental Search" #\C-Q "^R I-Search Quote Character")
+(define-key "Incremental Search" #\C-R "^R I-Search Previous Occurrence")
+(define-key "Incremental Search" #\C-S "^R I-Search Next Occurrence")
+(define-key "Incremental Search" #\C-W "^R I-Search Append Word")
+(define-key "Incremental Search" #\C-Y "^R I-Search Append Line")
+(define-key "Incremental Search" #\Rubout "^R I-Search Previous State")
+(define-key "Incremental Search" #\C-G "^R I-Search Previous Successful State")
+(define-key "Incremental Search" #\Altmode "^R I-Search Terminate")
+
+(define incremental-search-exit)
+(define incremental-search-window)
+(define current-search-state)
+
+(define (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))
+ (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-comtabs) result))))))))
+
+(define (incremental-search-loop)
+ (intercept-^G-interrupts (lambda ()
+ (incremental-search:pop!)
+ (incremental-search-loop))
+ command-reader))
+\f
+(define (incremental-search:append-string state string)
+ (let ((text (string-append (search-state-text state) string)))
+ (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))
+ 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)
+ (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: "))
+ (region-insert-string!
+ point
+ (image-representation (make-image (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)
+ unspecific)
+
+(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))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.1 1989/03/14 08:08: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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Autoload Definitions
+
+(declare (usual-integrations))
+\f
+;;;; Various Libraries
+
+(define-library 'INFO
+ '("info" (EDWIN INFO)))
+
+(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."
+ edwin-info-directory)
+(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-library 'DIRED
+ '("dired" (EDWIN DIRED)))
+
+(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-library 'RECTANGLE-COMMANDS
+ '("reccom" (EDWIN RECTANGLE)))
+
+(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 '(EDWIN RECTANGLE) 'delete-rectangle
+ 'RECTANGLE-COMMANDS)
+
+(define-autoload-procedure '(EDWIN RECTANGLE) 'yank-rectangle
+ 'RECTANGLE-COMMANDS)
+
+(define-library 'COMMAND-SUMMARY
+ '("keymap" (EDWIN COMMAND-SUMMARY)))
+
+(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-library 'TAGS
+ '("tags" (EDWIN TAGS)))
+
+(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
+;;;; Major Mode Libraries
+
+(define-library 'MIDAS-MODE
+ '("midas" (EDWIN)))
+
+(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-library 'PASCAL-MODE
+ '("pasmod" (EDWIN)))
+
+(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 #F to disable the option."
+ false)
+
+(define-library 'TEXINFO-MODE
+ '("tximod" (EDWIN)))
+
+(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-library 'C-MODE
+ '("c-mode" (EDWIN))
+ '("cinden" (EDWIN C-INDENTATION)))
+
+(define-autoload-major-mode "C" "Fundamental" 'C-MODE
+ "Major mode for editing C code.
+Expression and list commands understand all C brackets.
+Tab indents for C code.
+Comments are delimited with /* ... */.
+Paragraphs are separated by blank lines only.
+Delete converts tabs to spaces as it moves back.
+The characters { } ; : correct indentation when typed.
+
+Variables controlling indentation style:
+ C Auto Newline
+ Non-false means automatically newline before and after braces,
+ and after colons and semicolons, inserted in C code.
+ C Indent Level
+ Indentation of C statements within surrounding block.
+ The surrounding block's indentation is the indentation
+ of the line on which the open-brace appears.
+ C Continued Statement Offset
+ Extra indentation given to a substatement, such as the
+ then-clause of an if or body of a while.
+ C Brace Offset
+ Extra indentation for line if it starts with an open brace.
+ C Brace Imaginary Offset
+ An open brace following other text is treated as if it were
+ this far to the right of the start of its line.
+ C Argdecl Indent
+ Indentation level of declarations of C function arguments.
+ C Label Offset
+ Extra indentation for line that is a label, or case or default.")
+
+(define-autoload-command "C Mode" 'C-MODE
+ "Enter C mode.")
+
+(define-variable "C Mode Hook"
+ "If not false, a thunk to call when entering C mode."
+ false)
+
+(define-variable "C Indent Level"
+ "Indentation of C statements with respect to containing block."
+ 2)
+
+(define-variable "C Brace Offset"
+ "Extra indentation for braces, compared with other text in same context."
+ 0)
+
+(define-variable "C Brace Imaginary Offset"
+ "Imagined indentation of a C open brace that actually follows a statement."
+ 0)
+
+(define-variable "C Argdecl Indent"
+ "Indentation level of declarations of C function arguments."
+ 5)
+
+(define-variable "C Label Offset"
+ "Offset of C label lines and case statements relative to usual indentation."
+ -2)
+
+(define-variable "C Continued Statement Offset"
+ "Extra indent for lines not starting new statements."
+ 2)
+
+(define-variable "C Auto Newline"
+ "Non-false means automatically newline before and after braces,
+and after colons and semicolons, inserted in C code."
+ false)
\ No newline at end of file
--- /dev/null
+(package/system-loader "edwin" '() 'QUERY)
+(add-system! (make-system "Edwin" 3 0 '()))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/paths.scm,v 1.1 1989/03/14 08:08:55 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 Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Edwin Pathnames
+
+(declare (usual-integrations))
+
+(define edwin-binary-directory
+ (string->pathname "/zu/cph/edwin/"))
+
+(define edwin-info-directory
+ edwin-binary-directory)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Edwin Interpackage Renames
+
+(declare (usual-integrations))
+\f
+(let ((global (->environment '()))
+ (edwin (->environment '(edwin)))
+ (window (->environment '(edwin window))))
+ (let ((g<-e
+ (lambda (g e)
+ (local-assignment global g (lexical-reference edwin e)))))
+ (g<-e 'edit 'edwin)
+ (g<-e 'save-editor-files 'debug-save-files)
+ (g<-e 'reset-editor 'edwin-discard-state!)
+ (g<-e 'reset-editor-windows 'edwin-reset-windows)) (let ((e<-w
+ (lambda (e w)
+ (lexical-assignment edwin e (lexical-reference window w)))))
+ (e<-w 'window? 'buffer-frame?)
+ (e<-w 'window-x-size 'buffer-frame-x-size)
+ (e<-w 'window-y-size 'buffer-frame-y-size)
+ (e<-w '%set-window-buffer! 'set-window-buffer!)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.1 1989/03/14 08:08:56 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Unix Customizations for Edwin
+
+(declare (usual-integrations))
+\f
+(define (os/trim-pathname-string string)
+ (let ((end (string-length string))) (let loop ((index end))
+ (let ((slash (substring-find-previous-char string 0 index #\/)))
+ (cond ((or (not slash) (= slash end))
+ string)
+ ((memv (string-ref string (1+ slash)) '(#\~ #\$))
+ (string-tail string (1+ slash)))
+ ((zero? slash)
+ string)
+ ((char=? #\/ (string-ref string (-1+ slash)))
+ (string-tail string slash))
+ (else
+ (loop (-1+ slash))))))))
+
+(define (os/auto-save-pathname pathname buffer-name)
+ (let ((wrap
+ (lambda (name directory)
+ (merge-pathnames (string->pathname (string-append "#" name "#"))
+ directory))))
+ (if (not pathname)
+ (wrap (string-append "%" buffer-name)
+ (working-directory-pathname))
+ (wrap (pathname-name-string pathname)
+ (pathname-directory-path pathname)))))
+
+(define-variable "Backup By Copying When Linked"
+ "*Non-false means use copying to create backups for files with multiple names.
+This causes the alternate names to refer to the latest version as edited.
+This variable is relevant only if Backup By Copying is false."
+ false)
+
+(define-variable "Backup By Copying When Mismatch"
+ "*Non-false means create backups by copying if this preserves owner or group.
+Renaming may still be used (subject to control of other variables)
+when it would not result in changing the owner or group of the file;
+that is, for files which are owned by you and whose group matches
+the default for a new file created there by you.
+This variable is relevant only if Backup By Copying is false."
+ false)
+
+(define-variable "Version Control"
+ "*Control use of version numbers for backup files.
+#T means make numeric backup versions unconditionally.
+#F means make them for files that have some already.
+'NEVER means do not make them."
+ false)
+
+(define-variable "Kept Old Versions"
+ "*Number of oldest versions to keep when a new numbered backup is made."
+ 2)
+
+(define-variable "Kept New Versions"
+ "*Number of newest versions to keep when a new numbered backup is made.
+Includes the new backup. Must be > 0"
+ 2)
+
+(define (os/backup-buffer? truename)
+ (and (memv (string-ref (vector-ref (file-attributes truename) 8) 0)
+ '(#\- #\l))
+ (not
+ (let ((directory (pathname-directory truename)))
+ (and (pair? directory)
+ (eq? 'ROOT (car directory))
+ (pair? (cdr directory))
+ (eqv? "tmp" (cadr directory)))))))
+
+(define (os/default-backup-filename)
+ "~/%backup%~")
+\f
+(define (os/backup-by-copying? truename)
+ (let ((attributes (file-attributes truename)))
+ (and (ref-variable "Backup By Copying When Linked")
+ (> (file-attributes/n-links attributes) 1))
+ (and (ref-variable "Backup By Copying When Mismatch")
+ (not (and (= (file-attributes/uid attributes) (unix/current-uid))
+ (= (file-attributes/gid attributes) (unix/current-gid)))))))
+
+(define (os/buffer-backup-pathname truename)
+ (let ((no-versions
+ (lambda ()
+ (values
+ (string->pathname (string-append (pathname->string truename) "~"))
+ '()))))
+ (if (eq? 'NEVER (ref-variable "Version Control"))
+ (no-versions)
+ (let ((non-numeric (char-set-invert char-set:numeric))
+ (directory (pathname-directory-path truename))
+ (prefix (string-append (pathname-name-string truename) ".~")))
+ (let ((prefix-length (string-length prefix)))
+ (let ((filenames
+ (map pathname-name-string
+ (directory-read directory false))))
+ (let ((possibilities
+ (list-transform-positive filenames
+ (lambda (filename)
+ (let ((end (string-length filename)))
+ (let ((last (-1+ end)))
+ (and (string-prefix? prefix filename)
+ (char=? #\~ (string-ref filename last))
+ (eqv? last
+ (substring-find-next-char-in-set
+ filename
+ prefix-length
+ end
+ non-numeric)))))))))
+ (let ((versions
+ (sort (map (lambda (filename)
+ (string->number
+ (substring filename
+ prefix-length
+ (-1+ (string-length filename)))))
+ possibilities)
+ <)))
+ (let ((high-water-mark (apply max (cons 0 versions))))
+ (if (or (ref-variable "Version Control")
+ (positive? high-water-mark))
+ (let ((version->pathname
+ (lambda (version)
+ (merge-pathnames
+ (string->pathname
+ (string-append prefix
+ (number->string version)
+ "~"))
+ directory))))
+ (values
+ (version->pathname (1+ high-water-mark))
+ (let ((start
+ (ref-variable "Kept Old Versions"))
+ (end
+ (- (length versions)
+ (-1+ (ref-variable "Kept New Versions")))))
+ (if (< start end)
+ (map version->pathname
+ (sublist versions start end))
+ '()))))
+ (no-versions)))))))))))
+\f
+(define (os/make-dired-line pathname)
+ (let ((attributes (file-attributes pathname)))
+ (string-append " "
+ (file-attributes/mode-string attributes)
+ " "
+ (pad-on-left-to
+ (number->string (file-attributes/n-links attributes) 10)
+ 3)
+ " "
+ (pad-on-right-to
+ (unix/uid->string (file-attributes/uid attributes))
+ 8)
+ " "
+ (pad-on-right-to
+ (unix/gid->string (file-attributes/gid attributes))
+ 8)
+ " "
+ (pad-on-right-to
+ (number->string (file-attributes/length attributes) 10)
+ 7)
+ " "
+ (unix/file-time->string
+ (file-attributes/modification-time attributes))
+ " "
+ (pathname-name-string pathname))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/winout.scm,v 1.1 1989/03/14 08:08: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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Buffer I/O Ports
+
+(declare (usual-integrations))
+\f
+(define (with-output-to-current-point thunk)
+ (with-output-to-window-point (current-window) thunk))
+
+(define (with-output-to-window-point window thunk)
+ (with-interactive-output-port (window-output-port window) thunk))
+
+(define (with-interactive-output-port port thunk)
+ (with-output-to-port port
+ (lambda ()
+ (with-cmdl/output-port (nearest-cmdl) port thunk))))
+
+(define (window-output-port window)
+ (output-port/copy window-output-port-template window))
+
+(define (operation/write-char port char)
+ (let ((window (output-port/state port)))
+ (let ((buffer (window-buffer window))
+ (point (window-point window)))
+ (if (and (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (buffer-auto-save-modified? buffer)
+ (or (not (window-needs-redisplay? window))
+ (window-direct-update! window false)))
+ (cond ((and (group-end? point)
+ (char=? char #\newline)
+ (< (1+ (window-point-y window)) (window-y-size window)))
+ (window-direct-output-insert-newline! window))
+ ((and (char-graphic? char)
+ (< (1+ (window-point-x window)) (window-x-size window)))
+ (window-direct-output-insert-char! window char))
+ (else
+ (region-insert-char! point char)))
+ (region-insert-char! point char)))))
+
+(define (operation/write-string port string)
+ (let ((window (output-port/state port)))
+ (let ((buffer (window-buffer window))
+ (point (window-point window)))
+ (if (and (null? (cdr (buffer-windows buffer)))
+ (line-end? point)
+ (buffer-auto-save-modified? buffer)
+ (or (not (window-needs-redisplay? window))
+ (window-direct-update! window false))
+ (not (string-find-next-char-in-set string char-set:not-graphic))
+ (< (+ (string-length string) (window-point-x window))
+ (window-x-size window)))
+ (window-direct-output-insert-substring! window
+ string
+ 0
+ (string-length string))
+ (region-insert-string! point string)))))
+
+(define (operation/flush-output port)
+ (let ((window (output-port/state port)))
+ (if (window-needs-redisplay? window)
+ (window-direct-update! window false))))
+
+(define (operation/print-self state port)
+ (unparse-string state "to window ")
+ (unparse-object state (output-port/state port)))
+
+(define window-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
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1989 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; Window System Rename Exports
+
+(declare (usual-integrations))
+\f
+;; buffrm.scm
+(define window?)
+(define window-x-size)
+(define window-y-size)
+(define %set-window-buffer!)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.1 1989/03/14 08:08:58 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
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+
+;;;; X Terminal
+
+(declare (usual-integrations))
+\f
+(define-primitives
+ (xterm-open-display 1)
+ (xterm-close-display 1)
+ (xterm-close-all-displays 0)
+ (xterm-open-window 3)
+ (xterm-close-window 1)
+ (xterm-map 1)
+ (xterm-unmap 1)
+ (xterm-x-size 1)
+ (xterm-y-size 1)
+ (xterm-read-event-flags! 1)
+ (xterm-beep 1)
+ (xterm-flush 1)
+ (xterm-write-cursor! 3)
+ (xterm-write-char! 5)
+ (xterm-write-substring! 7)
+ (xterm-clear-rectangle! 6)
+ (xterm-read-chars 2))
+
+(define-structure (xterm-screen-state
+ (constructor make-xterm-screen-state (xterm))
+ (conc-name xterm-screen-state/))
+ (xterm false read-only true)
+ (highlight 0))
+
+(define (make-xterm-screen #!optional geometry)
+ (make-screen (make-xterm-screen-state
+ (xterm-open-window (or (xterm-open-display false)
+ (error "unable to open display"))
+ (and (not (default-object? geometry))
+ geometry)
+ false))
+ xterm-screen/beep
+ xterm-screen/finish-update!
+ xterm-screen/flush!
+ xterm-screen/inverse-video!
+ xterm-screen/start-update!
+ xterm-screen/subscreen-clear!
+ xterm-screen/write-char!
+ xterm-screen/write-cursor!
+ xterm-screen/write-substring!
+ xterm-screen/write-substrings!
+ xterm-screen/x-size
+ xterm-screen/y-size))
+
+(define-integrable (screen-xterm screen)
+ (xterm-screen-state/xterm (screen-state screen)))
+
+(define-integrable (screen-highlight screen)
+ (xterm-screen-state/highlight (screen-state screen)))
+
+(define-integrable (set-screen-highlight! screen highlight)
+ (set-xterm-screen-state/highlight! (screen-state screen) highlight))
+
+(define (xterm-screen/start-update! screen)
+ (xterm-screen/process-events! screen))
+
+(define (xterm-screen/finish-update! screen)
+ (xterm-flush (screen-xterm screen)))
+
+(define (xterm-screen/beep screen)
+ (let ((xterm (screen-xterm screen)))
+ (xterm-beep xterm)
+ (xterm-flush xterm)))
+
+(define (xterm-screen/flush! screen)
+ (xterm-flush (screen-xterm screen)))
+
+(define (xterm-screen/inverse-video! screen highlight?)
+ (let ((result (not (zero? (screen-highlight screen)))))
+ (set-screen-highlight! screen (if highlight? 1 0))
+ result))
+
+(define (xterm-screen/write-char! screen x y char)
+ (xterm-write-char! (screen-xterm screen) x y char (screen-highlight screen)))
+
+(define (xterm-screen/write-cursor! screen x y)
+ (xterm-write-cursor! (screen-xterm screen) x y))
+
+(define (xterm-screen/write-substring! screen x y string start end)
+ (xterm-write-substring! (screen-xterm screen) x y string start end
+ (screen-highlight screen)))
+
+(define (xterm-screen/write-substrings! screen x y strings bil biu bjl bju)
+ (let ((xterm (screen-xterm screen))
+ (highlight (screen-highlight screen)))
+ (clip (xterm-x-size xterm) x bil biu
+ (lambda (bxl ail aiu)
+ (clip (xterm-y-size xterm) y bjl bju
+ (lambda (byl ajl aju)
+ (let loop ((y byl) (j ajl))
+ (if (< j aju)
+ (begin
+ (xterm-write-substring! xterm
+ bxl y
+ (vector-ref strings j)
+ ail aiu
+ highlight)
+ (loop (1+ y) (1+ j)))))))))))
+
+(define (clip axu x bil biu receiver)
+ (let ((ail (- bil x)))
+ (if (< ail biu)
+ (let ((aiu (+ ail axu)))
+ (cond ((not (positive? x))
+ (receiver 0 ail (if (< aiu biu) aiu biu)))
+ ((< x axu)
+ (receiver x bil (if (< aiu biu) aiu biu))))))))
+
+(define (xterm-screen/subscreen-clear! screen xl xu yl yu)
+ (xterm-clear-rectangle! (screen-xterm screen) xl xu yl yu
+ (screen-highlight screen)))
+
+(define (xterm-screen/x-size screen)
+ (xterm-x-size (screen-xterm screen)))
+
+(define (xterm-screen/y-size screen)
+ (xterm-y-size (screen-xterm screen)))
+\f
+;;;; Input Port
+
+(define (make-xterm-input-port screen)
+ (input-port/copy xterm-input-port-template
+ (make-xterm-input-port-state screen)))
+
+(define-structure (xterm-input-port-state
+ (constructor make-xterm-input-port-state (screen))
+ (conc-name xterm-input-port-state/))
+ (screen false read-only true)
+ (buffer "")
+ (index 0))
+
+(define (operation/char-ready? port interval)
+ (let ((state (input-port/state port)))
+ (if (< (xterm-input-port-state/index state)
+ (string-length (xterm-input-port-state/buffer state)))
+ true
+ (let ((buffer
+ (xterm-screen/read-chars (xterm-input-port-state/screen state)
+ interval)))
+ (and buffer
+ (begin
+ (check-for-interrupts! state buffer 0)
+ true))))))
+
+(define (operation/peek-char port)
+ (let ((state (input-port/state port)))
+ (let ((buffer (xterm-input-port-state/buffer state))
+ (index (xterm-input-port-state/index state)))
+ (if (< index (string-length buffer))
+ (string-ref buffer index)
+ (refill-buffer! state 0)))))
+
+(define (operation/discard-char port)
+ (let ((state (input-port/state port)))
+ (set-xterm-input-port-state/index!
+ state
+ (1+ (xterm-input-port-state/index state)))))
+
+(define (operation/read-char port)
+ (let ((state (input-port/state port)))
+ (let ((buffer (xterm-input-port-state/buffer state))
+ (index (xterm-input-port-state/index state)))
+ (if (< index (string-length buffer))
+ (begin
+ (set-xterm-input-port-state/index! state (1+ index))
+ (string-ref buffer index))
+ (refill-buffer! state 1)))))
+
+(define (operation/print-self state port)
+ (unparse-string state "from screen ")
+ (unparse-object state
+ (xterm-input-port-state/screen (input-port/state port))))
+
+(define xterm-input-port-template
+ (make-input-port `((CHAR-READY? ,operation/char-ready?)
+ (DISCARD-CHAR ,operation/discard-char)
+ (PEEK-CHAR ,operation/peek-char)
+ (PRINT-SELF ,operation/print-self)
+ (READ-CHAR ,operation/read-char))
+ false))
+\f
+(define (refill-buffer! state index)
+ (let ((screen (xterm-input-port-state/screen state)))
+ (let loop ()
+ (let ((buffer (xterm-screen/read-chars screen false)))
+ (if (not buffer)
+ (loop)
+ (begin
+ (check-for-interrupts! state buffer index)
+ (string-ref buffer 0)))))))
+
+(define (xterm-screen/read-chars screen interval)
+ (let ((result (xterm-read-chars (screen-xterm screen) interval)))
+ (if (and (not (screen-in-update? screen))
+ (xterm-screen/process-events! screen))
+ (update-screen! screen false))
+ result))
+
+(define (xterm-screen/process-events! screen)
+ (let ((xterm (screen-xterm screen)))
+ (and (odd? (xterm-read-event-flags! xterm))
+ (let ((window (screen-window screen)))
+ (and window
+ (send window ':set-size!
+ (xterm-x-size xterm)
+ (xterm-y-size xterm))
+ true)))))
+
+(define (check-for-interrupts! state buffer index)
+ (set-xterm-input-port-state/buffer! state buffer)
+ (let ((^g-index
+ (and signal-interrupts?
+ (string-find-previous-char buffer #\BEL))))
+ (if ^g-index
+ (begin
+ (set-xterm-input-port-state/index! state (1+ ^g-index))
+ (signal-interrupt!))
+ (set-xterm-input-port-state/index! state index))))
+
+(define signal-interrupts?)
+(define pending-interrupt?)
+
+(define (signal-interrupt!)
+ (editor-beep)
+ (temporary-message "Quit")
+ (set! pending-interrupt? false)
+ (^G-signal))
+
+(define (with-editor-interrupts thunk)
+ (fluid-let ((signal-interrupts? true)
+ (pending-interrupt? false))
+ (thunk)))
+
+(define (with-editor-interrupts-enabled thunk)
+ (bind-signal-interrupts? true thunk))
+
+(define (with-editor-interrupts-disabled thunk)
+ (bind-signal-interrupts? false thunk))
+
+(define (bind-signal-interrupts? new-mask thunk)
+ (let ((old-mask))
+ (dynamic-wind (lambda ()
+ (set! old-mask signal-interrupts?)
+ (set! signal-interrupts? new-mask)
+ (if (and new-mask pending-interrupt?)
+ (signal-interrupt!)))
+ thunk
+ (lambda ()
+ (set! new-mask signal-interrupts?)
+ (set! signal-interrupts? old-mask)
+ (if (and old-mask pending-interrupt?)
+ (signal-interrupt!))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff