A version of @code{<let>} that creates recursive bindings, like
Scheme's @code{letrec}, or @code{letrec*} if @var{in-order?} is true.
@end deftp
-@deftp {Scheme Variable} <dynlet> fluids vals body
-@deftpx {External Representation} (dynlet @var{fluids} @var{vals} @var{body})
-Dynamic binding; the equivalent of Scheme's @code{with-fluids}.
-@var{fluids} should be a list of Tree-IL expressions that will
-evaluate to fluids, and @var{vals} a corresponding list of expressions
-to bind to the fluids during the dynamic extent of the evaluation of
-@var{body}.
-@end deftp
@deftp {Scheme Variable} <prompt> tag body handler
@deftpx {External Representation} (prompt @var{tag} @var{body} @var{handler})
A dynamic prompt. Instates a prompt named @var{tag}, an expression,
paired with their winding instructions, like @code{wind}.
@end deffn
-@deffn Instruction wind-fluids n
-Pop off @var{n} values and @var{n} fluids from the stack, in that order.
-Set the fluids to the values by creating a with-fluids object and
-pushing that object on the dynamic stack. @xref{Fluids and Dynamic
-States}.
+@deffn Instruction push-fluid
+Pop a value and a fluid from the stack, in that order. Set the fluid
+to the value by creating a with-fluids object and pushing that object
+on the dynamic stack. @xref{Fluids and Dynamic States}.
@end deffn
-@deffn Instruction unwind-fluids
+@deffn Instruction pop-fluid
Pop a with-fluids object from the dynamic stack, and swap the current
values of its fluids with the saved values of its fluids. In this way,
the dynamic environment is left as it was before the corresponding
-@code{wind-fluids} instruction was processed.
+@code{wind-fluid} instruction was processed.
@end deffn
@deffn Instruction fluid-ref
#include "libguile/eq.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
-#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
- case SCM_M_WITH_FLUIDS:
- {
- long i, len;
- SCM *fluidv, *valuesv, walk, res;
- scm_i_thread *thread = SCM_I_CURRENT_THREAD;
-
- len = scm_ilength (CAR (mx));
- fluidv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
- fluidv[i] = EVAL1 (CAR (walk), env);
- valuesv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
- valuesv[i] = EVAL1 (CAR (walk), env);
-
- scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv,
- thread->dynamic_state);
- res = eval (CDDR (mx), env);
- scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
-
- return res;
- }
-
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
proc = EVAL1 (CAR (mx), env);
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
-#define DYNLET(src, fluids, vals, body) \
- SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
SCM_SYNTAX ("@@", expand_atat);
SCM_SYNTAX ("begin", expand_begin);
SCM_SYNTAX ("define", expand_define);
-SCM_SYNTAX ("with-fluids", expand_with_fluids);
SCM_SYNTAX ("eval-when", expand_eval_when);
SCM_SYNTAX ("if", expand_if);
SCM_SYNTAX ("lambda", expand_lambda);
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
-SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
expand (CAR (body), env));
}
-static SCM
-expand_with_fluids (SCM expr, SCM env)
-{
- SCM binds, fluids, vals;
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- binds = CADR (expr);
- ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
- for (fluids = SCM_EOL, vals = SCM_EOL;
- scm_is_pair (binds);
- binds = CDR (binds))
- {
- SCM binding = CAR (binds);
- ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
- binding, expr);
- fluids = scm_cons (expand (CAR (binding), env), fluids);
- vals = scm_cons (expand (CADR (binding), env), vals);
- }
-
- return DYNLET (scm_source_properties (expr),
- scm_reverse_x (fluids, SCM_UNDEFINED),
- scm_reverse_x (vals, SCM_UNDEFINED),
- expand_sequence (CDDR (expr), env));
-}
-
static SCM
expand_eval_when (SCM expr, SCM env)
{
DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET);
DEFINE_NAMES (LETREC);
- DEFINE_NAMES (DYNLET);
scm_exp_vtable_vtable =
scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
#ifndef SCM_EXPAND_H
#define SCM_EXPAND_H
-/* Copyright (C) 2010, 2011
+/* Copyright (C) 2010, 2011, 2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM_EXPANDED_LAMBDA_CASE,
SCM_EXPANDED_LET,
SCM_EXPANDED_LETREC,
- SCM_EXPANDED_DYNLET,
SCM_NUM_EXPANDED_TYPES,
} scm_t_expanded_type;
#define SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) \
scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (in_order_p), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
-#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
-#define SCM_EXPANDED_DYNLET_FIELD_NAMES \
- { "src", "fluids", "vals", "body", }
-enum
- {
- SCM_EXPANDED_DYNLET_SRC,
- SCM_EXPANDED_DYNLET_FLUIDS,
- SCM_EXPANDED_DYNLET_VALS,
- SCM_EXPANDED_DYNLET_BODY,
- SCM_NUM_EXPANDED_DYNLET_FIELDS,
- };
-#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
- scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
-
#endif /* BUILDING_LIBGUILE */
\f
}
#undef FUNC_NAME
-SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
- (SCM fluid, SCM value, SCM thunk),
- "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
- "@var{thunk} must be a procedure with no argument.")
-#define FUNC_NAME s_scm_with_fluid
+SCM
+scm_with_fluid (SCM fluid, SCM value, SCM thunk)
{
return scm_c_with_fluid (fluid, value,
apply_thunk, (void *) SCM_UNPACK (thunk));
}
-#undef FUNC_NAME
SCM
scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
/* Primitives not exposed to general Scheme. */
static SCM wind;
static SCM unwind;
+static SCM push_fluid;
+static SCM pop_fluid;
static SCM
do_wind (SCM in, SCM out)
return SCM_UNSPECIFIED;
}
+static SCM
+do_push_fluid (SCM fluid, SCM val)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_push_fluids (&thread->dynstack, 1, &fluid, &val,
+ thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_pop_fluid (void)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
\f
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_DEFINE(var, val) \
MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
-#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \
- MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr)))
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
"let",
"quote",
"define",
- "with-fluids",
"apply",
"call/cc",
"call-with-values",
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args);
else
}
}
- case SCM_EXPANDED_DYNLET:
- return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
- memoize_exps (REF (exp, DYNLET, VALS), env),
- memoize (REF (exp, DYNLET, BODY), env));
-
default:
abort ();
}
unmemoize (CAR (args)), unmemoize (CDR (args)));
case SCM_M_DEFINE:
return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
- case SCM_M_WITH_FLUIDS:
- {
- SCM binds = SCM_EOL, fluids, vals;
- for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids);
- fluids = CDR (fluids), vals = CDR (vals))
- binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)),
- unmemoize (CAR (vals))),
- binds);
- return scm_list_3 (scm_sym_with_fluids,
- scm_reverse_x (binds, SCM_UNDEFINED),
- unmemoize (CDDR (args)));
- }
case SCM_M_IF:
return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+ push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
+ pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
}
SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
-SCM_API SCM scm_sym_with_fluids;
SCM_API SCM scm_sym_at;
SCM_API SCM scm_sym_atat;
SCM_M_LET,
SCM_M_QUOTE,
SCM_M_DEFINE,
- SCM_M_WITH_FLUIDS,
SCM_M_APPLY,
SCM_M_CONT,
SCM_M_CALL_WITH_VALUES,
NEXT;
}
-VM_DEFINE_INSTRUCTION (91, wind_fluids, "wind-fluids", 1, -1, 0)
+VM_DEFINE_INSTRUCTION (91, push_fluid, "push-fluid", 0, 2, 0)
{
- unsigned n = FETCH ();
-
+ SCM fluid, val;
+ POP2 (val, fluid);
SYNC_REGISTER ();
- sp -= 2 * n;
- CHECK_UNDERFLOW ();
- scm_dynstack_push_fluids (¤t_thread->dynstack, n, sp + 1, sp + 1 + n,
+ scm_dynstack_push_fluids (¤t_thread->dynstack, 1, &fluid, &val,
current_thread->dynamic_state);
- NULLSTACK (2 * n);
NEXT;
}
-VM_DEFINE_INSTRUCTION (92, unwind_fluids, "unwind-fluids", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (92, pop_fluid, "pop-fluid", 0, 0, 0)
{
/* This function must not allocate. */
scm_dynstack_unwind_fluids (¤t_thread->dynstack,
(define (abort-to-prompt tag . args)
(abort-to-prompt* tag args))
+(define (with-fluid* fluid val thunk)
+ "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
+@var{thunk} must be a procedure of no arguments."
+ ((@@ primitive push-fluid) fluid val)
+ (call-with-values thunk
+ (lambda vals
+ ((@@ primitive pop-fluid))
+ (apply values vals))))
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
(let ((running (fluid-ref %running-exception-handlers)))
- (with-fluids ((%running-exception-handlers (cons pre running)))
- (if (not (memq pre running))
- (apply pre thrown-k args))
- ;; fall through
- (if prompt-tag
- (apply abort-to-prompt prompt-tag thrown-k args)
- (apply prev thrown-k args))))
+ (with-fluid* %running-exception-handlers (cons pre running)
+ (lambda ()
+ (if (not (memq pre running))
+ (apply pre thrown-k args))
+ ;; fall through
+ (if prompt-tag
+ (apply abort-to-prompt prompt-tag thrown-k args)
+ (apply prev thrown-k args)))))
(apply prev thrown-k args)))))
(set! catch
(call-with-prompt
tag
(lambda ()
- (with-fluids
- ((%exception-handler
- (if pre-unwind-handler
- (custom-throw-handler tag k pre-unwind-handler)
- (default-throw-handler tag k))))
- (thunk)))
+ (with-fluid* %exception-handler
+ (if pre-unwind-handler
+ (custom-throw-handler tag k pre-unwind-handler)
+ (default-throw-handler tag k))
+ thunk))
(lambda (cont k . args)
(apply handler k args))))))
(scm-error 'wrong-type-arg "with-throw-handler"
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
- (with-fluids ((%exception-handler
- (custom-throw-handler #f k pre-unwind-handler)))
- (thunk))))
+ (with-fluid* %exception-handler
+ (custom-throw-handler #f k pre-unwind-handler)
+ thunk)))
(set! throw
(lambda (key . args)
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
+(define-syntax with-fluids
+ (lambda (stx)
+ (define (emit-with-fluids bindings body)
+ (syntax-case bindings ()
+ (()
+ body)
+ (((f v) . bindings)
+ #`(with-fluid* f v
+ (lambda ()
+ #,(emit-with-fluids #'bindings body))))))
+ (syntax-case stx ()
+ ((_ ((fluid val) ...) exp exp* ...)
+ (with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
+ ((val-tmp ...) (generate-temporaries #'(val ...))))
+ #`(let ((fluid-tmp fluid) ...)
+ (let ((val-tmp val) ...)
+ #,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
+ #'(begin exp exp* ...)))))))))
+
(define-syntax current-source-location
(lambda (x)
(syntax-case x ()
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
-;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
;;;
env))))
(eval x env)))
- (('with-fluids (fluids vals . exp))
- (let* ((fluids (map (lambda (x) (eval x env)) fluids))
- (vals (map (lambda (x) (eval x env)) vals)))
- (let lp ((fluids fluids) (vals vals))
- (if (null? fluids)
- (eval exp env)
- (with-fluids (((car fluids) (car vals)))
- (lp (cdr fluids) (cdr vals)))))))
-
(('call-with-prompt (tag thunk . handler))
(call-with-prompt
(eval tag env)
gensyms
vals
body)))
- (make-dynlet
- (lambda (src fluids vals body)
- (make-struct
- (vector-ref %expanded-vtables 18)
- 0
- src
- fluids
- vals
- body)))
(lambda?
(lambda (x)
(and (struct? x)
(build-conditional
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
(build-lexical-reference
(lambda (type source name var) (make-lexical-ref source name var)))
(build-lexical-assignment
(source-wrap e w (cdr w) mod)
x))
(else (decorate-source x s))))))
- (with-fluids
- ((transformer-environment (lambda (k) (k e r w s rib mod))))
- (rebuild-macro-output
- (p (source-wrap e (anti-mark w) s mod))
- (gensym (string-append "m-" (session-id) "-")))))))
+ (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
+ (with-fluid*
+ t-1
+ t
+ (lambda ()
+ (rebuild-macro-output
+ (p (source-wrap e (anti-mark w) s mod))
+ (gensym (string-append "m-" (session-id) "-")))))))))
(expand-body
(lambda (body outer-form r w mod)
(let* ((r (cons '("placeholder" placeholder) r))
#f
"source expression failed to match any pattern"
tmp)))))))
- (global-extend
- 'core
- 'with-fluids
- (lambda (e r w s mod)
- (let* ((tmp-1 e)
- (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
- (if tmp
- (apply (lambda (fluid val b b*)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) fluid)
- (map (lambda (x) (expand x r w mod)) val)
- (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
(global-extend 'define-syntax 'define-syntax '())
(lambda (source test-exp then-exp else-exp)
(make-conditional source test-exp then-exp else-exp)))
- (define build-dynlet
- (lambda (source fluids vals body)
- (make-dynlet source fluids vals body)))
-
(define build-lexical-reference
(lambda (type source name var)
(make-lexical-ref source name var)))
(expand #'then r w mod)
(expand #'else r w mod))))))
- (global-extend 'core 'with-fluids
- (lambda (e r w s mod)
- (syntax-case e ()
- ((_ ((fluid val) ...) b b* ...)
- (build-dynlet
- s
- (map (lambda (x) (expand x r w mod)) #'(fluid ...))
- (map (lambda (x) (expand x r w mod)) #'(val ...))
- (expand-body #'(b b* ...)
- (source-wrap e w s mod) r w mod))))))
-
(global-extend 'begin 'begin '())
(global-extend 'define 'define '())
;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
meta
(make-lambda-case #f req opt rest #f init vars body #f)))
+(define (make-dynlet src fluids vals body)
+ (let ((f (map (lambda (x) (gensym "fluid ")) fluids))
+ (v (map (lambda (x) (gensym "valud ")) vals)))
+ (make-let src (map (lambda (_) 'fluid) fluids) f fluids
+ (make-let src (map (lambda (_) 'val) vals) v vals
+ (let lp ((f f) (v v))
+ (if (null? f)
+ body
+ (make-primcall
+ src 'with-fluid*
+ (list (make-lexical-ref #f 'fluid (car f))
+ (make-lexical-ref #f 'val (car v))
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f #f #f '() '()
+ (lp (cdr f) (cdr v))
+ #f))))))))))
+
(define (compile-lambda loc meta args body)
(receive (valid? req-ids opt-ids rest-id)
(parse-lambda-list args)
`(call-with-values (lambda () ,@(recurse-body exp))
,(recurse (make-lambda #f '() body))))
- ((<dynlet> fluids vals body)
- `(with-fluids ,(map list
- (map recurse fluids)
- (map recurse vals))
- ,@(recurse-body body)))
-
((<prompt> tag body handler)
`(call-with-prompt
,(recurse tag)
(primitive 'call-with-values)
(recurse exp) (recurse body))
- ((<dynlet> fluids vals body)
- (primitive 'with-fluids)
- (for-each recurse fluids)
- (for-each recurse vals)
- (recurse body))
-
((<prompt> tag body handler)
(primitive 'call-with-prompt)
(primitive 'lambda)
<letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
<fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
<let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
- <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
<prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
<abort> abort? make-abort abort-src abort-tag abort-args abort-tail
;; (<lambda-case> req opt rest kw inits gensyms body alternate)
;; (<let> names gensyms vals body)
;; (<letrec> in-order? names gensyms vals body)
- ;; (<dynlet> fluids vals body)
(define-type (<tree-il> #:common-slots (src) #:printer print-tree-il)
(<fix> names gensyms vals body)
(('let-values exp body)
(make-let-values loc (retrans exp) (retrans body)))
- (('dynlet fluids vals body)
- (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
-
(('prompt tag body handler)
(make-prompt loc (retrans tag) (retrans body) (retrans handler)))
(($ <let-values> src exp body)
`(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
- (($ <dynlet> src fluids vals body)
- `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
- ,(unparse-tree-il body)))
-
(($ <prompt> src tag body handler)
`(prompt ,(unparse-tree-il tag)
,(unparse-tree-il body)
(($ <let-values> src exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
- (($ <dynlet> src fluids vals body)
- (let*-values (((seed ...) (fold-values foldts fluids seed ...))
- ((seed ...) (fold-values foldts vals seed ...)))
- (foldts body seed ...)))
(($ <prompt> src tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(($ <let-values> src exp body)
(make-let-values src (lp exp) (lp body)))
- (($ <dynlet> src fluids vals body)
- (make-dynlet src (map lp fluids) (map lp vals) (lp body)))
-
(($ <prompt> src tag body handler)
(make-prompt src (lp tag) (lp body) (lp handler)))
((<let-values> exp body)
(lset-union eq? (step exp) (step body)))
- ((<dynlet> fluids vals body)
- (apply lset-union eq? (step body) (map step (append fluids vals))))
-
((<prompt> tag body handler)
(lset-union eq? (step tag) (step body) (step-tail handler)))
((<let-values> exp body)
(max (recur exp) (recur body)))
- ((<dynlet> fluids vals body)
- (apply max (recur body) (map recur (append fluids vals))))
-
((<prompt> tag body handler)
(let ((cont-var (and (lambda-case? handler)
(pair? (lambda-case-gensyms handler))
body)
(($ <fix> src () () () body)
body)
- (($ <dynlet> src () () body)
- body)
(($ <lambda> src meta #f)
;; Give a body to case-lambda with no clauses.
(make-lambda
((wind . 2) . wind)
((unwind . 0) . unwind)
+ ((push-fluid . 2) . push-fluid)
+ ((pop-fluid . 0) . pop-fluid)
((bytevector-u8-ref . 2) . bv-u8-ref)
((bytevector-u8-set! . 3) . bv-u8-set)
(clear-stack-slots context gensyms)
(emit-code #f (make-glil-unbind))))))
- ((<dynlet> src fluids vals body)
- (for-each comp-push fluids)
- (for-each comp-push vals)
- (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
-
- (case context
- ((tail)
- (let ((MV (make-label)))
- ;; NB: in tail case, it is possible to preserve asymptotic tail
- ;; recursion, via merging unwind-fluids structures -- but we'd need
- ;; to compile in the body twice (once in tail context, assuming the
- ;; caller unwinds, and once with this trampoline thing, unwinding
- ;; ourselves).
- (comp-vals body MV)
- ;; one value: unwind and return
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-code #f (make-glil-call 'return 1))
-
- (emit-label MV)
- ;; multiple values: unwind and return values
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-code #f (make-glil-call 'return/nvalues 1))))
-
- ((push)
- (comp-push body)
- (emit-code #f (make-glil-call 'unwind-fluids 0)))
-
- ((vals)
- (let ((MV (make-label)))
- (comp-vals body MV)
- ;; one value: push 1 and fall through to MV case
- (emit-code #f (make-glil-const 1))
-
- (emit-label MV)
- ;; multiple values: unwind and goto MVRA
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- (emit-branch #f 'br MVRA)))
-
- ((drop)
- ;; compile body, discarding values. then unwind...
- (comp-drop body)
- (emit-code #f (make-glil-call 'unwind-fluids 0))
- ;; and fall through, or goto RA if there is one.
- (if RA
- (emit-branch #f 'br RA)))))
-
;; What's the deal here? The deal is that we are compiling the start of a
;; delimited continuation. We try to avoid heap allocation in the normal
;; case; so the body is an expression, not a thunk, and we try to render
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynlet> src fluids vals body)
- (let*-values (((fluids db*) (parallel-visit fluids db env 'value))
- ((vals db**) (parallel-visit vals db env 'value))
- ((body db***) (visit body (concat db** (concat db* db))
- env ctx)))
- (return (make-dynlet src fluids vals body)
- (concat db*** (concat db** db*)))))
(($ <toplevel-ref>)
(return exp vlist-null))
(($ <module-ref>)
(error "name should be symbol" exp))
(else
(visit exp env))))
- (($ <dynlet> src fluids vals body)
- (cond
- ((not (list? fluids))
- (error "fluids should be list" exp))
- ((not (list? vals))
- (error "vals should be list" exp))
- ((not (= (length fluids) (length vals)))
- (error "mismatch in fluids/vals" exp))
- (else
- (for-each (cut visit <> env) fluids)
- (for-each (cut visit <> env) vals)
- (visit body env))))
(($ <conditional> src condition subsequent alternate)
(visit condition env)
(visit subsequent env)
(logior (compute-effects producer)
(compute-effects consumer)
(cause &type-check)))
- (($ <dynlet> _ fluids vals body)
- (logior (accumulate-effects fluids)
- (accumulate-effects vals)
- (cause &type-check)
- (cause &fluid)
- (compute-effects body)))
(($ <toplevel-ref>)
(logior &toplevel
(cause &type-check)))
(cause &type-check)
(cause &fluid)))
+ (($ <primcall> _ 'push-fluid (fluid val))
+ (logior (compute-effects fluid)
+ (compute-effects val)
+ (cause &type-check)
+ (cause &fluid)))
+
+ (($ <primcall> _ 'pop-fluid ())
+ (logior (cause &fluid)))
+
;; Primitives that are normally effect-free, but which might
;; cause type checks, allocate memory, or access mutable
;; memory. FIXME: expand, to be more precise.
(define (lexical-refcount sym)
(var-refcount (lookup-var sym)))
+ (define (with-temporaries src exps refcount can-copy? k)
+ (let* ((pairs (map (match-lambda
+ ((and exp (? can-copy?))
+ (cons #f exp))
+ (exp
+ (let ((sym (gensym "tmp ")))
+ (record-new-temporary! 'tmp sym refcount)
+ (cons sym exp))))
+ exps))
+ (tmps (filter car pairs)))
+ (match tmps
+ (() (k exps))
+ (tmps
+ (make-let src
+ (make-list (length tmps) 'tmp)
+ (map car tmps)
+ (map cdr tmps)
+ (k (map (match-lambda
+ ((#f . val) val)
+ ((sym . _)
+ (make-lexical-ref #f 'tmp sym)))
+ pairs)))))))
+
+ (define (make-begin0 src first second)
+ (make-let-values
+ src
+ first
+ (let ((vals (gensym "vals ")))
+ (record-new-temporary! 'vals vals 1)
+ (make-lambda-case
+ #f
+ '() #f 'vals #f '() (list vals)
+ (make-seq
+ src
+ second
+ (make-primcall #f 'apply
+ (list
+ (make-primitive-ref #f 'values)
+ (make-lexical-ref #f 'vals vals))))
+ #f))))
+
;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link
;; from it to ORIG.
;;
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
- (($ <dynlet> src fluids vals body)
- (let ((body (loop body)))
- (and body
- (make-dynlet src fluids vals body))))
(($ <seq> src head tail)
(let ((tail (loop tail)))
(and tail (make-seq src head tail)))))))
(else #f))))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
- (($ <dynlet> src fluids vals body)
- (make-dynlet src (map for-value fluids) (map for-value vals)
- (for-tail body)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
exp)
(($ <toplevel-ref>)
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src 'dynamic-wind (w thunk u))
- (define (with-temporaries exps refcount k)
- (let* ((pairs (map (match-lambda
- ((and exp (? constant-expression?))
- (cons #f exp))
- (exp
- (let ((sym (gensym "tmp ")))
- (record-new-temporary! 'tmp sym refcount)
- (cons sym exp))))
- exps))
- (tmps (filter car pairs)))
- (match tmps
- (() (k exps))
- (tmps
- (make-let src
- (make-list (length tmps) 'tmp)
- (map car tmps)
- (map cdr tmps)
- (k (map (match-lambda
- ((#f . val) val)
- ((sym . _)
- (make-lexical-ref #f 'tmp sym)))
- pairs)))))))
- (define (make-begin0 src first second)
- (make-let-values
- src
- first
- (let ((vals (gensym "vals ")))
- (record-new-temporary! 'vals vals 1)
- (make-lambda-case
- #f
- '() #f 'vals #f '() (list vals)
- (make-seq
- src
- second
- (make-primcall #f 'apply
- (list
- (make-primitive-ref #f 'values)
- (make-lexical-ref #f 'vals vals))))
- #f))))
(for-tail
(with-temporaries
- (list w u) 2
+ src (list w u) 2 constant-expression?
(match-lambda
((w u)
(make-seq
(make-primcall src 'unwind '())
(make-call src u '())))))))))
+ (($ <primcall> src 'with-fluid* (f v thunk))
+ (for-tail
+ (with-temporaries
+ src (list f v thunk) 1 constant-expression?
+ (match-lambda
+ ((f v thunk)
+ (make-seq src
+ (make-primcall src 'push-fluid (list f v))
+ (make-begin0 src
+ (make-call src thunk '())
+ (make-primcall src 'pop-fluid '()))))))))
+
(($ <primcall> src 'values exps)
(cond
((null? exps)
variable-ref variable-set!
variable-bound?
- fluid-ref fluid-set!
+ fluid-ref fluid-set! with-fluid*
call-with-prompt
abort-to-prompt* abort-to-prompt
HCoop / bpt / guile.git / commitdiff