miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix multiple cond/slice bugs revealed by LotusRonin's new find testcase

Browse Source
This commit is contained in:
Nathan Braswell
2022-04-24 20:39:51 -04:00
parent 8a876a7b29
commit 8b3cab7a2f
2 changed files with 42 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
find.kp
View File

@@ -85,15 +85,14 @@
len2 (len sub) len2 (len sub)
) (cond (> len2 len1) -1 ) (cond (> len2 len1) -1
(= len2 0) i (= len2 0) i
(and (> len1 0) (> len2 0)) (and (> len1 0) (> len2 0)) (cond (compare_substr str sub) i
(cond (compare_substr str sub) i
true (_find (cdr str) sub (+ i 1))) true (_find (cdr str) sub (+ i 1)))
true -1 true -1
))) )))
; find the index of a substr in a str ; find the index of a substr in a str
; check if a substr is in a str ; check if a substr is in a str
find (lambda (str sub) (_find str sub 0)) find (lambda (str sub) (_find str sub 0))
contains(lambda (str sub) (!= (find str sub) -1)) contains (lambda (str sub) (!= (find str sub) -1))
monad (array 'write 1 "testing find funcs: \n" (vau (written code) monad (array 'write 1 "testing find funcs: \n" (vau (written code)
(array 'write 1 "find in \"foobar\" the string \"oba\"\n" (vau (written code) (array 'write 1 "find in \"foobar\" the string \"oba\"\n" (vau (written code)

50
partial_eval.scm
View File

@@ -74,7 +74,7 @@
(#t (error "bad value to concat " (list-ref args 0)))))) (#t (error "bad value to concat " (list-ref args 0))))))
(len (lambda (x) (cond ((list? x) (length x)) (len (lambda (x) (cond ((list? x) (length x))
((string? x) (string-length x)) ((string? x) (string-length x))
(#t (error "bad value to len"))))) (#t (error "bad value to len" x)))))
(idx (lambda (x i) (cond ((list? x) (list-ref x (if (< i 0) (+ i (len x)) i))) (idx (lambda (x i) (cond ((list? x) (list-ref x (if (< i 0) (+ i (len x)) i)))
((string? x) (char->integer (list-ref (string->list x) (if (< i 0) (+ i (len x)) i))))))) ((string? x) (char->integer (list-ref (string->list x) (if (< i 0) (+ i (len x)) i)))))))
(false #f) (false #f)
@@ -963,20 +963,22 @@
; WE SHOULDN'T DIE ON ERROR, since these errors may be guarded by conditions we ; WE SHOULDN'T DIE ON ERROR, since these errors may be guarded by conditions we
; can't evaluate. We'll keep branches that error as un-valed only ; can't evaluate. We'll keep branches that error as un-valed only
((pectx _err evaled_params later_hash) (if already_in ((pectx _err evaled_params later_hash) (if already_in
(array pectx nil (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil))) (array pectx nil (if already_stripped sliced_params
(_ (if (not ok) (error "BAD cond un")))) (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil)))
(_ (if (not ok) (error "BAD cond un first " already_stripped " " x))))
ux)) ux))
sliced_params) hash) sliced_params)) (array hash))
(foldl (dlambda ((pectx _err as later_hash) x) (foldl (dlambda ((pectx _err as later_hash) x)
(dlet (((pectx er a) (eval_helper x pectx))) (dlet (((pectx er a) (eval_helper x pectx)))
(mif er (dlet (((ok ux) (if already_stripped (array true x) (try_unval x (lambda (_) nil)))) (mif er (dlet (((ok ux) (if already_stripped (array true x) (try_unval x (lambda (_) nil))))
(_ (if (not ok) (error (str "BAD cond un" x))))) (_ (if (not ok) (error (str "BAD cond un second " already_stripped " " x)))))
(array pectx nil (concat as (array ux)) later_hash)) (array pectx nil (concat as (array ux)) later_hash))
(array pectx nil (concat as (array a)) later_hash))) (array pectx nil (concat as (array a)) later_hash)))
) (array (array env_counter (put memo hash nil)) nil (array) nil) sliced_params))) ) (array (array env_counter (put memo hash nil)) nil (array) nil) sliced_params)))
((env_counter omemo) pectx) ((env_counter omemo) pectx)
(new_call (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) pred) evaled_params))
(pectx (array env_counter memo)) (pectx (array env_counter memo))
) (array pectx nil (marked_array false true later_hash (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) pred) evaled_params) nil)))) ) (array pectx nil (marked_array false true later_hash new_call nil))))
((and (< (+ 2 i) (len params)) (false? pred)) (recurse_inner (+ 2 i) so_far pectx)) ((and (< (+ 2 i) (len params)) (false? pred)) (recurse_inner (+ 2 i) so_far pectx))
( (false? pred) (array pectx "comb reached end with no true" nil)) ( (false? pred) (array pectx "comb reached end with no true" nil))
(true (eval_helper (idx params (+ i 1)) pectx)) (true (eval_helper (idx params (+ i 1)) pectx))
@@ -1036,9 +1038,30 @@
) 'idx 1 true)) ) 'idx 1 true))
(array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent) (array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent)
(cond (cond
((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array)) ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array)
(int? (.val evaled_begin))
(or (and (>= (.val evaled_begin) 0) (<= (.val evaled_begin) (len (.marked_array_values evaled_array))))
(and (< (.val evaled_begin) 0) (>= (+ (.val evaled_begin) 1 (len (.marked_array_values evaled_array))) 0)
(<= (+ (.val evaled_begin) 1 (len (.marked_array_values evaled_array))) (len (.marked_array_values evaled_array)))))
(int? (.val evaled_end))
(or (and (>= (.val evaled_end) 0) (<= (.val evaled_end) (len (.marked_array_values evaled_array))))
(and (< (.val evaled_end) 0) (>= (+ (.val evaled_end) 1 (len (.marked_array_values evaled_array))) 0)
(<= (+ (.val evaled_end) 1 (len (.marked_array_values evaled_array))) (len (.marked_array_values evaled_array)))))
)
(array pectx nil (marked_array true false nil (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)) nil))) (array pectx nil (marked_array true false nil (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)) nil)))
((and (val? evaled_begin) (val? evaled_end) (val? evaled_array) (string? (.val evaled_array))) ((and (val? evaled_begin) (val? evaled_end) (val? evaled_array) (string? (.val evaled_array))
(int? (.val evaled_begin))
(or (and (>= (.val evaled_begin) 0) (<= (.val evaled_begin) (len (.val evaled_array))))
(and (< (.val evaled_begin) 0) (>= (+ (.val evaled_begin) 1 (len (.val evaled_array))) 0)
(<= (+ (.val evaled_begin) 1 (len (.val evaled_array))) (len (.val evaled_array)))))
(int? (.val evaled_end))
(or (and (>= (.val evaled_end) 0) (<= (.val evaled_end) (len (.val evaled_array))))
(and (< (.val evaled_end) 0) (>= (+ (.val evaled_end) 1 (len (.val evaled_array))) 0)
(<= (+ (.val evaled_end) 1 (len (.val evaled_array))) (len (.val evaled_array)))))
)
(array pectx nil (marked_val (slice (.val evaled_array) (.val evaled_begin) (.val evaled_end))))) (array pectx nil (marked_val (slice (.val evaled_array) (.val evaled_begin) (.val evaled_end)))))
(true (array pectx (str "bad params to slice " evaled_begin " " evaled_end " " evaled_array) nil)) (true (array pectx (str "bad params to slice " evaled_begin " " evaled_end " " evaled_array) nil))
) )
@@ -4533,15 +4556,13 @@
((ok x) (try_unval x (lambda (_) nil))) ((ok x) (try_unval x (lambda (_) nil)))
(err (if (not ok) "couldn't unval in compile" err)) (err (if (not ok) "couldn't unval in compile" err))
; TODO: This might fail because we don't have the real env stack, which we *should*! ((pectx e pex) (cond ((!= nil err) (array pectx err nil))
; In the mean time, if it does, just fall back to the non-more-evaled ones. (hit_recursion (array pectx "blockrecursion" nil))
((pectx e pex) (if (or (!= nil err) hit_recursion) (true (partial_eval_helper x false env (array nil nil) pectx 1 false))))
(array pectx err nil)
(partial_eval_helper x false env (array nil nil) pectx 1 false)))
(ctx (array datasi funcs memo env pectx inline_locals)) (ctx (array datasi funcs memo env pectx inline_locals))
) (array (mif e x pex) err ctx))))) ) (array (mif e x pex) e ctx)))))
((datasi funcs memo env pectx inline_locals) ctx) ((datasi funcs memo env pectx inline_locals) ctx)
(memo (put memo (.hash c) 'RECURSE_FAIL)) (memo (put memo (.hash c) 'RECURSE_FAIL))
(ctx (array datasi funcs memo env pectx inline_locals)) (ctx (array datasi funcs memo env pectx inline_locals))
@@ -4879,6 +4900,7 @@
(attempt_reduction (and (attempt_reduction (and
variadic variadic
(= 1 (len params)) (= 1 (len params))
(marked_array? body)
(= 4 (len (.marked_array_values body))) (= 4 (len (.marked_array_values body)))
(prim_comb? (idx (.marked_array_values body) 0)) (prim_comb? (idx (.marked_array_values body) 0))
(= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0))) (= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0)))