#| -*-Scheme-*-
-$Id: artdebug.scm,v 1.33 2003/02/14 18:28:10 cph Exp $
+$Id: artdebug.scm,v 1.34 2004/02/16 05:42:42 cph Exp $
Copyright 1989,1990,1991,1992,1993,1998 Massachusetts Institute of Technology
-Copyright 1999,2001,2003 Massachusetts Institute of Technology
+Copyright 1999,2001,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
value)))
(define (operation/write-char port char)
+ (guarantee-8-bit-char char)
(region-insert-char! (port/state port) char))
(define (operation/write-substring port string start end)
(region-insert-substring! (port/state port) string start end))
-(define (operation/fresh-line port)
- (guarantee-newline (port/state port)))
-
(define (operation/x-size port)
(let ((buffer (mark-buffer (port/state port))))
(and buffer
(make-port-type
`((WRITE-CHAR ,operation/write-char)
(WRITE-SUBSTRING ,operation/write-substring)
- (FRESH-LINE ,operation/fresh-line)
(X-SIZE ,operation/x-size)
(DEBUGGER-FAILURE ,operation/debugger-failure)
(DEBUGGER-MESSAGE ,operation/debugger-message)
#| -*-Scheme-*-
-$Id: bufinp.scm,v 1.11 2003/02/14 18:28:11 cph Exp $
+$Id: bufinp.scm,v 1.12 2004/02/16 05:42:49 cph Exp $
-Copyright 1986, 1989-1999 Massachusetts Institute of Technology
+Copyright 1989,1990,1991,1999,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(let ((value (with-input-from-port port thunk)))
(if (default-object? receiver)
value
- (receiver
- value
- (let ((state (port/state port)))
- (make-mark (buffer-input-port-state/group state)
- (buffer-input-port-state/current-index state))))))))
+ (receiver value (input-port/mark port))))))
(define (with-input-from-region region thunk)
- (with-input-from-port (make-buffer-input-port (region-start region)
- (region-end region))
+ (with-input-from-port
+ (make-buffer-input-port (region-start region) (region-end region))
thunk))
-(define-structure (buffer-input-port-state
- (conc-name buffer-input-port-state/))
- (group #f read-only #t)
- (end-index #f read-only #t)
- (current-index #f))
+(define (call-with-input-mark mark procedure)
+ (procedure (make-buffer-input-port mark (group-end mark))))
+
+(define (call-with-input-region region procedure)
+ (procedure
+ (make-buffer-input-port (region-start region) (region-end region))))
-(define (make-buffer-input-port mark end)
+(define (make-buffer-input-port start end)
;; This uses indices, so it can only be used locally
;; where there is no buffer-modification happening.
(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
- (let ((state (port/state port)))
- (< (buffer-input-port-state/current-index state)
- (buffer-input-port-state/end-index state))))
-
-(define (operation/peek-char port)
- (let ((state (port/state port)))
- (let ((current-index (buffer-input-port-state/current-index state)))
- (if (< current-index (buffer-input-port-state/end-index state))
- (group-right-char (buffer-input-port-state/group state)
- current-index)
- (make-eof-object port)))))
-
-(define (operation/discard-char port)
- (let ((state (port/state port)))
- (set-buffer-input-port-state/current-index!
- state
- (1+ (buffer-input-port-state/current-index state)))))
-\f
-(define (operation/read-char port)
- (let ((state (port/state port)))
- (let ((current-index (buffer-input-port-state/current-index state)))
- (if (< current-index (buffer-input-port-state/end-index state))
- (let ((char
- (group-right-char (buffer-input-port-state/group state)
- current-index)))
- (set-buffer-input-port-state/current-index! state
- (1+ current-index))
- char)
- (make-eof-object port)))))
-
-(define (operation/read-string port delimiters)
- (let ((state (port/state port)))
- (let ((current-index (buffer-input-port-state/current-index state))
- (end-index (buffer-input-port-state/end-index state))
- (group (buffer-input-port-state/group state)))
- (if (>= current-index end-index)
- (make-eof-object port)
- (let ((new-index
- (or (group-find-next-char-in-set group current-index end-index
- delimiters)
- end-index)))
- (let ((string
- (group-extract-string group current-index new-index)))
- (set-buffer-input-port-state/current-index! state new-index)
- string))))))
-
-(define (operation/discard-chars port delimiters)
- (let ((state (port/state port)))
- (let ((current-index (buffer-input-port-state/current-index state))
- (end-index (buffer-input-port-state/end-index state)))
- (if (< current-index end-index)
- (set-buffer-input-port-state/current-index!
- state
- (or (group-find-next-char-in-set
- (buffer-input-port-state/group state)
- current-index
- end-index
- delimiters)
- end-index))))))
-
-(define (operation/print-self state port)
- (unparse-string state "from buffer at ")
- (unparse-object
- state
- (let ((state (port/state port)))
- (make-mark (buffer-input-port-state/group state)
- (buffer-input-port-state/current-index state)))))
+ (make-bstate (mark-group start)
+ (mark-index start)
+ (mark-index end))))
+
+(define (input-port/mark port)
+ (let ((operation (port/operation port 'BUFFER-MARK)))
+ (if (not operation)
+ (error:bad-range-argument port 'INPUT-PORT/MARK))
+ (operation port)))
+
+(define-structure bstate
+ (group #f read-only #t)
+ (start #f)
+ (end #f read-only #t))
(define buffer-input-port-type
- (make-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
+ (make-port-type
+ `((BUFFER-MARK
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (make-mark (bstate-group state)
+ (bstate-start state)))))
+ (CHAR-READY?
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (fix:< (bstate-start state)
+ (bstate-end state)))))
+ (READ-CHAR
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (let ((start (bstate-start state)))
+ (if (fix:< start (bstate-end state))
+ (let ((char (group-right-char (bstate-group state) start)))
+ (set-bstate-start! state (fix:+ start 1))
+ char)
+ (make-eof-object port))))))
+ (WRITE-SELF
+ ,(lambda (port output)
+ (write-string " from buffer at " output)
+ (write (input-port/mark port) output))))
+ #f))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: bufout.scm,v 1.16 2003/02/14 18:28:11 cph Exp $
+$Id: bufout.scm,v 1.17 2004/02/16 05:42:55 cph Exp $
-Copyright 1986, 1989-1999 Massachusetts Institute of Technology
+Copyright 1989,1991,1992,1993,1998,1999 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(window-direct-update! window #f)))
(buffer-windows buffer)))))
-(define (operation/fresh-line port)
- (guarantee-newline (port/mark port)))
-
-(define (operation/print-self state port)
- (unparse-string state "to buffer at ")
- (unparse-object state (port/mark port)))
+(define (operation/write-self port output)
+ (write-string " to buffer at " output)
+ (write (port/mark port) output))
(define (operation/write-char port char)
- (region-insert-char! (port/mark port) char))
+ (guarantee-8-bit-char char)
+ (region-insert-char! (port/mark port) char)
+ 1)
(define (operation/write-substring port string start end)
- (region-insert-substring! (port/mark port) string start end))
+ (region-insert-substring! (port/mark port) string start end)
+ (fix:- end start))
(define (operation/close port)
(mark-temporary! (port/mark port)))
(define mark-output-port-type
(make-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-SELF ,operation/write-self)
(WRITE-SUBSTRING ,operation/write-substring)
(X-SIZE ,operation/x-size))
#f))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: debug.scm,v 1.66 2003/03/07 19:34:48 cph Exp $
+$Id: debug.scm,v 1.67 2004/02/16 05:43:03 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
This file is part of MIT/GNU Scheme.
port))))
(message "No condition to restart from."))))
-;;;
-;;;Sort of a kludge, borrowed from arthur's debugger,
-;;;this makes sure that the interface port that the restart
-;;;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 (make-port interface-port-type mark))))
(mark-temporary! mark)
value)))
-;;;Another thing borrowed from arthur, calls the cont
-;;;and exits the debugger
+(define interface-port-type
+ (make-port-type
+ `((WRITE-CHAR
+ ,(lambda (port char)
+ (guarantee-8-bit-char char)
+ (region-insert-char! (port/state port) char)))
+ (PROMPT-FOR-CONFIRMATION
+ ,(lambda (port prompt) port (prompt-for-confirmation? prompt)))
+ (PROMPT-FOR-EXPRESSION
+ ,(lambda (port prompt) port (prompt-for-expression prompt))))
+ #f))
+
(define (invoke-continuation continuation arguments avoid-deletion?)
(let ((buffer (current-buffer)))
(if (and (not avoid-deletion?)
(string-length separator))))
(lambda () (write value)))
port)))))
- (debugger-newline port)))
-\f
-;;;; Interface Port
-
-(define (operation/write-char port char)
- (region-insert-char! (port/state port) char))
-
-(define (operation/prompt-for-confirmation port prompt)
- port
- (prompt-for-confirmation? prompt))
-
-(define (operation/prompt-for-expression port prompt)
- port
- (prompt-for-expression prompt))
-
-(define interface-port-type
- (make-port-type
- `((WRITE-CHAR ,operation/write-char)
- (PROMPT-FOR-CONFIRMATION ,operation/prompt-for-confirmation)
- (PROMPT-FOR-EXPRESSION ,operation/prompt-for-expression))
- #f))
\ No newline at end of file
+ (debugger-newline port)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: debuge.scm,v 1.57 2003/02/14 18:28:11 cph Exp $
+$Id: debuge.scm,v 1.58 2004/02/16 05:43:09 cph Exp $
-Copyright 1986, 1989-2000 Massachusetts Institute of Technology
+Copyright 1987,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
+Copyright 1995,1998,2000,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(write-string "'")
(let ((region (buffer-unclipped-region buffer)))
(group-write-to-file
- (and (ref-variable translate-file-data-on-output
- (region-group region))
- (pathname-newline-translation pathname))
+ (ref-variable translate-file-data-on-output
+ (region-group region))
(region-group region)
(region-start-index region)
(region-end-index region)
#| -*-Scheme-*-
-$Id: dosfile.scm,v 1.44 2003/09/24 01:57:39 cph Exp $
+$Id: dosfile.scm,v 1.45 2004/02/16 05:43:14 cph Exp $
Copyright 1995,1996,1999,2000,2002,2003 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(list pathname mark)))
(group-insert-file! (mark-group mark)
(mark-index mark)
- temporary
- (pathname-newline-translation pathname)))))))
+ temporary))))))
(define (write-compressed-file program arguments region pathname)
((message-wrapper #f "Compressing file " (->namestring pathname))
#| -*-Scheme-*-
-$Id: editor.scm,v 1.258 2003/02/14 18:28:12 cph Exp $
+$Id: editor.scm,v 1.259 2004/02/16 05:43:21 cph Exp $
Copyright 1986,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
exit)))))))
(define dummy-i/o-port
- (make-i/o-port
- (map (lambda (name)
- (list name
- (lambda (port . ignore)
- ignore
- (error "Attempt to perform a"
- name
- (error-irritant/noise " operation on dummy I/O port:")
- port))))
- '(CHAR-READY? READ-CHAR PEEK-CHAR WRITE-CHAR))
- #f))
+ (make-port (make-port-type
+ (map (lambda (name)
+ (list name
+ (lambda (port . ignore)
+ ignore
+ (error "Attempt to perform a"
+ name
+ (error-irritant/noise
+ " operation on dummy I/O port:")
+ port))))
+ '(CHAR-READY? READ-CHAR WRITE-CHAR))
+ #f)
+ #f))
(define null-output-port
- (make-output-port `((WRITE-CHAR ,(lambda (port char) port char unspecific)))
- #f))
+ (make-port (make-port-type
+ `((WRITE-CHAR ,(lambda (port char) port char unspecific)))
+ #f)
+ #f))
(define (editor-start-child-cmdl with-editor-ungrabbed)
(lambda (cmdl thunk) cmdl (with-editor-ungrabbed thunk)))
#| -*-Scheme-*-
-$Id: edwin.pkg,v 1.286 2003/04/25 03:10:00 cph Exp $
+$Id: edwin.pkg,v 1.287 2004/02/16 05:43:26 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 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(parent ())
(import (runtime rep)
hook/repl-eval)
- (import (runtime primitive-io)
- input-buffer/read-substring
- make-input-buffer
- make-output-buffer
- output-buffer/drain-block
- output-buffer/write-substring-block)
(import (runtime character)
bucky-bits->prefix)
(import (runtime char-syntax)
#| -*-Scheme-*-
-$Id: fileio.scm,v 1.163 2003/09/24 04:47:57 cph Exp $
+$Id: fileio.scm,v 1.164 2004/02/16 05:43:33 cph Exp $
Copyright 1986,1989,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,1997,1999,2000,2001,2002 Massachusetts Institute of Technology
-Copyright 2003 Massachusetts Institute of Technology
+Copyright 2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(method truename mark visit?)
(let ((do-it
(lambda ()
- (group-insert-file!
- (mark-group mark)
- (mark-index mark)
- truename
- (pathname-newline-translation truename)))))
+ (group-insert-file! (mark-group mark)
+ (mark-index mark)
+ truename))))
(if (ref-variable read-file-message mark)
(let ((msg
(string-append "Reading file \""
value))
(do-it))))))
-(define (group-insert-file! group index truename translation)
- (let ((filename (->namestring truename)))
- (let ((channel (file-open-input-channel filename)))
- (let ((length (channel-file-length channel))
- (buffer
- (and translation
- (ref-variable translate-file-data-on-input group)
- (make-input-buffer channel 4096 translation))))
+(define (group-insert-file! group start truename)
+ (call-with-input-file truename
+ (lambda (port)
+ (if (not (ref-variable translate-file-data-on-input group))
+ (port/set-line-ending port 'BINARY))
+ (let ((length ((port/operation port 'LENGTH) port)))
(bind-condition-handler (list condition-type:allocation-failure)
(lambda (condition)
condition
- (error "File too large to fit in memory:" filename))
+ (error "File too large to fit in memory:"
+ (->namestring truename)))
(lambda ()
(without-interrupts
(lambda ()
- (prepare-gap-for-insert! group index length)))))
+ (prepare-gap-for-insert! group start length)))))
(let ((n
(let ((text (group-text group))
- (end (fix:+ index length)))
- (if buffer
- (fix:- (let loop ((index index))
- (if (fix:< index end)
- (let ((n
- (input-buffer/read-substring
- buffer text index end)))
- (if (fix:= n 0)
- index
- (loop (fix:+ index n))))
- index))
- index)
- (channel-read-block channel text index end)))))
+ (end (fix:+ start length)))
+ (let loop ((i start))
+ (if (fix:< i end)
+ (let ((n (input-port/read-substring! port text i end)))
+ (if (fix:> n 0)
+ (loop (fix:+ i n))
+ (fix:- i start)))
+ length)))))
(if (fix:> n 0)
(without-interrupts
(lambda ()
- (let ((gap-start* (fix:+ index n)))
- (undo-record-insertion! group index gap-start*)
- (finish-group-insert! group index n)))))
- (channel-close channel)
+ (let ((gap-start* (fix:+ start n)))
+ (undo-record-insertion! group start gap-start*)
+ (finish-group-insert! group start n)))))
n)))))
\f
;;;; Buffer Mode Initialization
(if (eq? 'DEFAULT translate?)
(ref-variable translate-file-data-on-output group)
translate?))
- (translation (and translate? (pathname-newline-translation pathname)))
(filename (->namestring pathname))
(method (write-file-method group pathname)))
(if method
(let ((do-it
(lambda ()
(if append?
- (group-append-to-file translation group start end
+ (group-append-to-file translate? group start end
filename)
- (group-write-to-file translation group start end
+ (group-write-to-file translate? group start end
filename)))))
(cond ((not message?)
(do-it))
;; the operating system after the channel is closed.
filename))
\f
-(define (group-write-to-file translation group start end filename)
- (let ((channel (file-open-output-channel filename)))
- (group-write-to-channel translation group start end channel)
- (channel-close channel)))
-
-(define (group-append-to-file translation group start end filename)
- (let ((channel (file-open-append-channel filename)))
- (group-write-to-channel translation group start end channel)
- (channel-close channel)))
-
-(define (group-write-to-channel translation group start end channel)
- (let ((buffer
- (and translation (make-output-buffer channel 4096 translation))))
- (%group-write group start end
- (if buffer
- (lambda (string start end)
- (output-buffer/write-substring-block buffer
- string start end))
- (lambda (string start end)
- (channel-write-block channel string start end))))
- (if buffer
- (output-buffer/drain-block buffer))))
+(define (group-write-to-file translate? group start end filename)
+ (call-with-output-file filename
+ (lambda (port)
+ (if (not translate?)
+ (port/set-line-ending port 'BINARY))
+ (group-write-to-port group start end port))))
+
+(define (group-append-to-file translate? group start end filename)
+ (call-with-append-file filename
+ (lambda (port)
+ (if (not translate?)
+ (port/set-line-ending port 'BINARY))
+ (group-write-to-port group start end port))))
(define (group-write-to-port group start end port)
(%group-write group start end
#| -*-Scheme-*-
-$Id: intmod.scm,v 1.119 2003/02/14 18:28:12 cph Exp $
+$Id: intmod.scm,v 1.120 2004/02/16 05:43:38 cph Exp $
Copyright 1986,1989,1991,1992,1993,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
;;; Output operations
(define (operation/write-char port char)
- (enqueue-output-string! port (string char)))
+ (guarantee-8-bit-char char)
+ (enqueue-output-string! port (string char))
+ 1)
(define (operation/write-substring port string start end)
- (enqueue-output-string! port (substring string start end)))
-
-(define (operation/fresh-line port)
- (enqueue-output-operation!
- port
- (lambda (mark transcript?) transcript? (guarantee-newline mark) #t)))
+ (enqueue-output-string! port (substring string start end))
+ (fix:- end start))
(define (operation/beep port)
(enqueue-output-operation!
\f
;;; Input operations
-(define (operation/peek-char port)
- (error "PEEK-CHAR not supported on this port:" port))
-
(define (operation/read-char port)
(error "READ-CHAR not supported on this port:" port))
(make-port-type
`((WRITE-CHAR ,operation/write-char)
(WRITE-SUBSTRING ,operation/write-substring)
- (FRESH-LINE ,operation/fresh-line)
(BEEP ,operation/beep)
(X-SIZE ,operation/x-size)
(DEBUGGER-FAILURE ,operation/debugger-failure)
(PROMPT-FOR-COMMAND-CHAR ,operation/prompt-for-command-char)
(SET-DEFAULT-DIRECTORY ,operation/set-default-directory)
(SET-DEFAULT-ENVIRONMENT ,operation/set-default-environment)
- (PEEK-CHAR ,operation/peek-char)
(READ-CHAR ,operation/read-char)
(READ ,operation/read)
(CURRENT-EXPRESSION-CONTEXT ,operation/current-expression-context)
#| -*-Scheme-*-
-$Id: make.scm,v 3.119 2004/01/16 20:38:09 cph Exp $
+$Id: make.scm,v 3.120 2004/02/16 05:43:45 cph Exp $
Copyright 1989,1990,1991,1992,1993,1994 Massachusetts Institute of Technology
Copyright 1995,2000,2001,2002,2003,2004 Massachusetts Institute of Technology
(load-package-set "edwin"
`((alternate-package-loader
. ,(load "edwin.bld" system-global-environment))))))))
-(add-identification! "Edwin" 3 115)
\ No newline at end of file
+(add-identification! "Edwin" 3 116)
\ No newline at end of file
#| -*-Scheme-*-
-$Id: process.scm,v 1.65 2003/02/14 18:28:13 cph Exp $
+$Id: process.scm,v 1.66 2004/02/16 05:43:52 cph Exp $
Copyright 1991,1992,1993,1996,1997,1999 Massachusetts Institute of Technology
-Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(output-port
(and output-mark
(mark->output-port
- (if (pair? output-mark) (car output-mark) output-mark))))
- (mark-translation
- (lambda (mark)
- (let ((pathname
- (let ((buffer (mark-buffer mark)))
- (and buffer
- (buffer-pathname buffer)))))
- (if pathname
- (pathname-newline-translation pathname)
- 'DEFAULT)))))
+ (if (pair? output-mark) (car output-mark) output-mark)))))
(let ((result
(run-synchronous-process-1 output-port
(lambda ()
(run-synchronous-subprocess
program arguments
'INPUT input-port
- 'INPUT-LINE-TRANSLATION
- (if input-region
- (let ((mark (region-start input-region)))
- (and (ref-variable translate-file-data-on-output mark)
- (mark-translation mark)))
- 'DEFAULT)
'OUTPUT output-port
- 'OUTPUT-LINE-TRANSLATION
- (if output-port
- (let ((mark (output-port->mark output-port)))
- (and (ref-variable translate-file-data-on-input mark)
- (mark-translation mark)))
- 'DEFAULT)
'REDISPLAY-HOOK
(and (if (pair? output-mark) (cdr output-mark) #f)
(lambda () (update-screens! '(IGNORE-INPUT))))
#| -*-Scheme-*-
-$Id: tterm.scm,v 1.39 2004/01/16 20:32:40 cph Exp $
+$Id: tterm.scm,v 1.40 2004/02/16 05:43:59 cph Exp $
Copyright 1990,1991,1993,1994,1998,1999 Massachusetts Institute of Technology
Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
(channel-type=terminal? channel)
(terminal-output-baud-rate channel))))
-(define (output-port/buffered-chars port)
- (let ((operation (port/operation port 'BUFFERED-OUTPUT-CHARS)))
+(define (output-port/buffered-bytes port)
+ (let ((operation (port/operation port 'BUFFERED-OUTPUT-BYTES)))
(if operation
(operation port)
0)))
finished?))
(define (console-discretionary-flush screen)
- (let ((n (output-port/buffered-chars console-i/o-port)))
+ (let ((n (output-port/buffered-bytes console-i/o-port)))
(if (fix:< 20 n)
(begin
(output-port/flush-output console-i/o-port)
#| -*-Scheme-*-
-$Id: unix.scm,v 1.117 2003/09/24 01:57:52 cph Exp $
+$Id: unix.scm,v 1.118 2004/02/16 05:44:05 cph Exp $
Copyright 1989,1991,1992,1993,1994,1995 Massachusetts Institute of Technology
Copyright 1996,1997,1999,2000,2002,2003 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(list pathname mark)))
(group-insert-file! (mark-group mark)
(mark-index mark)
- temporary
- (pathname-newline-translation pathname)))))))
+ temporary))))))
(define (write-compressed-file program region pathname)
((message-wrapper #f "Compressing file " (->namestring pathname))
#| -*-Scheme-*-
-$Id: winout.scm,v 1.17 2003/02/14 18:28:14 cph Exp $
+$Id: winout.scm,v 1.18 2004/02/16 05:44:11 cph Exp $
-Copyright 1986, 1989-2000 Massachusetts Institute of Technology
+Copyright 1989,1991,1992,1994,1999,2000 Massachusetts Institute of Technology
+Copyright 2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define (window-output-port window)
(make-port window-output-port-type window))
-(define (operation/fresh-line port)
- (if (not (line-start? (window-point (port/state port))))
- (operation/write-char port #\newline)))
-
(define (operation/write-char port char)
+ (guarantee-8-bit-char char)
(let ((window (port/state port)))
(let ((buffer (window-buffer window))
(point (window-point window)))
(define (operation/x-size port)
(window-x-size (port/state port)))
-(define (operation/print-self state port)
- (unparse-string state "to window ")
- (unparse-object state (port/state port)))
+(define (operation/write-self port output)
+ (write-string " to window " output)
+ (write (port/state port) output))
(define window-output-port-type
(make-port-type `((FLUSH-OUTPUT ,operation/flush-output)
- (FRESH-LINE ,operation/fresh-line)
- (PRINT-SELF ,operation/print-self)
(WRITE-CHAR ,operation/write-char)
+ (WRITE-SELF ,operation/write-self)
(WRITE-SUBSTRING ,operation/write-substring)
(X-SIZE ,operation/x-size))
#f))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: imail-imap.scm,v 1.200 2003/09/19 03:26:50 cph Exp $
+$Id: imail-imap.scm,v 1.201 2004/02/16 05:48:59 cph Exp $
-Copyright 1999,2000,2001,2003 Massachusetts Institute of Technology
+Copyright 1999,2000,2001,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(write-string string port))))
(define (file->string pathname)
- (call-with-input-file pathname
+ (call-with-output-string
(lambda (port)
- ((input-port/custom-operation port 'REST->STRING) port))))
+ (file->port pathname port))))
(define (file->port pathname output-port)
(call-with-input-file pathname
(lambda (input-port)
- (let ((buffer (make-string 4096)))
+ (let ((buffer (make-string #x1000)))
(let loop ()
(let ((n (read-string! buffer input-port)))
- (if (> n 0)
+ (if (fix:> n 0)
(begin
(write-substring buffer 0 n output-port)
(loop)))))))))
#| -*-Scheme-*-
-$Id: imail-util.scm,v 1.43 2003/03/10 20:53:51 cph Exp $
+$Id: imail-util.scm,v 1.44 2004/02/16 05:49:16 cph Exp $
-Copyright 2000,2001,2003 Massachusetts Institute of Technology
+Copyright 2000,2001,2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(define (open-xstring-input-port xstring position)
(if (not (<= 0 position (external-string-length xstring)))
(error:bad-range-argument position 'OPEN-XSTRING-INPUT-PORT))
- (let ((state (make-xstring-input-state xstring position position position)))
+ (let ((state (make-istate xstring position position position)))
(read-xstring-buffer state)
(make-port xstring-input-type state)))
-(define-structure (xstring-input-state
- (constructor make-xstring-input-state
+(define-structure (istate
+ (constructor make-istate
(xstring position buffer-start buffer-end))
- (conc-name xstring-input-state/))
+ (conc-name istate-))
xstring
position
- (buffer (make-string 65536) read-only #t)
+ (buffer (make-string #x10000) read-only #t)
buffer-start
buffer-end)
(define (xstring-port/xstring port)
- (xstring-input-state/xstring (port/state port)))
+ (istate-xstring (port/state port)))
(define (xstring-port/position port)
- (xstring-input-state/position (port/state port)))
+ (istate-position (port/state port)))
(define (read-xstring-buffer state)
- (let ((xstring (xstring-input-state/xstring state))
- (start (xstring-input-state/position state)))
+ (let ((xstring (istate-xstring state))
+ (start (istate-position state)))
(let ((xend (external-string-length xstring)))
(and (< start xend)
- (let* ((buffer (xstring-input-state/buffer state))
+ (let* ((buffer (istate-buffer state))
(end (min (+ start (string-length buffer)) xend)))
(without-interrupts
(lambda ()
- (set-xstring-input-state/buffer-start! state start)
- (set-xstring-input-state/buffer-end! state end)
+ (set-istate-buffer-start! state start)
+ (set-istate-buffer-end! state end)
(xsubstring-move! xstring start end buffer 0)))
#t)))))
\f
(define (xstring-input-port/discard-chars port delimiters)
(let ((state (port/state port)))
- (if (or (< (xstring-input-state/position state)
- (xstring-input-state/buffer-end state))
+ (if (or (< (istate-position state) (istate-buffer-end state))
(read-xstring-buffer state))
(let loop ()
- (let* ((start (xstring-input-state/buffer-start state))
+ (let* ((start (istate-buffer-start state))
(index
(substring-find-next-char-in-set
- (xstring-input-state/buffer state)
- (- (xstring-input-state/position state) start)
- (- (xstring-input-state/buffer-end state) start)
+ (istate-buffer state)
+ (- (istate-position state) start)
+ (- (istate-buffer-end state) start)
delimiters)))
(if index
- (set-xstring-input-state/position! state (+ start index))
+ (set-istate-position! state (+ start index))
(begin
- (set-xstring-input-state/position!
- state
- (xstring-input-state/buffer-end state))
+ (set-istate-position! state (istate-buffer-end state))
(if (read-xstring-buffer state)
(loop)))))))))
(define (xstring-input-port/read-string port delimiters)
(let ((state (port/state port)))
- (if (or (< (xstring-input-state/position state)
- (xstring-input-state/buffer-end state))
+ (if (or (< (istate-position state) (istate-buffer-end state))
(read-xstring-buffer state))
(let loop ((prefix #f))
- (let* ((start (xstring-input-state/buffer-start state))
- (b (xstring-input-state/buffer state))
- (si (- (xstring-input-state/position state) start))
- (ei (- (xstring-input-state/buffer-end state) start))
+ (let* ((start (istate-buffer-start state))
+ (b (istate-buffer state))
+ (si (- (istate-position state) start))
+ (ei (- (istate-buffer-end state) start))
(index (substring-find-next-char-in-set b si ei delimiters)))
(if index
(begin
- (set-xstring-input-state/position! state (+ start index))
+ (set-istate-position! state (+ start index))
(let ((s (make-string (fix:- index si))))
(substring-move! b si index s 0)
- (if prefix (string-append prefix s) s)))
+ (if prefix
+ (string-append prefix s)
+ s)))
(begin
- (set-xstring-input-state/position!
- state
- (xstring-input-state/buffer-end state))
+ (set-istate-position! state (istate-buffer-end state))
(let ((s (make-string (fix:- ei si))))
(substring-move! b si ei s 0)
- (let ((p (if prefix (string-append prefix s) s)))
+ (let ((p
+ (if prefix
+ (string-append prefix s)
+ s)))
(if (read-xstring-buffer state)
(loop p)
p)))))))
(make-eof-object port))))
-\f
+
(define xstring-input-type
(make-port-type
- (let ((read
- (lambda (port discard?)
- (let ((state (port/state port)))
- (let ((position (xstring-input-state/position state)))
- (if (or (< position (xstring-input-state/buffer-end state))
- (read-xstring-buffer state))
- (let ((char
- (string-ref
- (xstring-input-state/buffer state)
- (- position
- (xstring-input-state/buffer-start state)))))
- (if discard?
- (set-xstring-input-state/position!
- state (+ position 1)))
- char)
- (make-eof-object port))))))
- (xlength
- (lambda (state)
- (external-string-length (xstring-input-state/xstring state)))))
- `((READ-CHAR ,(lambda (port) (read port #t)))
- (PEEK-CHAR ,(lambda (port) (read port #f)))
- (DISCARD-CHAR
- ,(lambda (port)
- (let* ((state (port/state port))
- (position (xstring-input-state/position state)))
- (if (< position (xlength state))
- (set-xstring-input-state/position! state (+ position 1))))))
- (DISCARD-CHARS ,xstring-input-port/discard-chars)
- (READ-STRING ,xstring-input-port/read-string)
- (LENGTH ,(lambda (port) (xlength (port/state port))))
- (EOF?
- ,(lambda (port)
- (let ((state (port/state port)))
- (>= (xstring-input-state/position state) (xlength state)))))
- (CLOSE
- ,(lambda (port)
- (let ((state (port/state port)))
- (without-interrupts
- (lambda ()
- (set-xstring-input-state/xstring! state #f)
- (set-xstring-input-state/position! state 0)
- (set-xstring-input-state/buffer-start! state 0)
- (set-xstring-input-state/buffer-end! state 0))))))))
+ `((READ-CHAR
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (let ((position (istate-position state)))
+ (if (or (< position (istate-buffer-end state))
+ (read-xstring-buffer state))
+ (let ((char
+ (string-ref (istate-buffer state)
+ (- position (istate-buffer-start state)))))
+ (set-istate-position! state (+ position 1))
+ char)
+ (make-eof-object port))))))
+ (EOF?
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (>= (istate-position state)
+ (external-string-length (istate-xstring state))))))
+ (CLOSE
+ ,(lambda (port)
+ (let ((state (port/state port)))
+ (without-interrupts
+ (lambda ()
+ (set-istate-xstring! state #f)
+ (set-istate-position! state 0)
+ (set-istate-buffer-start! state 0)
+ (set-istate-buffer-end! state 0)))))))
#f))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: matcher.scm,v 1.32 2003/02/14 18:28:35 cph Exp $
+$Id: matcher.scm,v 1.33 2004/02/16 05:46:41 cph Exp $
-Copyright 2001, 2002 Massachusetts Institute of Technology
+Copyright 2001,2002,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
,(protect char-set free-names)))
(define-atomic-matcher (alphabet alphabet)
- `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* ,(protect alphabet free-names)))
+ `(MATCH-PARSER-BUFFER-CHAR-IN-ALPHABET ,*buffer-name*
+ ,(protect alphabet free-names)))
(define-atomic-matcher (string string)
`(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,(protect string free-names)))
#| -*-Scheme-*-
-$Id: xml-names.scm,v 1.1 2003/09/26 03:56:48 cph Exp $
+$Id: xml-names.scm,v 1.2 2004/02/16 05:50:37 cph Exp $
-Copyright 2003 Massachusetts Institute of Technology
+Copyright 2003,2004 Massachusetts Institute of Technology
This file is part of MIT/GNU Scheme.
(eq? (string-is-xml-nmtoken? string) 'NAME))
(define (string-is-xml-nmtoken? string)
- (let ((buffer (string->parser-buffer string)))
+ (let ((buffer
+ (wide-string->parser-buffer (utf8-string->wide-string string))))
(let ((check-char
(lambda ()
- (match-utf8-char-in-alphabet buffer alphabet:name-subsequent))))
+ (match-parser-buffer-char-in-alphabet buffer
+ alphabet:name-subsequent))))
(letrec
((no-colon
(lambda ()
(and (check-char)
(nmtoken?))
'NMTOKEN))))
- (if (match-utf8-char-in-alphabet buffer alphabet:name-initial)
+ (if (match-parser-buffer-char-in-alphabet buffer alphabet:name-initial)
(no-colon)
(and (check-char)
(nmtoken?)))))))
#| -*-Scheme-*-
-$Id: xml-parser.scm,v 1.53 2004/01/11 05:25:57 cph Exp $
+$Id: xml-parser.scm,v 1.54 2004/02/16 05:50:43 cph Exp $
Copyright 2001,2002,2003,2004 Massachusetts Institute of Technology
(lambda (end)
(match-parser-buffer-string-no-advance buffer end)))
#t)
- ((match-utf8-char-in-alphabet buffer alphabet)
+ ((match-parser-buffer-char-in-alphabet buffer alphabet)
(loop))
(must-match?
(let ((p (get-parser-buffer-pointer buffer))
(define parse-notation-name (simple-name-parser "notation"))
(define (match-name buffer)
- (and (match-utf8-char-in-alphabet buffer alphabet:name-initial)
+ (and (match-parser-buffer-char-in-alphabet buffer alphabet:name-initial)
(let loop ()
- (if (match-utf8-char-in-alphabet buffer alphabet:name-subsequent)
+ (if (match-parser-buffer-char-in-alphabet buffer
+ alphabet:name-subsequent)
(loop)
#t))))
(map make-xml-nmtoken (match match-name-token)))))
(define (match-name-token buffer)
- (and (match-utf8-char-in-alphabet buffer alphabet:name-subsequent)
+ (and (match-parser-buffer-char-in-alphabet buffer alphabet:name-subsequent)
(let loop ()
- (if (match-utf8-char-in-alphabet buffer alphabet:name-subsequent)
+ (if (match-parser-buffer-char-in-alphabet buffer
+ alphabet:name-subsequent)
(loop)
#t))))
\f
projects / mit-scheme.git / commitdiff