From: Chris Hanson Date: Tue, 14 Mar 1989 08:12:21 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~12234 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6be46d06d87851feae676f3febafefb954da9f4e;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/bufinp.scm b/v7/src/edwin/bufinp.scm new file mode 100644 index 000000000..473a111ee --- /dev/null +++ b/v7/src/edwin/bufinp.scm @@ -0,0 +1,149 @@ +;;; -*-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)) + +(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))))) + +(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 diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm new file mode 100644 index 000000000..e353bc690 --- /dev/null +++ b/v7/src/edwin/bufout.scm @@ -0,0 +1,64 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/edwin/cinden.scm b/v7/src/edwin/cinden.scm new file mode 100644 index 000000000..46befa603 --- /dev/null +++ b/v7/src/edwin/cinden.scm @@ -0,0 +1,307 @@ +;;; -*-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)) + +(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))) + +(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)))))) + +(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)) + +(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)))) + +(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 diff --git a/v7/src/edwin/clscon.scm b/v7/src/edwin/clscon.scm new file mode 100644 index 000000000..239d0afb9 --- /dev/null +++ b/v7/src/edwin/clscon.scm @@ -0,0 +1,115 @@ +;;; -*-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. +;;; ****************************************************************** + +(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 diff --git a/v7/src/edwin/clsmac.scm b/v7/src/edwin/clsmac.scm new file mode 100644 index 000000000..67fbe7986 --- /dev/null +++ b/v7/src/edwin/clsmac.scm @@ -0,0 +1,152 @@ +;;; -*-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. +;;; ****************************************************************** + +(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))) + +(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 diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm new file mode 100644 index 000000000..93ae40b9a --- /dev/null +++ b/v7/src/edwin/decls.scm @@ -0,0 +1,108 @@ +(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 diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm new file mode 100644 index 000000000..4b6207841 --- /dev/null +++ b/v7/src/edwin/edtstr.scm @@ -0,0 +1,81 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/edwin/edwin.cbf b/v7/src/edwin/edwin.cbf new file mode 100644 index 000000000..8c9bd9552 --- /dev/null +++ b/v7/src/edwin/edwin.cbf @@ -0,0 +1,7 @@ +;;; -*-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 diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr new file mode 100644 index 000000000..4e7a7fb3c --- /dev/null +++ b/v7/src/edwin/edwin.ldr @@ -0,0 +1,98 @@ +;;; -*-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 diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg new file mode 100644 index 000000000..67b0fcf6b --- /dev/null +++ b/v7/src/edwin/edwin.pkg @@ -0,0 +1,508 @@ +#| -*-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 + +(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 diff --git a/v7/src/edwin/edwin.sf b/v7/src/edwin/edwin.sf new file mode 100644 index 000000000..889cf583e --- /dev/null +++ b/v7/src/edwin/edwin.sf @@ -0,0 +1,26 @@ +;;; -*-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 diff --git a/v7/src/edwin/grpops.scm b/v7/src/edwin/grpops.scm new file mode 100644 index 000000000..bc1cd13df --- /dev/null +++ b/v7/src/edwin/grpops.scm @@ -0,0 +1,236 @@ +;;; -*-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)) + +;;; 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*))) + +(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)))))))) + +;;;; 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 diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm new file mode 100644 index 000000000..5755e29e6 --- /dev/null +++ b/v7/src/edwin/iserch.scm @@ -0,0 +1,373 @@ +;;; -*-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)) + +(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)) + +(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)) + +(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)))) + +(define (incremental-search:next-occurrence state) + (cond ((null? (search-state-parent state)) + (let ((point (search-state-initial-point state))) + (if (not (search-state-forward? state)) + (initial-search-state true point) + (begin + (insert-string (ref-variable "Previous Search String")) + (find-next-search-state state + (ref-variable "Previous Search String") + point))))) + ((search-state-successful? state) + (find-next-search-state state + (search-state-text state) + ((if (search-state-forward? state) + search-state-end-point + search-state-start-point) + state))) + ((not (search-state-forward? state)) + (find-next-search-state state + (search-state-text state) + (search-state-point state))) + (else + (unsuccessful-search-state state (search-state-text state) true)))) + +(define (incremental-search:previous-occurrence state) + (cond ((null? (search-state-parent state)) + (let ((point (search-state-initial-point state))) + (if (search-state-forward? state) + (initial-search-state false point) + (begin + (insert-string (ref-variable "Previous Search String")) + (find-previous-search-state + state + (ref-variable "Previous Search String") + point))))) + ((search-state-successful? state) + (find-previous-search-state state + (search-state-text state) + ((if (search-state-forward? state) + search-state-end-point + search-state-start-point) + state))) + ((search-state-forward? state) + (find-previous-search-state state + (search-state-text state) + (search-state-point state))) + (else + (unsuccessful-search-state state (search-state-text state) false)))) + +(define (initial-search-state forward? point) + (make-search-state "" '() forward? true point point point point)) + +(define (unsuccessful-search-state parent text forward?) + (let ((start-point (search-state-start-point parent))) + (make-search-state text parent forward? false + start-point + (mark+ start-point (string-length text)) + (search-state-point parent) + (search-state-initial-point parent)))) + +(define (find-next-search-state state text start) + (if (search-forward text start) + (let ((start-point (re-match-start 0)) + (end-point (re-match-end 0))) + (make-search-state text state true true + start-point end-point end-point + (if (search-state-forward? state) + (search-state-initial-point state) + (search-state-start-point state)))) + (unsuccessful-search-state state text true))) + +(define (find-previous-search-state state text start) + (if (search-backward text start) + (let ((start-point (re-match-start 0)) + (end-point (re-match-end 0))) + (make-search-state text state false true + start-point end-point start-point + (if (search-state-forward? state) + (search-state-end-point state) + (search-state-initial-point state)))) + (unsuccessful-search-state state text false))) + +(define (set-current-search-state! state) + (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))))) + +(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 diff --git a/v7/src/edwin/loadef.scm b/v7/src/edwin/loadef.scm new file mode 100644 index 000000000..0f30d8d5f --- /dev/null +++ b/v7/src/edwin/loadef.scm @@ -0,0 +1,293 @@ +;;; -*-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)) + +;;;; 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.") + +(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.") +;;;; 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.") + +;;;; 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) + +(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 diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm new file mode 100644 index 000000000..c5f8a7cc0 --- /dev/null +++ b/v7/src/edwin/make.scm @@ -0,0 +1,2 @@ +(package/system-loader "edwin" '() 'QUERY) +(add-system! (make-system "Edwin" 3 0 '())) \ No newline at end of file diff --git a/v7/src/edwin/paths.scm b/v7/src/edwin/paths.scm new file mode 100644 index 000000000..9f4d2308d --- /dev/null +++ b/v7/src/edwin/paths.scm @@ -0,0 +1,43 @@ +#| -*-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 diff --git a/v7/src/edwin/rename.scm b/v7/src/edwin/rename.scm new file mode 100644 index 000000000..752192050 --- /dev/null +++ b/v7/src/edwin/rename.scm @@ -0,0 +1,57 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm new file mode 100644 index 000000000..e30213581 --- /dev/null +++ b/v7/src/edwin/unix.scm @@ -0,0 +1,205 @@ +;;; -*-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)) + +(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%~") + +(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))))))))))) + +(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 diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm new file mode 100644 index 000000000..d2719db66 --- /dev/null +++ b/v7/src/edwin/winout.scm @@ -0,0 +1,109 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/edwin/winren.scm b/v7/src/edwin/winren.scm new file mode 100644 index 000000000..36855825b --- /dev/null +++ b/v7/src/edwin/winren.scm @@ -0,0 +1,46 @@ +;;; -*-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)) + +;; buffrm.scm +(define window?) +(define window-x-size) +(define window-y-size) +(define %set-window-buffer!) \ No newline at end of file diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm new file mode 100644 index 000000000..f83993d6a --- /dev/null +++ b/v7/src/edwin/xterm.scm @@ -0,0 +1,296 @@ +;;; -*-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)) + +(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))) + +;;;; 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)) + +(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