(groups/files-to-copy groups)))))
(define (load-quietly pathname environment)
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load pathname environment))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (load pathname environment)))
(define (->string object)
(if (string? object)
(if (not (default-object? value))
(begin
(write-string " --> " port)
- (parameterize* (list (cons param:printer-list-depth-limit 2)
- (cons param:printer-list-breadth-limit 10)
- (cons param:printer-string-length-limit 30))
- (lambda ()
- (write value port))))))))
+ (parameterize ((param:printer-list-depth-limit 2)
+ (param:printer-list-breadth-limit 10)
+ (param:printer-string-length-limit 30))
+ (write value port)))))))
(define (write-rtl-instructions rtl port)
(write-instructions
(lambda ()
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- (for-each show-rtl-instruction rtl))))))
+ (parameterize ((current-output-port port))
+ (for-each show-rtl-instruction rtl)))))
(define (dump-rtl filename)
(write-instructions
(define (write-instructions thunk)
(fluid-let ((*show-instruction* write))
- (parameterize* (list (cons param:printer-radix 16)
- (cons param:print-uninterned-symbols-by-name? #t))
- thunk)))
+ (parameterize ((param:printer-radix 16)
+ (param:print-uninterned-symbols-by-name? #t))
+ (thunk))))
(define (pp-instructions thunk)
(fluid-let ((*show-instruction* pretty-print))
- (parameterize* (list (cons param:pp-primitives-by-name? #f)
- (cons param:printer-radix 16)
- (cons param:print-uninterned-symbols-by-name? #t))
- thunk)))
+ (parameterize ((param:pp-primitives-by-name? #f)
+ (param:printer-radix 16)
+ (param:print-uninterned-symbols-by-name? #t))
+ (thunk))))
(define *show-instruction*)
(fix:> (vector-length object) 0)
(eq? tag (vector-ref object 0))))
(lambda (vector port)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- ((tagged-vector/unparser vector) vector port)))))
+ (parameterize ((param:printer-radix 16))
+ ((tagged-vector/unparser vector) vector port))))
tag))))
(define (define-vector-tag-unparser tag unparser)
(define (phase/lap-file-output scode port)
(compiler-phase "LAP File Output"
(lambda ()
- (parameterize* (list (cons param:printer-radix 16)
- (cons param:print-uninterned-symbols-by-name? #t))
- (lambda ()
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- (write-string "LAP for object ")
- (write *recursive-compilation-number*)
- (newline)
- (pp scode (current-output-port) #t 4)
- (newline)
- (newline)
- (newline)
- (for-each
- (lambda (instruction)
- (cond ((and (pair? instruction)
- (eq? (car instruction) 'LABEL))
- (write (cadr instruction))
- (write-char #\:))
- ((and (pair? instruction)
- (eq? (car instruction) 'COMMENT))
- (write-char #\tab)
- (write-string ";;")
- (for-each (lambda (frob)
- (write-string " ")
- (write (if (and (pair? frob)
- (eq? (car frob) 'RTL))
- (cadr frob)
- frob)))
- (cdr instruction)))
- (else
- (write-char #\tab)
- (write instruction)))
- (newline))
- *lap*)
- (if (not (zero? *recursive-compilation-number*))
- (begin
- (write-char #\page)
- (newline)))
- (output-port/flush-output port))))))))
+ (parameterize ((param:printer-radix 16)
+ (param:print-uninterned-symbols-by-name? #t))
+ (parameterize ((current-output-port port))
+ (write-string "LAP for object ")
+ (write *recursive-compilation-number*)
+ (newline)
+ (pp scode (current-output-port) #t 4)
+ (newline)
+ (newline)
+ (newline)
+ (for-each
+ (lambda (instruction)
+ (cond ((and (pair? instruction)
+ (eq? (car instruction) 'LABEL))
+ (write (cadr instruction))
+ (write-char #\:))
+ ((and (pair? instruction)
+ (eq? (car instruction) 'COMMENT))
+ (write-char #\tab)
+ (write-string ";;")
+ (for-each (lambda (frob)
+ (write-string " ")
+ (write (if (and (pair? frob)
+ (eq? (car frob) 'RTL))
+ (cadr frob)
+ frob)))
+ (cdr instruction)))
+ (else
+ (write-char #\tab)
+ (write instruction)))
+ (newline))
+ *lap*)
+ (if (not (zero? *recursive-compilation-number*))
+ (begin
+ (write-char #\page)
+ (newline)))
+ (output-port/flush-output port))))))
(disassembler/instructions #f start-address end-address #f))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction comment)
- (disassembler/write-instruction
- symbol-table
- offset
- (lambda ()
- (if comment
- (let ((s
- (call-with-output-string
- (lambda (port)
- (display instruction port)))))
- (if (< (string-length s) 40)
- (write-string (string-pad-right s 40))
- (write-string s))
- (write-string "; ")
- (display comment))
- (write instruction)))))))))
+ (parameterize ((param:printer-radix 16))
+ (disassembler/for-each-instruction instruction-stream
+ (lambda (offset instruction comment)
+ (disassembler/write-instruction
+ symbol-table
+ offset
+ (lambda ()
+ (if comment
+ (let ((s
+ (call-with-output-string
+ (lambda (port)
+ (display instruction port)))))
+ (if (< (string-length s) 40)
+ (write-string (string-pad-right s 40))
+ (write-string s))
+ (write-string "; ")
+ (display comment))
+ (write instruction))))))))
(define (disassembler/for-each-instruction instruction-stream procedure)
(let loop ((instruction-stream instruction-stream))
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/marked-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
+ (parameterize ((param:printer-radix 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/marked-start block)))
+ (cond ((not (< index end)) 'DONE)
+ ((object-type?
+ (let-syntax ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form))))))
+ (ucode-type linkage-section))
+ (system-vector-ref block index))
+ (loop (disassembler/write-linkage-section block
+ symbol-table
+ index)))
+ (else
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
(define (write-constant block symbol-table constant)
(write-string (cdr (write-to-string constant 60)))
(make-cursor block start symbol-table)))
(define (write-instructions cursor)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (let ((end (compiled-code-block/code-end (cursor-block cursor))))
- (let loop ()
- (if (< (cursor-offset cursor) end)
- (begin
- (write-instruction cursor)
- (loop))))))))
+ (parameterize ((param:printer-radix 16))
+ (let ((end (compiled-code-block/code-end (cursor-block cursor))))
+ (let loop ()
+ (if (< (cursor-offset cursor) end)
+ (begin
+ (write-instruction cursor)
+ (loop)))))))
(define (write-instruction cursor)
(write-offset cursor)
#t)))))
\f
(define (write-constants cursor)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (let* ((block (cursor-block cursor))
- (end (compiled-code-block/index->offset
- (system-vector-length block))))
-
- (assert (= (cursor-offset cursor)
- (* (1+ (compiled-code-block/marked-start block))
- address-units-per-object)))
- (let loop ()
- (let ((offset (cursor-offset cursor)))
- (if (< offset end)
- (let ((object (system-vector-ref
- block (compiled-code-block/offset->index offset))))
- (if (object-type? (ucode-type linkage-section) object)
- (write-linkage-section object cursor)
- (begin
- (write-offset cursor)
- (write-constant object cursor)
- (set-cursor-offset! cursor
- (+ offset address-units-per-object))))
- (loop)))))))))
+ (parameterize ((param:printer-radix 16))
+ (let* ((block (cursor-block cursor))
+ (end (compiled-code-block/index->offset
+ (system-vector-length block))))
+
+ (assert (= (cursor-offset cursor)
+ (* (1+ (compiled-code-block/marked-start block))
+ address-units-per-object)))
+ (let loop ()
+ (let ((offset (cursor-offset cursor)))
+ (if (< offset end)
+ (let ((object (system-vector-ref
+ block (compiled-code-block/offset->index offset))))
+ (if (object-type? (ucode-type linkage-section) object)
+ (write-linkage-section object cursor)
+ (begin
+ (write-offset cursor)
+ (write-constant object cursor)
+ (set-cursor-offset! cursor
+ (+ offset address-units-per-object))))
+ (loop))))))))
(define (write-constant constant cursor)
(write-string (cdr (write-to-string constant 60)))
(disassembler/instructions #f start-address end-address #f))
(define (disassembler/write-instruction-stream symbol-table instruction-stream)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (disassembler/for-each-instruction instruction-stream
- (lambda (offset instruction comment)
- (disassembler/write-instruction
- symbol-table
- offset
- (lambda ()
- (if comment
- (let ((s
- (call-with-output-string
- (lambda (port)
- (display instruction port)))))
- (if (< (string-length s) 40)
- (write-string (string-pad-right s 40))
- (write-string s))
- (write-string "; ")
- (display comment))
- (write instruction)))))))))
+ (parameterize ((param:printer-radix 16))
+ (disassembler/for-each-instruction instruction-stream
+ (lambda (offset instruction comment)
+ (disassembler/write-instruction
+ symbol-table
+ offset
+ (lambda ()
+ (if comment
+ (let ((s
+ (call-with-output-string
+ (lambda (port)
+ (display instruction port)))))
+ (if (< (string-length s) 40)
+ (write-string (string-pad-right s 40))
+ (write-string s))
+ (write-string "; ")
+ (display comment))
+ (write instruction))))))))
(define (disassembler/for-each-instruction instruction-stream procedure)
(let loop ((instruction-stream instruction-stream))
(loop (instruction-stream)))))))
\f
(define (disassembler/write-constants-block block symbol-table)
- (parameterize* (list (cons param:printer-radix 16))
- (lambda ()
- (let ((end (system-vector-length block)))
- (let loop ((index (compiled-code-block/marked-start block)))
- (cond ((not (< index end)) 'DONE)
- ((object-type?
- (let-syntax ((ucode-type
- (sc-macro-transformer
- (lambda (form environment)
- environment
- (apply microcode-type (cdr form))))))
- (ucode-type linkage-section))
- (system-vector-ref block index))
- (loop (disassembler/write-linkage-section block
- symbol-table
- index)))
- (else
- (disassembler/write-instruction
- symbol-table
- (compiled-code-block/index->offset index)
- (lambda ()
- (write-constant block
- symbol-table
- (system-vector-ref block index))))
- (loop (1+ index)))))))))
+ (parameterize ((param:printer-radix 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/marked-start block)))
+ (cond ((not (< index end)) 'DONE)
+ ((object-type?
+ (let-syntax ((ucode-type
+ (sc-macro-transformer
+ (lambda (form environment)
+ environment
+ (apply microcode-type (cdr form))))))
+ (ucode-type linkage-section))
+ (system-vector-ref block index))
+ (loop (disassembler/write-linkage-section block
+ symbol-table
+ index)))
+ (else
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
(define (write-constant block symbol-table constant)
(write-string (cdr (write-to-string constant 60)))
(if (or argument
(invalid-subexpression? sub))
(pp exp)
- (parameterize* (list (cons param:pp-no-highlights?
- #f))
- do-hairy)))
+ (parameterize ((param:pp-no-highlights? #f))
+ (do-hairy))))
((debugging-info/noise? exp)
(message ((debugging-info/noise exp) #t)))
(else
port))))
(define (print-with-subexpression expression subexpression)
- (parameterize* (list (cons param:print-primitives-by-name? #t))
- (lambda ()
- (if (invalid-subexpression? subexpression)
- (write (unsyntax expression))
- (let ((sub (write-to-string (unsyntax subexpression))))
- (write (unsyntax-with-substitutions
- expression
- (list
- (cons subexpression
- (unparser-literal/make
- (string-append
- (ref-variable subexpression-start-marker)
- sub
- (ref-variable subexpression-end-marker))))))))))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (if (invalid-subexpression? subexpression)
+ (write (unsyntax expression))
+ (let ((sub (write-to-string (unsyntax subexpression))))
+ (write (unsyntax-with-substitutions
+ expression
+ (list
+ (cons subexpression
+ (unparser-literal/make
+ (string-append
+ (ref-variable subexpression-start-marker)
+ sub
+ (ref-variable subexpression-end-marker)))))))))))
\f
(define (invalid-subexpression? subexpression)
(or (debugging-info/undefined-expression? subexpression)
port))
(define (print-reduction-as-subexpression expression)
- (parameterize* (list (cons param:print-primitives-by-name? #t))
- (lambda ()
- (write-string (ref-variable subexpression-start-marker))
- (write (unsyntax expression))
- (write-string (ref-variable subexpression-end-marker)))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (write-string (ref-variable subexpression-start-marker))
+ (write (unsyntax expression))
+ (write-string (ref-variable subexpression-end-marker))))
(define (print-history-level compiled? subproblem-number reduction-id
expression-thunk environment port)
(cdr
(call-with-truncated-output-string pad-width
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- expression-thunk))))
+ (parameterize ((current-output-port port))
+ (expression-thunk)))))
" ")
pad-width
#\-)
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
- (parameterize*
- (list (cons param:suppress-loading-message? #t))
- (lambda ()
- ((message-wrapper #f "Loading " (car library))
- (lambda ()
- (load-library library)))))))))
+ (parameterize
+ ((param:suppress-loading-message? #t))
+ ((message-wrapper #f "Loading " (car library))
+ (lambda ()
+ (load-library library))))))))
(load-library library))))))
(cond ((not (library-loaded? name))
(do-it))
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load filename environment 'DEFAULT purify?))))))))
\ No newline at end of file
+ (parameterize ((param:suppress-loading-message? #t))
+ (load filename environment 'DEFAULT purify?)))))))
\ No newline at end of file
(define (with-output-to-temporary-buffer name properties thunk)
(call-with-output-to-temporary-buffer name properties
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk))))
+ (parameterize ((current-output-port port))
+ (thunk)))))
(define (call-with-temporary-buffer name procedure)
(let ((buffer))
(define (with-input-from-mark mark thunk #!optional receiver)
(let ((port (make-buffer-input-port mark (group-end mark))))
(let ((value
- (parameterize* (list (cons current-input-port port))
- thunk)))
+ (parameterize ((current-input-port port))
+ (thunk))))
(if (default-object? receiver)
value
(receiver value (input-port/mark port))))))
(define (with-input-from-region region thunk)
- (parameterize* (list (cons current-input-port
- (make-buffer-input-port (region-start region)
- (region-end region))))
- thunk))
+ (parameterize ((current-input-port
+ (make-buffer-input-port (region-start region)
+ (region-end region))))
+ (thunk)))
(define (call-with-input-mark mark procedure)
(procedure (make-buffer-input-port mark (group-end mark))))
(define (with-output-to-mark mark thunk)
(call-with-output-mark mark
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk))))
+ (parameterize ((current-output-port port))
+ (thunk)))))
(define (call-with-output-mark mark procedure)
(let ((port (mark->output-port mark)))
indentation port)
(let ((start-mark #f)
(end-mark #f))
- (parameterize* (list (cons param:pp-no-highlights? #f))
- (lambda ()
- (debugger-pp
- (unsyntax-with-substitutions
- expression
- (list (cons subexpression
- (make-pretty-printer-highlight
- (unsyntax subexpression)
- (lambda (port)
- (set! start-mark
- (mark-right-inserting-copy
- (output-port->mark port)))
- unspecific)
- (lambda (port)
- (set! end-mark
- (mark-right-inserting-copy
- (output-port->mark port)))
- unspecific)))))
- indentation
- port)))
+ (parameterize ((param:pp-no-highlights? #f))
+ (debugger-pp
+ (unsyntax-with-substitutions
+ expression
+ (list (cons subexpression
+ (make-pretty-printer-highlight
+ (unsyntax subexpression)
+ (lambda (port)
+ (set! start-mark
+ (mark-right-inserting-copy
+ (output-port->mark port)))
+ unspecific)
+ (lambda (port)
+ (set! end-mark
+ (mark-right-inserting-copy
+ (output-port->mark port)))
+ unspecific)))))
+ indentation
+ port))
(if (and start-mark end-mark)
(highlight-region-excluding-indentation
(make-region start-mark end-mark)
(max summary-minimum-columns
(- columns indentation 4))
(lambda (port)
- (parameterize*
- (list (cons current-output-port port))
- (lambda ()
- ((bline-type/write-summary
- (bline/type bline))
- bline
- (current-output-port))))))))
+ (parameterize ((current-output-port port))
+ ((bline-type/write-summary
+ (bline/type bline))
+ bline
+ (current-output-port)))))))
(insert-string (cdr summary) mark)
(if (car summary)
(insert-string " ..." mark)))
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (parameterize* (list (cons param:print-primitives-by-name?
- #t))
- (lambda ()
- (write
- (unsyntax (if (invalid-subexpression? subexpression)
- expression
- subexpression))))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (write
+ (unsyntax (if (invalid-subexpression? subexpression)
+ expression
+ subexpression)))))
((debugging-info/noise? expression)
(write-string ";" port)
(write-string ((debugging-info/noise expression) #f)
(subproblem/number (reduction/subproblem reduction)))
port)))
(write-string " " port)
- (parameterize* (list (cons param:print-primitives-by-name? #t))
- (lambda ()
- (write (unsyntax (reduction/expression reduction)) port)))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (write (unsyntax (reduction/expression reduction)) port))))
(define (reduction/write-description bline port)
(let ((reduction (bline/object bline)))
(lambda (root-continuation)
(set! editor-thread-root-continuation
root-continuation)
- (parameterize* (list (cons notification-output-port
- null-output-port))
- (lambda ()
- (do ((thunks (let ((thunks editor-initial-threads))
- (set! editor-initial-threads '())
- thunks)
- (cdr thunks)))
- ((null? thunks))
- (create-thread root-continuation
- (car thunks)
- (car thunks)))
- (top-level-command-reader
- edwin-initialization)))))))
+ (parameterize ((notification-output-port
+ null-output-port))
+ (do ((thunks (let ((thunks editor-initial-threads))
+ (set! editor-initial-threads '())
+ thunks)
+ (cdr thunks)))
+ ((null? thunks))
+ (create-thread root-continuation
+ (car thunks)
+ (car thunks)))
+ (top-level-command-reader edwin-initialization))))))
message)
#f
`((START-CHILD ,(editor-start-child-cmdl with-editor-ungrabbed))
(call-with-transcript-buffer
(lambda (buffer)
(insert-string
- (parameterize*
- (list (cons param:print-with-maximum-readability? #t))
- (lambda ()
- (write-to-string expression)))
+ (parameterize ((param:print-with-maximum-readability? #t))
+ (write-to-string expression))
(buffer-end buffer)))))
(editor-eval buffer
expression
(define (editor-eval buffer sexp environment)
(let ((core
(lambda ()
- (parameterize* (list (cons current-input-port dummy-i/o-port))
- (lambda ()
- (let ((value))
- (let ((output-string
- (call-with-output-string
- (lambda (port)
- (parameterize* (list (cons current-output-port
- port))
- (lambda ()
- (set! value
- (eval-with-history sexp environment))
- unspecific))))))
- (let ((evaluation-output-receiver
- (ref-variable evaluation-output-receiver buffer)))
- (if evaluation-output-receiver
- (evaluation-output-receiver value output-string)
- (with-output-to-transcript-buffer
- (lambda ()
- (write-string output-string)
- (transcript-write
- value
- (and (ref-variable enable-transcript-buffer
- buffer)
- (transcript-buffer))))))))
- value))))))
+ (parameterize ((current-input-port dummy-i/o-port))
+ (let ((value))
+ (let ((output-string
+ (call-with-output-string
+ (lambda (port)
+ (parameterize ((current-output-port port))
+ (set! value
+ (eval-with-history sexp environment))
+ unspecific)))))
+ (let ((evaluation-output-receiver
+ (ref-variable evaluation-output-receiver buffer)))
+ (if evaluation-output-receiver
+ (evaluation-output-receiver value output-string)
+ (with-output-to-transcript-buffer
+ (lambda ()
+ (write-string output-string)
+ (transcript-write
+ value
+ (and (ref-variable enable-transcript-buffer
+ buffer)
+ (transcript-buffer))))))))
+ value)))))
(if (ref-variable enable-run-light? buffer)
(let ((run-light (ref-variable-object run-light))
(outside)
(let ((output-port
(mark->output-port (buffer-end buffer) buffer)))
(fresh-line output-port)
- (parameterize* (list (cons current-output-port output-port))
- thunk))))))
+ (parameterize ((current-output-port output-port))
+ (thunk)))))))
(let ((value))
(let ((output
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- (set! value (thunk))
- unspecific))))))
+ (parameterize ((current-output-port port))
+ (set! value (thunk))
+ unspecific)))))
(if (and (not (string-null? output))
(not (ref-variable evaluation-output-receiver)))
(string->temporary-buffer output "*Unsolicited-Output*" '())))
(define (transcript-value-string value)
(if (undefined-value? value)
""
- (parameterize* (list (cons param:printer-list-depth-limit
- (ref-variable transcript-list-depth-limit))
- (cons param:printer-list-breadth-limit
- (ref-variable transcript-list-breadth-limit)))
- (lambda ()
- (write-to-string value)))))
+ (parameterize ((param:printer-list-depth-limit
+ (ref-variable transcript-list-depth-limit))
+ (param:printer-list-breadth-limit
+ (ref-variable transcript-list-breadth-limit)))
+ (write-to-string value))))
\f
(define (call-with-transcript-buffer procedure)
(let ((buffer (transcript-buffer)))
(bind-condition-handler (list condition-type:error)
evaluation-error-handler
(lambda ()
- (parameterize* (list (cons current-input-port dummy-i/o-port))
- (lambda ()
- (with-output-to-transcript-buffer thunk))))))
+ (parameterize ((current-input-port dummy-i/o-port))
+ (with-output-to-transcript-buffer thunk)))))
\f
;;;; Stepper Mode
(lambda ()
(catch-file-errors (lambda (condition) condition #f)
(lambda ()
- (parameterize*
- (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load pathname '(EDWIN))))))))))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (load pathname '(EDWIN)))))))))))
(if (and (procedure? database)
(procedure-arity-valid? database 1))
(database buffer)
(define (with-output-to-help-display thunk)
(string->temporary-buffer (call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port
- port))
- thunk)))
+ (parameterize ((current-output-port port))
+ (thunk))))
"*Help*"
'(READ-ONLY)))
(detach-thread thread)
thread))))
(attach-buffer-interface-port! buffer port)
- (parameterize* (list (cons param:exit-hook inferior-repl/exit)
- (cons param:suspend-hook inferior-repl/suspend))
- (lambda ()
- (dynamic-wind
- (lambda () unspecific)
- (lambda ()
- (repl/start (make-repl #f
- port
- environment
- #f
- `((ERROR-DECISION ,error-decision))
- user-initial-prompt)
- (make-init-message message)))
- (lambda ()
- (signal-thread-event editor-thread
- (lambda ()
- (unwind-inferior-repl-buffer buffer)))))))))
+ (parameterize ((param:exit-hook inferior-repl/exit)
+ (param:suspend-hook inferior-repl/suspend))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (repl/start (make-repl #f
+ port
+ environment
+ #f
+ `((ERROR-DECISION ,error-decision))
+ user-initial-prompt)
+ (make-init-message message)))
+ (lambda ()
+ (signal-thread-event editor-thread
+ (lambda ()
+ (unwind-inferior-repl-buffer buffer))))))))
buffer))
(define (make-init-message message)
(lambda (mark)
(if mark
(insert-string
- (parameterize* (list (cons param:print-with-maximum-readability?
- #t))
- (lambda ()
- (write-to-string expression)))
+ (parameterize ((param:print-with-maximum-readability? #t))
+ (write-to-string expression))
mark))))
(let ((port (buffer-interface-port buffer #t)))
;;(move-mark-to! (port/mark port) (buffer-end buffer))
(set-prompt-history-strings!
'REPEAT-COMPLEX-COMMAND
(map (lambda (command)
- (parameterize* (list (cons param:print-with-maximum-readability?
- #t))
- (lambda ()
- (write-to-string command))))
+ (parameterize ((param:print-with-maximum-readability? #t))
+ (write-to-string command)))
(command-history-list)))
(execute-command-history-entry
(read-from-string
((symbol? argl)
(insert-string " . " point)
(insert-string (symbol->string argl) point)))))
- (parameterize*
- (list (cons param:print-uninterned-symbols-by-name? #t))
- (lambda ()
- (message procedure-name ": " argl)))))
+ (parameterize ((param:print-uninterned-symbols-by-name? #t))
+ (message procedure-name ": " argl))))
(editor-error "Expression does not evaluate to a procedure: "
(extract-string start end))))))))
(with-output-to-window-point (current-window) thunk))
(define (with-output-to-window-point window thunk)
- (parameterize* (list (cons current-output-port (window-output-port window)))
- thunk))
+ (parameterize ((current-output-port (window-output-port window)))
+ (thunk)))
(define (window-output-port window)
(make-port window-output-port-type window))
(if (not (option-loaded? name))
(let ((kernel
(lambda ()
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load-option name))))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (load-option name)))))
(if (nearest-cmdl/batch-mode?)
(kernel)
(with-notification
(lambda (inport)
(let loop ()
(let ((form
- (parameterize* (list (cons param:reader-fold-case? #f))
- (lambda ()
- (read inport)))))
+ (parameterize ((param:reader-fold-case? #f))
+ (read inport))))
(if (not (eof-object? form))
(begin
(include-cdecl form new-cwd twd includes)
(if (< n (expt 10 (- k 1)))
(string-append (string-pad-left (number->string n) (- k 1)) " ")
(let ((s
- (parameterize* (list (cons param:flonum-printer-cutoff
- `(RELATIVE ,k ENGINEERING)))
- (lambda ()
- (number->string (exact->inexact n))))))
+ (parameterize ((param:flonum-printer-cutoff
+ `(RELATIVE ,k ENGINEERING)))
+ (number->string (exact->inexact n)))))
(let ((regs (re-string-match "\\([0-9.]+\\)e\\([0-9]+\\)" s)))
(let ((mantissa (re-match-extract s regs 1))
(exponent (string->number (re-match-extract s regs 2))))
(lambda (original-body state)
(call-with-current-continuation
(lambda (continuation)
- (parameterize* (list (cons advice-continuation continuation))
- (lambda ()
- (with-restart 'use-value
- "Return a value from the advised procedure."
- continuation
- (lambda ()
- (prompt-for-evaluated-expression "Procedure value"))
+ (parameterize ((advice-continuation continuation))
+ (with-restart 'use-value
+ "Return a value from the advised procedure."
+ continuation
(lambda ()
+ (prompt-for-evaluated-expression "Procedure value"))
+ (lambda ()
+ (for-each (lambda (advice)
+ (with-simple-restart 'continue
+ "Continue with advised procedure."
+ (lambda ()
+ (advice procedure arguments environment))))
+ (car state))
+ (let ((value (scode-eval original-body environment)))
(for-each (lambda (advice)
(with-simple-restart 'continue
- "Continue with advised procedure."
+ "Return from advised procedure."
(lambda ()
- (advice procedure arguments environment))))
- (car state))
- (let ((value (scode-eval original-body environment)))
- (for-each (lambda (advice)
- (with-simple-restart 'continue
- "Return from advised procedure."
- (lambda ()
- (advice procedure
- arguments
- value
- environment))))
- (cdr state))
- value)))))))))))
+ (advice procedure
+ arguments
+ value
+ environment))))
+ (cdr state))
+ value))))))))))
(define advice-continuation)
\f
;;;; Break
(define (break-entry-advice procedure arguments environment)
- (parameterize* (list (cons the-procedure procedure)
- (cons the-arguments arguments))
- (lambda ()
- (break-rep environment "Breakpoint on entry" procedure arguments))))
+ (parameterize ((the-procedure procedure)
+ (the-arguments arguments))
+ (break-rep environment "Breakpoint on entry" procedure arguments)))
(define (break-exit-advice procedure arguments result environment)
- (parameterize* (list (cons the-procedure procedure)
- (cons the-arguments arguments)
- (cons the-result result))
- (lambda ()
- (break-rep environment "Breakpoint on exit" procedure arguments result)))
+ (parameterize ((the-procedure procedure)
+ (the-arguments arguments)
+ (the-result result))
+ (break-rep environment "Breakpoint on exit" procedure arguments result))
result)
(define (break-rep environment message . info)
(set! *command-line-arguments* '())
(let ((unused (or ((ucode-primitive get-unused-command-line 0)) '#())))
- (parameterize* (list (cons param:load-init-file? #t))
- (lambda ()
- (process-keyword (vector->list unused) '())
- (for-each (lambda (act) (act))
- (reverse after-parsing-actions))
- (if (and (param:load-init-file?)
- (not (nearest-cmdl/batch-mode?)))
- (load-init-file)))))))
+ (parameterize ((param:load-init-file? #t))
+ (process-keyword (vector->list unused) '())
+ (for-each (lambda (act) (act))
+ (reverse after-parsing-actions))
+ (if (and (param:load-init-file?)
+ (not (nearest-cmdl/batch-mode?)))
+ (load-init-file))))))
(define (find-keyword-parser keyword)
(let ((entry (assoc (strip-leading-hyphens keyword) *command-line-parsers*)))
(lambda (arg)
(run-in-nearest-repl
(lambda (repl)
- (parameterize* (list (cons param:suppress-loading-message?
- (cmdl/batch-mode? repl)))
- (lambda ()
- (load arg (repl/environment repl)))))))
+ (parameterize ((param:suppress-loading-message?
+ (cmdl/batch-mode? repl)))
+ (load arg (repl/environment repl))))))
"Loads the argument files as if in the REPL."
"In batch mode, loading messages are suppressed.")
(let ((x
(call-with-truncated-output-string length
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk)))))
+ (parameterize ((current-output-port port))
+ (thunk))))))
(if (and (car x) (> length 4))
(string-append (string-slice (cdr x) 0 (- length 4))
" ...")
(output-to-string
50
(lambda ()
- (parameterize* (list (cons param:print-primitives-by-name? #t))
- (lambda ()
- (write (unsyntax expression)))))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (write (unsyntax expression))))))
((debugging-info/noise? expression)
(output-to-string
50
(define *port*)
(define (command/internal dstate port)
- (parameterize* (list (cons *dstate* dstate)
- (cons *port* port))
- (lambda ()
- (debug/read-eval-print (->environment '(runtime debugger))
- "the debugger"
- "the debugger environment"))))
+ (parameterize ((*dstate* dstate)
+ (*port* port))
+ (debug/read-eval-print (->environment '(runtime debugger))
+ "the debugger"
+ "the debugger environment")))
(define-command (command/frame dstate port)
(debugger-presentation port
(string-titlecase (if reason (string-append reason "; " message) message)))
(define (debugger-pp expression indentation port)
- (parameterize* (list (cons param:printer-list-depth-limit
- debugger:list-depth-limit)
- (cons param:printer-list-breadth-limit
- debugger:list-breadth-limit)
- (cons param:printer-string-length-limit
- debugger:string-length-limit))
- (lambda ()
- (pretty-print expression port true indentation))))
+ (parameterize ((param:printer-list-depth-limit debugger:list-depth-limit)
+ (param:printer-list-breadth-limit debugger:list-breadth-limit)
+ (param:printer-string-length-limit
+ debugger:string-length-limit))
+ (pretty-print expression port true indentation)))
(define expression-indentation 4)
\f
(error:wrong-type-argument effector "effector" 'with-restart))
(if (not (or (not interactor) (procedure? interactor)))
(error:wrong-type-argument interactor "interactor" 'with-restart))
- (parameterize*
- (list (cons param:bound-restarts
- (cons (%make-restart name reporter effector interactor)
- (param:bound-restarts))))
- thunk))
+ (parameterize ((param:bound-restarts
+ (cons (%make-restart name reporter effector interactor)
+ (param:bound-restarts))))
+ (thunk)))
(define (with-simple-restart name reporter thunk)
(call-with-current-continuation
(define (bind-condition-handler types handler thunk)
(guarantee-condition-types types 'bind-condition-handler)
(guarantee-condition-handler handler 'bind-condition-handler)
- (parameterize*
- (list (cons dynamic-handler-frames
- (cons (cons types handler) (dynamic-handler-frames))))
- thunk))
+ (parameterize ((dynamic-handler-frames
+ (cons (cons types handler) (dynamic-handler-frames))))
+ (thunk)))
(define-integrable (guarantee-condition-handler object caller)
(guarantee unary-procedure? object caller))
(if (let ((types (break-on-signals-types)))
(and (pair? types)
(intersect-generalizations? types)))
- (parameterize* (list (cons break-on-signals-types '()))
- (lambda ()
- (breakpoint-procedure 'inherit
- "BKPT entered because of BREAK-ON-SIGNALS:"
- condition))))
+ (parameterize ((break-on-signals-types '()))
+ (breakpoint-procedure 'inherit
+ "BKPT entered because of BREAK-ON-SIGNALS:"
+ condition)))
(do ((frames (dynamic-handler-frames) (cdr frames)))
((not (pair? frames)))
(if (let ((types (caar frames)))
(or (not (pair? types))
(intersect-generalizations? types)))
- (parameterize* (list (cons dynamic-handler-frames (cdr frames)))
- (lambda ()
- (hook/invoke-condition-handler (cdar frames) condition)))))
+ (parameterize ((dynamic-handler-frames (cdr frames)))
+ (hook/invoke-condition-handler (cdar frames) condition))))
(do ((frames (static-handler-frames) (cdr frames)))
((not (pair? frames)))
(if (let ((types (caar frames)))
(or (not (pair? types))
(intersect-generalizations? types)))
- (parameterize* (list (cons dynamic-handler-frames '())
- (cons static-handler-frames (cdr frames)))
- (lambda ()
- (hook/invoke-condition-handler (cdar frames) condition)))))
+ (parameterize ((dynamic-handler-frames '())
+ (static-handler-frames (cdr frames)))
+ (hook/invoke-condition-handler (cdar frames) condition))))
unspecific)))
\f
;;;; Standard Condition Signallers
standard-error-hook)))
(if hook
(fluid-let ((standard-error-hook #!default))
- (parameterize* (list (cons param:standard-error-hook #f))
- (lambda ()
- (hook condition))))))
+ (parameterize ((param:standard-error-hook #f))
+ (hook condition)))))
(repl/start (push-repl 'inherit condition '() "error>")))
(define (standard-warning-handler condition)
standard-warning-hook)))
(if hook
(fluid-let ((standard-warning-hook #!default))
- (parameterize* (list (cons param:standard-warning-hook #f))
- (lambda ()
- (hook condition))))
+ (parameterize ((param:standard-warning-hook #f))
+ (hook condition)))
(let ((port (notification-output-port)))
(fresh-line port)
(write-string ";Warning: " port)
(else (error "Unexpected value:" v)))))))
(define (format-error-message message irritants port)
- (parameterize* (list (cons param:printer-list-depth-limit 2)
- (cons param:printer-list-breadth-limit 5))
- (lambda ()
- (for-each (lambda (irritant)
- (if (and (pair? irritant)
- (eq? (car irritant) error-irritant/noise-tag))
- (display (cdr irritant) port)
- (begin
- (write-char #\space port)
- (write irritant port))))
- (cons (if (string? message)
- (error-irritant/noise message)
- message)
- irritants)))))
+ (parameterize ((param:printer-list-depth-limit 2)
+ (param:printer-list-breadth-limit 5))
+ (for-each (lambda (irritant)
+ (if (and (pair? irritant)
+ (eq? (car irritant) error-irritant/noise-tag))
+ (display (cdr irritant) port)
+ (begin
+ (write-char #\space port)
+ (write irritant port))))
+ (cons (if (string? message)
+ (error-irritant/noise message)
+ message)
+ irritants))))
(define-integrable (error-irritant/noise noise)
(cons error-irritant/noise-tag noise))
(if (not (option-loaded? name))
(let ((kernel
(lambda ()
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load-option name))))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (load-option name)))))
(if (nearest-cmdl/batch-mode?)
(kernel)
(with-notification
(define ((make-with-input-from-file call) input-specifier thunk)
(call input-specifier
(lambda (port)
- (parameterize* (list (cons current-input-port port))
- thunk))))
+ (parameterize ((current-input-port port))
+ (thunk)))))
(define with-input-from-file
(make-with-input-from-file call-with-input-file))
(define ((make-with-output-to-file call) output-specifier thunk)
(call output-specifier
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk))))
+ (parameterize ((current-output-port port))
+ (thunk)))))
(define with-output-to-file
(make-with-output-to-file call-with-output-file))
(define ((hardware-trap-noise frame) long?)
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- (hardware-trap-frame/describe frame long?))))))
+ (parameterize ((current-output-port port))
+ (hardware-trap-frame/describe frame long?)))))
\f
(define (method/compiled-code frame)
(let ((get-environment
(make-settable-parameter '()))
(define (with-directory-rewriting-rule match replace thunk)
- (parameterize*
- (list (cons directory-rewriting-rules
- (cons (cons (pathname-as-directory (merge-pathnames match))
- replace)
- (directory-rewriting-rules))))
- thunk))
+ (parameterize ((directory-rewriting-rules
+ (cons (cons (pathname-as-directory (merge-pathnames match))
+ replace)
+ (directory-rewriting-rules))))
+ (thunk)))
(define (add-directory-rewriting-rule! match replace)
(let ((match (pathname-as-directory (merge-pathnames match))))
(define (wrap-loader pathname loader)
(lambda (environment purify?)
(lambda ()
- (parameterize* (list (cons current-load-pathname pathname)
- (cons current-load-environment environment))
- (lambda ()
- (loader environment purify?))))))
+ (parameterize ((current-load-pathname pathname)
+ (current-load-environment environment))
+ (loader environment purify?)))))
\f
(define (fasload pathname #!optional suppress-notifications?)
(receive (pathname* loader notifier) (choose-fasload-method pathname)
suppress-notifications?)
#f
(param:write-notifications?))))
- (parameterize* (list (cons param:write-notifications? notify?))
- (lambda ()
- (if notify?
- (notifier loader)
- (loader))))))
+ (parameterize ((param:write-notifications? notify?))
+ (if notify?
+ (notifier loader)
+ (loader)))))
(define (loading-notifier pathname)
(lambda (thunk)
(define (handle-load-hooks thunk)
(receive (result hooks)
(fluid-let ((load/loading? #t)) ;backwards compatibility
- (parameterize* (list (cons param:loading? #t)
- (cons param:after-load-hooks '()))
- (lambda ()
- (let ((result (thunk)))
- (values result (reverse (param:after-load-hooks)))))))
+ (parameterize ((param:loading? #t)
+ (param:after-load-hooks '()))
+ (let ((result (thunk)))
+ (values result (reverse (param:after-load-hooks))))))
(for-each (lambda (hook) (hook)) hooks)
result))
(apply scons-begin (read-files filenames #t)))))))
(define (read-files filenames fold-case?)
- (parameterize* (list (cons param:reader-fold-case? fold-case?))
- (lambda ()
- (append-map read-file filenames))))
+ (parameterize ((param:reader-fold-case? fold-case?))
+ (append-map read-file filenames)))
\f
(define $define-values
(spar-transformer->runtime
(lambda (pathname)
(merge-pathnames pathname directory-path)))
(let ((fnames (generate-directory-pathnames pattern)))
- (parameterize* (list (cons *expand-directory-prefixes?* #f))
- (lambda ()
- (map ->pathname fnames)))))))
+ (parameterize ((*expand-directory-prefixes?* #f))
+ (map ->pathname fnames))))))
(define (generate-directory-pathnames pathname)
(let ((channel (directory-channel-open (->namestring pathname))))
(cons (merge-pathnames (car entry) directory-path)
(cdr entry))))
(let ((entries (generate-directory-entries pattern)))
- (parameterize* (list (cons *expand-directory-prefixes?* #f))
- (lambda ()
- (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry)))
- entries)))))))
+ (parameterize ((*expand-directory-prefixes?* #f))
+ (map (lambda (entry) (cons (->pathname (car entry)) (cdr entry)))
+ entries))))))
(define (generate-directory-entries pathname)
(let ((channel (directory-channel-open (->namestring pathname))))
(define (search-parent pathname)
(call-with-values
(lambda ()
- (parameterize* (list (cons *options* '())
- (cons *parent* #f)
- (cons param:suppress-loading-message? #t))
- (lambda ()
- (load pathname (simple-top-level-environment #t))
- (values (*options*) (*parent*)))))
+ (parameterize ((*options* '())
+ (*parent* #f)
+ (param:suppress-loading-message? #t))
+ (load pathname (simple-top-level-environment #t))
+ (values (*options*) (*parent*))))
find-option))
(if (memq name loaded-options)
0)))
(define (pp-top-level expression port as-code? indentation list-depth)
- (parameterize* (list (cons x-size
- (- (or (get-param:pp-forced-x-size)
- (output-port/x-size port))
- 1))
- (cons output-port port)
- (cons param:print-uninterned-symbols-by-name?
- (get-param:pp-uninterned-symbols-by-name?))
- (cons param:printer-abbreviate-quotations?
- (or as-code?
- (param:printer-abbreviate-quotations?))))
- (lambda ()
- (let* ((numerical-walk
- (if (get-param:pp-avoid-circularity?)
- numerical-walk-avoid-circularities
- numerical-walk))
- (node (numerical-walk expression list-depth)))
- (if (positive? indentation)
- (*print-string (make-string indentation #\space)))
- (if as-code?
- (print-node node indentation list-depth)
- (print-non-code-node node indentation list-depth))
- (output-port/discretionary-flush port)))))
+ (parameterize ((x-size
+ (- (or (get-param:pp-forced-x-size)
+ (output-port/x-size port))
+ 1))
+ (output-port port)
+ (param:print-uninterned-symbols-by-name?
+ (get-param:pp-uninterned-symbols-by-name?))
+ (param:printer-abbreviate-quotations?
+ (or as-code?
+ (param:printer-abbreviate-quotations?))))
+ (let* ((numerical-walk
+ (if (get-param:pp-avoid-circularity?)
+ numerical-walk-avoid-circularities
+ numerical-walk))
+ (node (numerical-walk expression list-depth)))
+ (if (positive? indentation)
+ (*print-string (make-string indentation #\space)))
+ (if as-code?
+ (print-node node indentation list-depth)
+ (print-non-code-node node indentation list-depth))
+ (output-port/discretionary-flush port))))
(define x-size)
(define output-port)
(*print-char #\newline))
\f
(define (print-non-code-node node column depth)
- (parameterize* (list (cons dispatch-list '())
- (cons dispatch-default
- (if (get-param:pp-lists-as-tables?)
- print-data-table
- print-data-column)))
- (lambda ()
- (print-node node column depth))))
+ (parameterize ((dispatch-list '())
+ (dispatch-default
+ (if (get-param:pp-lists-as-tables?)
+ print-data-table
+ print-data-column)))
+ (print-node node column depth)))
(define (print-code-node node column depth)
- (parameterize* (list (cons dispatch-list (code-dispatch-list))
- (cons dispatch-default print-combination))
- (lambda ()
- (print-node node column depth))))
+ (parameterize ((dispatch-list (code-dispatch-list))
+ (dispatch-default print-combination))
+ (print-node node column depth)))
(define (print-data-column nodes column depth)
(*print-open)
(define (walk-highlighted-object object list-depth numerical-walk)
(let ((dl (pph/depth-limit object)))
- (parameterize* (list (cons param:printer-list-breadth-limit
- (let ((bl (pph/breadth-limit object)))
- (if (eq? bl 'default)
- (param:printer-list-breadth-limit)
- bl)))
- (cons param:printer-list-depth-limit
- (if (eq? dl 'default)
- (param:printer-list-depth-limit)
- dl)))
- (lambda ()
- (numerical-walk (pph/object object)
- (if (eq? dl 'default)
- list-depth
- 0))))))
+ (parameterize ((param:printer-list-breadth-limit
+ (let ((bl (pph/breadth-limit object)))
+ (if (eq? bl 'default)
+ (param:printer-list-breadth-limit)
+ bl)))
+ (param:printer-list-depth-limit
+ (if (eq? dl 'default)
+ (param:printer-list-depth-limit)
+ dl)))
+ (numerical-walk (pph/object object)
+ (if (eq? dl 'default)
+ list-depth
+ 0)))))
\f
;;; The following are circular list/vector handing procedures. They allow
;; do not have enough information to determine what the
;; variable name was. The original block can be used for
;; this, but it may as well be copied then.
- (parameterize* (list (cons *copy-constants?*
- (if (default-object? copy-constants?)
- *default/copy-constants?*
- copy-constants?))
- (cons *object-copies*
- (make-object-association-table)))
- (lambda ()
- (copy-object exp))))
+ (parameterize ((*copy-constants?*
+ (if (default-object? copy-constants?)
+ *default/copy-constants?*
+ copy-constants?))
+ (*object-copies* (make-object-association-table)))
+ (copy-object exp)))
(define (copy-object obj)
(let ((association (object-association obj)))
(textual-port-char-set (context-port context)))
(define (with-current-unparser-state context procedure)
- (parameterize* (list (cons initial-context context))
- (lambda ()
- (procedure (context-port context)))))
+ (parameterize ((initial-context context))
+ (procedure (context-port context))))
(define-deferred initial-context
(make-unsettable-parameter #f))
context)))))
(define (call-print-method print-method object context)
- (parameterize* (list (cons initial-context context))
- (lambda ()
- (print-method object (context-port context)))))
+ (parameterize ((initial-context context))
+ (print-method object (context-port context))))
(define (get-print-method-parts object)
(let ((print-method (get-print-method object)))
(pathname-defaults (param:default-pathname-defaults)))
(let ((thunk
(lambda ()
- (parameterize*
- (list (cons current-input-port #f)
- (cons current-output-port #f)
- (cons notification-output-port #f)
- (cons trace-output-port #f)
- (cons interaction-i/o-port #f)
- (cons working-directory-pathname
- (working-directory-pathname))
- (cons param:nearest-cmdl cmdl)
- (cons param:standard-error-hook #f)
- (cons param:standard-warning-hook #f)
- (cons param:standard-breakpoint-hook #f)
- (cons param:default-pathname-defaults pathname-defaults)
- (cons dynamic-handler-frames '())
- (cons param:bound-restarts
- (if (cmdl/parent cmdl) (param:bound-restarts) '())))
- (lambda ()
- (fluid-let ((*default-pathname-defaults* pathname-defaults))
- (let loop ((message message))
- (loop
- (bind-abort-restart cmdl
- (lambda ()
- (with-interrupt-mask interrupt-mask/all
- (lambda (interrupt-mask)
- interrupt-mask
- (unblock-thread-events)
- (ignore-errors
- (lambda ()
- ((->cmdl-message message) cmdl)))
- (call-with-current-continuation
- (lambda (continuation)
- (with-create-thread-continuation continuation
- (lambda ()
- ((cmdl/driver cmdl) cmdl))))))))))))))))
+ (parameterize ((current-input-port #f)
+ (current-output-port #f)
+ (notification-output-port #f)
+ (trace-output-port #f)
+ (interaction-i/o-port #f)
+ (working-directory-pathname
+ (working-directory-pathname))
+ (param:nearest-cmdl cmdl)
+ (param:standard-error-hook #f)
+ (param:standard-warning-hook #f)
+ (param:standard-breakpoint-hook #f)
+ (param:default-pathname-defaults pathname-defaults)
+ (dynamic-handler-frames '())
+ (param:bound-restarts
+ (if (cmdl/parent cmdl)
+ (param:bound-restarts)
+ '())))
+ (fluid-let ((*default-pathname-defaults* pathname-defaults))
+ (let loop ((message message))
+ (loop
+ (bind-abort-restart cmdl
+ (lambda ()
+ (with-interrupt-mask interrupt-mask/all
+ (lambda (interrupt-mask)
+ interrupt-mask
+ (unblock-thread-events)
+ (ignore-errors
+ (lambda ()
+ ((->cmdl-message message) cmdl)))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (with-create-thread-continuation continuation
+ (lambda ()
+ ((cmdl/driver cmdl) cmdl)))))))))))))))
(mutex (textual-port-thread-mutex port)))
(let ((thread (current-thread))
(owner (thread-mutex-owner mutex)))
(or message
(and condition
(cmdl-message/strings
- (parameterize*
- (list (cons param:printer-list-depth-limit 25)
- (cons param:printer-list-breadth-limit 100)
- (cons param:printer-string-length-limit 500))
- (lambda ()
- (condition/report-string condition))))))
+ (parameterize ((param:printer-list-depth-limit 25)
+ (param:printer-list-breadth-limit 100)
+ (param:printer-string-length-limit 500))
+ (condition/report-string condition)))))
(and condition
repl:allow-restart-notifications?
(condition-restarts-message condition))
standard-breakpoint-hook)))
(if hook
(fluid-let ((standard-breakpoint-hook #!default))
- (parameterize* (list (cons param:standard-breakpoint-hook #f))
- (lambda ()
- (hook condition))))))
+ (parameterize ((param:standard-breakpoint-hook #f))
+ (hook condition)))))
(repl/start (push-repl (breakpoint/environment condition)
condition
'()
(lambda ()
(set! time-world-saved time)
(set! time-world-restored (get-universal-time))
- (parameterize* (list (cons *within-restore-window?* #t))
- (lambda ()
- (event-distributor/invoke! event:after-restore)))
+ (parameterize ((*within-restore-window?* #t))
+ (event-distributor/invoke! event:after-restore))
(start-thread-timer)
(cond ((string? id)
(set! world-id id)
(let ((stack-frame (continuation/first-subproblem continuation)))
(if (eq? stack-frame-type/compiled-return-address
(stack-frame/type stack-frame))
- (parameterize*
- (list (cons stack-sampling-return-address
- (stack-frame/return-address stack-frame)))
- thunk)
+ (parameterize ((stack-sampling-return-address
+ (stack-frame/return-address stack-frame)))
+ (thunk))
(thunk)))))))
\f
;;;; Profile Data
(define (profile-pp expression output-port)
;; Random parametrization.
- (parameterize* (list (cons param:printer-list-breadth-limit 5)
- (cons param:printer-list-depth-limit 3)
- (cons param:printer-string-length-limit 40)
- (cons param:print-primitives-by-name? #t)
- (cons param:pp-save-vertical-space? #t)
- (cons param:pp-default-as-code? #t))
- (lambda ()
- (pp expression output-port))))
\ No newline at end of file
+ (parameterize ((param:printer-list-breadth-limit 5)
+ (param:printer-list-depth-limit 3)
+ (param:printer-string-length-limit 40)
+ (param:print-primitives-by-name? #t)
+ (param:pp-save-vertical-space? #t)
+ (param:pp-default-as-code? #t))
+ (pp expression output-port)))
\ No newline at end of file
;; obsolete
(define (with-input-from-string string thunk)
- (parameterize* (list (cons current-input-port (open-input-string string)))
- thunk))
+ (parameterize ((current-input-port (open-input-string string)))
+ (thunk)))
(define (call-with-input-string string procedure)
(procedure (open-input-string string)))
(define (with-output-to-string thunk)
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk))))
+ (parameterize ((current-output-port port))
+ (thunk)))))
;; deprecated
(define (with-output-to-truncated-string limit thunk)
(call-with-truncated-output-string limit
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- thunk))))
+ (parameterize ((current-output-port port))
+ (thunk)))))
\f
(define (open-output-string)
(make-textual-port string-output-type (make-ostate (string-builder) 0)))
;;;; Compiler
(define (compile-top-level pattern caller-context env)
- (parameterize* (list (cons name-counters (make-strong-eq-hash-table)))
- (lambda ()
- (optimize-result
- (compile-pattern pattern caller-context env)))))
+ (parameterize ((name-counters (make-strong-eq-hash-table)))
+ (optimize-result
+ (compile-pattern pattern caller-context env))))
(define (compile-pattern pattern caller-context env)
(let ((pattern* (rewrite-pattern pattern)))
(do () (#f)
(with-simple-restart 'abort "Return to SLIME top-level."
(lambda ()
- (parameterize* (list (cons *top-level-restart* (find-restart 'abort)))
- (lambda ()
- (process-one-message socket 0)))))))
+ (parameterize ((*top-level-restart* (find-restart 'abort)))
+ (process-one-message socket 0))))))
(define *top-level-restart*)
(define *index*)
(define (emacs-rex socket sexp pstring id)
- (parameterize* (list (cons *buffer-pstring* pstring)
- (cons *index* id))
- (lambda ()
- (eval (cons* (car sexp) socket (map quote-special (cdr sexp)))
- swank-env))))
+ (parameterize ((*buffer-pstring* pstring)
+ (*index* id))
+ (eval (cons* (car sexp) socket (map quote-special (cdr sexp)))
+ swank-env)))
(define *buffer-pstring*)
(let ((p (make-textual-port repl-port-type socket)))
(dynamic-wind
(lambda () unspecific)
- (lambda () (parameterize* (list (cons current-output-port p)) thunk))
+ (lambda () (parameterize ((current-output-port p)) (thunk)))
(lambda () (flush-output-port p)))))
(define repl-port-type)
socket
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- ((environment-lookup #f 'compiler:disassemble)
- (eval (read-from-string string)
- (buffer-env))))))))
+ (parameterize ((current-output-port port))
+ ((environment-lookup #f 'compiler:disassemble)
+ (eval (read-from-string string)
+ (buffer-env)))))))
;;;; Directory Functions
(define (swank:default-directory socket)
(lambda ()
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- (carefully-pa
- (eval (read-from-string name)
- (pstring->env pstring)))))))))))
+ (parameterize ((current-output-port port))
+ (carefully-pa
+ (eval (read-from-string name)
+ (pstring->env pstring))))))))))
(if (condition? v) 'nil v)))
(define (carefully-pa o)
(string-trim
(call-with-output-string
(lambda (port)
- (parameterize*
- (list (cons current-output-port port))
- (lambda () (pa binding))))))))
+ (parameterize ((current-output-port port))
+ (pa binding)))))))
#f))
(let ((extra (assq symbol swank-extra-documentation)))
(if extra
(define *sldb-state*)
(define (invoke-sldb socket level condition)
- (parameterize*
- (list (cons *sldb-state*
- (make-sldb-state condition (bound-restarts-for-emacs))))
- (lambda ()
- (dynamic-wind
- (lambda () #f)
- (lambda ()
- (write-message `(:debug 0 ,level ,@(sldb-info (*sldb-state*) 0 20))
- socket)
- (sldb-loop level socket))
- (lambda ()
- (write-message `(:debug-return 0 ,(- level 1) 'nil) socket))))))
+ (parameterize ((*sldb-state*
+ (make-sldb-state condition (bound-restarts-for-emacs))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (write-message `(:debug 0 ,level ,@(sldb-info (*sldb-state*) 0 20))
+ socket)
+ (sldb-loop level socket))
+ (lambda ()
+ (write-message `(:debug-return 0 ,(- level 1) 'nil) socket)))))
(define (sldb-loop level socket)
(write-message `(:debug-activate 0 ,level) socket)
(cond ((debugging-info/compiled-code? expression)
(write-string ";unknown compiled code" port))
((not (debugging-info/undefined-expression? expression))
- (parameterize* (list (cons param:print-primitives-by-name? #t))
- (lambda ()
- (write
- (unsyntax
- (if (or (debugging-info/undefined-expression? subexpression)
- (debugging-info/unknown-expression? subexpression))
- expression
- subexpression))
- port))))
+ (parameterize ((param:print-primitives-by-name? #t))
+ (write
+ (unsyntax
+ (if (or (debugging-info/undefined-expression? subexpression)
+ (debugging-info/unknown-expression? subexpression))
+ expression
+ subexpression))
+ port)))
((debugging-info/noise? expression)
(write-string ";" port)
(write-string ((debugging-info/noise expression) #f)
(stream (iline "block" (compiled-entry/block o))
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- ((environment-lookup #f 'compiler:disassemble)
- o)))))))))
+ (parameterize ((current-output-port port))
+ ((environment-lookup #f 'compiler:disassemble)
+ o))))))))
(define (inspect-code-block block)
(let loop ((i (compiled-code-block/constants-start block)))
(iline "env" (compiled-code-block/environment block))
(call-with-output-string
(lambda (port)
- (parameterize* (list (cons current-output-port port))
- (lambda ()
- ((environment-lookup #f 'compiler:disassemble)
- block)))))))))
+ (parameterize ((current-output-port port))
+ ((environment-lookup #f 'compiler:disassemble)
+ block))))))))
(define (inspect-scode o)
(stream (pprint-to-string o)))
(define (pprint-to-string o)
(call-with-output-string
(lambda (p)
- (parameterize* (list (cons param:printer-list-breadth-limit 10)
- (cons param:printer-list-depth-limit 4)
- (cons param:printer-string-length-limit 100))
- (lambda ()
- (pp o p))))))
+ (parameterize ((param:printer-list-breadth-limit 10)
+ (param:printer-list-depth-limit 4)
+ (param:printer-string-length-limit 100))
+ (pp o p)))))
;; quote keywords, t and nil
(define (quote-special x)
((rdb:identifier-renamer (rename-db)) new-identifier))
(define (with-identifier-renaming thunk)
- (parameterize* (list (cons rename-db (initial-rename-db)))
- (lambda () (post-process-output (thunk)))))
+ (parameterize ((rename-db (initial-rename-db)))
+ (post-process-output (thunk))))
(define-deferred rename-db
(make-unsettable-parameter 'unbound))
(make-unsettable-parameter unspecific))
(define (with-error-context form senv hist thunk)
- (parameterize* (list (cons error-context (serror-ctx form senv hist)))
- thunk))
+ (parameterize ((error-context (serror-ctx form senv hist)))
+ (thunk)))
;;; External signaller for macros.
(define (syntax-error message . irritants)
(current-input-port port))
(define (with-input-from-port port thunk)
- (parameterize* (list (cons current-input-port port))
- thunk))
+ (parameterize ((current-input-port port))
+ (thunk)))
(define (set-current-output-port! port)
(current-output-port port))
(define (with-output-to-port port thunk)
- (parameterize* (list (cons current-output-port port))
- thunk))
+ (parameterize ((current-output-port port))
+ (thunk)))
(define (set-notification-output-port! port)
(notification-output-port port))
(define (with-notification-output-port port thunk)
- (parameterize* (list (cons notification-output-port port))
- thunk))
+ (parameterize ((notification-output-port port))
+ (thunk)))
(define (set-trace-output-port! port)
(trace-output-port port))
(define (with-trace-output-port port thunk)
- (parameterize* (list (cons trace-output-port port))
- thunk))
+ (parameterize ((trace-output-port port))
+ (thunk)))
(define (set-interaction-i/o-port! port)
(interaction-i/o-port port))
(define (with-interaction-i/o-port port thunk)
- (parameterize* (list (cons interaction-i/o-port port))
- thunk))
\ No newline at end of file
+ (parameterize ((interaction-i/o-port port))
+ (thunk)))
\ No newline at end of file
(error:wrong-type-argument continuation
"continuation"
with-create-thread-continuation))
- (parameterize* (list (cons root-continuation-default continuation))
- thunk))
+ (parameterize ((root-continuation-default continuation))
+ (thunk)))
\f
(define (current-thread)
(or first-running-thread
(define (unsyntax-with-substitutions scode alist)
(if (not (alist? alist))
(error:wrong-type-argument alist "alist" 'unsyntax-with-substitutions))
- (parameterize* (list (cons substitutions alist))
- (lambda ()
- (unsyntax scode))))
+ (parameterize ((substitutions alist))
+ (unsyntax scode)))
(define-integrable (maybe-substitute object thunk)
(let ((association (has-substitution? object)))
(merge-pathnames pathname directory-path))
(let ((pathnames
(let ((fnames (generate-directory-pathnames directory-path)))
- (parameterize*
- (list (cons *expand-directory-prefixes?* false))
- (lambda ()
- (map ->pathname fnames))))))
+ (parameterize ((*expand-directory-prefixes?* false))
+ (map ->pathname fnames)))))
(if (and (eq? (pathname-name pattern) 'wild)
(eq? (pathname-type pattern) 'wild))
pathnames
unspecific))
(lambda ()
(let ((v
- (parameterize* (list (cons *notification-depth*
- (1+ (*notification-depth*))))
- thunk)))
+ (parameterize ((*notification-depth*
+ (1+ (*notification-depth*))))
+ (thunk))))
(set! done? #t)
v))
(lambda ()
(thread-report port)))
(define (ticks->string ticks)
- (parameterize* (list (cons param:flonum-printer-cutoff '(absolute 3)))
- (lambda ()
- (number->string (internal-time/ticks->seconds ticks) 10))))
+ (parameterize ((param:flonum-printer-cutoff '(absolute 3)))
+ (number->string (internal-time/ticks->seconds ticks) 10)))
(define (write-time-interval secs port)
(let ((min/sec (integer-divide secs 60)))
(define (with-working-directory-pathname name thunk)
(let ((pathname (new-pathname name)))
(fluid-let ((*default-pathname-defaults* pathname))
- (parameterize* (list (cons param:default-pathname-defaults pathname)
- (cons working-directory-pathname pathname))
- thunk))))
+ (parameterize ((param:default-pathname-defaults pathname)
+ (working-directory-pathname pathname))
+ (thunk)))))
(define (new-pathname name)
(pathname-simplify
\f
;;; Debugging utility
(define (pp-expression form #!optional port)
- (parameterize* (list (cons param:pp-primitives-by-name? #f)
- (cons param:pp-uninterned-symbols-by-name? #f)
- (cons param:printer-abbreviate-quotations? #t))
- (lambda ()
- (pp (cgen/external-with-declarations form) port))))
\ No newline at end of file
+ (parameterize ((param:pp-primitives-by-name? #f)
+ (param:pp-uninterned-symbols-by-name? #f)
+ (param:printer-abbreviate-quotations? #t))
+ (pp (cgen/external-with-declarations form) port)))
\ No newline at end of file
(let ((f1-time (run-test f1-test)))
(let ((report
(lambda (name time scale)
- (parameterize* (list
- (cons param:flonum-printer-cutoff '(ABSOLUTE 2)))
- (lambda ()
- (newline)
- (write name)
- (write-string "-test:\t")
- (write (exact->inexact time))
- (write-string "\t")
- (write (exact->inexact (/ (/ time scale) f1-time))))))))
+ (parameterize ((param:flonum-printer-cutoff '(absolute 2)))
+ (newline)
+ (write name)
+ (write-string "-test:\t")
+ (write (exact->inexact time))
+ (write-string "\t")
+ (write (exact->inexact (/ (/ time scale) f1-time)))))))
(report 'f1 f1-time 1)
(for-each (lambda (name test scale)
(report name (run-test test) scale))
(let ((pathname (merge-pathnames pathname)))
(with-working-directory-pathname (directory-pathname pathname)
(lambda ()
- (parameterize* (list (cons current-load-pathname pathname)
- (cons current-load-environment environment))
- (lambda ()
- (fluid-let ((*sabbr-table* (make-strong-eq-hash-table)))
- (read-xml-file pathname
- `((scheme ,(pi-expander environment))
- (svar ,svar-expander)
- (sabbr ,sabbr-expander))))))))))
+ (parameterize ((current-load-pathname pathname)
+ (current-load-environment environment))
+ (fluid-let ((*sabbr-table* (make-strong-eq-hash-table)))
+ (read-xml-file pathname
+ `((scheme ,(pi-expander environment))
+ (svar ,svar-expander)
+ (sabbr ,sabbr-expander)))))))))
\f
(define (make-expansion-environment pathname)
(let ((environment (extend-top-level-environment expander-environment)))
(define ((pi-expander environment) text)
(fluid-let ((*outputs* (cons '() '())))
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (let ((port (open-input-string text)))
- (let loop ()
- (let ((expression (read port)))
- (if (not (eof-object? expression))
- (begin
- (expander-eval expression environment)
- (loop))))))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (let ((port (open-input-string text)))
+ (let loop ()
+ (let ((expression (read port)))
+ (if (not (eof-object? expression))
+ (begin
+ (expander-eval expression environment)
+ (loop)))))))
(car *outputs*)))
(define expander-eval eval)
(environment-define environment 'define-xmlrpc-method
(lambda (name handler)
(hash-table-set! methods name handler)))
- (parameterize* (list (cons param:suppress-loading-message? #t))
- (lambda ()
- (load pathname environment))))
+ (parameterize ((param:suppress-loading-message? #t))
+ (load pathname environment)))
(hash-table-ref/default methods name #f)))
\ No newline at end of file
(define (write-expr-property tag p port)
(write-tag tag port)
(write-char #\space port)
- (parameterize* (list (cons param:printer-abbreviate-quotations? #t))
- (lambda ()
- (write (cdr p) port))))
+ (parameterize ((param:printer-abbreviate-quotations? #t))
+ (write (cdr p) port)))
(define (write-feature tag p port)
(write-tag tag port)
projects / mit-scheme.git / commitdiff