diff --git a/partial_eval.csc b/partial_eval.csc index 5010c2f..2630373 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -30,7 +30,7 @@ (#t (let* ( (clause (car items)) (result (cond - ((list? (car clause)) (let ((s (gensym))) + ((list? (car clause)) (let ((s (gensym 'dlet_s))) (cons `(,s ,(car (cdr clause))) (flat_map_i (lambda (i x) (recurse `((,x (list-ref ,s ,i)))) @@ -48,7 +48,7 @@ (lambda (x r c) (let ( (params (list-ref x 1)) - (param_sym (gensym)) + (param_sym (gensym 'dlambda_s)) (body (list-ref x 2)) ) `(lambda ,param_sym (dlet ( (,params ,param_sym) ) ,body)))))) @@ -72,7 +72,7 @@ (lambda (x r c) (let ( (cond (list-ref x 1)) - (v (gensym)) + (v (gensym 'mif_s)) (then (list-ref x 2)) (else (if (equal? 4 (length x)) (list-ref x 3) ''())) ) @@ -248,6 +248,8 @@ (attempted 61) (true 107))) (map .hash a)))) (hash_env (lambda (progress_idxs dbi arrs) (combine_hash (mif dbi (hash_num dbi) 59) (let* ( + (_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0)) + (_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0)) (inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v)))) (cond ((= nil progress_idxs) 23) ((= true progress_idxs) 29) @@ -295,7 +297,7 @@ (array_item_union sub_progress_idxs attempted) sub_progress_idxs)))) ) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes) x)))) - (marked_env (lambda (has_vals progress_idxs dbi arrs) (array 'env (hash_env progress_idxs dbi arrs) has_vals progress_idxs dbi arrs))) + (marked_env (lambda (has_vals progress_idxs dbi arrs) (array 'env (begin (true_print "marked_env ( " arrs ")") (hash_env progress_idxs dbi arrs)) has_vals progress_idxs dbi arrs))) (marked_val (lambda (x) (array 'val (hash_val x) x))) (marked_comb (lambda (wrap_level env_id de? se variadic params body) (array 'comb (hash_comb wrap_level env_id de? se variadic params body) wrap_level env_id de? se variadic params body))) (marked_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (array 'prim_comb (hash_prim_comb handler_fun real_or_name wrap_level val_head_ok) handler_fun real_or_name wrap_level val_head_ok))) @@ -566,7 +568,7 @@ (dlet ((param_entries (map (lambda (p) (array p (marked_symbol (array env_id) p))) params)) (possible_de_entry (mif (= nil de?) (array) (array (array de? (marked_symbol (array env_id) de?))))) (progress_idxs (cons env_id (needed_for_progress_slim de))) - ) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de)))))) + ) (begin (true_print "in make_tmp_inner_env based on concat " param_entries " " possible_de_entry " " (array de)) (marked_env false progress_idxs env_id (concat param_entries possible_de_entry (array de))))))) (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) @@ -686,7 +688,7 @@ (array nil (array)))) ; Don't need to check params, they're all values! (inner_env_progress_idxs (concat de_progress_idxs (needed_for_progress_slim se))) - (inner_env (marked_env true inner_env_progress_idxs env_id (concat (zip params final_params) de_entry (array se)))) + (inner_env (begin (true_print "Environment pre marked_env, gonna concat (zip of " params " " final_params ") " (zip params final_params) " " de_entry " " (array se)) (marked_env true inner_env_progress_idxs env_id (concat (zip params final_params) de_entry (array se))))) (_ (print_strip (indent_str indent) " with inner_env is " inner_env)) (_ (print_strip (indent_str indent) "going to eval " body)) diff --git a/partial_eval.scm b/partial_eval.scm new file mode 100644 index 0000000..9161dee --- /dev/null +++ b/partial_eval.scm @@ -0,0 +1,152 @@ + + +; For chicken +;(import (chicken process-context)) +;(import (chicken port)) +;(import (chicken io)) +;(import (chicken bitwise)) +;(import (chicken string)) +;(import (r5rs)) + +; Adapted from https://stackoverflow.com/questions/16335454/reading-from-file-using-scheme WTH +(define (slurp path) + (list->string (call-with-input-file path + (lambda (input-port) + (let loop ((x (read-char input-port))) + (cond + ((eof-object? x) '()) + (#t (begin (cons x (loop (read-char input-port))))))))))) + +;(define-syntax rec-lambda +; (er-macro-transformer +; (lambda (x ue me) +; (let ( +; (name (car (cdr x))) +; (params (car (cdr (cdr x)))) +; (body (car (cdr (cdr (cdr x))))) +; ) +; `(rec ,name (lambda ,params ,body)))))) +(define-syntax rec-lambda + (syntax-rules () + ((_ name params body) (rec name (lambda params body))))) + + +(let* ( + ; In Chez scheme it's + (arithmetic-shift bitwise-arithmetic-shift) + (lapply apply) + (= equal?) + (!= (lambda (a b) (not (= a b)))) + (array list) + (array? list?) + (concat (lambda args (cond ((equal? (length args) 0) (list)) + ((list? (list-ref args 0)) (apply append args)) + ((string? (list-ref args 0)) (apply string-append args)) + (#t (error "bad value to concat"))))) + (len (lambda (x) (cond ((list? x) (length x)) + ((string? x) (string-length x)) + (#t (error "bad value to len"))))) + (idx (lambda (x i) (list-ref x (if (< i 0) (+ i (len x)) i)))) + (false #f) + (true #t) + (nil '()) + (str-to-symbol string->symbol) + (get-text symbol->string) + + (bor bitwise-ior) + (band bitwise-and) + (bxor bitwise-xor) + (bnot bitwise-not) + (<< arithmetic-shift) + (>> (lambda (a b) (arithmetic-shift a (- b)))) + + + (nil? (lambda (x) (= nil x))) + (bool? (lambda (x) (or (= #t x) (= #f x)))) + + (read-string (lambda (s) (read (open-input-string s)))) + + (zip (lambda args (apply map list args))) + + (empty_dict (array)) + (put (lambda (m k v) (cons (array k v) m))) + ;(get-value (lambda (d k) (let ((result (alist-ref k d))) + ; (if (array? result) (idx result 0) + ; (error (print "could not find " k " in " d)))))) + ;(get-value-or-false (lambda (d k) (let ((result (alist-ref k d))) + ; (if (array? result) (idx result 0) + ; false)))) + + (% modulo) + (int? integer?) + (str? string?) + (env? (lambda (x) false)) + (combiner? (lambda (x) false)) + + ;; For chicken and Chez + (drop (rec-lambda recurse (x i) (if (= 0 i) x (recurse (cdr x) (- i 1))))) + (take (rec-lambda recurse (x i) (if (= 0 i) (array) (cons (car x) (recurse (cdr x) (- i 1)))))) + (slice (lambda (x s e) (let* ( (l (len x)) + (s (if (< s 0) (+ s l 1) s)) + (e (if (< e 0) (+ e l 1) e)) + (t (- e s)) ) + (take (drop x s) t)))) + (range (rec-lambda recurse (a b) + (cond ((= a b) nil) + ((< a b) (cons a (recurse (+ a 1) b))) + (true (cons a (recurse (- a 1) b))) + ))) + (filter (rec-lambda recurse (f l) (cond ((nil? l) nil) + ((f (car l)) (cons (car l) (recurse f (cdr l)))) + (true (recurse f (cdr l)))))) + + (flat_map (lambda (f l) ((rec recurse (lambda (f l) (cond + ((equal? '() l) '()) + (#t (append (f (car l)) (recurse f (cdr l))))) + )) f l))) + (str (lambda args (begin + (define mp (open-output-string)) + ((rec-lambda recurse (x) (if (and x (!= nil x)) (begin (display (car x) mp) (recurse (cdr x))) nil)) args) + (get-output-string mp)))) + + ;; both Gambit and Chez define pretty-print. Chicken doesn't obv + (print (lambda args (pretty-print (apply str args)))) + + (write_file (lambda (file bytes) (call-with-output-file file (lambda (out) (foldl (lambda (_ o) (write-byte o out)) (void) bytes))))) + ) + + (begin + (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) + ; shadowed by wasm + ;(print "drop 3" (drop '(1 2 3 4 5 6 7 8 9 10) 3)) + (print (slice '(1 2 3) 1 2)) + (print (slice '(1 2 3) 1 -1)) + (print (slice '(1 2 3) -1 -1)) + (print (slice '(1 2 3) -2 -1)) + + (print "ASWDF") + (print (str-to-symbol (str '(a b)))) + (print (symbol? (str-to-symbol (str '(a b))))) + ;(print ( (dlambda ((a b)) a) '(1337 1338))) + ;(print ( (dlambda ((a b)) b) '(1337 1338))) + + (print (str 1 2 3 (array 1 23 4) "a" "B")) + + ;(print (dlet ( (x 2) ((a b) '(1 2)) (((i i2) i3) '((5 6) 7)) ) (+ x a b i i2 i3))) + + (print (array 1 2 3)) + (print (command-line-arguments)) + + ;(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) + (print (read (open-input-string "'(3 4)"))) + + (print "if tests") + (print (if true 1 2)) + (print (if false 1 2)) + (print (if true 1)) + (print (if false 1)) + (print "if tests end") + + (print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9))) + ) +) diff --git a/shell.nix b/shell.nix index 8ab55cb..305456d 100644 --- a/shell.nix +++ b/shell.nix @@ -5,6 +5,8 @@ mkShell { LANG="en_US.UTF-8"; nativeBuildInputs = [ chicken + gambit + chez wabt wasmtime wasm3 diff --git a/to_compile.kp b/to_compile.kp index e3681b2..70ab027 100644 --- a/to_compile.kp +++ b/to_compile.kp @@ -126,18 +126,18 @@ rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - ;test0 (map (lambda (x) (+ x 1)) (array 1 2)) - ;test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2)) - ;test2 (filter_i (lambda (i x) (> i 0)) (array 1 2)) - ;test2 (filter (lambda ( x) (> x 1)) (array 1 2)) - ;test3 (not 1) - ;test4 (flat_map (lambda (x) (array 1 x 2)) (array 1 2)) - ;test5 (flat_map_i (lambda (i x) (array i x 2)) (array 1 2)) - ;test6 (let ( (a b) (array 1 2) c (+ a b) ) c) - ;test7 ((rec-lambda recurse (n) (cond (= 0 n) 1 - ; true (* n (recurse (- n 1))))) 5) - ;test8 ((lambda (a b c) (+ a b c)) 1 13 14) - ;test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14)) + test0 (map (lambda (x) (+ x 1)) (array 1 2)) + test1 (map_i (lambda (i x) (+ x i 1)) (array 1 2)) + test2 (filter_i (lambda (i x) (> i 0)) (array 1 2)) + test2 (filter (lambda ( x) (> x 1)) (array 1 2)) + test3 (not 1) + test4 (flat_map (lambda (x) (array 1 x 2)) (array 1 2)) + test5 (flat_map_i (lambda (i x) (array i x 2)) (array 1 2)) + test6 (let ( (a b) (array 1 2) c (+ a b) ) c) + test7 ((rec-lambda recurse (n) (cond (= 0 n) 1 + true (* n (recurse (- n 1))))) 5) + test8 ((lambda (a b c) (+ a b c)) 1 13 14) + test9 ((lambda (a (b c)) (+ a b c)) 1 (array 13 14)) ;monad (array 'open 3 "test_self_out" (lambda (fd code) ; (array 'write fd "wabcdefghijklmnopqrstuvwx" (lambda (written code) ; (array 'exit (if (= 0 written) 12 14))))))