I caught the Chicken compiler red handed, it's compiled version has zip change behavior part way through, caught in the act with some prints. Where it does so changes based on optimization level, which is a bad sign. Starting a (hopfully quick) port to more standard scheme - looking to support Chez and Gambit in addition to Chicken, with at least some commented out code if not some sort of conditional compilation. We're off to a roaring start with define-syntax broken in Gambit 4.9.3, from 2019, but there was a new version released last month that I think should fix it.
This commit is contained in:
Nathan Braswell
@@ -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))
|
||||
|
||||
|
||||
152
partial_eval.scm
Normal file
152
partial_eval.scm
Normal file
@@ -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)))
|
||||
)
|
||||
)
|
||||
@@ -5,6 +5,8 @@ mkShell {
|
||||
LANG="en_US.UTF-8";
|
||||
nativeBuildInputs = [
|
||||
chicken
|
||||
gambit
|
||||
chez
|
||||
wabt
|
||||
wasmtime
|
||||
wasm3
|
||||
|
||||
@@ -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))))))
|
||||
|
||||
Reference in New Issue
Block a user