#| -*-Scheme-*-
-$Id: 6001.pkg,v 1.16 2003/02/14 18:28:00 cph Exp $
+$Id: 6001.pkg,v 1.17 2005/04/01 05:09:21 cph Exp $
-Copyright (c) 1991-1999, 2001 Massachusetts Institute of Technology
+Copyright 1991,1992,1993,1994,1995,2001 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define-package (student scode-rewriting)
(files "nodefs")
(parent (student))
- (import (runtime rep)
- hook/repl-eval)
(initialization (initialize-package!)))
(define-package (student number)
#| -*-Scheme-*-
-$Id: nodefs.scm,v 1.15 2003/02/14 18:28:00 cph Exp $
+$Id: nodefs.scm,v 1.16 2005/04/01 05:09:26 cph Exp $
Copyright 1991,1992,1993,1995,2001,2003 Massachusetts Institute of Technology
+Copyright 2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(set! hook/repl-eval student/repl-eval)
unspecific)
-(define (student/repl-eval repl s-expression environment)
+(define (student/repl-eval s-expression environment repl)
(repl-scode-eval
- repl
(rewrite-scode (syntax s-expression environment)
(and repl
(let ((port (cmdl/port repl)))
'CURRENT-EXPRESSION-CONTEXT)))
(and operation
(operation port s-expression))))))
- environment))
+ environment
+ repl))
(define (rewrite-scode expression context)
(let ((expression
#| -*-Scheme-*-
-$Id: artdebug.scm,v 1.34 2004/02/16 05:42:42 cph Exp $
+$Id: artdebug.scm,v 1.35 2005/04/01 05:06:51 cph Exp $
Copyright 1989,1990,1991,1992,1993,1998 Massachusetts Institute of Technology
-Copyright 1999,2001,2003,2004 Massachusetts Institute of Technology
+Copyright 1999,2001,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(let ((environment (dstate-evaluation-environment dstate))
(continuation
(stack-frame->continuation (dstate/subproblem dstate)))
- (repl-eval hook/repl-eval))
+ (old-hook hook/repl-eval))
(fluid-let
((in-debugger-evaluation? #t)
(hook/repl-eval
- (lambda (expression environment)
+ (lambda (expression environment repl)
(let ((unique (cons 'unique 'id)))
(let ((result
(call-with-current-continuation
(continuation* (cons unique condition)))
(lambda ()
(continuation*
- (repl-eval expression
- environment))))))))))
+ (old-hook expression
+ environment
+ repl))))))))))
(if (and (pair? result)
(eq? unique (car result)))
(error (cdr result))
(newline port)
(newline port))
-(define (operation/prompt-for-expression port prompt)
- port
+(define (operation/prompt-for-expression port environment prompt)
+ port environment
(prompt-for-expression prompt))
(define (operation/prompt-for-confirmation port prompt)
#| -*-Scheme-*-
-$Id: debug.scm,v 1.68 2004/12/06 21:26:13 cph Exp $
+$Id: debug.scm,v 1.69 2005/04/01 05:06:57 cph Exp $
Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology
Copyright 1998,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(fluid-let ((prompt-for-confirmation
(lambda (prompt #!optional port)
port
- (call-with-interface-port
- (buffer-end buffer)
- (lambda (port)
- port
- (prompt-for-yes-or-no? prompt)))))
+ (call-with-interface-port (buffer-end buffer)
+ (lambda (port)
+ port
+ (prompt-for-yes-or-no? prompt)))))
(prompt-for-evaluated-expression
(lambda (prompt #!optional environment port)
port
- (call-with-interface-port
- (buffer-end buffer)
- (lambda (port)
- port
- (hook/repl-eval #f
- (prompt-for-expression prompt)
- (if (default-object? environment)
- (nearest-repl/environment)
- environment))))))
+ (call-with-interface-port (buffer-end buffer)
+ (lambda (port)
+ port
+ (repl-eval (prompt-for-expression prompt)
+ environment)))))
(hook/invoke-restart
(lambda (continuation arguments)
(invoke-continuation continuation
(PROMPT-FOR-CONFIRMATION
,(lambda (port prompt) port (prompt-for-confirmation? prompt)))
(PROMPT-FOR-EXPRESSION
- ,(lambda (port prompt) port (prompt-for-expression prompt))))
+ ,(lambda (port environment prompt)
+ port environment
+ (prompt-for-expression prompt))))
#f))
(define (invoke-continuation continuation arguments avoid-deletion?)
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.288 2004/03/30 04:27:52 cph Exp $
+$Id: edwin.pkg,v 1.289 2005/04/01 05:07:03 cph Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1996,1997,1998,1999,2000 Massachusetts Institute of Technology
-Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
)
(parent ())
- (import (runtime rep)
- hook/repl-eval)
(import (runtime character)
bucky-bits->prefix)
(import (runtime char-syntax)
(files "bufinp")
(parent (edwin))
(export (edwin)
+ call-with-input-mark
+ call-with-input-region
make-buffer-input-port
with-input-from-mark
with-input-from-region)
#| -*-Scheme-*-
-$Id: evlcom.scm,v 1.69 2004/11/19 17:35:08 cph Exp $
+$Id: evlcom.scm,v 1.70 2005/04/01 05:07:07 cph Exp $
Copyright 1986,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1997,1998,1999,2000,2001 Massachusetts Institute of Technology
-Copyright 2003,2004 Massachusetts Institute of Technology
+Copyright 2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
\f
;;;; Expression Prompts
-(define (prompt-for-expression-value prompt #!optional default . options)
- (let ((buffer (current-buffer)))
+(define (prompt-for-expression-value prompt #!optional default environment
+ . options)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment)
+ (begin
+ (guarantee-environment environment 'PROMPT-FOR-EXPRESSION-VALUE)
+ environment))))
(eval-with-history (apply prompt-for-expression
prompt
(if (or (symbol? default)
(vector? default))
`',default
default)
+ environment
options)
- (evaluation-environment buffer))))
-
-(define (prompt-for-expression prompt #!optional default . options)
- (read-from-string
- (apply prompt-for-string
- prompt
- (if (default-object? default)
- #f
- (write-to-string default))
- 'MODE
- (let ((environment (ref-variable scheme-environment)))
+ environment)))
+
+(define (prompt-for-expression prompt #!optional default environment . options)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment)
+ (begin
+ (guarantee-environment environment 'PROMPT-FOR-EXPRESSION)
+ environment))))
+ (read-from-string
+ (apply prompt-for-string
+ prompt
+ (if (default-object? default)
+ #f
+ (write-to-string default))
+ 'MODE
(lambda (buffer)
(set-buffer-major-mode! buffer
(ref-mode-object prompt-for-expression))
;; This sets up the correct environment in the typein buffer
;; so that completion of variables works right.
- (local-set-variable! scheme-environment environment buffer)))
- options)))
+ (local-set-variable! scheme-environment environment buffer))
+ options)
+ environment)))
-(define (read-from-string string)
+(define (read-from-string string environment)
(bind-condition-handler (list condition-type:error) evaluation-error-handler
(lambda ()
- (with-input-from-string string read))))
+ (read (open-input-string string) environment))))
(define-major-mode prompt-for-expression scheme #f
(mode-description (ref-mode-object minibuffer-local))
;;;; Evaluation
(define (evaluate-region region environment)
- (let ((buffer (mark-buffer (region-start region))))
+ (let ((buffer (->buffer region)))
(let ((evaluation-input-recorder
(ref-variable evaluation-input-recorder buffer)))
(if evaluation-input-recorder
evaluation-error-handler
(lambda ()
(let loop
- ((expressions (read-expressions-from-region region))
+ ((expressions (read-expressions-from-region region environment))
(result unspecific))
(if (null? expressions)
result
(loop (cdr expressions)
(editor-eval buffer (car expressions) environment))))))))
-(define (read-expressions-from-region region)
- (with-input-from-region region
- (lambda ()
- (let loop ()
- (let ((expression (read)))
- (if (eof-object? expression)
- '()
- (cons expression (loop))))))))
+(define (read-expressions-from-region region #!optional environment)
+ (let ((environment
+ (if (default-object? environment)
+ (evaluation-environment region)
+ environment)))
+ (call-with-input-region region
+ (lambda (port)
+ (let loop ()
+ (let ((expression (read port environment)))
+ (if (eof-object? expression)
+ '()
+ (cons expression (loop)))))))))
(define (evaluation-environment buffer #!optional global-ok?)
- (let ((buffer (or buffer (current-buffer)))
+ (let ((buffer (->buffer buffer))
(non-default
(lambda (object)
(if (environment? object)
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
- (hook/repl-eval #f expression environment))))
+ (repl-eval expression environment))))
(define (evaluation-error-handler condition)
(maybe-debug-scheme-error 'EVALUATION condition)
#| -*-Scheme-*-
-$Id: intmod.scm,v 1.120 2004/02/16 05:43:38 cph Exp $
+$Id: intmod.scm,v 1.121 2005/04/01 05:07:13 cph Exp $
Copyright 1986,1989,1991,1992,1993,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(and (not (null? windows))
(apply min (map window-x-size windows)))))))
-(define (operation/write-result port expression value hash-number)
+(define (operation/write-result port expression value hash-number environment)
(let ((buffer (port/buffer port))
(other-buffer?
(memq (operation/current-expression-context port expression)
(and (ref-variable enable-transcript-buffer buffer)
(transcript-buffer)))
(begin
- (default/write-result port expression value hash-number)
+ (default/write-result port expression value hash-number environment)
(if (and other-buffer? (not (mark-visible? (port/mark port))))
(transcript-write value #f))))))
\f
;;; Prompting
-(define (operation/prompt-for-expression port prompt)
- (unsolicited-prompt port prompt-for-expression prompt))
+(define (operation/prompt-for-expression port environment prompt)
+ (unsolicited-prompt port
+ (lambda (prompt)
+ (prompt-for-expression prompt #!default environment))
+ prompt))
(define (operation/prompt-for-confirmation port prompt)
(unsolicited-prompt port prompt-for-confirmation? prompt))
(cond ((eq? value wait-value) (suspend-current-thread) (loop))
((eq? value abort-value) (abort->nearest))
(else value)))))))
-
+\f
(define (when-buffer-selected buffer thunk)
(if (current-buffer? buffer)
(thunk)
(remove-select-buffer-hook buffer hook))))))
(add-select-buffer-hook buffer hook))))
-(define (operation/prompt-for-command-expression port prompt level)
+(define (operation/prompt-for-command-expression port environment prompt level)
+ environment
(parse-command-prompt port prompt)
(read-expression port level))
#| -*-Scheme-*-
-$Id: prompt.scm,v 1.201 2003/02/14 18:28:13 cph Exp $
+$Id: prompt.scm,v 1.202 2005/04/01 05:07:18 cph Exp $
-Copyright 1986, 1989-2001 Massachusetts Institute of Technology
+Copyright 1987.1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
+Copyright 2000,2001,2005 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define (typein-edit-other-window)
(let loop ((windows typein-saved-windows))
- (cond ((null? windows)
- (window0))
- ((and (not (typein-window? (car windows)))
- (window-visible? (car windows)))
- (car windows))
- (else
- (loop (cdr windows))))))
+ (if (pair? windows)
+ (if (and (not (typein-window? (car windows)))
+ (window-visible? (car windows)))
+ (car windows)
+ (loop (cdr windows)))
+ (window0))))
\f
(define-variable enable-recursive-minibuffers
"True means allow minibuffers to invoke commands that use recursive minibuffers."
(lambda ()
(delete-string start end)
(set-current-point! point)))))
-\f
+
;;;; Character Prompts
(define (prompt-for-char prompt)
(prompt-for-string "Redo" #f
'DEFAULT-TYPE 'INSERTED-DEFAULT
'HISTORY 'REPEAT-COMPLEX-COMMAND
- 'HISTORY-INDEX (- argument 1))))))
+ 'HISTORY-INDEX (- argument 1))
+ (->environment '(EDWIN))))))
\f
;;;; Pass-phrase Prompts
projects / mit-scheme.git / commitdiff