From 551e60cfe185b7b899ff25600481832bf2ca80c6 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Fri, 19 Nov 2021 01:08:27 -0500 Subject: [PATCH] Destructuring lambda, fix for compiling --- partial_eval.csc | 120 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 81 insertions(+), 39 deletions(-) diff --git a/partial_eval.csc b/partial_eval.csc index d256618..3d27148 100644 --- a/partial_eval.csc +++ b/partial_eval.csc @@ -11,36 +11,45 @@ ) `(rec ,name (lambda ,params ,body)))))) -(define flat_map_i (lambda (f l) ((rec-lambda recurse (f l i) (cond - ((equal? '() l) '()) - (#t (append (f i (car l)) (recurse f (cdr l) (+ i 1)))) - )) f l 0))) - -(define flatten-helper (rec-lambda recurse (items) - (cond - ((equal? '() items) '()) - (#t (let* ( - (clause (car items)) - (result (cond - ((list? (car clause)) (let ((s (gensym))) - (cons `(,s ,(car (cdr clause))) - (flat_map_i (lambda (i x) - (recurse `((,x (list-ref ,s ,i)))) - ) - (car clause))))) - (#t (list clause)))) - ) (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_map_i (lambda (f l) ((rec recurse (lambda (f l i) (cond + ((equal? '() l) '()) + (#t (append (f i (car l)) (recurse f (cdr l) (+ i 1))))) + )) f l 0))) + (flatten-helper (rec recurse (lambda (items) + (cond + ((equal? '() items) '()) + (#t (let* ( + (clause (car items)) + (result (cond + ((list? (car clause)) (let ((s (gensym))) + (cons `(,s ,(car (cdr clause))) + (flat_map_i (lambda (i x) + (recurse `((,x (list-ref ,s ,i)))) + ) + (car clause))))) + (#t (list clause)))) + ) (append result (recurse (cdr items))))) + )))) + (flat_items (flatten-helper items)) (_ (print items " flattened " flat_items)) ) `(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* ( (array list) @@ -115,25 +124,56 @@ (indent_str (rec-lambda recurse (i) (if (= i 0) "" (str " " (recurse (- i 1)))))) - ;(str_strip (lambda args (apply str (concat (slice args 0 -2) (array ((rec-lambda recurse (x) - ; (cond ((val? x) (.val x)) - ; ((marked_array? x) (let ((stripped_values (map recurse (.marked_array_values x)))) - ; (if (.marked_array_is_val x) (cons array stripped_values) - ; stripped_values))) - ; ((marked_symbol? x) (if (.marked_symbol_is_val x) (array 'quote (.marked_symbol_value x)) - ; (.marked_symbol_value x))) - ; ((comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) - ; (str " " params " " (recurse body) ">"))) - ; ((prim_comb? x) (idx x 2)) - ; ((marked_env? x) (let (e (.env_marked x) - ; index (.marked_env_idx x) - ; 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) ">") - ; ""))) - ; (true (error (str "some other str_strip? |" x "|"))) - ; ) - ;) (idx args -1))))))) - ;print_strip (lambda (& args) (println (lapply str_strip args))) + (str_strip (lambda args (apply str (concat (slice args 0 -2) (array ((rec-lambda recurse (x) + (cond ((val? x) (.val x)) + ((marked_array? x) (let ((stripped_values (map recurse (.marked_array_values x)))) + (if (.marked_array_is_val x) (cons array stripped_values) + stripped_values))) + ((marked_symbol? x) (if (.marked_symbol_is_val x) (array 'quote (.marked_symbol_value x)) + (.marked_symbol_value x))) + ((comb? x) (dlet (((wrap_level de? se variadic params body) (.comb x))) + (str " " params " " (recurse body) ">"))) + ((prim_comb? x) (idx x 2)) + ((marked_env? x) (let ((e (.env_marked x)) + (index (.marked_env_idx x)) + (u (idx e -1)) + ) (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) ">") + ""))) + (true (error (str "some other str_strip? |" x "|"))) + ) + ) (idx args -1))))))) + (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 (print (val? '(val))) @@ -145,6 +185,8 @@ (print (slice '(1 2 3) -2 -1)) (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"))