(append-string "Copying files from working directory to floppy.\n")
(let* ((working-directory (read-working-directory))
(floppy-directory (read-floppy-directory)))
- (with-values
+ (call-with-values
(lambda ()
(three-way-sort file-record/name=?
working-directory
(let ((eol
(or (string-find-next-char string #\newline start end)
end)))
- (with-values
+ (call-with-values
(lambda ()
(parse-dosls-line string start eol offset))
(lambda (filename time)
(values '() '() set*)
(let ((item (member? (car set) set*)))
(if item
- (with-values
+ (call-with-values
(lambda () (loop (cdr set) (delq! (car item) set*)))
(lambda (set-only both set*-only)
(values set-only
(cons (cons (car set) (car item)) both)
set*-only)))
- (with-values (lambda () (loop (cdr set) set*))
+ (call-with-values (lambda () (loop (cdr set) set*))
(lambda (set-only both set*-only)
(values (cons (car set) set-only)
both
unspecific)
remote-links))
- (with-values prepare-constants-block
+ (call-with-values prepare-constants-block
(or process-constants-block
(lambda (constants-code environment-label free-ref-label
n-sections)
(make-expression
block
continuation
- (with-values
+ (call-with-values
(lambda ()
(let ((collect
(lambda (names declarations body)
(set-procedure-closure-context!
procedure
(make-reference-context original-parent))
- (with-values
+ (call-with-values
(lambda ()
(let ((uninteresting-variable?
(lambda (variable)
bound-variables
variables-nontransitively-free)
true)))
- (with-values
+ (call-with-values
(lambda ()
(filter-bound-variables (block-bound-variables block)
free-variables
(procedure (block-procedure block)))
(let ((delete-integrations
(lambda (get-names set-names!)
- (with-values
+ (call-with-values
(lambda ()
(find-integrated-variables (get-names procedure)))
(lambda (not-integrated integrated)
(begin
(set! deletions (eq-set-adjoin rest deletions))
(set-procedure-rest! procedure false))))
- (with-values
+ (call-with-values
(lambda ()
(find-integrated-bindings (procedure-names procedure)
(procedure-values procedure)))
(define (find-integrated-bindings names vals)
(if (null? names)
(values '() '() '())
- (with-values
+ (call-with-values
(lambda ()
(find-integrated-bindings (cdr names) (cdr vals)))
(lambda (names* values* integrated)
(define (find-integrated-variables variables)
(if (null? variables)
(values '() '())
- (with-values
+ (call-with-values
(lambda ()
(find-integrated-variables (cdr variables)))
(lambda (not-integrated integrated)
(begin
(edges-disconnect-right! previous-edges)
(edge-disconnect! next-edge)
- (with-values
+ (call-with-values
(lambda ()
(order-subproblems/application
(parallel-application-node parallel)
(operands
(list-filter-indices (cdr subproblems) (inliner/operands inliner))))
(set-inliner/operands! inliner operands)
- (with-values
+ (call-with-values
(lambda ()
(discriminate-items operands subproblem-simple?))
(lambda (simple complex)
\f
(define (order-subproblems/out-of-line combination subproblems rest)
(let ((alist (add-defaulted-subproblems! combination subproblems)))
- (with-values
+ (call-with-values
(combination-ordering (combination/context combination)
(car subproblems)
(cdr subproblems)
(combination/model combination))
(lambda (effect-subproblems push-subproblems)
(set-combination/frame-size! combination (length push-subproblems))
- (with-values
+ (call-with-values
(lambda ()
(order-subproblems/maybe-overwrite-block
combination push-subproblems rest alist
(if (and (procedure/open? model)
(stack-block/static-link? model-block))
(lambda ()
- (with-values thunk
+ (call-with-values thunk
(lambda (effect-subproblems push-subproblems)
(values
effect-subproblems
standard)))
\f
(define (optimized-combination-ordering context operator operands callee)
- (with-values
+ (call-with-values
(lambda ()
(sort-subproblems/out-of-line operands callee))
(lambda (integrated non-integrated)
subproblems))
\f
(define (sort-subproblems/out-of-line all-subproblems callee)
- (with-values
+ (call-with-values
(lambda ()
(sort-integrated (cdr (procedure-original-required callee))
all-subproblems
'()
'()))
(lambda (subproblems integrated non-integrated)
- (with-values
+ (call-with-values
(lambda ()
(sort-integrated (procedure-original-optional callee)
subproblems
(or (node/bad-variables node)
(let ((bad-variables
(eq-set-union
- (with-values (lambda () (find-node-values node))
+ (call-with-values (lambda () (find-node-values node))
values->variables)
(walk-next node walk-node-for-variables))))
(set-node/bad-variables! node bad-variables)
rvalues))))
\f
(define (complex-parallel-constraints subproblems vars-referenced-later)
- (with-values (lambda () (discriminate-items subproblems subproblem-simple?))
+ (call-with-values
+ (lambda () (discriminate-items subproblems subproblem-simple?))
(lambda (simple complex)
(let ((discriminate-by-bad-vars
(lambda (subproblems)
(memq var vars-referenced-later))
(subproblem-free-variables subproblem))))))
(constraint-graph (make-constraint-graph)))
- (with-values (lambda () (discriminate-by-bad-vars simple))
+ (call-with-values (lambda () (discriminate-by-bad-vars simple))
(lambda (good-simples bad-simples)
- (with-values (lambda () (discriminate-by-bad-vars complex))
+ (call-with-values (lambda () (discriminate-by-bad-vars complex))
(lambda (good-complex bad-complex)
(add-constraint-set! good-simples
good-complex
(eq? (car adjustment) 'KNOWN)
(cdr adjustment)))))
(if overwritten-block
- (with-values
+ (call-with-values
(lambda ()
(subproblems->nodes subproblems
caller-block
(begin
(set-combination/reuse-existing-frame?! combination
overwritten-block)
- (with-values
+ (call-with-values
(lambda ()
(order-subproblems/overwrite-block
caller-block
(define reuse-size-limit 7)
\f
(define (subproblems->nodes subproblems caller-block overwritten-block)
- (with-values
+ (call-with-values
(lambda ()
(let ((n-subproblems (length subproblems)))
(let ((targets
(list-tail subproblems n-targets))
(values (make-nodes subproblems) '()))))))
(lambda (nodes extra-subproblems)
- (with-values
+ (call-with-values
(lambda ()
(discriminate-items nodes
(lambda (node)
(deallocate-registers nodes pushed registers))))))
(define (deallocate-registers nodes pushed registers)
- (with-values
+ (call-with-values
(lambda ()
(discriminate-items registers
(lambda (register)
(compiler-phase
"Pseudo-Assembly" ; garbage collection
(lambda ()
- (with-values
+ (call-with-values
(lambda ()
(stringify
(if (not (zero? *recursive-compilation-number*))
(vector-set! info 2 #t))
(vector-set! info 0 new)
info))))
-
+
(define (stackify/count/decrement! obj)
(let ((info (stackify/table/lookup obj)))
(cond ((not info)
(fix:+ curr-depth* 1)
max-depth*
regmap*))))))))
-
+
(define (build/unique obj prog curr-depth max-depth regmap)
;; Returns <program max-depth regmap>
(fix:max (fix:+ curr-depth 1) max-depth)
regmap))
((fake-compiled-procedure? obj)
- (with-values (lambda ()
- (build (fake-procedure/block obj)
- prog
- curr-depth
- max-depth
- regmap))
+ (call-with-values
+ (lambda ()
+ (build (fake-procedure/block obj)
+ prog
+ curr-depth
+ max-depth
+ regmap))
(lambda (prog* max-depth* regmap*)
(values
(build/natural stackify-opcode/cc-block-to-entry
(conc-name stackify-escape/))
(kind false read-only true)
(contents false read-only true))
-
+
(define (stackify/make-uuo-arity arity)
(stackify-escape/make 'arity arity))
(LAP (LEA ,target (@RO W ,pc-register (- ,label-expr ,pc-label)))))))
\f
(define (with-pc recvr)
- (with-values (lambda () (get-cached-label))
+ (call-with-values (lambda () (get-cached-label))
(lambda (label reg)
(if label
(recvr label reg)
(let ((end-block?
(let ((end-block (block-parent block)))
(lambda (block) (eq? block end-block)))))
- (with-values
+ (call-with-values
(lambda ()
(find-block/loop
link
(values locative (variable-name lvalue)))))
(define (find-block/variable context variable if-known if-ic)
- (with-values
+ (call-with-values
(lambda ()
(find-block context
0
block locative))))
\f
(define (nearest-ic-block-expression context)
- (with-values
+ (call-with-values
(lambda ()
(find-block context 0 (lambda (block) (not (block-parent block)))))
(lambda (block locative)
locative)))
(define (closure-ic-locative context block)
- (with-values
+ (call-with-values
(lambda ()
(find-block context 0 (lambda (block*) (eq? block* block))))
(lambda (block locative)
(define (block-ancestor-or-self->locative context block prefix suffix)
(stack-locative-offset
- (with-values
+ (call-with-values
(lambda ()
(find-block context prefix (lambda (block*) (eq? block* block))))
(lambda (block* locative)
'() false false)))
(make-scfg (cfg-entry-node scfg) '()))
(let ((temporary (rtl:make-pseudo-register)))
- (with-values
+ (call-with-values
(lambda ()
(generate-continuation-entry
(combination/context combination)
(preamble
(rtl:make-assignment temporary
(rtl:make-fetch register:value))))
- (with-values
+ (call-with-values
(lambda ()
(generate-continuation-entry (combination/context combination)
preamble))
nentries
(closure-block-entry-number block)))))
(needs-entry?
- (with-values
+ (call-with-values
(lambda () (procedure-arity-encoding procedure))
(lambda (min max)
(rtl:make-procedure-header
(rtl:make-open-procedure-header
(procedure-label procedure))))))
((procedure-rest procedure)
- (with-values (lambda () (procedure-arity-encoding procedure))
+ (call-with-values
+ (lambda () (procedure-arity-encoding procedure))
(lambda (min max)
(if (open-procedure-needs-dynamic-link? procedure)
(scfg*scfg->scfg!
(rtl:make-constant
(make-unassigned-reference-trap)))))))))
((IC)
- (with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr))
+ (call-with-values (lambda () (make-ic-cons value 'USE-ENV)) recvr))
((TRIVIAL-CLOSURE)
;; This is not an error.
;; It can be the consequence of bad style.
(declare (usual-integrations))
\f
(define (generate/rvalue operand scfg*cfg->cfg! generator)
- (with-values (lambda () (generate/rvalue* operand))
+ (call-with-values (lambda () (generate/rvalue* operand))
(lambda (prefix expression)
(scfg*cfg->cfg! prefix (generator expression)))))
*ic-procedure-headers*))
(let ((context (procedure-closure-context procedure)))
(if (reference? context)
- (with-values (lambda () (generate/rvalue* context))
+ (call-with-values (lambda () (generate/rvalue* context))
kernel)
;; Is this right if the procedure is being closed
;; inside another IC procedure?
((= (block-entry-number block*) 1)
;; Single entry point. This could use the multiclosure case
;; below, but this is simpler.
- (with-values (lambda () (procedure-arity-encoding procedure))
+ (call-with-values (lambda () (procedure-arity-encoding procedure))
(lambda (min max)
(rtl:make-typed-cons:procedure
(rtl:make-cons-closure
(cons procedure children)))
(entries
(map (lambda (proc)
- (with-values
+ (call-with-values
(lambda () (procedure-arity-encoding proc))
(lambda (min max)
(list (procedure-label proc) min max))))
(rvalue (definition-rvalue definition)))
(generate/rvalue rvalue scfg*scfg->scfg!
(lambda (expression)
- (with-values (lambda () (find-definition-variable context lvalue))
+ (call-with-values (lambda () (find-definition-variable context lvalue))
(lambda (environment name)
(load-temporary-register scfg*scfg->scfg! environment
(lambda (environment)
unspecific)))
\f
(define (generate/expression expression)
- (with-values
+ (call-with-values
(lambda ()
(generate/rgraph (expression-entry-node expression) generate/node))
(lambda (rgraph entry-edge)
(expression-debugging-info expression)))))
(define (generate/procedure procedure)
- (with-values
+ (call-with-values
(lambda ()
(generate/rgraph
(procedure-entry-node procedure)
\f
(define (generate/continuation continuation)
(let ((label (continuation/label continuation)))
- (with-values
+ (call-with-values
(lambda ()
(generate/rgraph
(continuation/entry-node continuation)
(special-primitive-handler obj)))))
(define (wrap-with-continuation-entry context prefix scfg-gen)
- (with-values (lambda () (generate-continuation-entry context prefix))
+ (call-with-values (lambda () (generate-continuation-entry context prefix))
(lambda (label setup cleanup)
(scfg-append! setup
(scfg-gen label)
(let ((expression (rtl:assign-expression rtl)))
(if (not (rtl:expression-contains? expression
nonfoldable-expression?))
- (with-values
+ (call-with-values
(lambda ()
(let ((next (rinst-next rinst)))
(if (rinst-dead-register? next register)
(phi-1 next)))
(recursion
(lambda (unwrap wrap)
- (with-values
+ (call-with-values
(lambda ()
(loop (unwrap expression)))
(lambda (next expression)
(values false false)))))))
(let ((recurse-and-search
(lambda (unwrap wrap)
- (with-values (lambda ()
- (recursion unwrap wrap))
+ (call-with-values (lambda () (recursion unwrap wrap))
(lambda (next expression*)
(if next
(values next expression*)
(lambda (rtl)
rtl ; ignored
false))))))))
-
+
(cond ((interpreter-value-register? expression)
(search-stopping-at expression
(lambda (rtl)
(loop))))))
(define (merge-suffixes! rgraph suffixes)
- (with-values
+ (call-with-values
(lambda ()
(discriminate-items suffixes
(lambda (suffix)
(let loop ((bblocks bblocks))
(if (null? bblocks)
'()
- (with-values (lambda () (matching-suffixes bblock (car bblocks)))
+ (call-with-values (lambda () (matching-suffixes bblock (car bblocks)))
(lambda (sx sy adjustments)
(if (or (interesting-suffix? bblock sx)
(interesting-suffix? (car bblocks) sy))
(adjustments '()))
(if (or (null? rx) (null? ry))
(values wx wy adjustments)
- (with-values
+ (call-with-values
(lambda ()
(match-rtl (rinst-rtl (car rx)) (rinst-rtl (car ry)) e))
(lambda (e adjustment)
string?)
(define (print-subproblem number frame port)
- (with-values (lambda () (stack-frame/debugging-info frame))
+ (call-with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
(print-history-level
(stack-frame/compiled-code? frame)
(%window-line-end-index? window index))))
(define (buffer-window/index->y window index)
- (with-values (lambda () (start-point-for-index window index))
+ (call-with-values (lambda () (start-point-for-index window index))
(lambda (start-index start-y line-start-index)
line-start-index
(predict-y window start-index start-y index))))
(define (buffer-window/index->coordinates window index)
- (with-values (lambda () (start-point-for-index window index))
+ (call-with-values (lambda () (start-point-for-index window index))
(lambda (start-index start-y line-start-index)
(let ((group (%window-group window))
(char-image-strings (%window-char-image-strings window))
(make-mark (%window-group window) index))))
(define (buffer-window/coordinates->index window x y)
- (with-values (lambda () (start-point-for-y window y))
+ (call-with-values (lambda () (start-point-for-y window y))
(lambda (start-index start-y)
(predict-index window start-index start-y x y))))
(let ((index (mark-index mark)))
(and (fix:<= (%window-group-start-index window) index)
(fix:<= index (%window-group-end-index window))
- (with-values (lambda () (start-point-for-index window index))
+ (call-with-values (lambda () (start-point-for-index window index))
(lambda (start-index start-y line-start-index)
line-start-index
(predict-index-visible? window start-index start-y index))))))
(set-car! history (cons (command-name command) arguments))
(set! command-history (cdr history))))))
(cond ((string? specification)
- (with-values
+ (call-with-values
(lambda ()
(let ((end (string-length specification)))
(let loop
index
end
#\newline)))
- (with-values
+ (call-with-values
(lambda ()
(interactive-argument
(string-ref specification index)
(+ index 1)
(or newline end))))
(lambda (argument expression from-tty?)
- (with-values
+ (call-with-values
(lambda ()
(if newline
(loop (+ newline 1))
(current-point))))
(if (zero? n)
(values (mark-permanent-copy start) expansion)
- (with-values
+ (call-with-values
(lambda ()
(dabbrevs-search start pattern direction do-case))
(lambda (loc expansion)
(if (or expansion (> which 0))
(step3 loc expansion)
;; Look forward
- (with-values (lambda ()
- (search&setup-table (max 1 (- which)) false))
+ (call-with-values
+ (lambda () (search&setup-table (max 1 (- which)) false))
(lambda (loc expansion)
(set-variable! last-dabbrevs-direction -1)
(step3 loc expansion)))))
;; Try looking backward unless inhibited.
(if (< which 0)
(step2 loc false)
- (with-values (lambda ()
- (search&setup-table (max 1 which) true))
+ (call-with-values
+ (lambda () (search&setup-table (max 1 which) true))
(lambda (loc expansion)
(if (not expansion)
(set-variable! last-dabbrevs-expansion-location
(window-cursor-enable! cursor-window)))
(define-method editor-frame (:button-event! editor-frame button x y)
- (with-values
+ (call-with-values
(lambda ()
(inferior-containing-coordinates editor-frame x y buffer-frame?))
(lambda (frame relative-x relative-y)
(let ((bufferset (make-bufferset initial-buffer))
(screen (display-type/make-screen display-type make-screen-args)))
(initialize-screen-root-window! screen bufferset initial-buffer)
- (with-values
+ (call-with-values
(lambda () (display-type/get-input-operations display-type screen))
(lambda (halt-update? peek-no-hang peek read)
(%make-editor name
regexp
"...")))
(message msg)
- (with-values
+ (call-with-values
(lambda ()
(without-clipping buffer
(lambda ()
(make-mail-buffer
(without-clipping buffer
(lambda ()
- (with-values (lambda () (original-header-limits memo))
+ (call-with-values (lambda () (original-header-limits memo))
(lambda (start end)
`(("To" "")
("Subject"
(define (memoize-messages buffer start end)
(let ((memo (buffer-msg-memo buffer)))
- (with-values
+ (call-with-values
(lambda ()
(memoize-messages* start
end
(let ((next (msg-memo/next memo)))
(if (not next)
(memoize-messages buffer start end)
- (with-values (lambda () (memoize-messages* start end memo))
+ (call-with-values (lambda () (memoize-messages* start end memo))
(lambda (start tail)
(mark-temporary! start)
(set-msg-memo/next! tail next)
buffer
(ref-variable-object tab-width))))
tab-width)))
- (with-values
+ (call-with-values
(lambda ()
(compute-horizontal-space target-column
(mark-column point)
(let ((baud-rate (output-port/baud-rate (console-i/o-port)))
(x-size (output-port/x-size (console-i/o-port)))
(y-size (output-port/y-size (console-i/o-port))))
- (make-screen (with-values
+ (make-screen (call-with-values
(lambda ()
(compute-scrolling-costs description
baud-rate
(output-n screen command n-lines)))
\f
(define (compute-scrolling-costs description baud-rate x-size y-size)
- (with-values
+ (call-with-values
(lambda ()
(i/d-line-cost-vectors description
baud-rate
(or (ts-insert-line description)
(ts-reverse-scroll description))))
(lambda (insert-line-cost insert-line-next-cost)
- (with-values
+ (call-with-values
(lambda ()
(i/d-line-cost-vectors description
baud-rate
#f))
(define (stack-frame->control-point stack-frame)
- (with-values (lambda () (print-stack-frame stack-frame))
+ (call-with-values (lambda () (print-stack-frame stack-frame))
(lambda (element-stream next-control-point)
(make-control-point
(stack-frame/interrupt-mask stack-frame)
(if (eq? (stack-frame/return-address stack-frame)
return-address/join-stacklets)
(values (stream) (vector-ref (stack-frame/elements stack-frame) 1))
- (with-values
+ (call-with-values
(lambda ()
(let ((next (stack-frame/%next stack-frame)))
(cond ((stack-frame? next)
(let loop ((frame top-subproblem) (level 0))
(if frame
(begin
- (with-values (lambda () (stack-frame/debugging-info frame))
+ (call-with-values (lambda () (stack-frame/debugging-info frame))
(lambda (expression environment subexpression)
subexpression
(terse-print-expression level
(set-dstate/number-of-reductions!
dstate
(improper-list-length (stack-frame/reductions stack-frame)))
- (with-values (lambda () (stack-frame/debugging-info stack-frame))
+ (call-with-values (lambda () (stack-frame/debugging-info stack-frame))
(lambda (expression environment subexpression)
(set-dstate/expression! dstate expression)
(set-dstate/subexpression! dstate subexpression)
(dbg-block/length block))))
(let ((stack-link (dbg-block/stack-link block)))
(cond ((not stack-link)
- (with-values
+ (call-with-values
(lambda ()
(stack-frame/resolve-stack-address
frame
#f #f #f))
(define (start-pipe-subprocess filename arguments environment)
- (with-values make-pipe
+ (call-with-values make-pipe
(lambda (child-read parent-write)
- (with-values make-pipe
+ (call-with-values make-pipe
(lambda (parent-read child-write)
(let ((process
(make-subprocess filename arguments environment
process))))))
(define (start-pty-subprocess filename arguments environment)
- (with-values open-pty-master
+ (call-with-values open-pty-master
(lambda (master-channel master-name slave-name)
master-name
(make-subprocess filename arguments environment
((scode-constant? expression)
expression)
(else
- (with-values (lambda () (split-environment environment))
+ (call-with-values (lambda () (split-environment environment))
(lambda (bound-names interpreter-environment)
(hook/extended-scode-eval
(cond ((null? bound-names)
projects / mit-scheme.git / commitdiff