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

Destructuring lambda, fix for compiling

Browse Source
This commit is contained in:
Nathan Braswell
2021-11-19 01:08:27 -05:00
parent d4ff61ade5
commit 551e60cfe1
1 changed files with 81 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files

102
partial_eval.csc
View File

@@ -11,12 +11,17 @@
) )
`(rec ,name (lambda ,params ,body)))))) `(rec ,name (lambda ,params ,body))))))
(define flat_map_i (lambda (f l) ((rec-lambda recurse (f l i) (cond (define-syntax dlet
(er-macro-transformer
(lambda (x r c)
(let* (
(items (list-ref x 1))
(body (list-ref x 2))
(flat_map_i (lambda (f l) ((rec recurse (lambda (f l i) (cond
((equal? '() l) '()) ((equal? '() l) '())
(#t (append (f i (car l)) (recurse f (cdr l) (+ i 1)))) (#t (append (f i (car l)) (recurse f (cdr l) (+ i 1)))))
)) f l 0))) )) f l 0)))
(flatten-helper (rec recurse (lambda (items)
(define flatten-helper (rec-lambda recurse (items)
(cond (cond
((equal? '() items) '()) ((equal? '() items) '())
(#t (let* ( (#t (let* (
@@ -30,17 +35,21 @@
(car clause))))) (car clause)))))
(#t (list clause)))) (#t (list clause))))
) (append result (recurse (cdr items))))) ) (append result (recurse (cdr items)))))
))) ))))
(define-syntax dlet
(er-macro-transformer
(lambda (x r c)
(let* (
(items (list-ref x 1))
(body (list-ref x 2))
(flat_items (flatten-helper items)) (flat_items (flatten-helper items))
(_ (print items " flattened " flat_items)) (_ (print items " flattened " flat_items))
) `(let* ,flat_items ,body) ) `(let* ,flat_items ,body)
)))) ))))
(define-syntax dlambda
(er-macro-transformer
(lambda (x r c)
(let (
(params (list-ref x 1))
(param_sym (gensym))
(body (list-ref x 2))
)
`(lambda ,param_sym (dlet ( (,params ,param_sym) ) ,body))))))
(let* ( (let* (
(array list) (array list)
@@ -115,25 +124,56 @@
(indent_str (rec-lambda recurse (i) (if (= i 0) "" (indent_str (rec-lambda recurse (i) (if (= i 0) ""
(str " " (recurse (- i 1)))))) (str " " (recurse (- i 1))))))
;(str_strip (lambda args (apply str (concat (slice args 0 -2) (array ((rec-lambda recurse (x) (str_strip (lambda args (apply str (concat (slice args 0 -2) (array ((rec-lambda recurse (x)
; (cond ((val? x) (.val x)) (cond ((val? x) (.val x))
; ((marked_array? x) (let ((stripped_values (map recurse (.marked_array_values x)))) ((marked_array? x) (let ((stripped_values (map recurse (.marked_array_values x))))
; (if (.marked_array_is_val x) (cons array stripped_values) (if (.marked_array_is_val x) (cons array stripped_values)
; stripped_values))) stripped_values)))
; ((marked_symbol? x) (if (.marked_symbol_is_val x) (array 'quote (.marked_symbol_value x)) ((marked_symbol? x) (if (.marked_symbol_is_val x) (array 'quote (.marked_symbol_value x))
; (.marked_symbol_value x))) (.marked_symbol_value x)))
; ((comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) ((comb? x) (dlet (((wrap_level de? se variadic params body) (.comb x)))
; (str "<comb " wrap_level " " de? " <se " (recurse se) "> " params " " (recurse body) ">"))) (str "<comb " wrap_level " " de? " <se " (recurse se) "> " params " " (recurse body) ">")))
; ((prim_comb? x) (idx x 2)) ((prim_comb? x) (idx x 2))
; ((marked_env? x) (let (e (.env_marked x) ((marked_env? x) (let ((e (.env_marked x))
; index (.marked_env_idx x) (index (.marked_env_idx x))
; u (idx e -1) (u (idx e -1))
; ) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV idx: " (str index) ", " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">") ) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV idx: " (str index) ", " (map (dlambda ((k v)) (array k (recurse v))) (slice e 0 -2)) " upper: " (recurse u) ">")
; "<no_upper_likely_root_env>"))) "<no_upper_likely_root_env>")))
; (true (error (str "some other str_strip? |" x "|"))) (true (error (str "some other str_strip? |" x "|")))
; ) )
;) (idx args -1))))))) ) (idx args -1)))))))
;print_strip (lambda (& args) (println (lapply str_strip args))) (print_strip (lambda args (println (apply str_strip args))))
(strip (let ((helper (rec-lambda recurse (x need_value)
(cond ((val? x) (.val x))
((marked_array? x) (let ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x))))
(if (.marked_array_is_val x) (if need_value (error (str "needed value for this strip but got" x)) (cons array stripped_values))
stripped_values)))
((marked_symbol? x) (if (.marked_symbol_is_val x) (if need_value (error (str "needed value for this strip but got" x)) (array quote (.marked_symbol_value x)))
(.marked_symbol_value x)))
((comb? x) (dlet (((wrap_level de? se variadic params body) (.comb x))
(de_entry (if de? (array de?) (array)))
(final_params (if variadic (concat (slice params 0 -2) '& (array (idx params -1))) params))
; Honestly, could trim down the env to match what could be evaluated in the comb
; Also if this isn't real, lower to a call to vau
(se_env (if (marked_env_real? se) (recurse se true) nil))
(body_v (recurse body false))
(ve (concat (array vau) de_entry (array final_params) (array body_v)))
(fe ((rec-lambda recurse (x i) (if (= i 0) x (recurse (array wrap x) (- i 1)))) ve wrap_level))
) (if se_env (eval fe se_env) fe)))
((prim_comb? x) (idx x 2))
; env emitting doesn't pay attention to real value right now, not sure if that makes sense
; TODO: properly handle de Bruijn indexed envs
((marked_env? x) (cond ((and (not need_value) (= 0 (.marked_env_idx x))) (array current-env))
(true (let ((_ (if (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x)))))
(upper (idx (.env_marked x) -1))
(upper_env (if upper (recurse upper true) empty_env))
(just_entries (slice (.env_marked x) 0 -2))
(vdict (map (dlambda ((k v)) (array k (recurse v true))) just_entries))
) (add-dict-to-env upper_env vdict))))
(true (error (str "some other strip? " x)))
)
))) (lambda (x) (let ((_ (print_strip "stripping: " x)) (r (helper x false)) (_ (println "result of strip " r))) r))))
(test-all (lambda () (begin (test-all (lambda () (begin
(print (val? '(val))) (print (val? '(val)))
@@ -145,6 +185,8 @@
(print (slice '(1 2 3) -2 -1)) (print (slice '(1 2 3) -2 -1))
(print "ASWDF") (print "ASWDF")
(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 (str 1 2 3 (array 1 23 4) "a" "B"))