From: Chris Hanson Date: Thu, 2 Mar 1989 02:16:55 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: 20090517-FFI~12254 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=09cda8033b9543fdce9e74c87ea21729e230c375;p=mit-scheme.git *** empty log message *** --- diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm index 8dadfe9ef..7f3723dc8 100644 --- a/v7/src/edwin/autold.scm +++ b/v7/src/edwin/autold.scm @@ -324,6 +324,13 @@ of subproblem 0." (insert-string "No" (window-point window)) (window-direct-update! window #!FALSE) #!FALSE) + ;; But there was a third possibility + ;; we didn't think about ... + ((char=? #\E char) + ((access standard-error-hook error-system) + environment message irritant + substitute-environment?) + (loop)) (else (beep) (loop))))) diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index 732d9d99d..e17b6e2ff 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -100,13 +100,13 @@ With an argument, inserts several newlines." (define (editor-error . strings) (if (not (null? strings)) (apply temporary-message strings)) - (beep) + (screen-beep the-alpha-screen) (abort-current-command)) (define (editor-failure . strings) (cond ((not (null? strings)) (apply temporary-message strings)) (*defining-keyboard-macro?* (clear-message))) - (beep) + (screen-beep the-alpha-screen) (keyboard-macro-disable)) (define (not-implemented) diff --git a/v7/src/edwin/buffrm.scm b/v7/src/edwin/buffrm.scm index 1679c35de..892f9a062 100644 --- a/v7/src/edwin/buffrm.scm +++ b/v7/src/edwin/buffrm.scm @@ -38,7 +38,7 @@ ;;;; Buffer Frames (declare (usual-integrations) - (integrate-external "edb:comwin.bin.0")) + ) (using-syntax class-syntax-table (define-class buffer-frame combination-leaf-window diff --git a/v7/src/edwin/bufwfs.scm b/v7/src/edwin/bufwfs.scm index 2091c78e0..246dee82a 100644 --- a/v7/src/edwin/bufwfs.scm +++ b/v7/src/edwin/bufwfs.scm @@ -38,7 +38,7 @@ ;;;; Buffer Windows: Fill and Scroll (declare (usual-integrations) - (integrate-external "edb:bufwin.bin.0")) + ) (using-syntax class-syntax-table ;;;; Fill @@ -176,33 +176,86 @@ (redraw-screen! window 0)) (define-procedure buffer-window (scroll-lines-down! window inferiors y-start) - (define (loop inferiors y-start) - (if (or (null? inferiors) - (>= y-start y-size)) - '() - (begin (set-inferior-start! (car inferiors) 0 y-start) - (cons (car inferiors) - (loop (cdr inferiors) - (inferior-y-end (car inferiors))))))) - (loop inferiors y-start)) + + ;; Returns new list of new inferiors. + + ;; "Fast scroll" can be invoked if the lines in the buffer are + ;; the full width of the screen and the screen image is correct. + ;; If the buffer-window width is the same size as the-alpha-window width + ;; then it is assumed that the line windows can be simply scrolled. + ;; If the redisplay flag for the buffer-window is off, then the image + ;; on the screen should be correct. + + (let ((absolute-start (inferior-absolute-position (car inferiors) + (lambda (x y) y) + (lambda () #f)))) + (let ((fast-scroll? (and (= x-size (window-x-size the-alpha-window)) + (false? (car (inferior-redisplay-flags + (car inferiors)))) + (not (false? absolute-start)))) + (starting-line (inferior-y-start (car inferiors)))) + + (define (loop inferiors y-start) + (if (or (null? inferiors) + (>= y-start y-size)) + '() + (begin ((if fast-scroll? + set-inferior-start-no-redisplay! + set-inferior-start!) + (car inferiors) 0 y-start) + (cons (car inferiors) + (loop (cdr inferiors) + (inferior-y-end (car inferiors))))))) + + (let ((value (loop inferiors y-start))) + ;; Now update the display + (if fast-scroll? + (screen-scroll-region-down! the-alpha-screen + (- y-start starting-line) + absolute-start + (+ absolute-start + (- y-size starting-line)))) + value)))) (define-procedure buffer-window (scroll-lines-up! window inferiors y-start start-index) - (define (loop inferiors y-start start-index) - (set-inferior-start! (car inferiors) 0 y-start) - (cons (car inferiors) - (if (null? (cdr inferiors)) - (fill-bottom window - (inferior-y-end (car inferiors)) - (line-end-index (buffer-group buffer) start-index)) - (let ((y-start (inferior-y-end (car inferiors)))) - (if (>= y-start y-size) - '() - (loop (cdr inferiors) - y-start - (+ start-index - (line-inferior-length inferiors)))))))) - (loop inferiors y-start start-index)) + + (let ((absolute-start (inferior-absolute-position (car inferiors) + (lambda (x y) y) + (lambda () #f)))) + (let ((fast-scroll? (and (= x-size (window-x-size the-alpha-window)) + (false? (car (inferior-redisplay-flags + (car inferiors)))) + (not (false? absolute-start)))) + (starting-line (inferior-y-start (car inferiors)))) + + (define (loop inferiors y-start start-index) + ((if fast-scroll? + set-inferior-start-no-redisplay! + set-inferior-start!) + (car inferiors) 0 y-start) + (cons (car inferiors) + (if (null? (cdr inferiors)) + (fill-bottom window + (inferior-y-end (car inferiors)) + (line-end-index (buffer-group buffer) + start-index)) + (let ((y-start (inferior-y-end (car inferiors)))) + (if (>= y-start y-size) + '() + (loop (cdr inferiors) + y-start + (+ start-index + (line-inferior-length inferiors)))))))) + (let ((value (loop inferiors y-start start-index))) + (if fast-scroll? + (screen-scroll-region-up! the-alpha-screen + (- starting-line y-start) + (- absolute-start + (- starting-line y-start)) + (+ absolute-start + (- y-size starting-line)))) + value)))) ;;; end USING-SYNTAX ) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index 32c0f9a11..b90f88131 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -38,7 +38,7 @@ ;;;; Buffer Windows: Base (declare (usual-integrations) - (integrate-external "edb:linwin.bin.0")) + ) (using-syntax class-syntax-table (define-class buffer-window vanilla-window diff --git a/v7/src/edwin/bufwiu.scm b/v7/src/edwin/bufwiu.scm index eca0cd958..0837df933 100644 --- a/v7/src/edwin/bufwiu.scm +++ b/v7/src/edwin/bufwiu.scm @@ -32,13 +32,14 @@ ;;; material, there shall be no use of the name of the ;;; Massachusetts Institute of Technology nor of any adaptation ;;; thereof in any advertising, promotional, or sales literature + ;;; without prior written consent from MIT in each case. ;;; ;;;; Buffer Windows: Image Update (declare (usual-integrations) - (integrate-external "edb:bufwin.bin.0")) + ) (using-syntax class-syntax-table ;;;; Insert/Delete/Clip diff --git a/v7/src/edwin/bufwmc.scm b/v7/src/edwin/bufwmc.scm index edacfe62d..c67ed650f 100644 --- a/v7/src/edwin/bufwmc.scm +++ b/v7/src/edwin/bufwmc.scm @@ -38,7 +38,7 @@ ;;;; Buffer Windows: Mark <-> Coordinate Maps (declare (usual-integrations) - (integrate-external "edb:bufwin.bin.0")) + ) (using-syntax class-syntax-table (define-procedure buffer-window (%window-mark->x window mark) diff --git a/v7/src/edwin/calias.scm b/v7/src/edwin/calias.scm index 35b6b7c63..1eaefddf3 100644 --- a/v7/src/edwin/calias.scm +++ b/v7/src/edwin/calias.scm @@ -63,11 +63,16 @@ (define-alias-char #\C-I #\Tab) (define-alias-char #\C-j #\Linefeed) (define-alias-char #\C-J #\Linefeed) +(define-alias-char #\C-k #\VT) +(define-alias-char #\C-K #\VT) (define-alias-char #\C-l #\Page) (define-alias-char #\C-L #\Page) (define-alias-char #\C-m #\Return) (define-alias-char #\C-M #\Return) +(define-alias-char #\C-z #\Call) +(define-alias-char #\C-Z #\Call) (define-alias-char #\C-[ #\Altmode) +(define-alias-char #\C-- #\Backnext) (define-alias-char #\C-M-h #\M-Backspace) (define-alias-char #\C-M-H #\M-Backspace) @@ -75,11 +80,16 @@ (define-alias-char #\C-M-I #\M-Tab) (define-alias-char #\C-M-j #\M-Linefeed) (define-alias-char #\C-M-J #\M-Linefeed) +(define-alias-char #\C-M-k #\M-VT) +(define-alias-char #\C-M-K #\M-VT) (define-alias-char #\C-M-l #\M-Page) (define-alias-char #\C-M-L #\M-Page) (define-alias-char #\C-M-m #\M-Return) (define-alias-char #\C-M-M #\M-Return) +(define-alias-char #\C-M-z #\M-Call) +(define-alias-char #\C-M-Z #\M-Call) (define-alias-char #\C-M-[ #\M-Altmode) +(define-alias-char #\C-M-- #\M-Backnext) ;;; These are definitions for the HP 9000 model 237. ;;; They should probably be isolated somehow, but there is no clear way. diff --git a/v7/src/edwin/class.scm b/v7/src/edwin/class.scm index c10922081..f6f444ad9 100644 --- a/v7/src/edwin/class.scm +++ b/v7/src/edwin/class.scm @@ -155,6 +155,12 @@ ;;; end CLASS-MACROS )) +(define (make-root-environment) + ;; **** Because IN-PACKAGE NULL-ENVIRONMENT broken. + (let ((methods (make-environment))) + ((access system-environment-remove-parent! environment-package) + methods))) + (define make-class) (define class?) (define name->class) @@ -178,22 +184,18 @@ class) (let ((class (vector class-tag name superclass object-size transforms - ;; **** MAKE-PACKAGE used here because - ;; MAKE-ENVIRONMENT is being flushed by the - ;; cross-syntaxer for no good reason. - (if superclass - (in-package (class-methods superclass) - (make-package methods ())) - ;; **** Because IN-PACKAGE NULL-ENVIRONMENT broken. - (make-package methods () - ((access system-environment-remove-parent! - environment-package) - (the-environment))))))) + (make-empty-methods superclass)))) ((access add-unparser-special-object! unparser-package) class object-unparser) (local-assignment class-descriptors name class) class))))) +(define (make-empty-methods superclass) + (if superclass + (in-package (class-methods superclass) + (make-environment)) + (make-root-environment))) + (set! class? (named-lambda (class? x) (and (vector? x) @@ -236,9 +238,7 @@ ((lexical-reference methods ':print-object) object)))) (define class-descriptors - (make-package class-descriptors () - ((access system-environment-remove-parent! environment-package) - (the-environment)))) + (make-root-environment)) ) diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm index aa09edd69..f52b56f80 100644 --- a/v7/src/edwin/comman.scm +++ b/v7/src/edwin/comman.scm @@ -101,6 +101,7 @@ (define (variable-ref variable) (lexical-reference edwin-package (variable-symbol variable))) + (define (variable-set! variable #!optional value) (lexical-assignment edwin-package (variable-symbol variable) (set! value))) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index 4aa9176db..d9769ca74 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -38,21 +38,24 @@ ;;;; Command Reader (declare (usual-integrations) - (integrate-external "edb:curren.bin.0")) + ) (using-syntax (access edwin-syntax-table edwin-package) (define (top-level-command-reader) (fluid-let ((*auto-save-keystroke-count* 0)) (define (^G-loop) - (with-keyboard-macro-disabled - (lambda () - (call-with-current-continuation - (lambda (continuation) - (fluid-let ((*^G-interrupt-continuation* continuation)) - (command-reader)))))) + (call-with-current-continuation + (lambda (continuation) + (fluid-let ((*^g-interrupt-continuation* continuation)) + (with-keyboard-macro-disabled + (lambda () + (catching-^g + (lambda () + (command-reader)))))))) (^G-loop)) (^G-loop))) + (define command-reader) (define execute-char) (define execute-command) diff --git a/v7/src/edwin/comwin.scm b/v7/src/edwin/comwin.scm index 22f00f9fa..ae280dc24 100644 --- a/v7/src/edwin/comwin.scm +++ b/v7/src/edwin/comwin.scm @@ -38,7 +38,7 @@ ;;;; Combination Windows (declare (usual-integrations) - (integrate-external "edb:window.bin.0")) + ) (using-syntax class-syntax-table ;;; Combination windows are used to split a window into vertically or diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index 6f3c52ec3..d0011b2f5 100644 --- a/v7/src/edwin/curren.scm +++ b/v7/src/edwin/curren.scm @@ -38,9 +38,7 @@ ;;;; Current State (declare (usual-integrations) - (integrate-external "edb:editor.bin.0") - (integrate-external "edb:buffer.bin.0") - (integrate-external "edb:bufset.bin.0")) + ) (using-syntax edwin-syntax-table ;;;; Windows diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 9766ca21b..5f847e477 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -45,6 +45,7 @@ (define edwin-reset) (define edwin-reset-windows) +(define edwin-get-input-port) (in-package window-package (set! edwin-reset @@ -73,7 +74,7 @@ (write-string " ;You are in an interaction window of the Edwin editor. -;Type C-H for help. C-H M will describe some useful commands."))) +;Type C-H for help. C-H M will describe some commands."))) (insert-interaction-prompt) (set-window-start-mark! (current-window) (buffer-start (current-buffer)) @@ -84,39 +85,37 @@ (named-lambda (edwin-reset-windows) (send the-alpha-window ':salvage!))) +(set! edwin-get-input-port +(named-lambda (edwin-get-input-port) + (the-alpha-screen->input-port))) ) (define (edwin) (if (or (unassigned? edwin-editor) (not edwin-editor)) (edwin-reset)) - (with-keyboard-interrupt-dispatch-table - editor-keyboard-interrupt-dispatch-table - (lambda () - (with-editor-interrupts-enabled - (lambda () - (with-editor-input-port console-input-port + (with-editor-input-port (edwin-get-input-port) (lambda () (within-editor edwin-editor (lambda () (fluid-let (((access *error-hook* error-system) edwin-error-hook)) - (perform-buffer-initializations! (current-buffer)) - (push-command-loop (lambda () 'DONE) - (lambda (state) + (perform-buffer-initializations! (current-buffer)) + (push-command-loop (lambda () 'DONE) + (lambda (state) (update-alpha-window! #!TRUE) (top-level-command-reader) state) - 'DUMMY-STATE)))))))))) - (tty-redraw-screen) + 'DUMMY-STATE)))))) +; (tty-redraw-screen) *the-non-printing-object*) -(in-package system-global-environment +;(in-package system-global-environment -(define tty-redraw-screen - (make-primitive-procedure 'TTY-REDRAW-SCREEN)) +;(define tty-redraw-screen +; (make-primitive-procedure 'TTY-REDRAW-SCREEN)) -) +;) (define editor-continuation) (define recursive-edit-continuation) diff --git a/v7/src/edwin/edtfrm.scm b/v7/src/edwin/edtfrm.scm index 2900409e7..05ffef60f 100644 --- a/v7/src/edwin/edtfrm.scm +++ b/v7/src/edwin/edtfrm.scm @@ -38,7 +38,7 @@ ;;;; Editor Frame (declare (usual-integrations) - (integrate-external "edb:window.bin.0")) + ) (using-syntax class-syntax-table ;;; Editor Frame diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index e9fdf4ba9..9c034125c 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -301,6 +301,8 @@ If a file with the new name already exists, confirmation is requested first." "Print the current region on the local printer." (print-region (current-region))) +#| + (define (print-region region) (let ((temp (temporary-buffer "*Printout*"))) (region-insert! (buffer-point temp) region) @@ -316,6 +318,8 @@ If a file with the new name already exists, confirmation is requested first." (define translate-file (make-primitive-procedure 'TRANSLATE-FILE)) +|# + ;;;; Supporting Stuff @@ -369,7 +373,8 @@ If a file with the new name already exists, confirmation is requested first." (define (prompt-for-pathname prompt #!optional default) (if (unassigned? default) (set! default #!FALSE)) (fluid-let ((*default-pathname* (or default (get-default-pathname))) - (*pathname-cache* #!FALSE)) + ;(*pathname-cache* #!FALSE) + ) (let ((string (prompt-for-completed-string prompt (pathname->string *default-pathname*) diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm index 6d0669436..a5180eda0 100644 --- a/v7/src/edwin/info.scm +++ b/v7/src/edwin/info.scm @@ -640,7 +640,7 @@ The name may be an abbreviation of the reference name." (define (node-search-start buffer nodename) (if (not (ref-variable "Info Tag Table Start")) (buffer-start buffer) - (let ((string (string-append "Node: " nodename "¢))) + (let ((string (string-append "Node: " nodename "¢"))) (let ((mark (search-forward string (ref-variable "Info Tag Table Start") (ref-variable "Info Tag Table End")))) diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index f8a78fae5..bb8274dce 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -59,8 +59,8 @@ (keyboard-macro-write-char char)) char)) -(define keyboard-active? - (make-primitive-procedure 'TTY-READ-CHAR-READY?)) +(define (keyboard-active? delay) + (char-ready? editor-input-port delay)) (define reset-command-prompt!) (define command-prompt) @@ -187,8 +187,8 @@ B 3BAB8C (set! message-should-be-erased? false) ((access clear-message! prompt-package)))) -(declare (compilable-primitive-functions - (keyboard-active? tty-read-char-ready?))) +;(declare (compilable-primitive-functions +; (keyboard-active? tty-read-char-ready?))) (define ((keyboard-reader macro-read-char read-char)) (if *executing-keyboard-macro?* @@ -221,7 +221,11 @@ B 3BAB8C ((access set-message! prompt-package) command-prompt-string)) ((access clear-message! prompt-package)))))) - (read-char)))) + (let loop () + (if (screen-damaged? the-alpha-screen) + (begin (screen-not-damaged! the-alpha-screen) + (update-alpha-window! #t))) + (if (keyboard-active? 50) (read-char) (loop)))))) (set! keyboard-read-char (keyboard-reader (lambda () (keyboard-macro-read-char)) diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index 113f4ac5a..13ef8352b 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -107,7 +107,8 @@ Otherwise, goes to the end of the current line, copies the preceding Output is inserted into the buffer at the end." (define (extract-expression start) - (let ((expression (extract-string start (forward-one-sexp start)))) + (let ((expression (extract-string start (or (forward-one-sexp start) + (editor-error "No Expression"))))) (ring-push! (ref-variable "Interaction Kill Ring") expression) expression)) @@ -140,10 +141,11 @@ Output is inserted into the buffer at the end." (dynamic-wind (lambda () 'DONE) (lambda () - (^G-interceptor (lambda ((continuation) value) + (^G-interceptor (lambda (continuation) + (lambda (value) (newline) (write-string "Abort!") - (continuation 'EXIT)) + (continuation 'EXIT))) (lambda () (let ((environment (evaluation-environment #!FALSE))) (with-output-to-current-point diff --git a/v7/src/edwin/linden.scm b/v7/src/edwin/linden.scm index 43d1793e9..adf3e21ee 100644 --- a/v7/src/edwin/linden.scm +++ b/v7/src/edwin/linden.scm @@ -154,7 +154,8 @@ (lisp-indent-special-form method state indent-point normal-indent)) (method - (method state indent-point normal-indent)))))))) + (method state indent-point normal-indent)) + (else #f))))))) ;;; Indent the first subform in a definition at the body indent. ;;; Indent subsequent subforms normally. diff --git a/v7/src/edwin/modwin.scm b/v7/src/edwin/modwin.scm index 2d353193b..a6c473af2 100644 --- a/v7/src/edwin/modwin.scm +++ b/v7/src/edwin/modwin.scm @@ -38,7 +38,7 @@ ;;;; Modeline Window (declare (usual-integrations) - (integrate-external "edb:window.bin.0")) + ) (using-syntax (access class-syntax-table edwin-package) (define-class modeline-window vanilla-window diff --git a/v7/src/edwin/motion.scm b/v7/src/edwin/motion.scm index 1d16df3b2..290821eee 100644 --- a/v7/src/edwin/motion.scm +++ b/v7/src/edwin/motion.scm @@ -38,7 +38,7 @@ ;;;; Motion within Groups (declare (usual-integrations) - (integrate-external "edb:struct.bin.0")) + ) ;;;; Motion by Characters diff --git a/v7/src/edwin/regexp.scm b/v7/src/edwin/regexp.scm index 656816181..1831cb943 100644 --- a/v7/src/edwin/regexp.scm +++ b/v7/src/edwin/regexp.scm @@ -152,8 +152,9 @@ registers group start end))) + (define %%re-search-forward - (make-primitive re-search-forward)) + (make-primitive re-search-buffer-forward)) (define-search char-search-backward char %re-search-backward compile-char group-start mark>=) @@ -173,8 +174,10 @@ registers group end start))) + (define %%re-search-backward - (make-primitive re-search-backward)) + (make-primitive re-search-buffer-backward)) + ;;;; Match @@ -208,8 +211,10 @@ registers group start end))) + (define %%re-match-forward - (make-primitive re-match)) + (make-primitive re-match-buffer)) + (set! char-match-backward (named-lambda (char-match-backward char #!optional start end) diff --git a/v7/src/edwin/regops.scm b/v7/src/edwin/regops.scm index c1131c776..b615b8975 100644 --- a/v7/src/edwin/regops.scm +++ b/v7/src/edwin/regops.scm @@ -38,7 +38,7 @@ ;;;; Operations on Groups (declare (usual-integrations) - (integrate-external "edb:struct.bin.0")) + ) ;;;; Region/Mark Operations diff --git a/v7/src/edwin/search.scm b/v7/src/edwin/search.scm index 054e33ba2..562054b63 100644 --- a/v7/src/edwin/search.scm +++ b/v7/src/edwin/search.scm @@ -42,7 +42,7 @@ ;;; expression search and match procedures. (declare (usual-integrations) - (integrate-external "edb:struct.bin.0")) + ) ;;;; Character Search #| diff --git a/v7/src/edwin/simple.scm b/v7/src/edwin/simple.scm index c264a5d73..7f683c766 100644 --- a/v7/src/edwin/simple.scm +++ b/v7/src/edwin/simple.scm @@ -181,9 +181,9 @@ (cond (*executing-keyboard-macro?*) ((not mark) (beep)) ((window-mark-visible? (current-window) mark) + (update-alpha-window! #!FALSE) (with-current-point mark (lambda () - (update-alpha-window! #!FALSE) (keyboard-active? 50)))) (else (temporary-message diff --git a/v7/src/edwin/struct.scm b/v7/src/edwin/struct.scm index 757cad2aa..a19ef8a2e 100644 --- a/v7/src/edwin/struct.scm +++ b/v7/src/edwin/struct.scm @@ -301,33 +301,49 @@ ;;; The marks list is cleaned every time that FOR-EACH-MARK! is ;;; called. It may be necessary to do this a little more often. -(declare (compilable-primitive-functions object-hash)) +;;; Group marks is a weak list of marks. + +(define weak-cons + (let ((weak-cons-type (microcode-type 'WEAK-CONS))) + (named-lambda (weak-cons car cdr) + (system-pair-cons weak-cons-type car cdr)))) + +(define %weak-car system-pair-car) +(define %weak-cdr system-pair-cdr) +(define %weak-set-cdr! system-pair-set-cdr!) + +(define (weak-member? object weak-list) + (declare (integrate %weak-car %weak-cdr)) + (cond ((null? weak-list) #f) + ((eq? object (%weak-car weak-list)) #t) + (else (weak-member? object (%weak-cdr weak-list))))) (define (mark-permanent! mark) - (let ((n (object-hash mark)) - (marks (group-marks (mark-group mark)))) - (if (not (memq n marks)) - (vector-set! (mark-group mark) group-index:marks (cons n marks)))) + (let ((marks (group-marks (mark-group mark)))) + (if (not (weak-member? mark marks)) + (vector-set! (mark-group mark) group-index:marks + (weak-cons mark marks)))) mark) (define (for-each-mark group procedure) + (declare (integrate %weak-car %weak-cdr %weak-set-cdr)) (define (loop-1 marks) (if (not (null? marks)) - (let ((mark (object-unhash (car marks)))) + (let ((mark (%weak-car marks))) (if mark (begin (procedure mark) - (loop-2 marks (cdr marks))) - (begin (vector-set! group group-index:marks (cdr marks)) - (loop-1 (cdr marks))))))) + (loop-2 marks (%weak-cdr marks))) + (begin (vector-set! group group-index:marks (%weak-cdr marks)) + (loop-1 (%weak-cdr marks))))))) (define (loop-2 previous marks) (if (not (null? marks)) - (let ((mark (object-unhash (car marks)))) + (let ((mark (%weak-car marks))) (if mark (begin (procedure mark) - (loop-2 marks (cdr marks))) - (begin (set-cdr! previous (cddr previous)) - (loop-2 previous (cdr previous))))))) + (loop-2 marks (%weak-cdr marks))) + (begin (%weak-set-cdr! previous (%weak-cdr (%weak-cdr previous))) + (loop-2 previous (%weak-cdr previous))))))) (loop-1 (group-marks group))) diff --git a/v7/src/edwin/syntax.scm b/v7/src/edwin/syntax.scm index d1d679cee..c81a6e577 100644 --- a/v7/src/edwin/syntax.scm +++ b/v7/src/edwin/syntax.scm @@ -50,7 +50,7 @@ "If true, ignore comments in backwards expression parsing. This should be false for comments that end in Newline, like Lisp. It can be true for comments that end in }, like Pascal. -This is because Newline occurs alot when it doesn't +This is because Newline occurs often when it doesn't indicate a comment ending." #!FALSE) @@ -312,6 +312,33 @@ indicate a comment ending." (mark-right-char-quoted? (mark-1+ mark)) (error "Mark has no left char" mark))) +(define (parse-state-depth state) + (vector-ref state 0)) + +(define (parse-state-in-string? state) ;#!FALSE or ASCII delimiter. + (vector-ref state 1)) + +(define (parse-state-in-comment? state) ;#!FALSE or 1 or 2. + (vector-ref state 2)) + +(define (parse-state-quoted? state) + (vector-ref state 3)) + +(define (parse-state-last-sexp state) + (vector-ref state 4)) +(define (set-parse-state-last-sexp! state value) + (vector-set! state 4 value)) + +(define (parse-state-containing-sexp state) + (vector-ref state 5)) +(define (set-parse-state-containing-sexp! state value) + (vector-set! state 5 value)) + +(define (parse-state-location state) + (vector-ref state 6)) +(define (set-parse-state-location! state value) + (vector-set! state 6 value)) + (define (forward-to-sexp-start mark end) (parse-state-location (parse-partial-sexp mark end 0 #!TRUE))) @@ -334,11 +361,17 @@ indicate a comment ending." (mark-index end) target-depth stop-before? old-state))) ;; Convert the returned indices to marks. - (if (vector-ref state 4) - (vector-set! state 4 (make-mark group (vector-ref state 4)))) - (if (vector-ref state 5) - (vector-set! state 5 (make-mark group (vector-ref state 5)))) - (vector-set! state 6 (make-mark group (vector-ref state 6))) + (if (parse-state-last-sexp state) + (set-parse-state-last-sexp! + state + (make-mark group (parse-state-last-sexp state)))) + (if (parse-state-containing-sexp state) + (set-parse-state-containing-sexp! + state + (make-mark group (parse-state-containing-sexp state)))) + (set-parse-state-location! + state + (make-mark group (parse-state-location state))) state)))) (set! char->syntax-code @@ -356,26 +389,6 @@ indicate a comment ending." 'DONE ) -(define (parse-state-depth state) - (vector-ref state 0)) - -(define (parse-state-in-string? state) ;#!FALSE or ASCII delimiter. - (vector-ref state 1)) - -(define (parse-state-in-comment? state) ;#!FALSE or 1 or 2. - (vector-ref state 2)) - -(define (parse-state-quoted? state) - (vector-ref state 3)) - -(define (parse-state-last-sexp state) - (vector-ref state 4)) - -(define (parse-state-containing-sexp state) - (vector-ref state 5)) - -(define (parse-state-location state) - (vector-ref state 6)) ;;;; Definition Start/End diff --git a/v7/src/edwin/undo.scm b/v7/src/edwin/undo.scm index 0da672199..73bfef15a 100644 --- a/v7/src/edwin/undo.scm +++ b/v7/src/edwin/undo.scm @@ -38,7 +38,7 @@ ;;;; Undo, translated from the GNU Emacs implementation in C. (declare (usual-integrations) - (integrate-external "edb:struct.bin.0")) + ) (using-syntax edwin-syntax-table (define enable-group-undo!) diff --git a/v7/src/edwin/utlwin.scm b/v7/src/edwin/utlwin.scm index 3d0f4841f..e6391163e 100644 --- a/v7/src/edwin/utlwin.scm +++ b/v7/src/edwin/utlwin.scm @@ -38,7 +38,7 @@ ;;;; Utility Windows (declare (usual-integrations) - (integrate-external "edb:window.bin.0")) + ) (using-syntax class-syntax-table ;;;; String Window diff --git a/v7/src/edwin/window.scm b/v7/src/edwin/window.scm index 8f8dccabb..9b2c7553e 100644 --- a/v7/src/edwin/window.scm +++ b/v7/src/edwin/window.scm @@ -38,7 +38,7 @@ ;;;; Window System (declare (usual-integrations) - (integrate-external "edb:class.bin.0")) + ) (using-syntax class-syntax-table ;;; Based on WINDOW-WIN, designed by RMS. @@ -125,6 +125,12 @@ (set! y-size y) (setup-redisplay-flags! redisplay-flags)) +(define-procedure vanilla-window (window-absolute-position window receiver + fail) + (if (eq? window the-alpha-window) + (receiver 0 0) + (=> superior :inferior-absolute-position window receiver fail))) + (define-procedure vanilla-window (window-redisplay-flags window) (declare (integrate window)) redisplay-flags) @@ -182,8 +188,6 @@ (xi (inferior-x-start (car inferiors))) (yi (inferior-y-start (car inferiors))) (flags (inferior-redisplay-flags (car inferiors)))) - (declare (compilable-primitive-functions - (keyboard-active? tty-read-char-ready?))) (if (and (or display-style (car flags)) xi yi) (and (or display-style (not (keyboard-active? 0))) @@ -289,6 +293,11 @@ (define-method vanilla-window (:set-inferior-start! window window* x y) (set-inferior-start! (find-inferior inferiors window*) x y)) + +(define-method vanilla-window (:inferior-absolute-position window window* + receiver fail) + (inferior-absolute-position (find-inferior inferiors window*) receiver fail)) + ;;;; Inferiors @@ -303,6 +312,17 @@ (set-inferior-start! inferior #!FALSE #!FALSE) (set-inferior-start! inferior (car position) (cdr position)))) +(define (inferior-absolute-position inferior receiver fail) + (if (and (inferior-x-start inferior) + (inferior-y-start inferior)) + (window-absolute-position (window-superior (inferior-window inferior)) + (lambda (x y) + (receiver + (+ x (inferior-x-start inferior)) + (+ y (inferior-y-start inferior)))) + fail) + (fail))) + (define (inferior-needs-redisplay! inferior) (if (and (inferior-x-start inferior) (inferior-y-start inferior)) @@ -410,9 +430,12 @@ (receiver (inferior-x-start inferior) (inferior-y-start inferior))) -(define (set-inferior-start! inferior x-start y-start) +(define (set-inferior-start-no-redisplay! inferior x-start y-start) (vector-set! (cdr inferior) 0 x-start) - (vector-set! (cdr inferior) 1 y-start) + (vector-set! (cdr inferior) 1 y-start)) + +(define (set-inferior-start! inferior x-start y-start) + (set-inferior-start-no-redisplay! inferior x-start y-start) (inferior-needs-redisplay! inferior)) (define (inferior-redisplay-flags inferior) diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index b1aa6d906..7e4b88936 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -734,6 +734,23 @@ ;;;; Compiled Pattern Disassembler #| +(define re-compile-fastmap (make-primitive-procedure 're-compile-fastmap)) + +(define null-translation + (let ((v (make-string 256))) + (let loop ((index 0)) + (if (= index 256) + v + (begin (vector-8b-set! v index index) + (loop (1+ index))))))) + +(define (hack-fastmap pat) + (let ((pattern (re-compile-pattern pat #f)) + (cs (char-set))) + (re-disassemble-pattern pattern) + (re-compile-fastmap pattern null-translation (make-syntax-table) cs) + (char-set-members cs))) + (define (re-disassemble-pattern compiled-pattern) (let ((n (string-length compiled-pattern))) (define (loop i)