;;; -*-Scheme-*-
;;;
-;;; $Id: artdebug.scm,v 1.26 1999/01/02 06:11:34 cph Exp $
+;;; $Id: artdebug.scm,v 1.27 1999/02/16 20:12:15 cph Exp $
;;;
;;; Copyright (c) 1989-1999 Massachusetts Institute of Technology
;;;
(define-variable debugger-confirm-return?
"True means to prompt for confirmation in RETURN-FROM and RETURN-TO
commands before returning the value."
- true
+ #t
boolean?)
(define-variable debugger-split-window?
"True means use another window for the debugger buffer; false means
use the current window."
- true
+ #t
boolean?)
(define-variable debugger-one-at-a-time?
(define-variable debugger-quit-on-return?
"True means quit debugger when executing a \"return\" command."
- true
+ #t
boolean?)
(define-variable debugger-quit-on-restart?
"True means quit debugger when executing a \"restart\" command."
- true
+ #t
boolean?)
(define-variable debugger-open-markers?
"True means newlines are inserted between marker lines."
- true
+ #t
boolean?)
(define-variable debugger-verbose-mode?
"True means display extra information without the user requesting it."
- false
+ #f
boolean?)
(define-variable debugger-expand-reductions?
"True says to insert reductions when reduction motion commands are used
in a subproblem whose reductions aren't already inserted."
- true
+ #t
boolean?)
(define-variable debugger-max-subproblems
(define-variable debugger-hide-system-code?
"True means don't show subproblems created by the runtime system."
- true
+ #t
boolean?)
(define-variable debugger-show-help-message?
"True means show a help message in the debugger buffer."
- true
+ #t
boolean?)
(define-variable debugger-debug-evaluations?
"True means evaluation errors in a debugger buffer start new debuggers."
- false
+ #f
boolean?)
\f
-(define in-debugger? false)
-(define in-debugger-evaluation? false)
+(define in-debugger? #f)
+(define in-debugger-evaluation? #f)
(define (maybe-debug-scheme-error switch-variable condition error-type-name)
(if (variable-value switch-variable)
(ref-variable debugger-start-on-error?))
(or (not (eq? (ref-variable debugger-start-on-error?) 'ASK))
(debug-scheme-error? condition error-type-name)))
- (fluid-let ((in-debugger? true))
+ (fluid-let ((in-debugger? #t))
((if (ref-variable debugger-split-window?)
select-buffer-other-window
select-buffer)
(if (and (not (null? buffers))
(null? (cdr buffers))
(ref-variable debugger-one-at-a-time?)
- (or (eq? true (ref-variable debugger-one-at-a-time?))
+ (or (eq? #t (ref-variable debugger-one-at-a-time?))
(prompt-for-confirmation?
"Another debugger buffer exists. Delete it")))
(kill-buffer (car buffers))))
(let ((point (mark-left-inserting-copy (current-point))))
(insert-string output point)
(guarantee-newlines 1 point)
- (insert-string (transcript-value-prefix-string value true) point)
+ (insert-string (transcript-value-prefix-string value #t) point)
(insert-string (transcript-value-string value) point)
(insert-newlines 2 point)
(mark-temporary! point)))
(lambda (region)
(let ((environment
(dstate-evaluation-environment (start-evaluation region))))
- (fluid-let ((in-debugger-evaluation? true))
+ (fluid-let ((in-debugger-evaluation? #t))
(evaluate-region region environment)))))
(define (start-evaluation region)
(stack-frame->continuation (dstate/subproblem dstate)))
(repl-eval hook/repl-eval))
(fluid-let
- ((in-debugger-evaluation? true)
+ ((in-debugger-evaluation? #t)
(hook/repl-eval
(lambda (expression environment syntax-table)
(let ((unique (cons 'unique 'id)))
(write-string string port)))
(pp (lambda (obj)
(fresh-line port)
- (pretty-print obj port true)
+ (pretty-print obj port #t)
(newline port))))
(if (dstate/reduction-number dstate)
(if (or argument
(invalid-subexpression? sub))
(pp exp)
- (fluid-let ((*pp-no-highlights?* false))
+ (fluid-let ((*pp-no-highlights?* #f))
(do-hairy))))
((debugging-info/noise? exp)
- (message ((debugging-info/noise exp) true)))
+ (message ((debugging-info/noise exp) #t)))
(else
(message "Unknown expression")))))))))))
(lambda (continuation arguments)
(invoke-continuation continuation
arguments
- false))))
+ #f))))
(invoke-restart restart)))))
\f
;;;; Marker Generation
((not (debugging-info/undefined-expression? expression))
(print-with-subexpression expression subexpression))
((debugging-info/noise? expression)
- (write-string ((debugging-info/noise expression) false)))
+ (write-string ((debugging-info/noise expression) #f)))
(else
(write-string ";undefined expression"))))
environment
port))))
(define (print-with-subexpression expression subexpression)
- (fluid-let ((*unparse-primitives-by-name?* true))
+ (fluid-let ((*unparse-primitives-by-name?* #t))
(if (invalid-subexpression? subexpression)
(write (unsyntax expression))
(let ((sub (write-to-string (unsyntax subexpression))))
(define (print-reduction subproblem-number reduction-number reduction port)
(print-history-level
- false
+ #f
subproblem-number
(string-append ", R=" (number->string reduction-number) " --- ")
(lambda ()
port))
(define (print-reduction-as-subexpression expression)
- (fluid-let ((*unparse-primitives-by-name?* true))
+ (fluid-let ((*unparse-primitives-by-name?* #t))
(write-string (ref-variable subexpression-start-marker))
(write (unsyntax expression))
(write-string (ref-variable subexpression-end-marker))))
(if (and reduction-number
(positive? (dstate/number-of-reductions dstate)))
(change-reduction! dstate reduction-number)
- (set-dstate/reduction-number! dstate false))
+ (set-dstate/reduction-number! dstate #f))
dstate)
(editor-error "Cannot find environment for evaluation.")))))
(if (and (dstate/using-history? dstate)
(positive? (dstate/number-of-reductions dstate)))
(change-reduction! dstate 0)
- (set-dstate/reduction-number! dstate false))))
+ (set-dstate/reduction-number! dstate #f))))
(delta (- subproblem-number (dstate/subproblem-number dstate))))
(if (negative? delta)
(let ((subproblems
(define (call-with-interface-port mark receiver)
(let ((mark (mark-left-inserting-copy mark)))
- (let ((value (receiver (port/copy interface-port-template mark))))
+ (let ((value (receiver (make-port interface-port-type mark))))
(mark-temporary! mark)
value)))
(fresh-line port)
(fluid-let ((debugger-pp
(lambda (expression indentation port)
- (pretty-print expression port true indentation))))
+ (pretty-print expression port #t indentation))))
(thunk))
(newline port)
(newline port))
port
(prompt-for-confirmation? prompt))
-(define interface-port-template
- (make-output-port
+(define interface-port-type
+ (make-output-port-type
`((WRITE-CHAR ,operation/write-char)
(WRITE-SUBSTRING ,operation/write-substring)
(FRESH-LINE ,operation/fresh-line)
(DEBUGGER-PRESENTATION ,debugger-presentation)
(PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression)
(PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation))
- false))
\ No newline at end of file
+ #f))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;;$Id: bufinp.scm,v 1.5 1999/01/02 06:11:34 cph Exp $
+;;;$Id: bufinp.scm,v 1.6 1999/02/16 20:12:24 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
(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))
+ (group #f read-only #t)
+ (end-index #f read-only #t)
+ (current-index #f))
(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))))
+ (make-port buffer-input-port-type
+ (make-buffer-input-port-state (mark-group mark)
+ (mark-index end)
+ (mark-index mark))))
(define (operation/char-ready? port interval)
interval ;ignore
(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
+(define buffer-input-port-type
+ (make-input-port-type `((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))
+ #f))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: bufout.scm,v 1.11 1999/01/02 06:11:34 cph Exp $
+;;; $Id: bufout.scm,v 1.12 1999/02/16 20:12:28 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
value)))
(define (mark->output-port mark #!optional buffer)
- (output-port/copy mark-output-port-template
- (cons (mark-left-inserting-copy mark)
- (if (default-object? buffer)
- false
- buffer))))
+ (make-port mark-output-port-type
+ (cons (mark-left-inserting-copy mark)
+ (if (default-object? buffer)
+ #f
+ buffer))))
(define (output-port->mark port)
(mark-temporary-copy (port/mark port)))
(for-each (if (mark= mark (buffer-point buffer))
(lambda (window)
(set-window-point! window mark)
- (window-direct-update! window false))
+ (window-direct-update! window #f))
(lambda (window)
- (window-direct-update! window false)))
+ (window-direct-update! window #f)))
(buffer-windows buffer)))))
(define (operation/fresh-line port)
(define (operation/x-size port)
(mark-x-size (port/mark port)))
-(define mark-output-port-template
- (make-output-port `((CLOSE ,operation/close)
- (FLUSH-OUTPUT ,operation/flush-output)
- (FRESH-LINE ,operation/fresh-line)
- (PRINT-SELF ,operation/print-self)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring)
- (X-SIZE ,operation/x-size))
- false))
\ No newline at end of file
+(define mark-output-port-type
+ (make-output-port-type `((CLOSE ,operation/close)
+ (FLUSH-OUTPUT ,operation/flush-output)
+ (FRESH-LINE ,operation/fresh-line)
+ (PRINT-SELF ,operation/print-self)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring)
+ (X-SIZE ,operation/x-size))
+ #f))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: debug.scm,v 1.46 1999/02/03 06:12:57 cph Exp $
+;;; $Id: debug.scm,v 1.47 1999/02/16 20:12:04 cph Exp $
;;;
;;; Copyright (c) 1992-1999 Massachusetts Institute of Technology
;;;
object
name
(vector)
- false
+ #f
'()
(make-1d-table))))
(buffer-put! buffer 'BROWSER browser)
(string-append
(if (1d-table/get (browser/properties browser)
'VISIBLE-SUB-BUFFERS?
- false)
+ #f)
""
" ")
prefix
(loop index (- argument 1))
(begin
(select-bline bline)
- false))))
+ #f))))
(else
(let ((index (- index 1)))
(if (<= 0 index)
(loop index (+ argument 1))
(begin
(select-bline bline)
- false)))))))))
+ #f)))))))))
(let ((point (current-point)))
(let ((index (mark->bline-index point)))
(cond (index
(loop index argument))
((= argument 0)
- false)
+ #f)
(else
(let ((n (if (< argument 0) -1 1)))
(let find-next ((mark point))
- (let ((mark (line-start mark n false)))
+ (let ((mark (line-start mark n #f)))
(and mark
(let ((index (mark->bline-index mark)))
(if index
(set-buffer-point! (mark-buffer mark) mark)))
(let ((buffer (bline/description-buffer bline)))
(if buffer
- (pop-up-buffer buffer false)))))
+ (pop-up-buffer buffer #f)))))
(define (highlight-the-number mark)
(let ((end (re-search-forward "[RSE][0-9]+ " mark (line-end mark 0))))
(and (subproblem? (bline/object bline))
(system-frame? (subproblem/stack-frame (bline/object bline)))))
(buffer
- (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER false))
+ (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
(get-environment
(1d-table/get (bline-type/properties (bline/type bline))
'GET-ENVIRONMENT
- false))
+ #f))
(env-exists? (if (and get-environment (not system?))
(let ((environment* (get-environment bline)))
(environment? environment*))
(bline-type/write-description (bline/type bline))))
(temporary-message "Computing, please wait...")
(and write-description
- (let ((buffer (browser/new-buffer (bline/browser bline) false)))
+ (let ((buffer (browser/new-buffer (bline/browser bline) #f)))
(call-with-output-mark (buffer-start buffer)
(lambda (port)
(write-description bline port)
(bline (mark->bline mark))
(browser (bline/browser bline))
(buffer
- (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER false))
+ (1d-table/get (bline/properties bline) 'DESCRIPTION-BUFFER #f))
(condition
(browser/object browser)))
(if (condition? condition)
;;;stuff gets called with uses the minibuffer for prompts
(define (call-with-interface-port mark receiver)
(let ((mark (mark-left-inserting-copy mark)))
- (let ((value (receiver (port/copy interface-port-template mark))))
+ (let ((value (receiver (make-port interface-port-type mark))))
(mark-temporary! mark)
value)))
(environment-browser-buffer environment))))))
(define (bline/attached-buffer bline type make-buffer)
- (let ((buffer (1d-table/get (bline/properties bline) type false)))
+ (let ((buffer (1d-table/get (bline/properties bline) type #f)))
(if (and buffer (buffer-alive? buffer))
buffer
(let ((buffer (make-buffer)))
(let ((get-environment
(1d-table/get (bline-type/properties (bline/type bline))
'GET-ENVIRONMENT
- false))
+ #f))
(lose
(lambda () (editor-error "The selected line has no environment."))))
(if get-environment
(set-bline/next! (record-modifier bline-rtd 'NEXT)))
(lambda (object type parent prev)
(let ((bline
- (constructor false object type
+ (constructor #f object type
parent (if parent (+ (bline/depth parent) 1) 0)
- false prev (if prev (+ (bline/offset prev) 1) 0)
+ #f prev (if prev (+ (bline/offset prev) 1) 0)
(make-1d-table))))
(if prev
(set-bline/next! prev bline))
(insert-newline mark)
(set-bline/start-mark!
bline
- (make-permanent-mark (mark-group mark) index true))))
+ (make-permanent-mark (mark-group mark) index #t))))
blines)
(mark-temporary! mark)))))
(set-browser/lines! browser bv*))))))
(write-string "--more--" port))
(define bline-type:continuation-line
- (make-bline-type continuation-line/write-summary false 0))
+ (make-bline-type continuation-line/write-summary #f 0))
(define (bline/continuation? bline)
(eq? (bline/type bline) bline-type:continuation-line))
(define-variable debugger-confirm-return?
"True means prompt for confirmation in \"return\" commands.
The prompting occurs prior to returning the value."
- true
+ #t
boolean?)
(define-variable debugger-quit-on-return?
"True means quit debugger when executing a \"return\" command.
Quitting the debugger kills the debugger buffer and any associated buffers."
- true
+ #t
boolean?)
(define-variable debugger-quit-on-restart?
"True means quit debugger when executing a \"restart\" command.
Quitting the debugger kills the debugger buffer and any associated buffers."
- true
+ #t
boolean?)
;;;Limited this bc the bindings are now pretty-printed
(define (continuation->blines continuation limit)
(let ((beyond-system-code #f))
(let loop ((frame (continuation/first-subproblem continuation))
- (prev false)
+ (prev #f)
(n 0))
(if (not frame)
'()
(walk-reductions
(lambda (bline reductions)
(cons bline
- (let loop ((reductions reductions) (prev false))
+ (let loop ((reductions reductions) (prev #f))
(if (null? reductions)
(next-subproblem bline)
(let ((bline
(let ((bline
(make-bline subproblem
bline-type:subproblem
- false
+ #f
prev)))
(cons bline
(next-subproblem bline)))
(let ((bline
(make-bline (car reductions)
bline-type:reduction
- false
+ #f
prev)))
(walk-reductions bline
(if (> n 0)
(walk-reductions
(make-bline subproblem
bline-type:subproblem
- false
+ #f
prev)
(subproblem/reductions subproblem)))))))
(cond ((and (not (ref-variable debugger-hide-system-code?))
(begin (set! beyond-system-code #t) #t)
#f)
beyond-system-code)
- (list (make-continuation-bline continue false prev)))
+ (list (make-continuation-bline continue #f prev)))
(else (continue))))))))
\f
(define subproblem-rtd
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (fluid-let ((*unparse-primitives-by-name?* true))
+ (fluid-let ((*unparse-primitives-by-name?* #t))
(write
(unsyntax (if (invalid-subexpression? subexpression)
expression
subexpression)))))
((debugging-info/noise? expression)
(write-string ";" port)
- (write-string ((debugging-info/noise expression) false)
+ (write-string ((debugging-info/noise expression) #f)
port))
(else
(write-string ";undefined expression" port))))))))
expression-indentation
port))))
((debugging-info/noise? expression)
- (write-string ((debugging-info/noise expression) true)
+ (write-string ((debugging-info/noise expression) #t)
port))
(else
(write-string (if (stack-frame/compiled-code? frame)
(subproblem/number (reduction/subproblem reduction)))
port)))
(write-string " " port)
- (fluid-let ((*unparse-primitives-by-name?* true))
+ (fluid-let ((*unparse-primitives-by-name?* #t))
(write (unsyntax (reduction/expression reduction)) port))))
(define (reduction/write-description bline port)
buffer))))
(define (environment->blines environment)
- (let loop ((environment environment) (prev false))
- (let ((bline (make-bline environment bline-type:environment false prev)))
+ (let loop ((environment environment) (prev #f))
+ (let ((bline (make-bline environment bline-type:environment #f prev)))
(cons bline
- (if (eq? true (environment-has-parent? environment))
+ (if (eq? #t (environment-has-parent? environment))
(loop (environment-parent environment) bline)
'())))))
\f
(write limit port)
(write-string " shown):" port)
(finish (list-head names limit))
- true)))))))
+ #t)))))))
(else
(write-string " BINDINGS:" port)
(finish
port
(prompt-for-expression prompt))
-(define interface-port-template
- (make-output-port
+(define interface-port-type
+ (make-output-port-type
`((WRITE-CHAR ,operation/write-char)
(PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
(PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression))
- false))
\ No newline at end of file
+ #f))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: intmod.scm,v 1.95 1999/01/02 06:11:34 cph Exp $
+;;; $Id: intmod.scm,v 1.96 1999/02/16 20:12:20 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
(define (make-interface-port buffer thread)
(letrec
((port
- (port/copy interface-port-template
+ (make-port interface-port-type
(make-interface-port-state
thread
(mark-right-inserting-copy (buffer-end buffer))
syntax-table))
#t)))
-(define interface-port-template
- (make-i/o-port
+(define interface-port-type
+ (make-i/o-port-type
`((WRITE-CHAR ,operation/write-char)
(WRITE-SUBSTRING ,operation/write-substring)
(FRESH-LINE ,operation/fresh-line)
;;; -*-Scheme-*-
;;;
-;;;$Id: winout.scm,v 1.11 1999/02/16 00:44:11 cph Exp $
+;;;$Id: winout.scm,v 1.12 1999/02/16 20:12:09 cph Exp $
;;;
;;; Copyright (c) 1986, 1989-1999 Massachusetts Institute of Technology
;;;
(with-output-to-port (window-output-port window) thunk))
(define (window-output-port window)
- (output-port/copy window-output-port-template window))
+ (make-port window-output-port-type window))
(define (operation/fresh-line port)
(if (not (line-start? (window-point (port/state port))))
(line-end? point)
(buffer-auto-save-modified? buffer)
(or (not (window-needs-redisplay? window))
- (window-direct-update! window false)))
+ (window-direct-update! window #f)))
(cond ((and (group-end? point)
(char=? char #\newline)
(< (1+ (window-point-y window)) (window-y-size window)))
(line-end? point)
(buffer-auto-save-modified? buffer)
(or (not (window-needs-redisplay? window))
- (window-direct-update! window false))
+ (window-direct-update! window #f))
(let loop ((i (- end 1)))
(or (< i start)
(let ((char (string-ref string i)))
(define (operation/flush-output port)
(let ((window (port/state port)))
(if (window-needs-redisplay? window)
- (window-direct-update! window false))))
+ (window-direct-update! window #f))))
(define (operation/x-size port)
(window-x-size (port/state port)))
(unparse-string state "to window ")
(unparse-object state (port/state port)))
-(define window-output-port-template
- (make-output-port `((FLUSH-OUTPUT ,operation/flush-output)
- (FRESH-LINE ,operation/fresh-line)
- (PRINT-SELF ,operation/print-self)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring)
- (X-SIZE ,operation/x-size))
- false))
\ No newline at end of file
+(define window-output-port-type
+ (make-output-port-type `((FLUSH-OUTPUT ,operation/flush-output)
+ (FRESH-LINE ,operation/fresh-line)
+ (PRINT-SELF ,operation/print-self)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring)
+ (X-SIZE ,operation/x-size))
+ #f))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: emacs.scm,v 14.23 1999/01/02 06:11:34 cph Exp $
+$Id: emacs.scm,v 14.24 1999/02/16 20:11:25 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
(define (initialize-package!)
(set! emacs-console-port
(make-i/o-port
- (let ((operations
- `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression)
- (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char)
- (PROMPT-FOR-COMMAND-EXPRESSION
- ,emacs/prompt-for-command-expression)
- (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation)
- (DEBUGGER-FAILURE ,emacs/debugger-failure)
- (DEBUGGER-MESSAGE ,emacs/debugger-message)
- (DEBUGGER-PRESENTATION ,emacs/debugger-presentation)
- (WRITE-RESULT ,emacs/write-result)
- (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory)
- (READ-START ,emacs/read-start)
- (READ-FINISH ,emacs/read-finish)
- (GC-START ,emacs/gc-start)
- (GC-FINISH ,emacs/gc-finish))))
- (append-map* operations
- (lambda (name)
- (if (assq name operations)
- '()
- `((,name
- ,(port/operation the-console-port name)))))
- (port/operation-names the-console-port)))
+ (make-i/o-port-type
+ `((PROMPT-FOR-EXPRESSION ,emacs/prompt-for-expression)
+ (PROMPT-FOR-COMMAND-CHAR ,emacs/prompt-for-command-char)
+ (PROMPT-FOR-COMMAND-EXPRESSION
+ ,emacs/prompt-for-command-expression)
+ (PROMPT-FOR-CONFIRMATION ,emacs/prompt-for-confirmation)
+ (DEBUGGER-FAILURE ,emacs/debugger-failure)
+ (DEBUGGER-MESSAGE ,emacs/debugger-message)
+ (DEBUGGER-PRESENTATION ,emacs/debugger-presentation)
+ (WRITE-RESULT ,emacs/write-result)
+ (SET-DEFAULT-DIRECTORY ,emacs/set-default-directory)
+ (READ-START ,emacs/read-start)
+ (READ-FINISH ,emacs/read-finish)
+ (GC-START ,emacs/gc-start)
+ (GC-FINISH ,emacs/gc-finish))
+ the-console-port-type)
(port/state the-console-port)))
;; YUCCH! Kludge to copy mutex of console port into emacs port.
(set-port/thread-mutex! emacs-console-port
#| -*-Scheme-*-
-$Id: fileio.scm,v 1.15 1999/02/16 05:39:07 cph Exp $
+$Id: fileio.scm,v 1.16 1999/02/16 20:11:34 cph Exp $
Copyright (c) 1991-1999 Massachusetts Institute of Technology
\f
(define (initialize-package!)
(let ((input-operations
- `((BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
- (CHAR-READY? ,operation/char-ready?)
- (CHARS-REMAINING ,operation/chars-remaining)
- (CLOSE-INPUT ,operation/close-input)
- (DISCARD-CHAR ,operation/discard-char)
- (DISCARD-CHARS ,operation/discard-chars)
- (EOF? ,operation/eof?)
- (INPUT-BLOCKING-MODE ,operation/input-blocking-mode)
- (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
- (INPUT-CHANNEL ,operation/input-channel)
- (INPUT-OPEN? ,operation/input-open?)
- (INPUT-TERMINAL-MODE ,operation/input-terminal-mode)
- (LENGTH ,operation/length)
- (PEEK-CHAR ,operation/peek-char)
- (READ-CHAR ,operation/read-char)
- (READ-STRING ,operation/read-string)
- (READ-SUBSTRING ,operation/read-substring)
- (REST->STRING ,operation/rest->string)
- (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode)
- (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)
- (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode)))
- (output-operations
- `((BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
- (CLOSE-OUTPUT ,operation/close-output)
- (FLUSH-OUTPUT ,operation/flush-output)
- (FRESH-LINE ,operation/fresh-line)
- (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode)
- (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
- (OUTPUT-CHANNEL ,operation/output-channel)
- (OUTPUT-OPEN? ,operation/output-open?)
- (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode)
- (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode)
- (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
- (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring)))
+ `((LENGTH ,operation/length)
+ (REST->STRING ,operation/rest->string)))
(other-operations
- `((CLOSE ,operation/close)
+ `((WRITE-SELF ,operation/write-self)
(PATHNAME ,operation/pathname)
- (WRITE-SELF ,operation/write-self)
(TRUENAME ,operation/truename))))
- (set! input-file-template
- (make-input-port (append input-operations
- other-operations)
- #f))
- (set! output-file-template
- (make-output-port (append output-operations
- other-operations)
- #f))
- (set! i/o-file-template
- (make-i/o-port (append input-operations
- output-operations
- other-operations)
- #f)))
+ (set! input-file-type
+ (make-input-port-type (append input-operations
+ other-operations)
+ generic-input-type))
+ (set! output-file-type
+ (make-output-port-type other-operations
+ generic-output-type))
+ (set! i/o-file-type
+ (make-i/o-port-type (append input-operations
+ other-operations)
+ generic-i/o-type)))
unspecific)
-(define input-file-template)
-(define output-file-template)
-(define i/o-file-template)
+(define input-file-type)
+(define output-file-type)
+(define i/o-file-type)
(define input-buffer-size 512)
(define output-buffer-size 512)
(let* ((pathname (merge-pathnames filename))
(channel (file-open-input-channel (->namestring pathname)))
(port
- (port/copy
- input-file-template
+ (make-port
+ input-file-type
(make-file-state
(make-input-buffer channel
input-buffer-size
(file-open-append-channel filename)
(file-open-output-channel filename))))
(port
- (port/copy
- output-file-template
+ (make-port
+ output-file-type
(make-file-state
#f
(make-output-buffer channel
(channel (file-open-io-channel (->namestring pathname)))
(translation (pathname-newline-translation pathname))
(port
- (port/copy
- i/o-file-template
+ (make-port
+ i/o-file-type
(make-file-state
(make-input-buffer channel input-buffer-size translation)
(make-output-buffer channel output-buffer-size translation)
(let* ((pathname (merge-pathnames filename))
(channel (file-open-input-channel (->namestring pathname)))
(port
- (port/copy input-file-template
+ (make-port input-file-type
(make-file-state (make-input-buffer channel
input-buffer-size
#f)
(file-open-append-channel filename)
(file-open-output-channel filename))))
(port
- (port/copy output-file-template
+ (make-port output-file-type
(make-file-state #f
(make-output-buffer channel
output-buffer-size
(let* ((pathname (merge-pathnames filename))
(channel (file-open-io-channel (->namestring pathname)))
(port
- (port/copy i/o-file-template
+ (make-port i/o-file-type
(make-file-state (make-input-buffer channel
input-buffer-size
#f)
(pathname #f read-only #t))
(define (operation/length port)
- (channel-file-length (operation/input-channel port)))
+ (channel-file-length (port/input-channel port)))
(define (operation/pathname port)
(file-state/pathname (port/state port)))
#| -*-Scheme-*-
-$Id: genio.scm,v 1.13 1999/02/16 05:38:34 cph Exp $
+$Id: genio.scm,v 1.14 1999/02/16 20:11:38 cph Exp $
Copyright (c) 1991-1999 Massachusetts Institute of Technology
(other-operations
`((CLOSE ,operation/close)
(WRITE-SELF ,operation/write-self))))
- (set! generic-input-template
- (make-input-port (append input-operations
- other-operations)
- #f))
- (set! generic-output-template
- (make-output-port (append output-operations
- other-operations)
- #f))
- (set! generic-i/o-template
- (make-i/o-port (append input-operations
- output-operations
- other-operations)
- #f)))
+ (set! generic-input-type
+ (make-input-port-type (append input-operations
+ other-operations)
+ #f))
+ (set! generic-output-type
+ (make-output-port-type (append output-operations
+ other-operations)
+ #f))
+ (set! generic-i/o-type
+ (make-i/o-port-type (append input-operations
+ output-operations
+ other-operations)
+ #f)))
unspecific)
-(define generic-input-template)
-(define generic-output-template)
-(define generic-i/o-template)
+(define generic-input-type)
+(define generic-output-type)
+(define generic-i/o-type)
\f
(define (make-generic-input-port input-channel input-buffer-size
#!optional line-translation)
(if (default-object? line-translation)
'DEFAULT
line-translation)))
- (make-generic-port generic-input-template
+ (make-generic-port generic-input-type
(make-input-buffer input-channel
input-buffer-size
line-translation)
(if (default-object? line-translation)
'DEFAULT
line-translation)))
- (make-generic-port generic-output-template
+ (make-generic-port generic-output-type
#f
(make-output-buffer output-channel
output-buffer-size
(if (default-object? output-line-translation)
input-line-translation
output-line-translation)))
- (make-generic-port generic-i/o-template
+ (make-generic-port generic-i/o-type
(make-input-buffer input-channel
input-buffer-size
input-line-translation)
output-buffer-size
output-line-translation)))))
-(define (make-generic-port template input-buffer output-buffer)
- (let ((port (port/copy template (vector input-buffer output-buffer))))
+(define (make-generic-port type input-buffer output-buffer)
+ (let ((port (make-port type (vector input-buffer output-buffer))))
(if input-buffer
(set-channel-port! (input-buffer/channel input-buffer) port))
(if output-buffer
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.313 1999/02/16 19:49:07 cph Exp $
+$Id: runtime.pkg,v 14.314 1999/02/16 20:11:18 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
console-output-port
set-console-i/o-port!)
(export (runtime emacs-interface)
- the-console-port)
+ the-console-port
+ the-console-port-type)
(initialization (initialize-package!)))
(define-package (runtime continuation)
make-generic-input-port
make-generic-output-port)
(export (runtime console-i/o-port)
- operation/buffered-input-chars
- operation/buffered-output-chars
- operation/char-ready?
- operation/input-blocking-mode
- operation/input-buffer-size
- operation/input-channel
- operation/input-open?
- operation/input-terminal-mode
- operation/output-blocking-mode
- operation/output-buffer-size
- operation/output-channel
- operation/output-open?
- operation/output-terminal-mode
- operation/set-input-blocking-mode
- operation/set-input-buffer-size
- operation/set-input-terminal-mode
- operation/set-output-blocking-mode
- operation/set-output-buffer-size
- operation/set-output-terminal-mode)
+ generic-i/o-type)
(export (runtime file-i/o-port)
- operation/buffered-input-chars
- operation/buffered-output-chars
- operation/char-ready?
- operation/chars-remaining
- operation/close
- operation/close-input
- operation/close-output
- operation/discard-char
- operation/discard-chars
- operation/eof?
- operation/flush-output
- operation/fresh-line
- operation/input-blocking-mode
- operation/input-buffer-size
- operation/input-channel
- operation/input-open?
- operation/input-terminal-mode
- operation/output-blocking-mode
- operation/output-buffer-size
- operation/output-channel
- operation/output-open?
- operation/output-terminal-mode
- operation/peek-char
- operation/read-char
- operation/read-string
- operation/read-substring
- operation/set-input-blocking-mode
- operation/set-input-buffer-size
- operation/set-input-terminal-mode
- operation/set-output-blocking-mode
- operation/set-output-buffer-size
- operation/set-output-terminal-mode
- operation/write-char
- operation/write-substring)
+ generic-i/o-type
+ generic-input-type
+ generic-output-type)
(initialization (initialize-package!)))
(define-package (runtime gensym)
#| -*-Scheme-*-
-$Id: strnin.scm,v 14.5 1999/01/02 06:19:10 cph Exp $
+$Id: strnin.scm,v 14.6 1999/02/16 20:11:55 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! input-string-template
- (make-input-port `((CHAR-READY? ,operation/char-ready?)
- (DISCARD-CHAR ,operation/discard-char)
- (DISCARD-CHARS ,operation/discard-chars)
- (PEEK-CHAR ,operation/peek-char)
- (WRITE-SELF ,operation/write-self)
- (READ-CHAR ,operation/read-char)
- (READ-STRING ,operation/read-string))
- false)))
+ (set! input-string-port-type
+ (make-input-port-type `((CHAR-READY? ,operation/char-ready?)
+ (DISCARD-CHAR ,operation/discard-char)
+ (DISCARD-CHARS ,operation/discard-chars)
+ (PEEK-CHAR ,operation/peek-char)
+ (WRITE-SELF ,operation/write-self)
+ (READ-CHAR ,operation/read-char)
+ (READ-STRING ,operation/read-string))
+ #f))
+ unspecific)
(define (with-input-from-string string thunk)
(with-input-from-port (string->input-port string) thunk))
(if (default-object? end)
(string-length string)
(check-index end (string-length string) 'STRING->INPUT-PORT))))
- (input-port/copy
- input-string-template
+ (make-port
+ input-string-port-type
(make-input-string-state string
(if (default-object? start)
0
(error:bad-range-argument index procedure))
index)
-(define input-string-template)
+(define input-string-port-type)
(define-structure (input-string-state (type vector)
(conc-name input-string-state/))
- (string false read-only true)
+ (string #f read-only #t)
start
- (end false read-only true))
+ (end #f read-only #t))
(define-integrable (input-port/string port)
(input-string-state/string (input-port/state port)))
#| -*-Scheme-*-
-$Id: strott.scm,v 14.6 1999/02/16 00:53:21 cph Exp $
+$Id: strott.scm,v 14.7 1999/02/16 20:11:51 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! output-string-template
- (make-output-port `((WRITE-SELF ,operation/write-self)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring))
- #f)))
+ (set! output-string-port-type
+ (make-output-port-type `((WRITE-SELF ,operation/write-self)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring))
+ #f)))
(define (with-output-to-truncated-string max thunk)
(call-with-current-continuation
(let ((state
(make-output-string-state return max '() max)))
(with-output-to-port
- (output-port/copy output-string-template state)
+ (make-port output-string-port-type state)
thunk)
(output-string-state/accumulator state))))))))
-(define output-string-template)
+(define output-string-port-type)
(define-structure (output-string-state (type vector)
(conc-name output-string-state/))
#| -*-Scheme-*-
-$Id: strout.scm,v 14.9 1999/01/02 06:19:10 cph Exp $
+$Id: strout.scm,v 14.10 1999/02/16 20:11:47 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (initialize-package!)
- (set! output-string-template
- (make-output-port `((WRITE-SELF ,operation/write-self)
- (WRITE-CHAR ,operation/write-char)
- (WRITE-SUBSTRING ,operation/write-substring))
- false))
+ (set! output-string-port-type
+ (make-output-port-type `((WRITE-SELF ,operation/write-self)
+ (WRITE-CHAR ,operation/write-char)
+ (WRITE-SUBSTRING ,operation/write-substring))
+ #f))
unspecific)
(define (with-output-to-string thunk)
(define (with-string-output-port generator)
(let ((state (make-output-string-state (make-string 16) 0)))
- (let ((port (output-port/copy output-string-template state)))
+ (let ((port (make-port output-string-port-type state)))
(generator port)
(without-interrupts
(lambda ()
(string-head (output-string-state/accumulator state)
(output-string-state/counter state)))))))
-(define output-string-template)
+(define output-string-port-type)
(define-structure (output-string-state (type vector)
(conc-name output-string-state/))
#| -*-Scheme-*-
-$Id: ttyio.scm,v 1.9 1999/02/16 05:44:54 cph Exp $
+$Id: ttyio.scm,v 1.10 1999/02/16 20:11:30 cph Exp $
Copyright (c) 1991-1999 Massachusetts Institute of Technology
(output-channel (tty-output-channel)))
(set! hook/read-char operation/read-char)
(set! hook/peek-char operation/peek-char)
- (set! the-console-port
- (make-i/o-port
+ (set! the-console-port-type
+ (make-i/o-port-type
`((BEEP ,operation/beep)
- (BUFFERED-INPUT-CHARS ,operation/buffered-input-chars)
- (BUFFERED-OUTPUT-CHARS ,operation/buffered-output-chars)
- (CHAR-READY? ,operation/char-ready?)
(CLEAR ,operation/clear)
- (DISCARD-CHAR ,operation/read-char)
- (DISCRETIONARY-FLUSH-OUTPUT ,operation/discretionary-flush-output)
+ (DISCRETIONARY-FLUSH-OUTPUT
+ ,operation/discretionary-flush-output)
(FLUSH-OUTPUT ,operation/flush-output)
(FRESH-LINE ,operation/fresh-line)
- (INPUT-BLOCKING-MODE ,operation/input-blocking-mode)
- (INPUT-BUFFER-SIZE ,operation/input-buffer-size)
- (INPUT-CHANNEL ,operation/input-channel)
- (INPUT-OPEN? ,operation/input-open?)
- (INPUT-TERMINAL-MODE ,operation/input-terminal-mode)
- (OUTPUT-BLOCKING-MODE ,operation/output-blocking-mode)
- (OUTPUT-BUFFER-SIZE ,operation/output-buffer-size)
- (OUTPUT-CHANNEL ,operation/output-channel)
- (OUTPUT-OPEN? ,operation/output-open?)
- (OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode)
(PEEK-CHAR ,(lambda (port) (hook/peek-char port)))
- (WRITE-SELF ,operation/write-self)
(READ-CHAR ,(lambda (port) (hook/read-char port)))
(READ-FINISH ,operation/read-finish)
- (SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode)
- (SET-INPUT-BUFFER-SIZE ,operation/set-input-buffer-size)
- (SET-INPUT-TERMINAL-MODE ,operation/set-input-terminal-mode)
- (SET-OUTPUT-BLOCKING-MODE ,operation/set-output-blocking-mode)
- (SET-OUTPUT-BUFFER-SIZE ,operation/set-output-buffer-size)
- (SET-OUTPUT-TERMINAL-MODE ,operation/set-output-terminal-mode)
(WRITE-CHAR ,operation/write-char)
+ (WRITE-SELF ,operation/write-self)
(WRITE-SUBSTRING ,operation/write-substring)
(X-SIZE ,operation/x-size)
(Y-SIZE ,operation/y-size))
- (make-console-port-state
- (make-input-buffer input-channel input-buffer-size)
- (make-output-buffer output-channel output-buffer-size)
- (channel-type=file? input-channel))))
+ generic-i/o-type))
+ (set! the-console-port
+ (make-port the-console-port-type
+ (make-console-port-state
+ (make-input-buffer input-channel input-buffer-size)
+ (make-output-buffer output-channel output-buffer-size)
+ (channel-type=file? input-channel))))
(set-channel-port! input-channel the-console-port)
(set-channel-port! output-channel the-console-port))
(add-event-receiver! event:before-exit save-console-input)
(set-current-input-port! the-console-port)
(set-current-output-port! the-console-port))
+(define the-console-port-type)
(define the-console-port)
(define input-buffer-size 512)
(define output-buffer-size 512)
#| -*-Scheme-*-
-$Id: runtime.pkg,v 14.318 1999/02/16 19:49:13 cph Exp $
+$Id: runtime.pkg,v 14.319 1999/02/16 20:11:00 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
console-output-port
set-console-i/o-port!)
(export (runtime emacs-interface)
- the-console-port)
+ the-console-port
+ the-console-port-type)
(initialization (initialize-package!)))
(define-package (runtime continuation)
make-generic-input-port
make-generic-output-port)
(export (runtime console-i/o-port)
- operation/buffered-input-chars
- operation/buffered-output-chars
- operation/char-ready?
- operation/input-blocking-mode
- operation/input-buffer-size
- operation/input-channel
- operation/input-open?
- operation/input-terminal-mode
- operation/output-blocking-mode
- operation/output-buffer-size
- operation/output-channel
- operation/output-open?
- operation/output-terminal-mode
- operation/set-input-blocking-mode
- operation/set-input-buffer-size
- operation/set-input-terminal-mode
- operation/set-output-blocking-mode
- operation/set-output-buffer-size
- operation/set-output-terminal-mode)
+ generic-i/o-type)
(export (runtime file-i/o-port)
- operation/buffered-input-chars
- operation/buffered-output-chars
- operation/char-ready?
- operation/chars-remaining
- operation/close
- operation/close-input
- operation/close-output
- operation/discard-char
- operation/discard-chars
- operation/eof?
- operation/flush-output
- operation/fresh-line
- operation/input-blocking-mode
- operation/input-buffer-size
- operation/input-channel
- operation/input-open?
- operation/input-terminal-mode
- operation/output-blocking-mode
- operation/output-buffer-size
- operation/output-channel
- operation/output-open?
- operation/output-terminal-mode
- operation/peek-char
- operation/read-char
- operation/read-string
- operation/read-substring
- operation/set-input-blocking-mode
- operation/set-input-buffer-size
- operation/set-input-terminal-mode
- operation/set-output-blocking-mode
- operation/set-output-buffer-size
- operation/set-output-terminal-mode
- operation/write-char
- operation/write-substring)
+ generic-i/o-type
+ generic-input-type
+ generic-output-type)
(initialization (initialize-package!)))
(define-package (runtime gensym)
projects / mit-scheme.git / commitdiff