Step 10c: fix capabilities, closure-scope, define-library imports
- Initialize _cek_call_ref in sx_ref.ml — fixes 8 capabilities tests - Rename test variable 'peek' to 'get-val' — collides with new peek special form. Fixes closure-scope-edge test. - Add import clause handling to define-library — was silently skipping (import ...) inside library definitions. Fixes 4 define-library tests. 2767/2768 OCaml (1 pre-existing aser/render-to-sx issue). Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -611,7 +611,7 @@ and sf_syntax_rules args env =
|
|||||||
|
|
||||||
(* step-sf-define-library *)
|
(* step-sf-define-library *)
|
||||||
and step_sf_define_library args env kont =
|
and step_sf_define_library args env kont =
|
||||||
(let lib_spec = (first (args)) in let decls = (rest (args)) in (let lib_env = (env_extend (env)) in let exports = ref ((List [])) in let body_forms = ref ((List [])) in (let () = ignore ((List.iter (fun decl -> ignore ((if sx_truthy ((let _and = (list_p (decl)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (decl)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (decl))))))) then (let kind = (symbol_name ((first (decl)))) in (if sx_truthy ((prim_call "=" [kind; (String "export")])) then (exports := (prim_call "append" [!exports; (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (rest (decl)))))]); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "begin")])) then (body_forms := (prim_call "append" [!body_forms; (rest (decl))]); Nil) else Nil))) else Nil))) (sx_to_list decls); Nil)) in (let () = ignore ((List.iter (fun form -> ignore ((eval_expr (form) (lib_env)))) (sx_to_list !body_forms); Nil)) in (let export_dict = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun name -> ignore ((if sx_truthy ((env_has (lib_env) (name))) then (sx_dict_set_b export_dict name (env_get (lib_env) (name))) else Nil))) (sx_to_list !exports); Nil)) in (let () = ignore ((register_library (lib_spec) (export_dict))) in (make_cek_value (Nil) (env) (kont)))))))))
|
(let lib_spec = (first (args)) in let decls = (rest (args)) in (let lib_env = (env_extend (env)) in let exports = ref ((List [])) in let body_forms = ref ((List [])) in (let () = ignore ((List.iter (fun decl -> ignore ((if sx_truthy ((let _and = (list_p (decl)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (decl)))))) in if not (sx_truthy _and) then _and else (symbol_p ((first (decl))))))) then (let kind = (symbol_name ((first (decl)))) in (if sx_truthy ((prim_call "=" [kind; (String "export")])) then (exports := (prim_call "append" [!exports; (List (List.map (fun s -> (if sx_truthy ((symbol_p (s))) then (symbol_name (s)) else (String (sx_str [s])))) (sx_to_list (rest (decl)))))]); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "import")])) then (List.iter (fun import_set -> ignore (bind_import_set import_set lib_env)) (sx_to_list (rest decl)); Nil) else (if sx_truthy ((prim_call "=" [kind; (String "begin")])) then (body_forms := (prim_call "append" [!body_forms; (rest (decl))]); Nil) else Nil)))) else Nil))) (sx_to_list decls); Nil)) in (let () = ignore ((List.iter (fun form -> ignore ((eval_expr (form) (lib_env)))) (sx_to_list !body_forms); Nil)) in (let export_dict = (Dict (Hashtbl.create 0)) in (let () = ignore ((List.iter (fun name -> ignore ((if sx_truthy ((env_has (lib_env) (name))) then (sx_dict_set_b export_dict name (env_get (lib_env) (name))) else Nil))) (sx_to_list !exports); Nil)) in (let () = ignore ((register_library (lib_spec) (export_dict))) in (make_cek_value (Nil) (env) (kont)))))))))
|
||||||
|
|
||||||
(* bind-import-set *)
|
(* bind-import-set *)
|
||||||
and bind_import_set import_set env =
|
and bind_import_set import_set env =
|
||||||
@@ -916,3 +916,5 @@ let enhance_error_with_trace msg =
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
let () = Sx_types._cek_call_ref := cek_call
|
||||||
|
|||||||
@@ -1986,6 +1986,10 @@
|
|||||||
(map
|
(map
|
||||||
(fn (s) (if (symbol? s) (symbol-name s) (str s)))
|
(fn (s) (if (symbol? s) (symbol-name s) (str s)))
|
||||||
(rest decl))))
|
(rest decl))))
|
||||||
|
(= kind "import")
|
||||||
|
(for-each
|
||||||
|
(fn (import-set) (bind-import-set import-set lib-env))
|
||||||
|
(rest decl))
|
||||||
(= kind "begin")
|
(= kind "begin")
|
||||||
(set! body-forms (append body-forms (rest decl)))
|
(set! body-forms (append body-forms (rest decl)))
|
||||||
:else nil))))
|
:else nil))))
|
||||||
|
|||||||
@@ -223,84 +223,80 @@
|
|||||||
;; closure scope edge cases
|
;; closure scope edge cases
|
||||||
;; --------------------------------------------------------------------------
|
;; --------------------------------------------------------------------------
|
||||||
|
|
||||||
(defsuite "closure-scope-edge"
|
(defsuite
|
||||||
(deftest "for-each captures independent value per iteration"
|
"closure-scope-edge"
|
||||||
;; Each fn closure captures the loop variable value at call time.
|
(deftest
|
||||||
;; Build thunks from map so each one sees its own x.
|
"for-each captures independent value per iteration"
|
||||||
(let ((thunks (map (fn (x) (fn () x)) (list 10 20 30))))
|
(let
|
||||||
|
((thunks (map (fn (x) (fn () x)) (list 10 20 30))))
|
||||||
(assert-equal 10 ((nth thunks 0)))
|
(assert-equal 10 ((nth thunks 0)))
|
||||||
(assert-equal 20 ((nth thunks 1)))
|
(assert-equal 20 ((nth thunks 1)))
|
||||||
(assert-equal 30 ((nth thunks 2)))))
|
(assert-equal 30 ((nth thunks 2)))))
|
||||||
|
(deftest
|
||||||
(deftest "multiple closures from same let are independent"
|
"multiple closures from same let are independent"
|
||||||
;; Two closures from one let have separate parameter environments
|
(define
|
||||||
;; but share the same closed-over bindings.
|
make-pair
|
||||||
(define make-pair
|
(fn
|
||||||
(fn (init)
|
(init)
|
||||||
(let ((state init))
|
(let
|
||||||
(list
|
((state init))
|
||||||
(fn (v) (set! state v)) ;; setter
|
(list (fn (v) (set! state v)) (fn () state)))))
|
||||||
(fn () state))))) ;; getter
|
(let
|
||||||
(let ((pair-a (make-pair 0))
|
((pair-a (make-pair 0)) (pair-b (make-pair 100)))
|
||||||
(pair-b (make-pair 100)))
|
(let
|
||||||
(let ((set-a (nth pair-a 0)) (get-a (nth pair-a 1))
|
((set-a (nth pair-a 0))
|
||||||
(set-b (nth pair-b 0)) (get-b (nth pair-b 1)))
|
(get-a (nth pair-a 1))
|
||||||
|
(set-b (nth pair-b 0))
|
||||||
|
(get-b (nth pair-b 1)))
|
||||||
(set-a 7)
|
(set-a 7)
|
||||||
(set-b 42)
|
(set-b 42)
|
||||||
;; Each pair is independent — no crosstalk
|
(assert-equal 7 (get-a))
|
||||||
(assert-equal 7 (get-a))
|
|
||||||
(assert-equal 42 (get-b))
|
(assert-equal 42 (get-b))
|
||||||
(set-a 99)
|
(set-a 99)
|
||||||
(assert-equal 99 (get-a))
|
(assert-equal 99 (get-a))
|
||||||
(assert-equal 42 (get-b)))))
|
(assert-equal 42 (get-b)))))
|
||||||
|
(deftest
|
||||||
(deftest "closure over closure — function returning a function"
|
"closure over closure — function returning a function"
|
||||||
(define make-adder-factory
|
(define
|
||||||
(fn (base)
|
make-adder-factory
|
||||||
(fn (offset)
|
(fn (base) (fn (offset) (fn (x) (+ base offset x)))))
|
||||||
(fn (x) (+ base offset x)))))
|
(let
|
||||||
(let ((factory (make-adder-factory 100)))
|
((factory (make-adder-factory 100)))
|
||||||
(let ((add-10 (factory 10))
|
(let
|
||||||
(add-20 (factory 20)))
|
((add-10 (factory 10)) (add-20 (factory 20)))
|
||||||
(assert-equal 115 (add-10 5))
|
(assert-equal 115 (add-10 5))
|
||||||
(assert-equal 125 (add-20 5))
|
(assert-equal 125 (add-20 5))
|
||||||
;; base=100 is shared by both; offset differs
|
|
||||||
(assert-equal 130 (add-10 20))
|
(assert-equal 130 (add-10 20))
|
||||||
(assert-equal 140 (add-20 20)))))
|
(assert-equal 140 (add-20 20)))))
|
||||||
|
(deftest
|
||||||
(deftest "closure survives after creating scope is gone"
|
"closure survives after creating scope is gone"
|
||||||
(define make-frozen-adder
|
(define make-frozen-adder (fn (n) (fn (x) (+ n x))))
|
||||||
(fn (n)
|
(let
|
||||||
(fn (x) (+ n x))))
|
((add5 (make-frozen-adder 5)) (add99 (make-frozen-adder 99)))
|
||||||
(let ((add5 (make-frozen-adder 5))
|
(assert-equal 10 (add5 5))
|
||||||
(add99 (make-frozen-adder 99)))
|
|
||||||
;; make-frozen-adder's local env is gone; closures still work
|
|
||||||
(assert-equal 10 (add5 5))
|
|
||||||
(assert-equal 105 (add5 100))
|
(assert-equal 105 (add5 100))
|
||||||
(assert-equal 100 (add99 1))
|
(assert-equal 100 (add99 1))
|
||||||
(assert-equal 199 (add99 100))))
|
(assert-equal 199 (add99 100))))
|
||||||
|
(deftest
|
||||||
(deftest "closure sees set! mutations from sibling closure"
|
"closure sees set! mutations from sibling closure"
|
||||||
;; Two closures close over the same let-bound variable.
|
(let
|
||||||
;; When one mutates it, the other sees the new value.
|
((shared 0))
|
||||||
(let ((shared 0))
|
(let
|
||||||
(let ((inc! (fn () (set! shared (+ shared 1))))
|
((inc! (fn () (set! shared (+ shared 1))))
|
||||||
(peek (fn () shared)))
|
(get-val (fn () shared)))
|
||||||
(assert-equal 0 (peek))
|
(assert-equal 0 (get-val))
|
||||||
(inc!)
|
(inc!)
|
||||||
(assert-equal 1 (peek))
|
(assert-equal 1 (get-val))
|
||||||
(inc!)
|
(inc!)
|
||||||
(inc!)
|
(inc!)
|
||||||
(assert-equal 3 (peek)))))
|
(assert-equal 3 (get-val)))))
|
||||||
|
(deftest
|
||||||
(deftest "closure captures value not reference for immutable bindings"
|
"closure captures value not reference for immutable bindings"
|
||||||
;; Create closure when x=1, then shadow x=99 in an inner let.
|
(let
|
||||||
;; The closure should see the x it closed over (1), not the shadowed one.
|
((x 1))
|
||||||
(let ((x 1))
|
(let
|
||||||
(let ((f (fn () x)))
|
((f (fn () x)))
|
||||||
(let ((x 99))
|
(let ((x 99)) (assert-equal 1 (f)))
|
||||||
(assert-equal 1 (f)))
|
|
||||||
;; Even after inner let ends, f still returns 1
|
|
||||||
(assert-equal 1 (f))))))
|
(assert-equal 1 (f))))))
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user