(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)))))
(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)
;;;; Buffer Frames
(declare (usual-integrations)
- (integrate-external "edb:comwin.bin.0"))
+ )
(using-syntax class-syntax-table
\f
(define-class buffer-frame combination-leaf-window
;;;; Buffer Windows: Fill and Scroll
(declare (usual-integrations)
- (integrate-external "edb:bufwin.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;;; Fill
(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
)
;;;; Buffer Windows: Base
(declare (usual-integrations)
- (integrate-external "edb:linwin.bin.0"))
+ )
(using-syntax class-syntax-table
\f
(define-class buffer-window vanilla-window
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
+
;;; without prior written consent from MIT in each case.
;;;
;;;; Buffer Windows: Image Update
(declare (usual-integrations)
- (integrate-external "edb:bufwin.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;;; Insert/Delete/Clip
;;;; Buffer Windows: Mark <-> Coordinate Maps
(declare (usual-integrations)
- (integrate-external "edb:bufwin.bin.0"))
+ )
(using-syntax class-syntax-table
\f
(define-procedure buffer-window (%window-mark->x window mark)
(define-alias-char #\C-I #\Tab)
(define-alias-char #\C-j #\Linefeed)
(define-alias-char #\C-J #\Linefeed)
+(define-alias-char #\C-k #\VT)
+(define-alias-char #\C-K #\VT)
(define-alias-char #\C-l #\Page)
(define-alias-char #\C-L #\Page)
(define-alias-char #\C-m #\Return)
(define-alias-char #\C-M #\Return)
+(define-alias-char #\C-z #\Call)
+(define-alias-char #\C-Z #\Call)
(define-alias-char #\C-[ #\Altmode)
+(define-alias-char #\C-- #\Backnext)
(define-alias-char #\C-M-h #\M-Backspace)
(define-alias-char #\C-M-H #\M-Backspace)
(define-alias-char #\C-M-I #\M-Tab)
(define-alias-char #\C-M-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.
;;; end CLASS-MACROS
))
\f
+(define (make-root-environment)
+ ;; **** Because IN-PACKAGE NULL-ENVIRONMENT broken.
+ (let ((methods (make-environment)))
+ ((access system-environment-remove-parent! environment-package)
+ methods)))
+
(define make-class)
(define class?)
(define name->class)
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)
((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))
)
\f
(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)))
;;;; Command Reader
(declare (usual-integrations)
- (integrate-external "edb:curren.bin.0"))
+ )
(using-syntax (access edwin-syntax-table edwin-package)
\f
(define (top-level-command-reader)
(fluid-let ((*auto-save-keystroke-count* 0))
(define (^G-loop)
- (with-keyboard-macro-disabled
- (lambda ()
- (call-with-current-continuation
- (lambda (continuation)
- (fluid-let ((*^G-interrupt-continuation* continuation))
- (command-reader))))))
+ (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)
;;;; Combination Windows
(declare (usual-integrations)
- (integrate-external "edb:window.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;; Combination windows are used to split a window into vertically or
;;;; Current State
(declare (usual-integrations)
- (integrate-external "edb:editor.bin.0")
- (integrate-external "edb:buffer.bin.0")
- (integrate-external "edb:bufset.bin.0"))
+ )
(using-syntax edwin-syntax-table
\f
;;;; Windows
(define edwin-reset)
(define edwin-reset-windows)
+(define edwin-get-input-port)
(in-package window-package
(set! edwin-reset
(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))
(named-lambda (edwin-reset-windows)
(send the-alpha-window ':salvage!)))
+(set! edwin-get-input-port
+(named-lambda (edwin-get-input-port)
+ (the-alpha-screen->input-port)))
)
\f
(define (edwin)
(if (or (unassigned? edwin-editor)
(not edwin-editor))
(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))
-)
+;)
\f
(define editor-continuation)
(define recursive-edit-continuation)
;;;; Editor Frame
(declare (usual-integrations)
- (integrate-external "edb:window.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;; Editor Frame
"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)
(define translate-file
(make-primitive-procedure 'TRANSLATE-FILE))
+|#
+
\f
;;;; Supporting Stuff
(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*)
(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"))))
(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)
(set! message-should-be-erased? false)
((access clear-message! prompt-package))))
\f
-(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?*
((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))
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))
(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
(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)))))))
\f
;;; Indent the first subform in a definition at the body indent.
;;; Indent subsequent subforms normally.
;;;; Modeline Window
(declare (usual-integrations)
- (integrate-external "edb:window.bin.0"))
+ )
(using-syntax (access class-syntax-table edwin-package)
\f
(define-class modeline-window vanilla-window
;;;; Motion within Groups
(declare (usual-integrations)
- (integrate-external "edb:struct.bin.0"))
+ )
\f
;;;; Motion by Characters
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>=)
registers
group end start)))
+
(define %%re-search-backward
- (make-primitive re-search-backward))
+ (make-primitive re-search-buffer-backward))
+
\f
;;;; Match
registers
group start end)))
+
(define %%re-match-forward
- (make-primitive re-match))
+ (make-primitive re-match-buffer))
+
\f
(set! char-match-backward
(named-lambda (char-match-backward char #!optional start end)
;;;; Operations on Groups
(declare (usual-integrations)
- (integrate-external "edb:struct.bin.0"))
+ )
\f
;;;; Region/Mark Operations
;;; expression search and match procedures.
(declare (usual-integrations)
- (integrate-external "edb:struct.bin.0"))
+ )
\f
;;;; Character Search
#|
(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
;;; 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)))
\f
"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)
(mark-right-char-quoted? (mark-1+ mark))
(error "Mark has no left char" mark)))
+(define (parse-state-depth state)
+ (vector-ref state 0))
+
+(define (parse-state-in-string? state) ;#!FALSE or ASCII delimiter.
+ (vector-ref state 1))
+
+(define (parse-state-in-comment? state) ;#!FALSE or 1 or 2.
+ (vector-ref state 2))
+
+(define (parse-state-quoted? state)
+ (vector-ref state 3))
+
+(define (parse-state-last-sexp state)
+ (vector-ref state 4))
+(define (set-parse-state-last-sexp! state value)
+ (vector-set! state 4 value))
+
+(define (parse-state-containing-sexp state)
+ (vector-ref state 5))
+(define (set-parse-state-containing-sexp! state value)
+ (vector-set! state 5 value))
+
+(define (parse-state-location state)
+ (vector-ref state 6))
+(define (set-parse-state-location! state value)
+ (vector-set! state 6 value))
+
(define (forward-to-sexp-start mark end)
(parse-state-location (parse-partial-sexp mark end 0 #!TRUE)))
\f
(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
'DONE
)
-(define (parse-state-depth state)
- (vector-ref state 0))
-
-(define (parse-state-in-string? state) ;#!FALSE or ASCII delimiter.
- (vector-ref state 1))
-
-(define (parse-state-in-comment? state) ;#!FALSE or 1 or 2.
- (vector-ref state 2))
-
-(define (parse-state-quoted? state)
- (vector-ref state 3))
-
-(define (parse-state-last-sexp state)
- (vector-ref state 4))
-
-(define (parse-state-containing-sexp state)
- (vector-ref state 5))
-
-(define (parse-state-location state)
- (vector-ref state 6))
\f
;;;; Definition Start/End
;;;; Undo, translated from the GNU Emacs implementation in C.
(declare (usual-integrations)
- (integrate-external "edb:struct.bin.0"))
+ )
(using-syntax edwin-syntax-table
\f
(define enable-group-undo!)
;;;; Utility Windows
(declare (usual-integrations)
- (integrate-external "edb:window.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;;; String Window
;;;; Window System
(declare (usual-integrations)
- (integrate-external "edb:class.bin.0"))
+ )
(using-syntax class-syntax-table
\f
;;; Based on WINDOW-WIN, designed by RMS.
(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)
(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)))
(define-method vanilla-window (:set-inferior-start! window window* x y)
(set-inferior-start! (find-inferior inferiors window*) x y))
+
+(define-method vanilla-window (:inferior-absolute-position window window*
+ receiver fail)
+ (inferior-absolute-position (find-inferior inferiors window*) receiver fail))
+
\f
;;;; Inferiors
(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))
(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)
\f
;;;; Compiled Pattern Disassembler
#|
+(define re-compile-fastmap (make-primitive-procedure 're-compile-fastmap))
+
+(define null-translation
+ (let ((v (make-string 256)))
+ (let loop ((index 0))
+ (if (= index 256)
+ v
+ (begin (vector-8b-set! v index index)
+ (loop (1+ index)))))))
+
+(define (hack-fastmap pat)
+ (let ((pattern (re-compile-pattern pat #f))
+ (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)
projects / mit-scheme.git / commitdiff