From: Chris Hanson Date: Wed, 11 Jan 2017 07:47:05 +0000 (-0800) Subject: A huge round of name normalizations and some simplifications. X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~154 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3af25d10a98778ff81b5e68c144b6ef8e01e8de0;p=mit-scheme.git A huge round of name normalizations and some simplifications. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index edf3e0191..f16024d6d 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -120,11 +120,12 @@ USA. ucode-primitive ucode-type) (import (runtime port) - generic-port-operation:write-substring - make-port-type - make-port - port/input-channel - port/output-channel) + (make-port make-textual-port) + (make-port-type make-textual-port-type) + (port/input-channel input-port-channel) + (port/output-channel output-port-channel) + (port/state textual-port-state) + generic-port-operation:write-substring) (export (edwin class-macros) class-instance-transforms) (export () diff --git a/src/runtime/dosprm.scm b/src/runtime/dosprm.scm index c75bd7316..38691a968 100644 --- a/src/runtime/dosprm.scm +++ b/src/runtime/dosprm.scm @@ -391,7 +391,7 @@ USA. (and entry (cdr entry))) (let ((filename (generate-fat-init-file short-base))) - (let ((channel (port/output-channel port))) + (let ((channel (output-port-channel port))) (channel-file-set-position channel (channel-file-length channel))) diff --git a/src/runtime/dosproc.scm b/src/runtime/dosproc.scm index b9b46411f..7f3c7f7ce 100644 --- a/src/runtime/dosproc.scm +++ b/src/runtime/dosproc.scm @@ -52,7 +52,7 @@ USA. (lambda (port*) (recvr (channel-descriptor - (port/output-channel port*))))))) + (output-port-channel port*))))))) (call-with-input-file fname (lambda (input) (let ((string (read-string (char-set) input))) @@ -72,7 +72,7 @@ USA. (lambda (port*) (recvr (channel-descriptor - (port/input-channel port*)))))))) + (input-port-channel port*)))))))) (define (with-output-channel in out) (cond ((default-object? stderr) @@ -81,7 +81,7 @@ USA. (run in out -1)) ((not (output-port? stderr)) (error "run: stderr not an output port" stderr)) - ((port/output-channel stderr) + ((output-port-channel stderr) => (lambda (channel) (output-port/flush-output stderr) @@ -103,7 +103,7 @@ USA. (with-output-channel in -1)) ((not (output-port? stdout)) (error "run: stdout not an output port" stdout)) - ((port/output-channel stdout) + ((output-port-channel stdout) => (lambda (channel) (output-port/flush-output stdout) @@ -118,7 +118,7 @@ USA. (with-input-channel -1)) ((not (input-port? stdin)) (error "run: stdin not an input port" stdin)) - ((port/input-channel stdin) + ((input-port-channel stdin) => (lambda (channel) (with-input-channel (channel-descriptor channel)))) (else diff --git a/src/runtime/emacs.scm b/src/runtime/emacs.scm index b085e504e..ece60c73c 100644 --- a/src/runtime/emacs.scm +++ b/src/runtime/emacs.scm @@ -178,13 +178,13 @@ USA. (define (emacs/gc-start port) (output-port/flush-output port) - (cwb (port/output-channel port) "\033b" 0 2)) + (cwb (output-port-channel port) "\033b" 0 2)) (define (emacs/gc-finish port) - (cwb (port/output-channel port) "\033e" 0 2)) + (cwb (output-port-channel port) "\033e" 0 2)) (define (transmit-signal port type) - (let ((channel (port/output-channel port)) + (let ((channel (output-port-channel port)) (buffer (string #\altmode type))) (output-port/flush-output port) (with-absolutely-no-interrupts @@ -192,7 +192,7 @@ USA. (cwb channel buffer 0 2))))) (define (transmit-signal-with-argument port type string) - (let ((channel (port/output-channel port)) + (let ((channel (output-port-channel port)) (length (string-length string))) (let ((buffer-length (+ length 3))) (let ((buffer (make-string buffer-length))) @@ -229,7 +229,7 @@ USA. (define (initialize-package!) (set! vanilla-console-port-type (textual-port-type the-console-port)) (set! emacs-console-port-type - (make-port-type + (make-textual-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) @@ -267,4 +267,4 @@ USA. vanilla-console-port-type))) (define (deferred-operation name) - (port-type/operation vanilla-console-port-type name)) \ No newline at end of file + (textual-port-type-operation vanilla-console-port-type name)) \ No newline at end of file diff --git a/src/runtime/fileio.scm b/src/runtime/fileio.scm index 6e2d3a588..237bb506c 100644 --- a/src/runtime/fileio.scm +++ b/src/runtime/fileio.scm @@ -40,8 +40,8 @@ USA. (WRITE-SELF ,operation/write-self)))) (let ((make-type (lambda (source sink) - (make-port-type other-operations - (generic-i/o-port-type source sink))))) + (make-textual-port-type other-operations + (generic-i/o-port-type source sink))))) (set! input-file-type (make-type 'CHANNEL #f)) (set! output-file-type (make-type #f 'CHANNEL)) (set! i/o-file-type (make-type 'CHANNEL 'CHANNEL)))) @@ -54,8 +54,8 @@ USA. (define (operation/length port) (channel-file-length - (or (port/input-channel port) - (port/output-channel port)))) + (or (input-port-channel port) + (output-port-channel port)))) (define (operation/write-self port output-port) (write-string " for file: " output-port) @@ -67,9 +67,9 @@ USA. (flush-output port)) (if (input-port? port) (let ((input-buffer (port-input-buffer port))) - (- (channel-file-position (port/input-channel port)) + (- (channel-file-position (input-port-channel port)) (input-buffer-free-bytes input-buffer))) - (channel-file-position (port/output-channel port)))) + (channel-file-position (output-port-channel port)))) (define (operation/set-position! port position) (guarantee-positionable-port port 'OPERATION/SET-POSITION!) @@ -79,14 +79,14 @@ USA. (if (input-port? port) (clear-input-buffer (port-input-buffer port))) (channel-file-set-position (if (input-port? port) - (port/input-channel port) - (port/output-channel port)) + (input-port-channel port) + (output-port-channel port)) position)) (define (guarantee-positionable-port port caller) (guarantee-port port caller) (if (and (i/o-port? port) - (not (eq? (port/input-channel port) (port/output-channel port)))) + (not (eq? (input-port-channel port) (output-port-channel port)))) (error:bad-range-argument port caller)) (if (and (input-port? port) (not (input-buffer-using-binary-normalizer? diff --git a/src/runtime/genio.scm b/src/runtime/genio.scm index 8c21cd7e0..dab58a15e 100644 --- a/src/runtime/genio.scm +++ b/src/runtime/genio.scm @@ -34,11 +34,12 @@ USA. (if (not (or source sink)) (error "Missing arguments.")) (let ((port - (make-port (if (default-object? type) - (generic-i/o-port-type (source-type source) - (sink-type sink)) - type) - (apply make-gstate source sink 'TEXT 'TEXT extra-state)))) + (make-textual-port (if (default-object? type) + (generic-i/o-port-type (source-type source) + (sink-type sink)) + type) + (apply make-gstate source sink 'TEXT 'TEXT + extra-state)))) (let ((ib (port-input-buffer port))) (if ib ((source/set-port (input-buffer-source ib)) port))) @@ -96,15 +97,15 @@ USA. (list->vector extra))) (define-integrable (port-input-buffer port) - (gstate-input-buffer (port/state port))) + (gstate-input-buffer (textual-port-state port))) (define-integrable (port-output-buffer port) - (gstate-output-buffer (port/state port))) + (gstate-output-buffer (textual-port-state port))) (define (generic-i/o-port-accessor index) (guarantee-index-fixnum index 'GENERIC-I/O-PORT-ACCESSOR) (lambda (port) - (let ((extra (gstate-extra (port/state port)))) + (let ((extra (gstate-extra (textual-port-state port)))) (if (not (fix:< index (vector-length extra))) (error "Accessor index out of range:" index)) (vector-ref extra index)))) @@ -112,7 +113,7 @@ USA. (define (generic-i/o-port-modifier index) (guarantee-index-fixnum index 'GENERIC-I/O-PORT-MODIFIER) (lambda (port object) - (let ((extra (gstate-extra (port/state port)))) + (let ((extra (gstate-extra (textual-port-state port)))) (if (not (fix:< index (vector-length extra))) (error "Accessor index out of range:" index)) (vector-set! extra index object)))) @@ -165,9 +166,9 @@ USA. (WRITE-SELF ,generic-io/write-self)))) (let ((make-type (lambda ops - (make-port-type (append (apply append ops) - other-operations) - #f)))) + (make-textual-port-type (append (apply append ops) + other-operations) + #f)))) (set! generic-type00 (make-type)) (set! generic-type10 (make-type ops:in1)) (set! generic-type20 (make-type ops:in1 ops:in2)) @@ -417,10 +418,10 @@ USA. #t) (define (generic-io/coding port) - (gstate-coding (port/state port))) + (gstate-coding (textual-port-state port))) (define (generic-io/set-coding port name) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((ib (gstate-input-buffer state))) (if ib (set-input-buffer-coding! ib name))) @@ -442,10 +443,10 @@ USA. (else '()))) (define (generic-io/line-ending port) - (gstate-line-ending (port/state port))) + (gstate-line-ending (textual-port-state port))) (define (generic-io/set-line-ending port name) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((ib (gstate-input-buffer state))) (if ib (set-input-buffer-line-ending! diff --git a/src/runtime/intrpt.scm b/src/runtime/intrpt.scm index 92837f9de..796c2824f 100644 --- a/src/runtime/intrpt.scm +++ b/src/runtime/intrpt.scm @@ -190,7 +190,8 @@ USA. cmdl-interrupt/abort-nearest)) (define (signal-interrupt hook/interrupt hook/clean-input char interrupt) - (let ((thread (thread-mutex-owner (port/thread-mutex console-i/o-port)))) + (let ((thread + (thread-mutex-owner (textual-port-thread-mutex console-i/o-port)))) (if thread (signal-thread-event thread (lambda () diff --git a/src/runtime/mime-codec.scm b/src/runtime/mime-codec.scm index 60dcc7627..469cae7d0 100644 --- a/src/runtime/mime-codec.scm +++ b/src/runtime/mime-codec.scm @@ -29,22 +29,22 @@ USA. (declare (usual-integrations)) (define (make-decoding-port-type update finalize) - (make-port-type + (make-textual-port-type `((WRITE-CHAR ,(lambda (port char) (guarantee-8-bit-char char) - (update (port/state port) (string char) 0 1) + (update (textual-port-state port) (string char) 0 1) 1)) (WRITE-SUBSTRING ,(lambda (port string start end) (if (string? string) (begin - (update (port/state port) string start end) + (update (textual-port-state port) string start end) (fix:- end start)) (generic-port-operation:write-substring port string start end)))) (CLOSE-OUTPUT ,(lambda (port) - (finalize (port/state port))))) + (finalize (textual-port-state port))))) #f)) (define condition-type:decode-mime @@ -227,7 +227,7 @@ USA. v))) (define (make-decode-quoted-printable-port port text?) - (make-port decode-quoted-printable-port-type + (make-textual-port decode-quoted-printable-port-type (decode-quoted-printable:initialize port text?))) (define decode-quoted-printable-port-type @@ -528,7 +528,8 @@ USA. v))) (define (make-decode-base64-port port text?) - (make-port decode-base64-port-type (decode-base64:initialize port text?))) + (make-textual-port decode-base64-port-type + (decode-base64:initialize port text?))) (define decode-base64-port-type (make-decoding-port-type decode-base64:update decode-base64:finalize)) @@ -671,8 +672,8 @@ USA. v))) (define (make-decode-binhex40-port port text?) - (make-port decode-binhex40-port-type - (decode-binhex40:initialize port text?))) + (make-textual-port decode-binhex40-port-type + (decode-binhex40:initialize port text?))) (define decode-binhex40-port-type (make-decoding-port-type decode-binhex40:update decode-binhex40:finalize)) @@ -788,15 +789,15 @@ USA. ;;;; BinHex 4.0 run-length decoding (define (make-binhex40-run-length-decoding-port port) - (make-port binhex40-run-length-decoding-port-type - (make-binhex40-rld-state port))) + (make-textual-port binhex40-run-length-decoding-port-type + (make-binhex40-rld-state port))) (define binhex40-run-length-decoding-port-type - (make-port-type + (make-textual-port-type `((WRITE-CHAR ,(lambda (port char) (guarantee-8-bit-char char) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((port (binhex40-rld-state/port state)) (char* (binhex40-rld-state/char state))) (cond ((binhex40-rld-state/marker-seen? state) @@ -819,7 +820,7 @@ USA. 1)) (CLOSE-OUTPUT ,(lambda (port) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((port (binhex40-rld-state/port state)) (char* (binhex40-rld-state/char state))) (if char* @@ -846,15 +847,15 @@ USA. ;;;; BinHex 4.0 deconstruction (define (make-binhex40-deconstructing-port port) - (make-port binhex40-deconstructing-port-type - (make-binhex40-decon port))) + (make-textual-port binhex40-deconstructing-port-type + (make-binhex40-decon port))) (define binhex40-deconstructing-port-type - (make-port-type + (make-textual-port-type `((WRITE-CHAR ,(lambda (port char) (guarantee-8-bit-char char) - (case (binhex40-decon/state (port/state port)) + (case (binhex40-decon/state (textual-port-state port)) ((READING-HEADER) (binhex40-decon-reading-header port char)) ((COPYING-DATA) (binhex40-decon-copying-data port char)) ((SKIPPING-TAIL) (binhex40-decon-skipping-tail port)) @@ -863,12 +864,13 @@ USA. 1)) (CLOSE-OUTPUT ,(lambda (port) - (if (not (eq? (binhex40-decon/state (port/state port)) 'FINISHED)) + (if (not (eq? (binhex40-decon/state (textual-port-state port)) + 'FINISHED)) (error:decode-binhex40 "Premature EOF in BinHex 4.0 stream."))))) #f)) (define (binhex40-decon-reading-header port char) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((index (binhex40-decon/index state))) (if (fix:= index 0) (begin @@ -888,7 +890,7 @@ USA. (set-binhex40-decon/state! state 'COPYING-DATA))))))))) (define (binhex40-decon-copying-data port char) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (write-char char (binhex40-decon/port state)) (let ((index (+ (binhex40-decon/index state) 1))) (if (< index (binhex40-decon/data-length state)) @@ -903,7 +905,7 @@ USA. (set-binhex40-decon/state! state 'SKIPPING-TAIL)))))) (define (binhex40-decon-skipping-tail port) - (let ((state (port/state port))) + (let ((state (textual-port-state port))) (let ((index (+ (binhex40-decon/index state) 1))) (set-binhex40-decon/index! state index) (if (>= index (binhex40-decon/data-length state)) @@ -1061,7 +1063,7 @@ USA. v))) (define (make-decode-uue-port port text?) - (make-port decode-uue-port-type (decode-uue:initialize port text?))) + (make-textual-port decode-uue-port-type (decode-uue:initialize port text?))) (define decode-uue-port-type (make-decoding-port-type decode-uue:update decode-uue:finalize)) diff --git a/src/runtime/ntprm.scm b/src/runtime/ntprm.scm index d59e33089..48f2b2d8d 100644 --- a/src/runtime/ntprm.scm +++ b/src/runtime/ntprm.scm @@ -448,7 +448,7 @@ USA. (and entry (cdr entry))) (let ((filename (generate-fat-init-file short-base))) - (let ((channel (port/output-channel port))) + (let ((channel (output-port-channel port))) (channel-file-set-position channel (channel-file-length channel))) diff --git a/src/runtime/output.scm b/src/runtime/output.scm index da3f34820..ddbef5586 100644 --- a/src/runtime/output.scm +++ b/src/runtime/output.scm @@ -321,8 +321,9 @@ USA. (define (call-with-truncated-output-port limit port generator) (call-with-current-continuation (lambda (k) - (let ((port (make-port truncated-output-type - (make-tstate port limit k 0)))) + (let ((port + (make-textual-port truncated-output-type + (make-tstate port limit k 0)))) (generator port) #f)))) @@ -333,7 +334,7 @@ USA. count) (define (trunc-out/write-char port char) - (let ((ts (port/state port))) + (let ((ts (textual-port-state port))) (if (< (tstate-count ts) (tstate-limit ts)) (begin (set-tstate-count! ts (+ (tstate-count ts) 1)) @@ -341,17 +342,17 @@ USA. ((tstate-continuation ts) #t)))) (define (trunc-out/flush-output port) - (output-port/flush-output (tstate-port (port/state port)))) + (output-port/flush-output (tstate-port (textual-port-state port)))) (define (trunc-out/discretionary-flush-output port) - (output-port/discretionary-flush (tstate-port (port/state port)))) + (output-port/discretionary-flush (tstate-port (textual-port-state port)))) (define truncated-output-type) (define (initialize-package!) (set! truncated-output-type - (make-port-type `((WRITE-CHAR ,trunc-out/write-char) - (FLUSH-OUTPUT ,trunc-out/flush-output) - (DISCRETIONARY-FLUSH-OUTPUT - ,trunc-out/discretionary-flush-output)) - #f)) + (make-textual-port-type `((WRITE-CHAR ,trunc-out/write-char) + (FLUSH-OUTPUT ,trunc-out/flush-output) + (DISCRETIONARY-FLUSH-OUTPUT + ,trunc-out/discretionary-flush-output)) + #f)) unspecific) \ No newline at end of file diff --git a/src/runtime/parse.scm b/src/runtime/parse.scm index 0b0395627..315fa726b 100644 --- a/src/runtime/parse.scm +++ b/src/runtime/parse.scm @@ -975,7 +975,7 @@ USA. ;; Check the port property list for the name, and then the ;; environment. This way a port can override the default. (let* ((nope "no-overridden-value") - (v (port/get-property port name nope))) + (v (textual-port-property port name nope))) (if (eq? v nope) default-value v))) @@ -1011,7 +1011,9 @@ USA. (if file-attribute-alist (begin ;; Disable further attributes parsing. - (port/set-property! port '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?* #f) + (set-textual-port-property! port + '*PARSER-ENABLE-FILE-ATTRIBUTES-PARSING?* + #f) (process-keyword-attribute file-attribute-alist port) (process-mode-attribute file-attribute-alist port) (process-studly-case-attribute file-attribute-alist port)))) @@ -1030,13 +1032,15 @@ USA. (cond ((and (symbol? value) (or (string-ci=? (symbol-name value) "none") (string-ci=? (symbol-name value) "false"))) - (port/set-property! port '*PARSER-KEYWORD-STYLE* #f)) + (set-textual-port-property! port '*PARSER-KEYWORD-STYLE* #f)) ((and (symbol? value) (string-ci=? (symbol-name value) "prefix")) - (port/set-property! port '*PARSER-KEYWORD-STYLE* 'PREFIX)) + (set-textual-port-property! port '*PARSER-KEYWORD-STYLE* + 'PREFIX)) ((and (symbol? value) (string-ci=? (symbol-name value) "suffix")) - (port/set-property! port '*PARSER-KEYWORD-STYLE* 'SUFFIX)) + (set-textual-port-property! port '*PARSER-KEYWORD-STYLE* + 'SUFFIX)) (else (warn "Unrecognized value for keyword-style" value))))))) @@ -1075,14 +1079,15 @@ USA. (warn "Attribute value mismatch. Expected True.") #f) (else - (port/set-property! + (set-textual-port-property! port '*PARSER-CANONICALIZE-SYMBOLS?* #f)))) ((or (not value) (and (symbol? value) (string-ci=? (symbol-name value) "false"))) - (port/set-property! port '*PARSER-CANONICALIZE-SYMBOLS?* #t)) + (set-textual-port-property! port + '*PARSER-CANONICALIZE-SYMBOLS?* + #t)) (else (warn "Unrecognized value for sTuDly-case" value))))))) - (define-syntax define-parse-error (sc-macro-transformer diff --git a/src/runtime/port.scm b/src/runtime/port.scm index 6a8ed7b37..95155ce28 100644 --- a/src/runtime/port.scm +++ b/src/runtime/port.scm @@ -29,124 +29,80 @@ USA. (declare (usual-integrations)) -;;;; Port type +;;;; Textual port types (define-record-type - (%make-port-type parent - standard-operations - custom-operations - char-ready? - read-char - unread-char - peek-char - read-substring - write-char - write-substring - fresh-line - line-start? - flush-output - discretionary-flush-output) - port-type? - (parent port-type/parent) - (standard-operations port-type/standard-operations - set-port-type/standard-operations!) - (custom-operations port-type/custom-operations - set-port-type/custom-operations!) + (%make-textual-port-type operations + char-ready? + read-char + unread-char + peek-char + read-substring + write-char + write-substring + fresh-line + line-start? + flush-output + discretionary-flush-output) + textual-port-type? + (operations %port-type-operations) ;; input operations: - (char-ready? port-type/char-ready?) - (read-char port-type/read-char) - (unread-char port-type/unread-char) - (peek-char port-type/peek-char) - (read-substring port-type/read-substring) + (char-ready? port-type-operation:char-ready?) + (read-char port-type-operation:read-char) + (unread-char port-type-operation:unread-char) + (peek-char port-type-operation:peek-char) + (read-substring port-type-operation:read-substring) ;; output operations: - (write-char port-type/write-char) - (write-substring port-type/write-substring) - (fresh-line port-type/fresh-line) - (line-start? port-type/line-start?) - (flush-output port-type/flush-output) - (discretionary-flush-output port-type/discretionary-flush-output)) + (write-char port-type-operation:write-char) + (write-substring port-type-operation:write-substring) + (fresh-line port-type-operation:fresh-line) + (line-start? port-type-operation:line-start?) + (flush-output port-type-operation:flush-output) + (discretionary-flush-output port-type-operation:discretionary-flush-output)) (set-record-type-unparser-method! (standard-unparser-method (lambda (type) - (if (port-type/supports-input? type) - (if (port-type/supports-output? type) + (if (port-type-supports-input? type) + (if (port-type-supports-output? type) 'TEXTUAL-I/O-PORT-TYPE 'TEXTUAL-INPUT-PORT-TYPE) - (if (port-type/supports-output? type) + (if (port-type-supports-output? type) 'TEXTUAL-OUTPUT-PORT-TYPE 'TEXTUAL-PORT-TYPE))) #f)) -(define (guarantee-port-type object #!optional caller) - (if (not (port-type? object)) - (error:not-port-type object caller)) - object) +(define (port-type-supports-input? type) + (port-type-operation:read-char type)) -(define (error:not-port-type object #!optional caller) - (error:wrong-type-argument object "port type" caller)) - -(define-integrable (port-type/supports-input? type) - (port-type/read-char type)) - -(define-integrable (port-type/supports-output? type) - (port-type/write-char type)) - -(define (input-port-type? object) - (and (port-type? object) - (port-type/supports-input? object) - #t)) +(define (port-type-supports-output? type) + (port-type-operation:write-char type)) -(define (output-port-type? object) - (and (port-type? object) - (port-type/supports-output? object) - #t)) +(define (port-type-operation-names type) + (map car (%port-type-operations type))) -(define (i/o-port-type? object) - (and (port-type? object) - (port-type/supports-input? object) - (port-type/supports-output? object) - #t)) +(define (textual-port-type-operations type) + (map (lambda (entry) + (list (car entry) (cdr entry))) + (%port-type-operations type))) -(define (port-type/operation-names type) - (guarantee-port-type type 'PORT-TYPE/OPERATION-NAMES) - (append (map car (port-type/standard-operations type)) - (map car (port-type/custom-operations type)))) - -(define (port-type/operations type) - (guarantee-port-type type 'PORT-TYPE/OPERATIONS) - (append! (map (lambda (entry) - (list (car entry) (cdr entry))) - (port-type/standard-operations type)) - (map (lambda (entry) - (list (car entry) (cdr entry))) - (port-type/custom-operations type)))) - -(define (port-type/operation type name) - (let ((entry - (or (assq name (port-type/custom-operations type)) - (assq name (port-type/standard-operations type))))) +(define (textual-port-type-operation type name) + (let ((entry (assq name (%port-type-operations type)))) (and entry (cdr entry)))) ;;;; Constructors -(define (make-port-type operations parent-type) - (if (not (list-of-type? operations - (lambda (elt) - (and (pair? elt) - (symbol? (car elt)) - (pair? (cdr elt)) - (procedure? (cadr elt)) - (null? (cddr elt)))))) - (error:wrong-type-argument operations "operations list" 'MAKE-PORT-TYPE)) +(define (make-textual-port-type operations parent-type) + (guarantee-list-of textual-port-type-operation? operations + 'make-textual-port-type) (if parent-type - (guarantee-port-type parent-type 'MAKE-PORT-TYPE)) + (guarantee textual-port-type? parent-type 'make-textual-port-type)) (receive (standard-operations custom-operations) (parse-operations-list operations parent-type) (let ((op - (let ((input? (assq 'READ-CHAR standard-operations)) - (output? (assq 'WRITE-CHAR standard-operations)) + (let ((input? (assq 'read-char standard-operations)) + (output? (assq 'write-char standard-operations)) (cond-op (lambda (flag mapper) (if flag @@ -160,26 +116,35 @@ USA. (let ((p (assq name standard-operations))) (and p (cdr p))))))))))) - (%make-port-type parent-type - standard-operations - custom-operations - (op 'CHAR-READY?) - (op 'READ-CHAR) - (op 'UNREAD-CHAR) - (op 'PEEK-CHAR) - (op 'READ-SUBSTRING) - (op 'WRITE-CHAR) - (op 'WRITE-SUBSTRING) - (op 'FRESH-LINE) - (op 'LINE-START?) - (op 'FLUSH-OUTPUT) - (op 'DISCRETIONARY-FLUSH-OUTPUT))))) + (%make-textual-port-type (append custom-operations standard-operations) + (op 'char-ready?) + (op 'read-char) + (op 'unread-char) + (op 'peek-char) + (op 'read-substring) + (op 'write-char) + (op 'write-substring) + (op 'fresh-line) + (op 'line-start?) + (op 'flush-output) + (op 'discretionary-flush-output))))) + +(define (textual-port-type-operation? object) + (and (pair? object) + (symbol? (car object)) + (pair? (cdr object)) + (procedure? (cadr object)) + (null? (cddr object)))) + +(add-boot-init! + (lambda () + (register-predicate! textual-port-type-operation? 'port-type-operation))) (define (parse-operations-list operations parent-type) (parse-operations-list-1 (if parent-type (append operations - (delete-matching-items (port-type/operations parent-type) + (delete-matching-items (textual-port-type-operations parent-type) (let ((excluded (append (if (assq 'READ-CHAR operations) @@ -399,36 +364,36 @@ USA. ;;;; Textual ports (define-record-type - (%make-textual-port type state thread-mutex unread? previous properties + (%make-textual-port thread-mutex type state unread? previous properties transcript) textual-port? + (thread-mutex textual-port-thread-mutex) (type textual-port-type set-textual-port-type!) (state textual-port-state set-textual-port-state!) - (thread-mutex textual-port-thread-mutex set-textual-port-thread-mutex!) (unread? textual-port-unread? set-textual-port-unread?!) (previous textual-port-previous set-textual-port-previous!) (properties textual-port-properties set-textual-port-properties!) (transcript textual-port-transcript set-textual-port-transcript!)) -(define (make-port type state) - (guarantee-port-type type 'MAKE-PORT) - (%make-textual-port type state (make-thread-mutex) #f #f '() #f)) +(define (make-textual-port type state) + (guarantee textual-port-type? type 'MAKE-TEXTUAL-PORT) + (%make-textual-port (make-thread-mutex) type state #f #f '() #f)) (define (textual-input-port? object) (and (textual-port? object) - (port-type/supports-input? (port/type object)) + (port-type-supports-input? (textual-port-type object)) #t)) (define (textual-output-port? object) (and (textual-port? object) - (port-type/supports-output? (port/type object)) + (port-type-supports-output? (textual-port-type object)) #t)) (define (textual-i/o-port? object) (and (textual-port? object) - (let ((type (port/type object))) - (and (port-type/supports-input? type) - (port-type/supports-output? type) + (let ((type (textual-port-type object))) + (and (port-type-supports-input? type) + (port-type-supports-output? type) #t)))) (add-boot-init! @@ -440,38 +405,6 @@ USA. (register-predicate! textual-i/o-port? 'textual-i/o-port '<= textual-port?))) -(define (port=? p1 p2) - (guarantee-port p1 'PORT=?) - (guarantee-port p2 'PORT=?) - (eq? p1 p2)) - -(define (textual-port-operation-names port) - (port-type/operation-names (port/type port))) - -(define (textual-port-operation port name) - (guarantee textual-port? port 'textual-port-operation) - (port-type/operation (port/type port) name)) - -(define-syntax define-port-operation - (sc-macro-transformer - (lambda (form environment) - (let ((name (cadr form))) - `(DEFINE (,(symbol-append 'TEXTUAL-PORT-OPERATION/ name) PORT) - (,(close-syntax (symbol-append 'PORT-TYPE/ name) environment) - (PORT/TYPE PORT))))))) - -(define-port-operation char-ready?) -(define-port-operation read-char) -(define-port-operation unread-char) -(define-port-operation peek-char) -(define-port-operation read-substring) -(define-port-operation write-char) -(define-port-operation write-substring) -(define-port-operation fresh-line) -(define-port-operation line-start?) -(define-port-operation flush-output) -(define-port-operation discretionary-flush-output) - (set-record-type-unparser-method! (standard-unparser-method (lambda (port) @@ -483,13 +416,7 @@ USA. (cond ((textual-port-operation port 'WRITE-SELF) => (lambda (operation) (operation port output-port))))))) - -(define (port/copy port state) - (let ((port (copy-record port))) - (set-textual-port-state! port state) - (set-textual-port-thread-mutex! port (make-thread-mutex)) - port)) - + (define (close-textual-port port) (let ((close (textual-port-operation port 'CLOSE))) (if close @@ -508,7 +435,7 @@ USA. (if close-output (close-output port)))) -(define (port/open? port) +(define (textual-port-open? port) (let ((open? (textual-port-operation port 'OPEN?))) (if open? (open? port) @@ -541,23 +468,49 @@ USA. (and operation (operation port)))) -(define (port/get-property port name default) - (guarantee-symbol name 'PORT/GET-PROPERTY) +(define (textual-port-operation-names port) + (port-type-operation-names (textual-port-type port))) + +(define (textual-port-operation port name) + (textual-port-type-operation (textual-port-type port) name)) + +(define-syntax define-port-operation + (sc-macro-transformer + (lambda (form environment) + (let ((name (cadr form))) + `(DEFINE (,(symbol 'TEXTUAL-PORT-OPERATION/ name) PORT) + (,(close-syntax (symbol 'PORT-TYPE-OPERATION: name) environment) + (TEXTUAL-PORT-TYPE PORT))))))) + +(define-port-operation char-ready?) +(define-port-operation read-char) +(define-port-operation unread-char) +(define-port-operation peek-char) +(define-port-operation read-substring) +(define-port-operation write-char) +(define-port-operation write-substring) +(define-port-operation fresh-line) +(define-port-operation line-start?) +(define-port-operation flush-output) +(define-port-operation discretionary-flush-output) + +(define (textual-port-property port name default) + (guarantee symbol? name 'port-property) (let ((p (assq name (textual-port-properties port)))) (if p (cdr p) default))) -(define (port/set-property! port name value) - (guarantee-symbol name 'PORT/SET-PROPERTY!) +(define (set-textual-port-property! port name value) + (guarantee symbol? name 'set-port-property!) (let ((alist (textual-port-properties port))) (let ((p (assq name alist))) (if p (set-cdr! p value) (set-textual-port-properties! port (cons (cons name value) alist)))))) -(define (port/intern-property! port name get-value) - (guarantee-symbol name 'PORT/INTERN-PROPERTY!) +(define (intern-textual-port-property! port name get-value) + (guarantee symbol? name 'INTERN-PORT-PROPERTY!) (let ((alist (textual-port-properties port))) (let ((p (assq name alist))) (if p @@ -566,8 +519,8 @@ USA. (set-textual-port-properties! port (cons (cons name value) alist)) value))))) -(define (port/remove-property! port name) - (guarantee-symbol name 'PORT/REMOVE-PROPERTY!) +(define (remove-textual-port-property! port name) + (guarantee symbol? name 'REMOVE-PORT-PROPERTY!) (set-textual-port-properties! port (del-assq! name (textual-port-properties port)))) @@ -591,7 +544,7 @@ USA. (let ((tport (textual-port-transcript port))) (if tport (output-port/discretionary-flush tport)))) - + (define (port/supports-coding? port) (let ((operation (textual-port-operation port 'SUPPORTS-CODING?))) (if operation @@ -702,13 +655,13 @@ USA. (if (and read-mode write-mode (read-mode port)) (let ((outside-mode)) (dynamic-wind (lambda () - (if (port/open? port) + (if (textual-port-open? port) (begin (set! outside-mode (read-mode port)) (write-mode port mode)))) thunk (lambda () - (if (port/open? port) + (if (textual-port-open? port) (begin (set! mode (read-mode port)) (write-mode port outside-mode)))))) @@ -777,17 +730,17 @@ USA. (define interaction-i/o-port) (add-boot-init! (lambda () - (set! current-input-port (make-port-parameter guarantee-input-port)) - (set! current-output-port (make-port-parameter guarantee-output-port)) - (set! notification-output-port (make-port-parameter guarantee-output-port)) - (set! trace-output-port (make-port-parameter guarantee-output-port)) - (set! interaction-i/o-port (make-port-parameter guarantee-i/o-port)) + (set! current-input-port (make-port-parameter input-port?)) + (set! current-output-port (make-port-parameter output-port?)) + (set! notification-output-port (make-port-parameter output-port?)) + (set! trace-output-port (make-port-parameter output-port?)) + (set! interaction-i/o-port (make-port-parameter i/o-port?)) unspecific)) -(define (make-port-parameter guarantee) +(define (make-port-parameter predicate) (make-general-parameter #f (lambda (port) - (if port (guarantee port)) + (if port (guarantee predicate port)) port) default-parameter-merger (lambda (port) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index e0230eb45..9bb98fe77 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -149,7 +149,7 @@ USA. (with-create-thread-continuation continuation (lambda () ((cmdl/driver cmdl) cmdl)))))))))))))))) - (mutex (port/thread-mutex port))) + (mutex (textual-port-thread-mutex port))) (let ((thread (current-thread)) (owner (thread-mutex-owner mutex))) (cond ((and owner (not (eq? thread owner))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index bd271647b..bf746950b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2474,25 +2474,21 @@ USA. (export () ;; BEGIN legacy bindings (port/input-blocking-mode input-port-blocking-mode) - (port/input-channel input-port-channel) (port/input-terminal-mode input-port-terminal-mode) + (port/open? textual-port-open?) (port/operation textual-port-operation) (port/operation-names textual-port-operation-names) (port/output-blocking-mode output-port-blocking-mode) - (port/output-channel output-port-channel) (port/output-terminal-mode output-port-terminal-mode) (port/set-input-blocking-mode set-input-port-blocking-mode!) (port/set-input-terminal-mode set-input-port-terminal-mode!) (port/set-output-blocking-mode set-output-port-blocking-mode!) (port/set-output-terminal-mode set-output-port-terminal-mode!) - (port/state textual-port-state) - (port/thread-mutex textual-port-thread-mutex) (port/type textual-port-type) (port/with-input-blocking-mode with-input-port-blocking-mode) (port/with-input-terminal-mode with-input-port-terminal-mode) (port/with-output-blocking-mode with-output-port-blocking-mode) (port/with-output-terminal-mode with-output-port-terminal-mode) - (set-port/state! set-textual-port-state!) ;; END legacy bindings close-input-port close-output-port @@ -2505,36 +2501,27 @@ USA. guarantee-port i/o-port? input-port-blocking-mode - input-port-channel input-port-open? input-port-terminal-mode input-port? interaction-i/o-port + intern-textual-port-property! notification-output-port output-port-blocking-mode - output-port-channel output-port-open? output-port-terminal-mode output-port? port/coding - port/copy - port/get-property - port/intern-property! port/known-coding? port/known-codings port/known-line-ending? port/known-line-endings port/line-ending - port/open? - textual-port-operation - textual-port-operation-names - port/remove-property! port/set-coding port/set-line-ending - port/set-property! port/supports-coding? - port=? port? + remove-textual-port-property! set-current-input-port! set-current-output-port! set-input-port-blocking-mode! @@ -2543,7 +2530,13 @@ USA. set-notification-output-port! set-output-port-blocking-mode! set-output-port-terminal-mode! + set-textual-port-property! set-trace-output-port! + textual-port-open? + textual-port-operation + textual-port-operation-names + textual-port-property + textual-port-thread-mutex textual-port? trace-output-port with-input-from-port @@ -2556,11 +2549,10 @@ USA. with-output-to-port with-trace-output-port) (export (runtime) - (port/input-channel textual-input-port-channel) - (port/output-channel textual-output-port-channel) - generic-port-operation:write-substring - make-port - make-port-type + input-port-channel + make-textual-port + make-textual-port-type + output-port-channel set-textual-port-state! textual-port-state) (export (runtime input-port) @@ -2585,11 +2577,12 @@ USA. (export (runtime transcript) set-textual-port-transcript! textual-port-transcript) + (export (runtime mime-codec) + generic-port-operation:write-substring) (export (runtime emacs-interface) - port-type/operation - set-textual-port-thread-mutex! set-textual-port-type! - textual-port-type) + textual-port-type + textual-port-type-operation) (initialization (initialize-package!))) (define-package (runtime input-port) diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index 6a35b62e0..ff6d226c6 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -150,22 +150,22 @@ USA. (define socket-port-type) (define (initialize-package!) (set! socket-port-type - (make-port-type `((CLOSE-INPUT ,socket/close-input) - (CLOSE-OUTPUT ,socket/close-output)) - (generic-i/o-port-type 'CHANNEL 'CHANNEL))) + (make-textual-port-type `((CLOSE-INPUT ,socket/close-input) + (CLOSE-OUTPUT ,socket/close-output)) + (generic-i/o-port-type 'CHANNEL 'CHANNEL))) unspecific) (define (socket/close-input port) (if (port/open? port) ((ucode-primitive shutdown-socket 2) - (channel-descriptor (port/input-channel port)) + (channel-descriptor (input-port-channel port)) 1)) (generic-io/close-input port)) (define (socket/close-output port) (if (port/open? port) ((ucode-primitive shutdown-socket 2) - (channel-descriptor (port/input-channel port)) + (channel-descriptor (input-port-channel port)) 2)) (generic-io/close-output port)) diff --git a/src/runtime/stringio.scm b/src/runtime/stringio.scm index 5959f3ee7..be3a189bd 100644 --- a/src/runtime/stringio.scm +++ b/src/runtime/stringio.scm @@ -43,14 +43,14 @@ USA. (receive (start end) (check-index-limits start end (string-length string) 'OPEN-INPUT-STRING) - (make-port narrow-input-type - (make-internal-input-state string start end)))) + (make-textual-port narrow-input-type + (make-internal-input-state string start end)))) ((wide-string? string) (receive (start end) (check-index-limits start end (wide-string-length string) 'OPEN-INPUT-STRING) - (make-port wide-input-type - (make-internal-input-state string start end)))) + (make-textual-port wide-input-type + (make-internal-input-state string start end)))) (else (error:not-string string 'OPEN-INPUT-STRING)))) @@ -73,14 +73,14 @@ USA. end))) (define (make-string-in-type peek-char read-char unread-char) - (make-port-type `((CHAR-READY? ,string-in/char-ready?) - (EOF? ,internal-in/eof?) - (PEEK-CHAR ,peek-char) - (READ-CHAR ,read-char) - (READ-SUBSTRING ,internal-in/read-substring) - (UNREAD-CHAR ,unread-char) - (WRITE-SELF ,string-in/write-self)) - #f)) + (make-textual-port-type `((CHAR-READY? ,string-in/char-ready?) + (EOF? ,internal-in/eof?) + (PEEK-CHAR ,peek-char) + (READ-CHAR ,read-char) + (READ-SUBSTRING ,internal-in/read-substring) + (UNREAD-CHAR ,unread-char) + (WRITE-SELF ,string-in/write-self)) + #f)) (define (make-internal-input-state string start end) (make-iistate string start end start)) @@ -100,11 +100,11 @@ USA. (write-string " from string" output-port)) (define (internal-in/eof? port) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (not (fix:< (iistate-next ss) (iistate-end ss))))) (define (internal-in/read-substring port string start end) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (let ((n (move-chars! (iistate-string ss) (iistate-next ss) (iistate-end ss) string start end))) @@ -117,13 +117,13 @@ USA. narrow-in/unread-char)) (define (narrow-in/peek-char port) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (fix:< (iistate-next ss) (iistate-end ss)) (string-ref (iistate-string ss) (iistate-next ss)) (make-eof-object port)))) (define (narrow-in/read-char port) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (fix:< (iistate-next ss) (iistate-end ss)) (let ((char (string-ref (iistate-string ss) (iistate-next ss)))) (set-iistate-next! ss (fix:+ (iistate-next ss) 1)) @@ -131,7 +131,7 @@ USA. (make-eof-object port)))) (define (narrow-in/unread-char port char) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (not (fix:< (iistate-start ss) (iistate-next ss))) (error "No char to unread:" port)) (let ((prev (fix:- (iistate-next ss) 1))) @@ -145,13 +145,13 @@ USA. wide-in/unread-char)) (define (wide-in/peek-char port) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (fix:< (iistate-next ss) (iistate-end ss)) (wide-string-ref (iistate-string ss) (iistate-next ss)) (make-eof-object port)))) (define (wide-in/read-char port) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (fix:< (iistate-next ss) (iistate-end ss)) (let ((char (wide-string-ref (iistate-string ss) (iistate-next ss)))) (set-iistate-next! ss (fix:+ (iistate-next ss) 1)) @@ -159,7 +159,7 @@ USA. (make-eof-object port)))) (define (wide-in/unread-char port char) - (let ((ss (port/state port))) + (let ((ss (textual-port-state port))) (if (not (fix:< (iistate-start ss) (iistate-next ss))) (error "No char to unread:" port)) (let ((prev (fix:- (iistate-next ss) 1))) @@ -262,19 +262,20 @@ USA. n))))) (define (make-octets-input-type) - (make-port-type `((WRITE-SELF - ,(lambda (port output-port) - port - (write-string " from byte vector" output-port)))) - (generic-i/o-port-type #t #f))) + (make-textual-port-type + `((WRITE-SELF + ,(lambda (port output-port) + port + (write-string " from byte vector" output-port)))) + (generic-i/o-port-type #t #f))) ;;;; Output as characters (define (open-narrow-output-string) - (make-port narrow-output-type (make-ostate (make-string 16) 0 0))) + (make-textual-port narrow-output-type (make-ostate (make-string 16) 0 0))) (define (open-wide-output-string) - (make-port wide-output-type (make-ostate (make-wide-string 16) 0 0))) + (make-textual-port wide-output-type (make-ostate (make-wide-string 16) 0 0))) (define (get-output-string port) ((port/operation port 'EXTRACT-OUTPUT) port)) @@ -315,7 +316,7 @@ USA. (define (narrow-out/write-char port char) (if (not (fix:< (char->integer char) #x100)) (error:not-8-bit-char char)) - (let ((os (port/state port))) + (let ((os (textual-port-state port))) (maybe-grow-buffer os 1) (string-set! (ostate-buffer os) (ostate-index os) char) (set-ostate-index! os (fix:+ (ostate-index os) 1)) @@ -323,11 +324,11 @@ USA. 1)) (define (narrow-out/extract-output port) - (let ((os (port/state port))) + (let ((os (textual-port-state port))) (string-head (ostate-buffer os) (ostate-index os)))) (define (narrow-out/extract-output! port) - (let* ((os (port/state port)) + (let* ((os (textual-port-state port)) (output (string-head! (ostate-buffer os) (ostate-index os)))) (reset-buffer! os) output)) @@ -338,7 +339,7 @@ USA. wide-out/extract-output!)) (define (wide-out/write-char port char) - (let ((os (port/state port))) + (let ((os (textual-port-state port))) (maybe-grow-buffer os 1) (wide-string-set! (ostate-buffer os) (ostate-index os) char) (set-ostate-index! os (fix:+ (ostate-index os) 1)) @@ -346,24 +347,24 @@ USA. 1)) (define (wide-out/extract-output port) - (let ((os (port/state port))) + (let ((os (textual-port-state port))) (wide-substring (ostate-buffer os) 0 (ostate-index os)))) (define (wide-out/extract-output! port) - (let ((os (port/state port))) + (let ((os (textual-port-state port))) (let ((output (wide-substring (ostate-buffer os) 0 (ostate-index os)))) (reset-buffer! os) output))) (define (make-string-out-type write-char extract-output extract-output!) - (make-port-type `((WRITE-CHAR ,write-char) - (WRITE-SUBSTRING ,string-out/write-substring) - (EXTRACT-OUTPUT ,extract-output) - (EXTRACT-OUTPUT! ,extract-output!) - (OUTPUT-COLUMN ,string-out/output-column) - (POSITION ,string-out/position) - (WRITE-SELF ,string-out/write-self)) - #f)) + (make-textual-port-type `((WRITE-CHAR ,write-char) + (WRITE-SUBSTRING ,string-out/write-substring) + (EXTRACT-OUTPUT ,extract-output) + (EXTRACT-OUTPUT! ,extract-output!) + (OUTPUT-COLUMN ,string-out/output-column) + (POSITION ,string-out/position) + (WRITE-SELF ,string-out/write-self)) + #f)) (define-structure ostate buffer @@ -371,17 +372,17 @@ USA. column) (define (string-out/output-column port) - (ostate-column (port/state port))) + (ostate-column (textual-port-state port))) (define (string-out/position port) - (ostate-index (port/state port))) + (ostate-index (textual-port-state port))) (define (string-out/write-self port output-port) port (write-string " to string" output-port)) (define (string-out/write-substring port string start end) - (let ((os (port/state port)) + (let ((os (textual-port-state port)) (n (- end start))) (maybe-grow-buffer os n) (let* ((start* (ostate-index os)) @@ -494,11 +495,11 @@ USA. (fix:- end start)))))) (define (make-octets-output-type) - (make-port-type `((EXTRACT-OUTPUT ,octets-out/extract-output) - (EXTRACT-OUTPUT! ,octets-out/extract-output!) - (POSITION ,octets-out/position) - (WRITE-SELF ,octets-out/write-self)) - (generic-i/o-port-type #f #t))) + (make-textual-port-type `((EXTRACT-OUTPUT ,octets-out/extract-output) + (EXTRACT-OUTPUT! ,octets-out/extract-output!) + (POSITION ,octets-out/position) + (WRITE-SELF ,octets-out/write-self)) + (generic-i/o-port-type #f #t))) (define (octets-out/extract-output port) (output-port/flush-output port) diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 967a5a2b0..175e19525 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -303,7 +303,7 @@ USA. (eval sexp (buffer-env))))))) (define (with-output-to-repl socket thunk) - (let ((p (make-port repl-port-type socket))) + (let ((p (make-textual-port repl-port-type socket))) (dynamic-wind (lambda () unspecific) (lambda () (with-output-to-port p thunk)) @@ -316,17 +316,17 @@ USA. (set! *index* (make-unsettable-parameter unspecific)) (set! *buffer-pstring* (make-unsettable-parameter unspecific)) (set! repl-port-type - (make-port-type + (make-textual-port-type `((WRITE-CHAR ,(lambda (port char) (write-message `(:write-string ,(string char)) - (port/state port)) + (textual-port-state port)) 1)) (WRITE-SUBSTRING ,(lambda (port string start end) (if (< start end) (write-message `(:write-string ,(substring string start end)) - (port/state port))) + (textual-port-state port))) (- end start)))) #f)) unspecific) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index adbe37782..13e32e45c 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -268,7 +268,7 @@ USA. ((not return?) (run-first-thread))))) (define (console-thread) - (thread-mutex-owner (port/thread-mutex console-i/o-port))) + (thread-mutex-owner (textual-port-thread-mutex console-i/o-port))) (define (other-running-threads?) (thread/next (current-thread))) diff --git a/src/runtime/ttyio.scm b/src/runtime/ttyio.scm index 76fa8e321..36de538b6 100644 --- a/src/runtime/ttyio.scm +++ b/src/runtime/ttyio.scm @@ -34,7 +34,7 @@ USA. (output-channel (tty-output-channel)) (gtype (generic-i/o-port-type 'CHANNEL 'CHANNEL))) (let ((type - (make-port-type + (make-textual-port-type `((BEEP ,operation/beep) (CHAR-READY? ,generic-io/char-ready?) (CLEAR ,operation/clear) @@ -48,7 +48,9 @@ USA. (X-SIZE ,operation/x-size) (Y-SIZE ,operation/y-size)) gtype))) - (let ((port (make-port type (make-cstate input-channel output-channel)))) + (let ((port + (make-textual-port type + (make-cstate input-channel output-channel)))) (set-channel-port! input-channel port) (set-channel-port! output-channel port) (set! the-console-port port) @@ -68,8 +70,8 @@ USA. (define (reset-console) (let ((input-channel (tty-input-channel)) (output-channel (tty-output-channel))) - (set-port/state! the-console-port - (make-cstate input-channel output-channel)) + (set-textual-port-state! the-console-port + (make-cstate input-channel output-channel)) (let ((s ((ucode-primitive reload-retrieve-string 0)))) (if s (set-input-buffer-contents! (port-input-buffer the-console-port) @@ -93,7 +95,7 @@ USA. unspecific) (define (console-i/o-port? port) - (port=? port console-i/o-port)) + (eqv? port console-i/o-port)) (define the-console-port) (define console-i/o-port) diff --git a/src/runtime/usrint.scm b/src/runtime/usrint.scm index 4ef359dbd..e588cd9d8 100644 --- a/src/runtime/usrint.scm +++ b/src/runtime/usrint.scm @@ -440,26 +440,26 @@ USA. (newline port))))))) (define (wrap-notification-port port) - (make-port wrapped-notification-port-type port)) + (make-textual-port wrapped-notification-port-type port)) (define (make-wrapped-notification-port-type) - (make-port-type `((WRITE-CHAR ,operation/write-char) - (X-SIZE ,operation/x-size) - (COLUMN ,operation/column) - (FLUSH-OUTPUT ,operation/flush-output) - (DISCRETIONARY-FLUSH-OUTPUT - ,operation/discretionary-flush-output)) - #f)) + (make-textual-port-type `((WRITE-CHAR ,operation/write-char) + (X-SIZE ,operation/x-size) + (COLUMN ,operation/column) + (FLUSH-OUTPUT ,operation/flush-output) + (DISCRETIONARY-FLUSH-OUTPUT + ,operation/discretionary-flush-output)) + #f)) (define (operation/write-char port char) - (let ((port* (port/state port))) + (let ((port* (textual-port-state port))) (let ((n (output-port/write-char port* char))) (if (char=? char #\newline) (write-notification-prefix port*)) n))) (define (operation/x-size port) - (let ((port* (port/state port))) + (let ((port* (textual-port-state port))) (let ((op (port/operation port* 'X-SIZE))) (and op (let ((n (op port*))) @@ -468,7 +468,7 @@ USA. 0))))))) (define (operation/column port) - (let ((port* (port/state port))) + (let ((port* (textual-port-state port))) (let ((op (port/operation port* 'COLUMN))) (and op (let ((n (op port*))) @@ -477,10 +477,10 @@ USA. 0))))))) (define (operation/flush-output port) - (output-port/flush-output (port/state port))) + (output-port/flush-output (textual-port-state port))) (define (operation/discretionary-flush-output port) - (output-port/discretionary-flush (port/state port))) + (output-port/discretionary-flush (textual-port-state port))) (define (write-notification-prefix port) (write-string ";" port) diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm index d27b32af0..77ab1e384 100644 --- a/src/xml/rdf-struct.scm +++ b/src/xml/rdf-struct.scm @@ -185,10 +185,8 @@ USA. (define (with-rdf-input-port port thunk) (fluid-let ((*rdf-bnode-registry* - (or (port/get-property port 'RDF-BNODE-REGISTRY #f) - (let ((table (make-string-hash-table))) - (port/set-property! port 'RDF-BNODE-REGISTRY table) - table)))) + (intern-textual-port-property! port 'RDF-BNODE-REGISTRY + make-string-hash-table))) (thunk))) (define *rdf-bnode-registry*) @@ -416,9 +414,9 @@ USA. (if registry (begin (guarantee-rdf-prefix-registry registry 'PORT/SET-RDF-PREFIX-REGISTRY!) - (port/set-property! port 'RDF-PREFIX-REGISTRY registry)) - (port/remove-property! port 'RDF-PREFIX-REGISTRY))) + (set-textual-port-property! port 'RDF-PREFIX-REGISTRY registry)) + (remove-textual-port-property! port 'RDF-PREFIX-REGISTRY))) (define (port/rdf-prefix-registry port) - (or (port/get-property port 'RDF-PREFIX-REGISTRY #f) + (or (textual-port-property port 'RDF-PREFIX-REGISTRY #f) *default-rdf-prefix-registry*)) \ No newline at end of file