diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 14dd861..76c4889 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -244,6 +244,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) scm_i_swap_with_fluids (wind_elt, SCM_I_CURRENT_THREAD->dynamic_state); } + else if (SCM_WITH_SPECIAL_P (wind_elt)) + { + scm_i_with_special_from_guard (wind_elt, + SCM_I_CURRENT_THREAD->dynamic_state); + } else if (SCM_PROMPT_P (wind_elt)) ; /* pass -- see vm_reinstate_partial_continuation */ else if (scm_is_pair (wind_elt)) @@ -277,6 +282,11 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) scm_i_swap_with_fluids (wind_elt, SCM_I_CURRENT_THREAD->dynamic_state); } + else if (SCM_WITH_SPECIAL_P (wind_elt)) + { + scm_i_with_special_to_guard (wind_elt, + SCM_I_CURRENT_THREAD->dynamic_state); + } else if (SCM_PROMPT_P (wind_elt)) ; /* pass -- though we could invalidate the prompt */ else if (scm_is_pair (wind_elt)) diff --git a/libguile/fluids.c b/libguile/fluids.c index 327d12f..c43011d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -346,6 +346,47 @@ scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals) return ret; } + +const int nguards = 10; +SCM guards[10]; +SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals) +{ + SCM ret; + if(n > nguards) + scm_misc_error ("with-special", + "VM with-special can maximally be called with 10 slots", + SCM_EOL); + + /* Ensure that there are no duplicates in the fluids set -- an N^2 operation, + but N will usually be small, so perhaps that's OK. */ + { + size_t i, j; + + for (j = n; j--;) + for (i = j; i--;) + if (scm_is_eq (fluids[i], fluids[j])) + { + vals[i] = vals[j]; /* later bindings win */ + n--; + fluids[j] = fluids[n]; + vals[j] = vals[n]; + break; + } + } + + ret = scm_words (scm_tc7_with_special | (n << 8), 1 + n*2); + SCM_SET_CELL_WORD_1 (ret, n); + + while (n--) + { + if (SCM_UNLIKELY ( !SCM_VARIABLEP (fluids[n]))) + scm_wrong_type_arg ("with-special need a box as input", 0, fluids[n]); + SCM_SET_CELL_OBJECT (ret, 1 + n * 2, fluids[n]); + SCM_SET_CELL_OBJECT (ret, 2 + n * 2, vals[n]); + } + + return ret; +} void scm_i_swap_with_fluids (SCM wf, SCM dynstate) @@ -385,6 +426,80 @@ scm_i_swap_with_fluids (SCM wf, SCM dynstate) SCM_WITH_FLUIDS_SET_NTH_VAL (wf, i, x); } } + +void +scm_i_with_special_to_guard (SCM wf, SCM dynstate) +{ + SCM fluids; + size_t i, max = 0; + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + + /* We could cache the max in the with-fluids, but that would take more mem, + and we're touching all the fluids anyway, so this per-swap traversal should + be OK. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t num = FLUID_NUM (guards[i]); + max = (max > num) ? max : num; + } + + if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (dynstate); + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + } + + /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t fluid_num; + + fluid_num = FLUID_NUM (guards[i]); + SCM_SIMPLE_VECTOR_SET + (fluids, fluid_num, + SCM_VARIABLE_REF (SCM_WITH_SPECIAL_NTH_VAR (wf, i))); + } +} + +void +scm_i_with_special_from_guard (SCM wf, SCM dynstate) +{ + SCM fluids; + size_t i, max = 0; + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + + /* We could cache the max in the with-fluids, but that would take more mem, + and we're touching all the fluids anyway, so this per-swap traversal should + be OK. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t num = FLUID_NUM ( guards[i]); + max = (max > num) ? max : num; + } + + if (SCM_UNLIKELY (max >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + { + /* Lazily grow the current thread's dynamic state. */ + grow_dynamic_state (dynstate); + + fluids = DYNAMIC_STATE_FLUIDS (dynstate); + } + + /* Bind the fluids. Order doesn't matter, as all fluids are distinct. */ + for (i = 0; i < SCM_WITH_SPECIAL_LEN (wf); i++) + { + size_t fluid_num; + SCM x; + + fluid_num = FLUID_NUM (guards[i]); + x = SCM_SIMPLE_VECTOR_REF (fluids, fluid_num); + SCM_VARIABLE_SET (SCM_WITH_SPECIAL_NTH_VAR (wf, i), x); + } +} SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, (SCM fluids, SCM values, SCM thunk), @@ -592,6 +707,12 @@ SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0, void scm_init_fluids () { + int i; + for(i = 0; i < nguards; i++) + { + guards[i] = scm_make_fluid(); + } + #include "libguile/fluids.x" } diff --git a/libguile/fluids.h b/libguile/fluids.h index 2b91ff3..6a593a7 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -38,6 +38,12 @@ #define SCM_WITH_FLUIDS_NTH_VAL(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2)) #define SCM_WITH_FLUIDS_SET_NTH_VAL(x,n,v) (SCM_SET_CELL_OBJECT ((x), 2 + (n)*2, (v))) +#define SCM_WITH_SPECIAL_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_with_special) +#define SCM_WITH_SPECIAL_LEN(x) (SCM_CELL_WORD ((x), 0) >> 8) +#define SCM_WITH_SPECIAL_NTH_VAR(x,n) (SCM_CELL_OBJECT ((x), 1 + (n)*2)) +#define SCM_WITH_SPECIAL_NTH_KIND(x,n) (SCM_CELL_OBJECT ((x), 2 + (n)*2)) + + /* Fluids. @@ -73,6 +79,12 @@ SCM_API SCM scm_fluid_bound_p (SCM fluid); SCM_INTERNAL SCM scm_i_make_with_fluids (size_t n, SCM *fluids, SCM *vals); SCM_INTERNAL void scm_i_swap_with_fluids (SCM with_fluids, SCM dynamic_state); +SCM_INTERNAL SCM scm_i_make_with_special (size_t n, SCM *fluids, SCM *vals); +SCM_INTERNAL void scm_i_with_special_from_guard +(SCM with_fluids, SCM dynamic_state); +SCM_INTERNAL void scm_i_with_special_to_guard +(SCM with_fluids, SCM dynamic_state); + SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *cdata); SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val, diff --git a/libguile/tags.h b/libguile/tags.h index a3032bf..869a9d4 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -426,7 +426,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_program 79 #define scm_tc7_array 85 #define scm_tc7_bitvector 87 -#define scm_tc7_unused_20 93 +#define scm_tc7_with_special 93 #define scm_tc7_unused_11 95 #define scm_tc7_unused_12 101 #define scm_tc7_unused_18 103 diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 34545dd..f9e8151 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1556,6 +1556,7 @@ VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) NEXT; } + VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) { SCM wf; @@ -1565,6 +1566,30 @@ VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) NEXT; } + +VM_DEFINE_INSTRUCTION (99, wind_special, "wind-special", 1, -1, 0) +{ + unsigned n = FETCH (); + SCM wf; + + SYNC_REGISTER (); + sp -= 2 * n; + CHECK_UNDERFLOW (); + wf = scm_i_make_with_special (n, sp + 1, sp + 1 + n); + NULLSTACK (2 * n); + + //This is not nessesary + //scm_i_swap_with_special (wf, current_thread->dynamic_state); + scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (100, unwind_special, "unwind-special", 0, 0, 0) +{ + scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); + NEXT; +} + VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) { size_t num; diff --git a/module/Makefile.am b/module/Makefile.am index c47d0b4..b07c342 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -101,6 +101,7 @@ SCHEME_LANG_SOURCES = \ language/scheme/decompile-tree-il.scm TREE_IL_LANG_SOURCES = \ + language/tree-il/special.scm \ language/tree-il/primitives.scm \ language/tree-il/effects.scm \ language/tree-il/fix-letrec.scm \ @@ -337,6 +338,7 @@ OOP_SOURCES = \ oop/goops/simple.scm SYSTEM_SOURCES = \ + system/vm/special-variable.scm \ system/vm/inspect.scm \ system/vm/coverage.scm \ system/vm/frame.scm \ diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index badce9f..50d64b8 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -151,7 +151,7 @@ (hashq-set! res k v) res)) -(define (analyze-lexicals x) +(define* (analyze-lexicals x #:optional (special-vars #f)) ;; bound-vars: lambda -> (sym ...) ;; all identifiers bound within a lambda (define bound-vars (make-hash-table)) @@ -159,6 +159,9 @@ ;; all identifiers referenced in a lambda, but not bound ;; NB, this includes identifiers referenced by contained lambdas (define free-vars (make-hash-table)) + ;; free-syms: sym -> #t + ;; All variables that is free with respect to a lambda. + (define free-syms (make-hash-table)) ;; assigned: sym -> #t ;; variables that are assigned (define assigned (make-hash-table)) @@ -180,7 +183,7 @@ (analyze! x new-proc (append labels labels-in-proc) #t #f)) (define (recur x new-proc) (analyze! x new-proc '() tail? #f)) (record-case x - (( proc args) + (( proc args) (apply lset-union eq? (step-tail-call proc args) (map step args))) @@ -236,6 +239,9 @@ (let ((free (recur body x))) (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) + (for-each (lambda (var) + (hashq-set! free-syms var #t)) + free) free)) (( opt kw inits gensyms body alternate) @@ -286,7 +292,8 @@ ;; recur/labels instead of recur (hashq-set! bound-vars x '()) (let ((free (recur/labels body x gensyms))) - (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x))) + (hashq-set! bound-vars x + (reverse! (hashq-ref bound-vars x))) (hashq-set! free-vars x free) free)))) vals)) @@ -330,7 +337,11 @@ (append (hashq-ref bound-vars val) (hashq-ref bound-vars proc))) (hashq-remove! bound-vars val) - (hashq-remove! free-vars val)))) + (hashq-remove! free-vars val)) + ;; Else we will allocate a closure; register the free-syms + (for-each (lambda (sym) + (hashq-set! free-syms sym #t)) + (hashq-ref free-vars val)))) gensyms vals) (lset-difference eq? (apply lset-union eq? body-refs var-refs) @@ -395,7 +406,12 @@ (begin (hashq-set! (hashq-ref allocation (car c)) x - `(#f ,(hashq-ref assigned (car c)) . ,n)) + `(#f ,(and (hashq-ref assigned (car c)) + (not (and special-vars + (hashq-ref special-vars (car c)) + (not (hashq-ref free-syms + (car c)))))) + . ,n)) (lp (cdr c) (1+ n))))) (let ((nlocs (allocate! body x 0)) @@ -427,7 +443,15 @@ (begin (hashq-set! allocation (car gensyms) (make-hashq - proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n))) + proc `(#t + ,(and (hashq-ref assigned (car gensyms)) + (not (and special-vars + (hashq-ref special-vars + (car gensyms)) + (not (hashq-ref + free-syms + (car gensyms)))))) + . ,n))) (lp (cdr gensyms) (1+ n))))) (if alternate (allocate! alternate proc n) n))) @@ -456,7 +480,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n))))))))) (( gensyms vals body) @@ -471,7 +500,12 @@ (hashq-set! allocation v (make-hashq proc - `(#t ,(hashq-ref assigned v) . ,n))) + `(#t ,(and (hashq-ref assigned v) + (not (and special-vars + (hashq-ref special-vars v) + (not (hashq-ref free-syms + v))))) + . ,n))) (lp (cdr gensyms) (1+ n)))))) (( gensyms vals body) diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index e4df6e1..b4d3836 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -29,6 +29,7 @@ #:use-module (language tree-il optimize) #:use-module (language tree-il canonicalize) #:use-module (language tree-il analyze) + #:use-module (language tree-il special) #:use-module ((srfi srfi-1) #:select (filter-map)) #:export (compile-glil)) @@ -64,9 +65,10 @@ (let* ((x (make-lambda (tree-il-src x) '() (make-lambda-case #f '() #f #f #f '() '() x #f))) - (x (optimize! x e opts)) + (x (optimize! (optimize! x e opts) e opts)) (x (canonicalize! x)) - (allocation (analyze-lexicals x))) + (special-vars (register-special-vars x)) + (allocation (analyze-lexicals x special-vars))) (with-fluids ((*comp-module* e)) (values (flatten-lambda x #f allocation) @@ -199,6 +201,19 @@ (proc emit-code) (reverse out))) +(define (with-special? x) + (record-case x + (( src proc args) + (record-case proc + (( src mod name public?) + (and (equal? mod '(system vm special-variable)) + (eq? name 'w-special) + (= (length args) 1) + (car args))) + (else #f))) + (else #f))) + + (define (flatten-lambda x self-label allocation) (record-case x (( src meta body) @@ -229,6 +244,7 @@ (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA)) (define (comp-fix tree RA) (comp tree context RA MVRA)) + ;; Use this helper to guard some syms ;; A couple of helpers. Note that if we are in tail context, we ;; won't have an RA. (define (maybe-emit-return) @@ -236,6 +252,15 @@ (emit-branch #f 'br RA) (if (eq? context 'tail) (emit-code #f (make-glil-call 'return 1))))) + + (define (is-boxed? x) + (record-case x + (( src gensym) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + boxed?) + (_ #f))) + (else #f))) ;; After lexical binding forms in non-tail context, call this ;; function to clear stack slots, allowing their previous values to @@ -255,7 +280,25 @@ (,loc (error "bad let var allocation" x loc)))))) syms)))) - (record-case x + (if (pair? x) + (case (car x) + ((raw-ref) + (record-case (cdr x) + (( src gensym) + (case context + ((push) + (pmatch (hashq-ref (hashq-ref allocation gensym) self) + ((,local? ,boxed? . ,index) + (emit-code src + (make-glil-lexical local? #f 'ref index))) + (,loc + (error "bad lexical allocation" x loc)))) + (else + (error "Bad raw-ref")))))) + (else + (error "Bad pair tree-il"))) + + (record-case x (() (case context ((push vals tail) @@ -277,7 +320,7 @@ (comp-drop (car exps)) (lp (cdr exps)))))) - (( src proc args) + (( src proc args) ;; FIXME: need a better pattern-matcher here (cond ((and (primitive-ref? proc) @@ -1037,11 +1080,38 @@ (if RA (emit-branch #f 'br RA))))) - (( src fluids vals body) - (for-each comp-push fluids) - (for-each comp-push vals) - (emit-code #f (make-glil-call 'wind-fluids (length fluids))) - + (( src fluids vals body) + (define spc (let lp ((l (map (lambda (sym val) + (let ((sp (with-special? val))) + (and (is-boxed? sym) + sp))) + fluids vals))) + (if (pair? l) + (if (car l) + (cons (car l) (lp (cdr l))) + (lp (cdr l))) + '()))) + (define id (lambda (x) x)) + (define spc? (or-map with-special? vals)) + (if (and spc? (null? spc)) + (comp-tail body) + (begin + (if spc? + (for-each (lambda (ref) + (when (is-boxed? ref) + (comp-push (cons 'raw-ref ref)))) + fluids) + (for-each comp-push fluids)) + + (if spc? + (for-each comp-push spc) + (for-each comp-push vals)) + + (if spc? + (emit-code #f (make-glil-call 'wind-special (length spc))) + (emit-code #f (make-glil-call 'wind-fluids (length fluids)))) + + (begin (case context ((tail) (let ((MV (make-label))) @@ -1052,17 +1122,23 @@ ;; ourselves). (comp-vals body MV) ;; one value: unwind and return - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (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)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (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))) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (emit-code #f (make-glil-call 'unwind-fluids 0)))) ((vals) (let ((MV (make-label))) @@ -1072,16 +1148,20 @@ (emit-label MV) ;; multiple values: unwind and goto MVRA - (emit-code #f (make-glil-call 'unwind-fluids 0)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (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)) + (if spc? + (emit-code #f (make-glil-call 'unwind-special 0)) + (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))))) + (emit-branch #f 'br RA)))))))) (( src fluid) (case context @@ -1202,4 +1282,4 @@ (emit-code #f (make-glil-mv-bind 1 #f))) ((vals) ;; Go to MVRA. - (emit-branch #f 'br MVRA))))))) + (emit-branch #f 'br MVRA)))))))) diff --git a/module/language/tree-il/special.scm b/module/language/tree-il/special.scm new file mode 100644 index 0000000..0e38084 --- /dev/null +++ b/module/language/tree-il/special.scm @@ -0,0 +1,104 @@ +(define-module (language tree-il special) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:use-module (system base syntax) + #:use-module (system base message) + #:use-module (system vm program) + #:use-module (language tree-il) + #:use-module (system base pmatch) + #:export (register-special-vars)) + + +(define (register-special-vars x) + (define register (make-hash-table)) + (let lp ((x x)) + (record-case x + (( proc args) + (record-case proc + (( src mod name public?) + (if (and (equal? mod '(system vm special-variable)) + (eq? name 'special) + (= (length args) 1)) + (record-case (car args) + (( src gensym) + (hashq-set! register gensym #t)) + (else #t)))) + (else #f)) + (lp proc) + (for-each lp args)) + + (( test consequent alternate) + (lp test) + (lp consequent) + (lp alternate)) + + + (( gensym exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exp) + (lp exp)) + + (( exps) + (for-each lp exps)) + + (( body) + (lp body)) + + (( opt kw inits gensyms body alternate) + (for-each lp inits) + (lp body) + (if alternate (lp alternate))) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( gensyms vals body) + (for-each lp vals) + (lp body)) + + (( exp body) + (lp exp) + (lp body)) + + (( body winder unwinder) + (lp body) + (lp winder) + (lp unwinder)) + + (( fluids vals body) + (lp body) + (for-each lp (append fluids vals))) + + (( fluid) + (lp fluid)) + + (( fluid exp) + (lp fluid) (lp exp)) + + (( tag body handler) + (lp tag) + (lp body) + (lp handler)) + + (( tag args tail) + (lp tag) (lp tail) (for-each lp args)) + + (else #t))) + register) + diff --git a/module/system/vm/special-variable.scm b/module/system/vm/special-variable.scm new file mode 100644 index 0000000..99cc497 --- /dev/null +++ b/module/system/vm/special-variable.scm @@ -0,0 +1,85 @@ +(define-module (system vm special-variable) + #:export (with-special with-special-soft special-wind-guard)) + +(define special (lambda (x) x)) +(define w-special (lambda (x) x)) + +(define-syntax-rule (mark-as-special v ...) + (begin + (special v) + ... + (if #f #f))) + +;; This will allocate guard on the stack as a boxed value +(define (make-winder l) + (lambda () + (let loop ((l l)) + (if (pair? l) + (let ((c (car l))) + (variable-set! (cdr c) (car c)) + (loop (cdr l))) + (if #f #f))))) + +(define (make-unwinder l) + (lambda () + (let loop ((l l)) + (if (pair? l) + (let ((c (car l))) + (set-car! c (variable-ref (cdr c))) + (loop (cdr l))) + (if #f #f))))) + +(define-syntax with-special + (lambda (x) + (syntax-case x () + ((_ (x ...) code ...) + (with-syntax (((((a k) ...) (y ...)) + (let loop ((i 0) (l #'(x ...)) (r '())) + (if (or (= i 10) (null? l)) + (list (reverse r) l) + (loop (+ i 1) (cdr l) (cons (car l) r)))))) + (if (null? #'(y ...)) + #'(with-fluids ((a (w-special k)) ...) + (mark-as-special a) ... + code ...) + #'(with-fluids ((a (w-special k)) ...) + (mark-as-special a) ... + (with-special (y ...) code ...)))))))) + +(define guards (make-vector 10)) +(let lp ((i 0)) + (when (< i 10) (vector-set! guards i (make-fluid)))) + +(define-syntax with-special-soft + (lambda (x) + (syntax-case x () + ((_ (x ...) code ...) + (with-syntax (((((a k) ...) (y ...)) + (let loop ((i 0) (l #'(x ...)) (r '())) + (if (or (= i 10) (null? l)) + (list (reverse r) l) + (loop (+ i 1) (cdr l) (cons (car l) r)))))) + (with-syntax (((i ...) (iota (length #'(a ...))))) + (if (null? #'(y ...)) + #'(with-fluids (((vector-ref guards i) a) ...) + (with-special* ((i a k) ...) + code ...)) + #'(with-fluids (((vector-ref guards i) a) ...) + (with-special* ((i a k) ...) + (with-special-soft (y ...) code ...)))))))))) + +(define special-wind-guard (make-fluid (lambda (x) #t))) +(define-syntax-rule (with-special* ((i a k) ...) code ...) + (dynamic-wind + (lambda () + (when ((fluid-ref special-wind-guard) k) + (set! a (fluid-ref (vector-ref guards i)))) + ...) + (lambda () + code ...) + (lambda y + (fluid-set! (vector-ref guards i) a) + ...))) + + +