STANDARD-UNPARSER-METHOD rather than UNPARSER/STANDARD-METHOD.
* Rewrite instances of PRINT-SELF using WRITE-SELF. Rewrite instances
of UNPARSER/STANDARD-METHOD using STANDARD-UNPARSER-METHOD.
#| -*-Scheme-*-
-$Id: defstr.scm,v 14.24 1993/03/17 04:04:25 cph Exp $
+$Id: defstr.scm,v 14.25 1993/10/21 14:52:32 cph Exp $
Copyright (c) 1988-93 Massachusetts Institute of Technology
((eq? type 'RECORD)
false)
(else
- `(,(absolute 'UNPARSER/STANDARD-METHOD)
- ',name))))
+ `(,(absolute 'STANDARD-UNPARSER-METHOD)
+ ',name
+ #F))))
type
named?
(and named? type-name)
#| -*-Scheme-*-
-$Id: emacs.scm,v 14.18 1993/10/18 22:50:03 cph Exp $
+$Id: emacs.scm,v 14.19 1993/10/21 14:52:34 cph Exp $
Copyright (c) 1988-93 Massachusetts Institute of Technology
(define (emacs/read-finish port)
(port/read-finish the-console-port)
(transmit-signal port #\f))
-
-(define (emacs/print-self state port)
- port
- (unparse-string state "for emacs"))
\f
;;;; Protocol Encoding
#| -*-Scheme-*-
-$Id: error.scm,v 14.37 1993/10/21 12:14:16 cph Exp $
+$Id: error.scm,v 14.38 1993/10/21 14:52:34 cph Exp $
Copyright (c) 1988-93 Massachusetts Institute of Technology
(constructor %make-condition-type
(name field-indexes number-of-fields reporter))
(print-procedure
- (unparser/standard-method 'CONDITION-TYPE
- (lambda (state type)
- (unparse-string state (%condition-type/name type))))))
+ (standard-unparser-method 'CONDITION-TYPE
+ (lambda (type port)
+ (write-char #\space port)
+ (write-string (%condition-type/name type) port)))))
(name false read-only true)
generalizations
(field-indexes false read-only true)
(conc-name %condition/)
(constructor %make-condition (type continuation restarts))
(print-procedure
- (unparser/standard-method 'CONDITION
- (lambda (state condition)
- (unparse-string state
- (%condition-type/name
- (%condition/type condition)))))))
+ (standard-unparser-method 'CONDITION
+ (lambda (condition port)
+ (write-char #\space port)
+ (write-string
+ (%condition-type/name (%condition/type condition))
+ port)))))
(type false read-only true)
(continuation false read-only true)
(restarts false read-only true)
(conc-name %restart/)
(constructor %make-restart (name reporter effector))
(print-procedure
- (unparser/standard-method 'RESTART
- (lambda (state restart)
+ (standard-unparser-method 'RESTART
+ (lambda (restart port)
+ (write-char #\space port)
(let ((name (%restart/name restart)))
(if name
- (unparse-object state name)
- (unparse-string state "(anonymous)")))))))
+ (write name port)
+ (write-string "(anonymous)" port)))))))
(name false read-only true)
(reporter false read-only true)
(effector false read-only true)
#| -*-Scheme-*-
-$Id: fileio.scm,v 1.6 1993/10/21 11:49:43 cph Exp $
+$Id: fileio.scm,v 1.7 1993/10/21 14:52:36 cph Exp $
Copyright (c) 1991-1993 Massachusetts Institute of Technology
(other-operations
`((CLOSE ,operation/close)
(PATHNAME ,operation/pathname)
- (PRINT-SELF ,operation/print-self)
+ (WRITE-SELF ,operation/write-self)
(TRUENAME ,operation/truename))))
(set! input-file-template
(make-input-port (append input-operations
;; determine the truename.
operation/pathname)
-(define (operation/print-self unparser-state port)
- (unparse-string unparser-state "for file: ")
- (unparse-object unparser-state (operation/truename port)))
+(define (operation/write-self port output-port)
+ (write-string " for file: " output-port)
+ (write (operation/truename port) output-port))
(define (operation/rest->string port)
;; This operation's intended purpose is to snarf an entire file in
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/genio.scm,v 1.2 1991/11/26 07:06:12 cph Exp $
+$Id: genio.scm,v 1.3 1993/10/21 14:52:37 cph Exp $
-Copyright (c) 1991 Massachusetts Institute of Technology
+Copyright (c) 1991-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(WRITE-SUBSTRING ,operation/write-substring)))
(other-operations
`((CLOSE ,operation/close)
- (PRINT-SELF ,operation/print-self))))
+ (WRITE-SELF ,operation/write-self))))
(set! generic-input-template
(make-input-port (append input-operations
other-operations)
(define-integrable (port/output-buffer port)
(vector-ref (port/state port) 1))
-(define (operation/print-self unparser-state port)
+(define (operation/write-self port output-port)
(cond ((i/o-port? port)
- (unparse-string unparser-state "for channels: ")
- (unparse-object unparser-state (operation/input-channel port))
- (unparse-string unparser-state " ")
- (unparse-object unparser-state (operation/output-channel port)))
+ (write-string " for channels: " output-port)
+ (write (operation/input-channel port) output-port)
+ (write-string " " output-port)
+ (write (operation/output-channel port) output-port))
((input-port? port)
- (unparse-string unparser-state "for channel: ")
- (unparse-object unparser-state (operation/input-channel port)))
+ (write-string " for channel: " output-port)
+ (write (operation/input-channel port) output-port))
((output-port? port)
- (unparse-string unparser-state "for channel: ")
- (unparse-object unparser-state (operation/output-channel port)))
+ (write-string " for channel: " output-port)
+ (write (operation/output-channel port) output-port))
(else
- (unparse-string unparser-state "for channel"))))
+ (write-string " for channel" output-port))))
\f
(define (operation/char-ready? port interval)
(input-buffer/char-ready? (port/input-buffer port) interval))
#| -*-Scheme-*-
-$Id: packag.scm,v 14.17 1993/10/21 11:49:48 cph Exp $
+$Id: packag.scm,v 14.18 1993/10/21 14:52:37 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(for-each loop (package/children package)))
(set-record-type-unparser-method!
rtd
- (unparser/standard-method 'PACKAGE
- (lambda (state package)
- (unparse-object state (package/name package)))))))
+ (standard-unparser-method 'PACKAGE
+ (lambda (package port)
+ (write-char #\space port)
+ (write (package/name package) port))))))
\f
(define (package/child package name)
(let loop ((children (package/children package)))
#| -*-Scheme-*-
-$Id: pathnm.scm,v 14.26 1993/01/29 00:07:22 adams Exp $
+$Id: pathnm.scm,v 14.27 1993/10/21 14:52:38 cph Exp $
Copyright (c) 1988-1993 Massachusetts Institute of Technology
(constructor %make-pathname)
(conc-name %pathname-)
(print-procedure
- (unparser/standard-method 'PATHNAME
- (lambda (state pathname)
- (unparse-object state (->namestring pathname))))))
+ (standard-unparser-method 'PATHNAME
+ (lambda (pathname port)
+ (write-char #\space port)
+ (write (->namestring pathname) port)))))
(host false read-only true)
(device false read-only true)
(directory false read-only true)
(let ((pathname (->pathname pathname)))
((host-operation/end-of-file-marker/output (%pathname-host pathname))
pathname)))
-
+\f
(define (pathname=? x y)
(let ((x (->pathname x))
(y (->pathname y)))
(define (pathname-simplify pathname)
(let ((pathname (->pathname pathname)))
((host-operation/pathname-simplify (%pathname-host pathname)) pathname)))
-\f
+
(define (directory-pathname pathname)
(let ((pathname (->pathname pathname)))
(%make-pathname (%pathname-host pathname)
(let ((pathname (->pathname pathname)))
((host-operation/directory-pathname-as-file (%pathname-host pathname))
pathname)))
-
+\f
(define (pathname-new-device pathname device)
(let ((pathname (->pathname pathname)))
(%make-pathname (%pathname-host pathname)
(define (guarantee-host host operation)
(if (not (host? host)) (error:wrong-type-argument host "host" operation))
host)
-
+\f
(define (host-operation/parse-namestring host)
(host-type/operation/parse-namestring (host/type host)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/poplat.scm,v 14.2 1988/06/13 11:49:48 cph Rel $
+$Id: poplat.scm,v 14.3 1993/10/21 14:52:39 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! population-tag
- (unparser/standard-method 'POPULATION)))
+ (standard-unparser-method 'POPULATION #f)))
(define bogus-false '(BOGUS-FALSE))
(define population-tag '(POPULATION))
#| -*-Scheme-*-
-$Id: port.scm,v 1.6 1993/10/21 12:14:18 cph Exp $
+$Id: port.scm,v 1.7 1993/10/21 14:52:40 cph Exp $
Copyright (c) 1991-93 Massachusetts Institute of Technology
(set-record-type-unparser-method! port-rtd
(lambda (state port)
- ((unparser/standard-method
- (cond ((i/o-port? port) 'I/O-PORT)
- ((input-port? port) 'INPUT-PORT)
- ((output-port? port) 'OUTPUT-PORT)
- (else 'PORT))
- (port/operation port 'PRINT-SELF))
+ ((let ((name
+ (cond ((i/o-port? port) 'I/O-PORT)
+ ((input-port? port) 'INPUT-PORT)
+ ((output-port? port) 'OUTPUT-PORT)
+ (else 'PORT))))
+ (cond ((port/operation port 'WRITE-SELF)
+ => (lambda (operation)
+ (standard-unparser-method name operation)))
+ ((port/operation port 'PRINT-SELF)
+ => (lambda (operation)
+ (unparser/standard-method name operation)))
+ (else
+ (standard-unparser-method name #f))))
state
port)))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/prop1d.scm,v 14.4 1989/09/15 17:16:35 jinx Rel $
+$Id: prop1d.scm,v 14.5 1993/10/21 14:52:41 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! 1d-table-tag
- (unparser/standard-method '1D-TABLE)))
+ (standard-unparser-method '1D-TABLE #f)))
(define population-of-1d-tables)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strnin.scm,v 14.3 1990/11/09 08:44:34 cph Rel $
+$Id: strnin.scm,v 14.4 1993/10/21 14:52:41 cph Exp $
-Copyright (c) 1988, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(DISCARD-CHAR ,operation/discard-char)
(DISCARD-CHARS ,operation/discard-chars)
(PEEK-CHAR ,operation/peek-char)
- (PRINT-SELF ,operation/print-self)
+ (WRITE-SELF ,operation/write-self)
(READ-CHAR ,operation/read-char)
(READ-STRING ,operation/read-string))
false)))
(with-input-from-port (string->input-port string) thunk))
(define (string->input-port string #!optional start end)
- (input-port/copy input-string-template
- (make-input-string-state
- string
- (if (default-object? start) 0 start)
- (if (default-object? end) (string-length string) end))))
+ (let ((end
+ (if (default-object? end)
+ (string-length string)
+ (check-index end (string-length string) 'STRING->INPUT-PORT))))
+ (input-port/copy
+ input-string-template
+ (make-input-string-state string
+ (if (default-object? start)
+ 0
+ (check-index start end 'STRING->INPUT-PORT))
+ end))))
+
+(define (check-index index limit procedure)
+ (if (not (exact-nonnegative-integer? index))
+ (error:wrong-type-argument index "exact non-negative integer" procedure))
+ (if (not (<= index limit))
+ (error:bad-range-argument index procedure))
+ index)
(define input-string-template)
\f
(define (operation/char-ready? port interval)
interval
- (< (input-port/start port) (input-port/end port)))
+ (fix:< (input-port/start port) (input-port/end port)))
(define (operation/peek-char port)
- (if (< (input-port/start port) (input-port/end port))
+ (if (fix:< (input-port/start port) (input-port/end port))
(string-ref (input-port/string port) (input-port/start port))
(make-eof-object port)))
(define (operation/discard-char port)
- (set-input-port/start! port (1+ (input-port/start port))))
+ (set-input-port/start! port (fix:+ (input-port/start port) 1)))
(define (operation/read-char port)
(let ((start (input-port/start port)))
- (if (< start (input-port/end port))
+ (if (fix:< start (input-port/end port))
(begin
- (set-input-port/start! port (1+ start))
+ (set-input-port/start! port (fix:+ start 1))
(string-ref (input-port/string port) start))
(make-eof-object port))))
(define (operation/read-string port delimiters)
(let ((start (input-port/start port))
(end (input-port/end port)))
- (if (< start end)
+ (if (fix:< start end)
(let ((string (input-port/string port)))
(let ((index
(or (substring-find-next-char-in-set string
(define (operation/discard-chars port delimiters)
(let ((start (input-port/start port))
(end (input-port/end port)))
- (if (< start end)
+ (if (fix:< start end)
(set-input-port/start!
port
(or (substring-find-next-char-in-set (input-port/string port)
delimiters)
end)))))
-(define (operation/print-self state port)
+(define (operation/write-self port output-port)
port
- (unparse-string state "from string"))
\ No newline at end of file
+ (write-string " from string" output-port))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/strott.scm,v 14.3 1988/10/15 17:19:21 cph Rel $
+$Id: strott.scm,v 14.4 1993/10/21 14:52:42 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
(define (initialize-package!)
(set! output-string-template
- (make-output-port `((PRINT-SELF ,operation/print-self)
+ (make-output-port `((WRITE-SELF ,operation/write-self)
(WRITE-CHAR ,operation/write-char)
(WRITE-STRING ,operation/write-string))
false)))
(set-output-string-state/accumulator! state accumulator)
(set-output-string-state/counter! state counter))))))
-(define (operation/print-self state port)
+(define (operation/write-self port output-port)
port
- (unparse-string state "to string (truncating)"))
\ No newline at end of file
+ (write-string " to string (truncating)" output-port))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: strout.scm,v 14.7 1993/01/19 05:33:49 cph Exp $
+$Id: strout.scm,v 14.8 1993/10/21 14:52:43 cph Exp $
Copyright (c) 1988-93 Massachusetts Institute of Technology
\f
(define (initialize-package!)
(set! output-string-template
- (make-output-port `((PRINT-SELF ,operation/print-self)
+ (make-output-port `((WRITE-SELF ,operation/write-self)
(WRITE-CHAR ,operation/write-char)
(WRITE-SUBSTRING ,operation/write-substring))
false))
(output-string-state/accumulator state) n)
(set-output-string-state/counter! state n*)))))
-(define (operation/print-self state port)
+(define (operation/write-self port output-port)
port
- (unparse-string state "to string"))
\ No newline at end of file
+ (write-string " to string" output-port))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/ttyio.scm,v 1.3 1993/08/16 09:50:12 jawilson Exp $
+$Id: ttyio.scm,v 1.4 1993/10/21 14:52:43 cph Exp $
Copyright (c) 1991-93 Massachusetts Institute of Technology
(OUTPUT-CHANNEL ,operation/output-channel)
(OUTPUT-TERMINAL-MODE ,operation/output-terminal-mode)
(PEEK-CHAR ,(lambda (port) (hook/peek-char port)))
- (PRINT-SELF ,operation/print-self)
+ (WRITE-SELF ,operation/write-self)
(READ-CHAR ,(lambda (port) (hook/read-char port)))
(READ-FINISH ,operation/read-finish)
(SET-INPUT-BLOCKING-MODE ,operation/set-input-blocking-mode)
port
((ucode-primitive tty-y-size 0)))
-(define (operation/print-self state port)
+(define (operation/write-self port output-port)
port
- (unparse-string state "for console"))
\ No newline at end of file
+ (write-string " for console" output-port))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/urtrap.scm,v 14.2 1988/06/13 11:59:56 cph Rel $
+$Id: urtrap.scm,v 14.3 1993/10/21 14:52:44 cph Exp $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
(define-structure (reference-trap
(print-procedure
- (unparser/standard-method 'REFERENCE-TRAP
- (lambda (state trap)
- (unparse-object state (reference-trap-kind trap))))))
+ (standard-unparser-method 'REFERENCE-TRAP
+ (lambda (trap port)
+ (write-char #\space port)
+ (write (reference-trap-kind trap) port)))))
(kind false read-only true)
(extra false read-only true))
#| -*-Scheme-*-
-$Id: x11graph.scm,v 1.34 1993/09/15 20:55:26 adams Exp $
+$Id: x11graph.scm,v 1.35 1993/10/21 14:52:45 cph Exp $
Copyright (c) 1989-1993 Massachusetts Institute of Technology
(declare (integrate-external "graphics"))
\f
(define-primitives
- (x-debug 1)
(x-open-display 1)
(x-close-display 1)
(x-close-all-displays 0)
(x-window-beep 1)
(x-window-clear 1)
+ (x-window-colormap 1)
(x-window-event-mask 1)
(x-window-flush 1)
(x-window-iconify 1)
(x-window-set-position 3)
(x-window-set-size 3)
(x-window-starbase-filename 1)
+ (x-window-visual 1)
(x-window-withdraw 1)
(x-window-x-size 1)
(x-window-y-size 1)
(x-graphics-draw-line 5)
(x-graphics-draw-point 3)
(x-graphics-draw-string 4)
+ (x-graphics-fill-polygon 2)
(x-graphics-map-x-coordinate 2)
(x-graphics-map-y-coordinate 2)
(x-graphics-move-cursor 3)
(x-graphics-set-vdc-extent 5)
(x-graphics-vdc-extent 1)
- (x-graphics-fill-polygon 2)
-
(x-bytes-into-image 2)
(x-create-image 3)
(x-destroy-image 1)
(x-set-window-colormap 2)
(x-store-color 5)
(x-store-colors 2)
- (x-window-colormap 1)
-
- (x-window-visual 1)
(x-visual-deallocate 1))
-
+\f
;; These constants must match "microcode/x11base.c"
(define-integrable event-type:button-down 0)
(define-integrable event-type:button-up 1)
(conc-name x-display/)
(constructor make-x-display (name xd))
(print-procedure
- (unparser/standard-method 'X-DISPLAY
- (lambda (state display)
- (unparse-object state (x-display/name display))))))
+ (standard-unparser-method 'X-DISPLAY
+ (lambda (display port)
+ (write-char #\space port)
+ (write (x-display/name display) port)))))
(name false read-only true)
xd
(window-list (make-protection-list) read-only true)
(define (x-image/fill-from-byte-vector image byte-vector)
(x-bytes-into-image byte-vector (x-image/descriptor image)))
-
+\f
;; Abstraction layer for generic images
(define (x-graphics/create-image device width height)
(x-store-color (colormap/descriptor colormap) position r g b))
(define (x-colormap/store-colors colormap color-vector)
- (x-store-colors (colormap/descriptor colormap) color-vector))
+ (x-store-colors (colormap/descriptor colormap) color-vector))
\ No newline at end of file
projects / mit-scheme.git / commitdiff