From: Chris Hanson Date: Mon, 16 Feb 2004 05:50:43 +0000 (+0000) Subject: Changes required by reimplementation of I/O subsystem. X-Git-Tag: 20090517-FFI~1693 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f0942bf0676a7ee57cffb22b843923a789dcf571;p=mit-scheme.git Changes required by reimplementation of I/O subsystem. --- diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 93672c148..4f902fa01 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -1301,14 +1301,12 @@ Prefix argument means do not kill the debugger buffer." 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 @@ -1346,7 +1344,6 @@ Prefix argument means do not kill the debugger 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) diff --git a/v7/src/edwin/bufinp.scm b/v7/src/edwin/bufinp.scm index fc0cf5d79..1c63073dc 100644 --- a/v7/src/edwin/bufinp.scm +++ b/v7/src/edwin/bufinp.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -32,107 +32,62 @@ USA. (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))))) - -(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 diff --git a/v7/src/edwin/bufout.scm b/v7/src/edwin/bufout.scm index be4e16957..322fe6339 100644 --- a/v7/src/edwin/bufout.scm +++ b/v7/src/edwin/bufout.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -67,18 +68,18 @@ USA. (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))) @@ -89,9 +90,8 @@ USA. (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 diff --git a/v7/src/edwin/debug.scm b/v7/src/edwin/debug.scm index 6bf3a604b..709f781e5 100644 --- a/v7/src/edwin/debug.scm +++ b/v7/src/edwin/debug.scm @@ -1,9 +1,10 @@ #| -*-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. @@ -477,18 +478,24 @@ USA. 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?) @@ -1773,24 +1780,4 @@ once it has been renamed, it will not be deleted automatically.") (string-length separator)))) (lambda () (write value))) port))))) - (debugger-newline port))) - -;;;; 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 diff --git a/v7/src/edwin/debuge.scm b/v7/src/edwin/debuge.scm index acf3cd719..d3c82a321 100644 --- a/v7/src/edwin/debuge.scm +++ b/v7/src/edwin/debuge.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -62,9 +63,8 @@ USA. (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) diff --git a/v7/src/edwin/dosfile.scm b/v7/src/edwin/dosfile.scm index 81d993fd4..95c783176 100644 --- a/v7/src/edwin/dosfile.scm +++ b/v7/src/edwin/dosfile.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -536,8 +537,7 @@ filename suffix \".gz\"." (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)) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index d00379315..310928619 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -510,21 +510,25 @@ TRANSCRIPT messages appear in transcript buffer, if it is enabled; 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))) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 0e3ff09b8..ecb7ac26f 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,10 +1,10 @@ #| -*-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. @@ -104,12 +104,6 @@ USA. (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) diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 4fd697599..9ca43932f 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,10 +1,10 @@ #| -*-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. @@ -198,11 +198,9 @@ of the predicates is satisfied, the file is written in the usual way." (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 \"" @@ -214,44 +212,37 @@ of the predicates is satisfied, the file is written in the usual way." 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))))) ;;;; Buffer Mode Initialization @@ -642,7 +633,6 @@ Otherwise, a message is written both before and after long file writes." (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 @@ -668,9 +658,9 @@ Otherwise, a message is written both before and after long file writes." (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)) @@ -689,28 +679,19 @@ Otherwise, a message is written both before and after long file writes." ;; the operating system after the channel is closed. filename)) -(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 diff --git a/v7/src/edwin/intmod.scm b/v7/src/edwin/intmod.scm index d2bd8ec2e..688c825dc 100644 --- a/v7/src/edwin/intmod.scm +++ b/v7/src/edwin/intmod.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -854,15 +854,13 @@ If this is an error, the debugger examines the error condition." ;;; 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! @@ -958,9 +956,6 @@ If this is an error, the debugger examines the error condition." ;;; 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)) @@ -1120,7 +1115,6 @@ If this is an error, the debugger examines the error condition." (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) @@ -1132,7 +1126,6 @@ If this is an error, the debugger examines the error condition." (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) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 271ffd277..e40ea22be 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -40,4 +40,4 @@ USA. (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 diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index dbf7c52c5..52d120729 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,9 +1,9 @@ #| -*-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. @@ -577,35 +577,14 @@ after the listing is made.)" (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)))) diff --git a/v7/src/edwin/tterm.scm b/v7/src/edwin/tterm.scm index d3e85669e..ef56c565a 100644 --- a/v7/src/edwin/tterm.scm +++ b/v7/src/edwin/tterm.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -96,8 +96,8 @@ USA. (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))) @@ -517,7 +517,7 @@ USA. 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) diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index 9110c52e4..666998686 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,9 +1,10 @@ #| -*-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. @@ -401,8 +402,7 @@ of the filename suffixes \".gz\", \".bz2\", or \".Z\"." (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)) diff --git a/v7/src/edwin/winout.scm b/v7/src/edwin/winout.scm index b2d1b2961..5b8b5f7d1 100644 --- a/v7/src/edwin/winout.scm +++ b/v7/src/edwin/winout.scm @@ -1,8 +1,9 @@ #| -*-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. @@ -37,11 +38,8 @@ USA. (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))) @@ -98,15 +96,14 @@ USA. (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 diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm index 46ccee0a0..787badd56 100644 --- a/v7/src/imail/imail-imap.scm +++ b/v7/src/imail/imail-imap.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -1741,17 +1741,17 @@ USA. (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))))))))) diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm index d93a8c26c..f93d21dcf 100644 --- a/v7/src/imail/imail-util.scm +++ b/v7/src/imail/imail-util.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -431,37 +431,37 @@ USA. (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))))) @@ -472,98 +472,80 @@ USA. (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)))) - + (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 diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm index de24028c4..07de51b97 100644 --- a/v7/src/star-parser/matcher.scm +++ b/v7/src/star-parser/matcher.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -291,7 +291,8 @@ USA. ,(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))) diff --git a/v7/src/xml/xml-names.scm b/v7/src/xml/xml-names.scm index 064cc21b2..0b3bedcd6 100644 --- a/v7/src/xml/xml-names.scm +++ b/v7/src/xml/xml-names.scm @@ -1,8 +1,8 @@ #| -*-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. @@ -105,10 +105,12 @@ USA. (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 () @@ -132,7 +134,7 @@ USA. (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?))))))) diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm index 555700a83..f33051040 100644 --- a/v7/src/xml/xml-parser.scm +++ b/v7/src/xml/xml-parser.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -362,7 +362,7 @@ USA. (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)) @@ -427,9 +427,10 @@ USA. (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)))) @@ -439,9 +440,10 @@ USA. (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))))