(define-integrable (stack-marker-frame/repl-eval-boundary? stack-frame)
(eq? with-repl-eval-boundary (stack-marker-frame/type stack-frame)))
\f
-;;;; Unparser
+;;;; Printer
(define (stack-frame->continuation stack-frame)
(make-continuation (stack-frame->control-point stack-frame)
#f))
(define (stack-frame->control-point stack-frame)
- (with-values (lambda () (unparse/stack-frame stack-frame))
+ (with-values (lambda () (print-stack-frame stack-frame))
(lambda (element-stream next-control-point)
(make-control-point
(stack-frame/interrupt-mask stack-frame)
element-stream)
next-control-point))))
-(define (unparse/stack-frame stack-frame)
+(define (print-stack-frame stack-frame)
(if (eq? (stack-frame/return-address stack-frame)
return-address/join-stacklets)
(values (stream) (vector-ref (stack-frame/elements stack-frame) 1))
(lambda ()
(let ((next (stack-frame/%next stack-frame)))
(cond ((stack-frame? next)
- (unparse/stack-frame next))
+ (print-stack-frame next))
((parser-state? next)
(values (parser-state/element-stream next)
(parser-state/next-control-point next)))
appropriate boolean constant had been specified instead.
* The PRINT-FUNCTION option is named PRINT-PROCEDURE. Its argument is
- a procedure of two arguments (the unparser state and the structure
- instance) rather than three as in Common Lisp.
+ a procedure of two arguments (the structure instance and a textual output
+ port) rather than three as in Common Lisp.
* By default, named structures are tagged with a unique object of some
kind. In Common Lisp, the structures are tagged with symbols, but
(if print-procedure-option
(option/argument print-procedure-option)
(and type-option
- (default-unparser-text context)))
+ (default-print-method context)))
(if type-option
(option/argument type-option)
'record)
(define (default-predicate-name context)
(symbol (parser-context/name context) '?))
-(define (default-unparser-text context)
+(define (default-print-method context)
`(,(absolute 'standard-print-method context)
',(parser-context/name context)))
'wild
(substring string start end)))
\f
-;;;; Pathname Unparser
+;;;; Pathname printer
(define (dos/pathname->namestring pathname)
- (string-append (unparse-device (%pathname-device pathname))
- (unparse-directory (%pathname-directory pathname))
- (unparse-name (%pathname-name pathname)
+ (string-append (print-device (%pathname-device pathname))
+ (print-directory (%pathname-directory pathname))
+ (print-name (%pathname-name pathname)
(%pathname-type pathname))))
-(define (unparse-device device)
+(define (print-device device)
(if (or (not device) (eq? device 'unspecific))
""
(string-append device ":")))
-(define (unparse-directory directory)
+(define (print-directory directory)
(cond ((or (not directory) (eq? directory 'unspecific))
"")
((pair? directory)
(let loop ((directory (cdr directory)))
(if (null? directory)
""
- (string-append (unparse-directory-component (car directory))
+ (string-append (print-directory-component (car directory))
sub-directory-delimiter-string
(loop (cdr directory)))))))
(else
(error:illegal-pathname-component directory "directory"))))
-(define (unparse-directory-component component)
+(define (print-directory-component component)
(cond ((eq? component 'up) "..")
((string? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
-(define (unparse-name name type)
- (let ((name (or (unparse-component name) ""))
- (type (unparse-component type)))
+(define (print-name name type)
+ (let ((name (or (print-component name) ""))
+ (type (print-component type)))
(if type
(string-append name "." type)
name)))
-(define (unparse-component component)
+(define (print-component component)
(cond ((or (not component) (string? component)) component)
((eq? component 'wild) "*")
(else (error:illegal-pathname-component component "component"))))
(simplify-directory
(let ((directory (%pathname-directory pathname))
(component
- (parse-directory-component (unparse-name name type))))
+ (parse-directory-component (print-name name type))))
(cond ((not (pair? directory)) (list 'relative component))
((equal? component ".") directory)
(else (append directory (list component))))))
(call-with-values
(lambda ()
(parse-name
- (unparse-directory-component (car (last-pair directory)))))
+ (print-directory-component (car (last-pair directory)))))
(lambda (name type)
(%%make-pathname (%pathname-host pathname)
(%pathname-device pathname)
(else #f)))
(define (undefined-value? object)
- ;; Note: the unparser takes advantage of the fact that objects
+ ;; Note: the printer takes advantage of the fact that objects
;; satisfying this predicate also satisfy:
;; (object-type? (ucode-type constant) object)
(or (eq? object unspecific)
;; to describe an arity dispatched procedure:
;; FULL: full bodies of procedures
;; NAMED: just name if the procedure is a named lambda, like FULL if unnamed
- ;; SHORT: procedures appear in #[...] unparser syntax
+ ;; SHORT: procedures appear in #[...] syntax
(set! param:pp-arity-dispatched-procedure-style
(make-settable-parameter 'full))
(set! param:pp-auto-highlighter (make-settable-parameter #f))
(let ((print-string
(lambda (s)
(if (string? s)
- (*unparse-string s)
+ (*print-string s)
(s (output-port))))))
(print-string (pph/start-string pph))
(thunk)
numerical-walk))
(node (numerical-walk expression list-depth)))
(if (positive? indentation)
- (*unparse-string (make-string indentation #\space)))
+ (*print-string (make-string indentation #\space)))
(if as-code?
(print-node node indentation list-depth)
(print-non-code-node node indentation list-depth))
(define x-size)
(define output-port)
-(define-integrable (*unparse-char char)
+(define-integrable (*print-char char)
(output-port/write-char (output-port) char))
-(define-integrable (*unparse-string string)
+(define-integrable (*print-string string)
(output-port/write-string (output-port) string))
-(define-integrable (*unparse-open)
- (*unparse-char #\())
+(define-integrable (*print-open)
+ (*print-char #\())
-(define-integrable (*unparse-close)
- (*unparse-char #\)))
+(define-integrable (*print-close)
+ (*print-char #\)))
-(define-integrable (*unparse-space)
- (*unparse-char #\space))
+(define-integrable (*print-space)
+ (*print-char #\space))
-(define-integrable (*unparse-newline)
- (*unparse-char #\newline))
+(define-integrable (*print-newline)
+ (*print-char #\newline))
\f
(define (print-non-code-node node column depth)
(parameterize* (list (cons dispatch-list '())
(print-node node column depth))))
(define (print-data-column nodes column depth)
- (*unparse-open)
+ (*print-open)
(print-column nodes (+ column 1) (+ depth 1))
- (*unparse-close))
+ (*print-close))
(define (print-data-table nodes column depth)
- (*unparse-open)
+ (*print-open)
(maybe-print-table nodes (+ column 1) (+ depth 1))
- (*unparse-close))
+ (*print-close))
(define (print-node node column depth)
(cond ((list-node? node)
(print-list-node node column depth))
((symbol? node)
- (*unparse-symbol node))
+ (*print-symbol node))
((prefix-node? node)
- (*unparse-string (prefix-node-prefix node))
+ (*print-string (prefix-node-prefix node))
(let ((new-column
(+ column (string-length (prefix-node-prefix node))))
(subnode (prefix-node-subnode node)))
(+ column (pph/start-string-length highlight))
(+ depth (pph/end-string-length highlight))))))))
(else
- (*unparse-string node))))
+ (*print-string node))))
(define (print-list-node node column depth)
(if (and (get-param:pp-save-vertical-space?)
(cond ((list-node? node)
(print-guaranteed-list-node node))
((symbol? node)
- (*unparse-symbol node))
+ (*print-symbol node))
((highlighted-node? node)
(with-highlight-strings-printed (highlighted-node/highlight node)
(lambda ()
(print-guaranteed-node (highlighted-node/subnode node)))))
((prefix-node? node)
- (*unparse-string (prefix-node-prefix node))
+ (*print-string (prefix-node-prefix node))
(print-guaranteed-node (prefix-node-subnode node)))
(else
- (*unparse-string node))))
+ (*print-string node))))
(define (print-guaranteed-list-node node)
- (*unparse-open)
+ (*print-open)
(let loop ((nodes (node-subnodes node)))
(print-guaranteed-node (car nodes))
(if (not (null? (cdr nodes)))
(begin
- (*unparse-space)
+ (*print-space)
(loop (cdr nodes)))))
- (*unparse-close))
+ (*print-close))
(define (print-column nodes column depth)
(let loop ((nodes nodes))
;;;; Printers
(define (print-combination nodes column depth)
- (*unparse-open)
+ (*print-open)
(let ((column (+ column 1))
(depth (+ depth 1)))
(cond ((null? (cdr nodes))
(print-node (car nodes) column depth))
((two-on-first-line? nodes column depth)
(print-guaranteed-node (car nodes))
- (*unparse-space)
+ (*print-space)
(print-guaranteed-column (cdr nodes)
(+ column 1 (node-size (car nodes)))))
(else
(print-column nodes column depth))))
- (*unparse-close))
+ (*print-close))
(define dispatch-list)
(define dispatch-default)
(define code-dispatch-list)
(define ((special-printer procedure) nodes column depth)
- (*unparse-open)
- (print-guaranteed-node (car nodes)) ;(*unparse-symbol (car nodes))
- (*unparse-space)
+ (*print-open)
+ (print-guaranteed-node (car nodes)) ;(*print-symbol (car nodes))
+ (*print-space)
(if (not (null? (cdr nodes)))
(procedure (cdr nodes)
(+ column 2 (node-size (car nodes)))
(+ column 2)
(+ depth 1)))
- (*unparse-close))
+ (*print-close))
;;; Force the indentation to be an optimistic column.
(print-node (car nodes) optimistic depth))
((symbol? (car nodes))
;; named let
- (*unparse-symbol (car nodes))
+ (*print-symbol (car nodes))
(let ((new-optimistic
(+ optimistic (+ 1 (symbol-length (car nodes))))))
(cond ((fits-within? (cadr nodes) new-optimistic 0)
- (*unparse-space)
+ (*print-space)
(print-guaranteed-node (cadr nodes))
(print-body (cddr nodes)))
((and (list-node? (cadr nodes))
(fits-as-column? (node-subnodes (cadr nodes))
(+ new-optimistic 2)
0))
- (*unparse-space)
- (*unparse-open)
+ (*print-space)
+ (*print-open)
(print-guaranteed-column (node-subnodes (cadr nodes))
(+ new-optimistic 1))
- (*unparse-close)
+ (*print-close)
(print-body (cddr nodes)))
(else
(tab-to optimistic)
;;; Starts a new line with the specified indentation.
(define (tab-to column)
- (*unparse-newline)
+ (*print-newline)
(pad-with-spaces column))
(define-integrable (pad-with-spaces n-spaces)
- (*unparse-string (make-string n-spaces #\space)))
+ (*print-string (make-string n-spaces #\space)))
\f
;;;; Numerical Walk
(lambda (port)
(write symbol port)))))
-(define (*unparse-symbol symbol)
+(define (*print-symbol symbol)
(write symbol (output-port)))
(define-structure (prefix-node
'wild
(substring string start end)))
\f
-;;;; Pathname Unparser
+;;;; Pathname print
(define (unix/pathname->namestring pathname)
- (string-append (unparse-directory (%pathname-directory pathname))
- (unparse-name (%pathname-name pathname)
+ (string-append (print-directory (%pathname-directory pathname))
+ (print-name (%pathname-name pathname)
(%pathname-type pathname))))
-(define (unparse-directory directory)
+(define (print-directory directory)
(cond ((not directory)
"")
((pair? directory)
(let loop ((directory (cdr directory)))
(if (not (pair? directory))
""
- (string-append (unparse-directory-component (car directory))
+ (string-append (print-directory-component (car directory))
"/"
(loop (cdr directory)))))))
(else
(error:illegal-pathname-component directory "directory"))))
-(define (unparse-directory-component component)
+(define (print-directory-component component)
(cond ((eq? component 'up) "..")
((eq? component 'here) ".")
((string? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
-(define (unparse-name name type)
- (let ((name (or (unparse-component name) ""))
- (type (unparse-component type)))
+(define (print-name name type)
+ (let ((name (or (print-component name) ""))
+ (type (print-component type)))
(if type
(string-append name "." type)
name)))
-(define (unparse-component component)
+(define (print-component component)
(cond ((or (not component) (string? component)) component)
((eq? component 'wild) "*")
(else (error:illegal-pathname-component component "component"))))
'unspecific
(let ((directory (%pathname-directory pathname))
(component
- (parse-directory-component (unparse-name name type))))
+ (parse-directory-component (print-name name type))))
(cond ((not (pair? directory))
(list 'relative component))
((equal? component ".")
;; the original pathname and leave it to the caller to deal
;; with any problems this might cause.
pathname
- (parse-name (unparse-directory-component (car (last-pair directory)))
+ (parse-name (print-directory-component (car (last-pair directory)))
(lambda (name type)
(%make-pathname (%pathname-host pathname)
'unspecific
projects / mit-scheme.git / commitdiff