(unit (import) (export let+)
(#%define let+ (#%lambda (bindings . bodies) (#%let-values (((syn-error) (#%lambda (msg expr) (raise-syntax-error (#%quote let+) msg (#%cons (#%quote let+) (#%cons bindings bodies)) expr)))) (#%let-values (((expand-pattern) (#%lambda (x) (#%let-values (((g71) (#%lambda (x) (syn-error "invalid pattern" x)))) (#%if (pair? x) (#%if (#%if (equal? (car x) (#%quote values)) (list? (cdr x)) #f) (#%letrec-values (((g66) (#%lambda (g67 g68) (#%if (null? g67) ((#%lambda (x) x) (reverse g68)) (#%if (symbol? (car g67)) (g66 (cdr g67) (cons (car g67) g68)) (g71 x)))))) (g66 (cdr x) (#%quote ()))) (g71 x)) (#%if (symbol? x) ((#%lambda (x) (#%cons x ())) x) (g71 x))))))) (#%let-values (((single-binding) (#%lambda (sym binding e body) (#%cons sym (#%cons (#%cons (#%cons (expand-pattern binding) (#%cons e ())) ()) (#%cons body ())))))) (#%let-values (((multiple-bindings) (#%lambda (sym binding e body) (#%cons sym (#%cons (map list (map expand-pattern binding) e) (#%cons body ())))))) (#%let-values (((translate-binding) (#%lambda (binding body) (#%let-values (((g90) (#%lambda (x) (syn-error "invalid binding" x)))) (#%if (pair? binding) (#%if (equal? (car binding) (#%quote val)) (#%if (#%if (pair? (cdr binding)) (#%if (pair? (cddr binding)) (null? (cdddr binding)) #f) #f) ((#%lambda (b e) (single-binding (#%quote let-values) b e body)) (cadr binding) (caddr binding)) (g90 binding)) (#%if (equal? (car binding) (#%quote vals)) (#%if (list? (cdr binding)) (#%letrec-values (((g75) (#%lambda (g76 g77 g78) (#%if (null? g76) ((#%lambda (b e) (multiple-bindings (#%quote let-values) b e body)) (reverse g78) (reverse g77)) (#%if (#%if (pair? (car g76)) (#%if (pair? (cdar g76)) (null? (cddar g76)) #f) #f) (g75 (cdr g76) (cons (cadar g76) g77) (cons (caar g76) g78)) (g90 binding)))))) (g75 (cdr binding) (#%quote ()) (#%quote ()))) (g90 binding)) (#%if (equal? (car binding) (#%quote rec)) (#%if (#%if (pair? (cdr binding)) (#%if (pair? (cddr binding)) (null? (cdddr binding)) #f) #f) ((#%lambda (b e) (single-binding (#%quote letrec-values) b e body)) (cadr binding) (caddr binding)) (g90 binding)) (#%if (equal? (car binding) (#%quote recs)) (#%if (list? (cdr binding)) (#%letrec-values (((g81) (#%lambda (g82 g83 g84) (#%if (null? g82) ((#%lambda (b e) (multiple-bindings (#%quote letrec-values) b e body)) (reverse g84) (reverse g83)) (#%if (#%if (pair? (car g82)) (#%if (pair? (cdar g82)) (null? (cddar g82)) #f) #f) (g81 (cdr g82) (cons (cadar g82) g83) (cons (caar g82) g84)) (g90 binding)))))) (g81 (cdr binding) (#%quote ()) (#%quote ()))) (g90 binding)) (#%if (#%if (equal? (car binding) (#%quote _)) (list? (cdr binding)) #f) ((#%lambda (e) (#%cons (#%quote begin) (#%append e (#%cons body ())))) (cdr binding)) (g90 binding)))))) (g90 binding)))))) (#%let-values () (#%if (#%if (list? bindings) (andmap (#%lambda (x) (#%if (list? x) (#%if (<= 2 (length x)) (symbol? (car x)) #f) #f)) bindings) #f) (#%void) (syn-error "invalid syntax" bindings)) (#%letrec-values (((loop) (#%lambda (l) (#%if (null? l) (#%cons (#%quote begin) bodies) (translate-binding (car l) (loop (cdr l))))))) (loop bindings)))))))))))
