* microcode/hooks.c (Prim_values Prim_call_with_values): New.
* microcode/returns.h (RC_MULTIPLE_VALUES): New return code.
* microcode/interp.c: Interpret new return code.
* runtime/conpar.scm: Parse new stack frame type.
* runtime/boot.scm (values call-with-values with-values): Assign
these bindings earlier in the boot. They are no longer inlined by the
scode optimizer and cannot be assigned later.
* runtime/global.scm: Remove old definitions.
* runtime/runtime.pkg: Move declarations.
* runtime/thread.scm (with-thread-events-blocked): Pass multiple values.
* runtime/wind.scm (%execute-at-new-state-point): Pass multiple values.
* compiler/base/cfg2.scm (cleanup-noop-nodes): Pass multiple values.
* src/sf/usiexp.scm (values-expansion call-with-values-expansion):
Remove.
(define (cleanup-noop-nodes thunk)
(fluid-let ((*noop-nodes* '()))
- (let ((value (thunk)))
- (for-each snode-delete! *noop-nodes*)
- value)))
+ (call-with-values thunk
+ (lambda value*
+ (for-each snode-delete! *noop-nodes*)
+ (apply values value*)))))
(define (make-false-pcfg)
(snode->pcfg-false (make-noop-node)))
}
}
\f
+DEFINE_PRIMITIVE ("VALUES", Prim_values, 0, LEXPR,
+ "(VALUES . values)\n\
+Return zero or more values to the current continuation.")
+{
+ PRIMITIVE_HEADER (LEXPR);
+ {
+ unsigned long n_args = GET_LEXPR_ACTUALS;
+ unsigned long extra = 0;
+
+#ifdef CC_SUPPORT_P
+ if (return_to_interpreter == (STACK_REF (n_args)))
+ extra = 1;
+#endif
+
+ if (CHECK_RETURN_CODE (RC_MULTIPLE_VALUES, n_args+extra))
+ {
+ SCHEME_OBJECT consumer = (CONT_EXP (n_args+extra));
+ unsigned long n_words = CONTINUATION_SIZE+extra;
+ {
+ SCHEME_OBJECT * scan_from = (STACK_LOC (n_args));
+ SCHEME_OBJECT * scan_end = (STACK_LOC (0));
+ SCHEME_OBJECT * scan_to = (STACK_LOC (n_args + n_words));
+ while (scan_from != scan_end)
+ (STACK_LOCATIVE_PUSH (scan_to)) = (STACK_LOCATIVE_PUSH (scan_from));
+ stack_pointer = (STACK_LOC (n_words));
+ }
+ assert (RETURN_CODE_P (STACK_REF (n_args)));
+ STACK_PUSH (consumer);
+ PUSH_APPLY_FRAME_HEADER (n_args);
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+
+ PRIMITIVE_RETURN (n_args == 0 ? UNSPECIFIC : (ARG_REF(1)));
+ }
+}
+
+DEFINE_PRIMITIVE ("CALL-WITH-VALUES", Prim_call_with_values, 2, 2,
+ "(CALL-WITH-VALUES PRODUCER CONSUMER)\n\
+Call PRODUCER and tail-apply its return values to CONSUMER.")
+{
+ PRIMITIVE_HEADER (2);
+ canonicalize_primitive_context ();
+ {
+ SCHEME_OBJECT producer = (STACK_POP ());
+ STACK_PUSH (MAKE_RETURN_CODE (RC_MULTIPLE_VALUES));
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
+ STACK_PUSH (producer);
+ PUSH_APPLY_FRAME_HEADER (0);
+ Pushed ();
+ PRIMITIVE_ABORT (PRIM_APPLY);
+ /*NOTREACHED*/
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+}
+\f
/* CALL-WITH-CURRENT-CONTINUATION creates a control point (a pointer
to the current stack) and passes it to PROCEDURE as its only
argument. The inverse operation, typically called THROW, is
}
break;
+ case RC_MULTIPLE_VALUES:
+ /* Frame consists of the consumer already popped into EXP. */
+ /* This is a normal return; tail-apply EXP to VAL. */
+ Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
+ STACK_PUSH (GET_VAL);
+ STACK_PUSH (GET_EXP);
+ PUSH_APPLY_FRAME_HEADER (1);
+ Pushed ();
+ SET_PRIMITIVE (SHARP_F);
+ goto internal_apply;
+
default:
POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION);
}
\f
#define RC_END_OF_COMPUTATION 0x00
#define RC_JOIN_STACKLETS 0x01
-/* unused 0x02 */
+#define RC_MULTIPLE_VALUES 0x02
#define RC_INTERNAL_APPLY 0x03
/* unused 0x04 */
#define RC_RESTORE_HISTORY 0x05
{ \
/* 0x00 */ "non-existent-continuation", \
/* 0x01 */ "join-stacklets", \
-/* 0x02 */ 0, \
+/* 0x02 */ "multiple-values", \
/* 0x03 */ "internal-apply", \
/* 0x04 */ 0, \
/* 0x05 */ "restore-history", \
((ucode-primitive with-interrupt-mask)
(fix:and limit-mask (get-interrupt-enables))
procedure))
+
+(define values (ucode-primitive values -1))
+
+(define call-with-values (ucode-primitive call-with-values 2))
+
+(define with-values (ucode-primitive call-with-values 2))
\f
(define (object-constant? object)
((ucode-primitive constant?) object))
(standard-frame 'NON-EXISTENT-CONTINUATION 2)
(standard-frame 'POP-RETURN-ERROR 2)
(standard-frame 'RESTORE-VALUE 2)
+ (standard-frame 'MULTIPLE-VALUES 2)
(standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history)
(standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
(define bind-cell-contents!
(object-component-binder cell-contents set-cell-contents!))
-(define (values . objects)
- (lambda (receiver)
- (apply receiver objects)))
-
-(define (call-with-values thunk receiver)
- ((thunk) receiver))
-
-(define with-values call-with-values)
-
(define (write-to-string object #!optional max)
(if (or (default-object? max) (not max))
(with-output-to-string (lambda () (write object)))
guarantee-unparser-method
;; END deprecated bindings
bracketed-unparser-method
+ call-with-values
default-object
default-object?
gc-space-status
simple-unparser-method
standard-unparser-method
unparser-method?
+ values
with-absolutely-no-interrupts
with-limited-interrupts
+ with-values
without-interrupts)
(export (runtime)
add-boot-init!))
append-hook-to-list
apply
bind-cell-contents!
- call-with-values
cd
cell-contents
cell?
unspecific
user-initial-environment
user-initial-prompt
- values
wait-interval
with-history-disabled
with-interrupt-mask
- with-values
write-to-string)
(import (runtime thread)
with-obarray-lock)
(if thread
(let ((block-events? (thread/block-events? thread)))
(set-thread/block-events?! thread #t)
- (let ((value
- ((ucode-primitive with-stack-marker 3)
- (lambda ()
- (set-interrupt-enables! interrupt-mask)
- (let ((value (thunk)))
- (set-interrupt-enables! interrupt-mask/gc-ok)
- value))
- 'WITH-THREAD-EVENTS-BLOCKED
- block-events?)))
+ (let ((value*))
+ ((ucode-primitive with-stack-marker 3)
+ (lambda ()
+ (set-interrupt-enables! interrupt-mask)
+ (call-with-values thunk
+ (lambda values** (set! value* values**)))
+ (set-interrupt-enables! interrupt-mask/gc-ok))
+ 'WITH-THREAD-EVENTS-BLOCKED
+ block-events?)
(let ((thread first-running-thread))
(if thread
(set-thread/block-events?! thread block-events?)))
(set-interrupt-enables! interrupt-mask)
- value))
+ (apply values value*)))
(begin
(set-interrupt-enables! interrupt-mask)
(thunk))))))
(set-state-point/from-nearer! old-root after)
(set-state-space/nearest-point! space new-point))
old-root)))))
- (let ((value
- (with-stack-marker during %translate-to-state-point old-root)))
+ (let ((value*))
+ (with-stack-marker
+ (lambda ()
+ (call-with-values during (lambda value** (set! value* value**))))
+ %translate-to-state-point old-root)
(%translate-to-state-point old-root)
- value)))
+ (apply values value*))))
(define (%translate-to-state-point point)
(%without-interrupts
((null? rest) (constant/make (and expr (object/scode expr)) '()))
(else (error "Improper list."))))
\f
-(define (values-expansion expr operands block)
- (let ((block (block/make block #t '())))
- (let ((variables
- (map (lambda (position)
- (variable/make&bind!
- block
- (string->uninterned-symbol
- (string-append "value-" (number->string position)))))
- (iota (length operands)))))
- (combination/make
- expr
- block
- (procedure/make
- #f
- block lambda-tag:let variables '() #f
- (let ((block (block/make block #t '())))
- (let ((variable (variable/make&bind! block 'RECEIVER)))
- (procedure/make
- #f block lambda-tag:unnamed (list variable) '() #f
- (declaration/make
- #f
- ;; The receiver is used only once, and all its operand
- ;; expressions are effect-free, so integrating here is
- ;; safe.
- (declarations/parse block '((INTEGRATE-OPERATOR RECEIVER)))
- (combination/make #f
- block
- (reference/make #f block variable)
- (map (lambda (variable)
- (reference/make #f block variable))
- variables)))))))
- operands))))
-
-(define (call-with-values-expansion expr operands block)
- (if (and (pair? operands)
- (pair? (cdr operands))
- (null? (cddr operands)))
- (combination/make expr
- block
- (combination/make #f block (car operands) '())
- (cdr operands))
- #f))
-
-\f
;;;; General CAR/CDR Encodings
(define (call-to-car? expression)
cadddr
caddr
cadr
- call-with-values
car
cdaaar
cdaadr
string->symbol
symbol?
third
- values
weak-pair?
- with-values
zero?)
(map car global-primitives)))
\f
cadddr-expansion
caddr-expansion
cadr-expansion
- call-with-values-expansion
car-expansion
cdaaar-expansion
cdaadr-expansion
string->symbol-expansion
symbol?-expansion
third-expansion
- values-expansion
weak-pair?-expansion
- call-with-values-expansion
zero?-expansion)
(map (lambda (p)
(make-primitive-expander
projects / mit-scheme.git / commitdiff