conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix cond to conform to R7RS 'If the selected ⟨clause⟩ contains only the ⟨test⟩ and no ⟨expression⟩s, then the value of the ⟨test⟩ is returned as the result.'

This commit is contained in:
Doug Currie 2016-01-23 16:14:11 -05:00
parent 7019f81aaf
commit 0f3ef76fcb
1 changed files with 230 additions and 222 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

452
extlib/benz/boot.c
View File

@ -192,16 +192,20 @@ my $src = <<'EOL';
(if (and (variable? (car clause)) (if (and (variable? (car clause))
(variable=? (the 'else) (make-identifier (car clause) env))) (variable=? (the 'else) (make-identifier (car clause) env)))
(cons the-begin (cdr clause)) (cons the-begin (cdr clause))
(if (and (variable? (cadr clause)) (if (null? (cdr clause))
(variable=? (the '=>) (make-identifier (cadr clause) env)))
(let ((tmp (make-identifier 'tmp here))) (let ((tmp (make-identifier 'tmp here)))
(list (the 'let) (list (list tmp (car clause))) (list (the 'let) (list (list tmp (car clause)))
(list the-if tmp (list the-if tmp tmp (cons (the 'cond) (cdr clauses)))))
(list (car (cddr clause)) tmp) (if (and (variable? (cadr clause))
(cons (the 'cond) (cdr clauses))))) (variable=? (the '=>) (make-identifier (cadr clause) env)))
(list the-if (car clause) (let ((tmp (make-identifier 'tmp here)))
(cons the-begin (cdr clause)) (list (the 'let) (list (list tmp (car clause)))
(cons (the 'cond) (cdr clauses)))))))))) (list the-if tmp
(list (car (cddr clause)) tmp)
(cons (the 'cond) (cdr clauses)))))
(list the-if (car clause)
(cons the-begin (cdr clause))
(cons (the 'cond) (cdr clauses)))))))))))
(define-macro quasiquote (define-macro quasiquote
(lambda (form env) (lambda (form env)
@ -788,220 +792,224 @@ const char pic_boot[][80] = {
"\n (if (null? clauses)\n #undefined\n (let ((clause (car cla", "\n (if (null? clauses)\n #undefined\n (let ((clause (car cla",
"uses)))\n (if (and (variable? (car clause))\n (vari", "uses)))\n (if (and (variable? (car clause))\n (vari",
"able=? (the 'else) (make-identifier (car clause) env)))\n (cons th", "able=? (the 'else) (make-identifier (car clause) env)))\n (cons th",
"e-begin (cdr clause))\n (if (and (variable? (cadr clause))\n ", "e-begin (cdr clause))\n (if (null? (cdr clause))\n ",
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", " (let ((tmp (make-identifier 'tmp here)))\n (list (the 'le",
" (let ((tmp (make-identifier 'tmp here)))\n ", "t) (list (list tmp (car clause)))\n (list the-if tmp t",
" (list (the 'let) (list (list tmp (car clause)))\n (li", "mp (cons (the 'cond) (cdr clauses)))))\n (if (and (variable? (",
"st the-if tmp\n (list (car (cddr clause)) tmp)\n ", "cadr clause))\n (variable=? (the '=>) (make-identifie",
" (cons (the 'cond) (cdr clauses)))))\n ", "r (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp ",
" (list the-if (car clause)\n (cons the-begin (cd", "here)))\n (list (the 'let) (list (list tmp (car clause))",
"r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(", ")\n (list the-if tmp\n ",
"define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ", " (list (car (cddr clause)) tmp)\n (c",
" (and (pair? form)\n (variable? (car form))\n (variable=? (t", "ons (the 'cond) (cdr clauses)))))\n (list the-if (car clau",
"he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)", "se)\n (cons the-begin (cdr clause))\n ",
"\n (and (pair? form)\n (variable? (car form))\n (variable=", " (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquot",
"? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic", "e\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ",
"ing? form)\n (and (pair? form)\n (pair? (car form))\n (var", " (variable? (car form))\n (variable=? (the 'quasiquote) (make-",
"iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif", "identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? for",
"ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo", "m)\n (variable? (car form))\n (variable=? (the 'unquote) (make",
"te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n", "-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and ",
" (list (the 'list)\n (list (the 'quote) (the 'unquote", "(pair? form)\n (pair? (car form))\n (variable? (caar form))\n ",
"))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli", " (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))",
"cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ", ")\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? e",
"(the 'append)\n (car (cdr (car expr)))\n (qq dep", "xpr)\n (if (= depth 1)\n (car (cdr expr))\n (list (the",
"th (cdr expr)))\n (list (the 'cons)\n (list (the 'list", " 'list)\n (list (the 'quote) (the 'unquote))\n (",
")\n (list (the 'quote) (the 'unquote-splicing))\n ", "qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-",
" (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep", "splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ",
"th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ", " (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ",
"(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q", " (list (the 'cons)\n (list (the 'list)\n ",
"q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l", " (list (the 'quote) (the 'unquote-splicing))\n (qq (- d",
"ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr", "epth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
" expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect", " ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ",
"or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ", " (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cd",
" (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def", "r expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ",
"ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ", " (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; ve",
" (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l", "ctor\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector-",
"et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi", ">list expr))))\n ;; simple datum\n (else\n (list (the 'quote) ex",
"ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n", "pr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lamb",
"(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n", "da (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cd",
"\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))", "r form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ",
")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)", " `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,",
" `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ", "(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n ",
"'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial", " (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*",
"s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t", "\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
"he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)", "(cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bi",
"\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", "ndings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)",
"(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi", "))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body))))",
"th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@", ")\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cd",
"(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ", "r form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (ca",
" ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((", "r (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ",
"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum", " `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lambd",
"ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l", "a () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ",
"oop ((formal formal))\n (if (pair? formal)\n `((,the", " (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(d",
"-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (", "efine-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form)",
"variable? formal)\n `((,the-define ,formal #undefined))\n ", "))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier ",
" '())))\n (,(the 'call-with-values) (,the-lambda () ,@b", "'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))\n",
"ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo", " (if (pair? formal)\n `((,the-define ,(car formal) ",
"rmal formal) (args arguments))\n (if (pair? formal)\n ", "#undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ",
" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t", " `((,the-define ,formal #undefined))\n '())",
"he 'cdr) ,args)))\n (if (variable? formal)\n ", "))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the-",
" `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define", "lambda\n ,arguments\n ,@(let loop ((formal formal) (args arg",
"-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (", "uments))\n (if (pair? formal)\n `((,the-set! ,(c",
"test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f", "ar formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ",
"orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id", " (if (variable? formal)\n `((,the-set! ,for",
"entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ", "mal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (f",
",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ", "orm env)\n (let ((bindings (car (cdr form)))\n (test (car (car (cd",
" ,@cleanup)\n (,the-begin\n ", "r (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (bo",
",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (", "dy (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here)))",
"car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo", "\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)\n",
"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ", " (,the-if ,test\n (,the-begin\n ,@cl",
" `(,the-if ,test\n (,the-begin ,@body)\n #undefine", "eanup)\n (,the-begin\n ,@body\n ",
"d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)", " (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr ",
"))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und", "x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((tes",
"efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo", "t (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ",
"rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))", " (,the-begin ,@body)\n #undefined))))\n\n(define-macro u",
"))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t", "nless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cd",
"he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c", "r (cdr form))))\n `(,the-if ,test\n #undefined\n ",
"lauses)\n #undefined\n (let ((clause (car clauses)", " (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key",
"))\n `(,the-if ,(if (and (variable? (car clause))\n ", " (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-ke",
" (variable=? (the 'else) (make-identifier (car clause) ", "y (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ",
"env)))\n #t\n `(", " ,(let loop ((clauses clauses))\n (if (null? clauses)\n ",
",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla", " #undefined\n (let ((clause (car clauses)))\n ",
"use))))\n ,(if (and (variable? (cadr clause))\n ", "`(,the-if ,(if (and (variable? (car clause))\n ",
" (variable=? (the '=>) (make-identifier (cadr cla", " (variable=? (the 'else) (make-identifier (car clause) env)))\n ",
"use) env)))\n `(,(car (cdr (cdr clause))) ,the-k", " #t\n `(,(the 'or) ,@(map (lam",
"ey)\n `(,the-begin ,@(cdr clause)))\n ", "bda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ",
" ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l", " ,(if (and (variable? (cadr clause))\n ",
"ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr", " (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
" form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f", " `(,(car (cdr (cdr clause))) ,the-key)\n ",
"ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ", " `(,the-begin ,@(cdr clause)))\n ,(loo",
"(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", "p (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (",
" (let ((x (assq var renames)))\n (if x\n ", "let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(th",
" (cadr x)\n (begin\n ", "e 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body)",
" (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)", "))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n ",
" ',var ',env)) . ,renames))\n (rename var))))))\n ", " (letrec\n ((rename (lambda (var)\n (let ((x (ass",
" (walk (lambda (f form)\n (cond\n ((vari", "q var renames)))\n (if x\n (cadr x",
"able? form)\n (f form))\n ((pair? form)\n ", ")\n (begin\n (set! renames `",
" `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ", "((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,rena",
" ((vector? form)\n `(,(the 'list->vector) (walk", "mes))\n (rename var))))))\n (walk (lambda (f",
" f (vector->list form))))\n (else\n `(,(the", " form)\n (cond\n ((variable? form)\n ",
" 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `", " (f form))\n ((pair? form)\n `(,(",
"(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac", "the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vecto",
"ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec", "r? form)\n `(,(the 'list->vector) (walk f (vector->list form)",
"\n ((rename (lambda (var)\n (let ((x (assq var rename", ")))\n (else\n `(,(the 'quote) ,form))))))\n ",
"s)))\n (if x\n (cadr x)\n ", " (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ",
" (begin\n (set! renames `((,var ,(mak", " ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n ",
"e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", " (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (l",
" (rename var)))))))\n\n (define (syntax-quasiquote? f", "ambda (var)\n (let ((x (assq var renames)))\n ",
"orm)\n (and (pair? form)\n (variable? (car form))\n ", " (if x\n (cadr x)\n (begi",
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n", "n\n (set! renames `((,var ,(make-identifier var env) ",
" (define (syntax-unquote? form)\n (and (pair? form)\n ", "(,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
" (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-", " (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (p",
"identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", "air? form)\n (variable? (car form))\n (variable=? (the",
" (and (pair? form)\n (pair? (car form))\n (var", " 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synta",
"iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m", "x-unquote? form)\n (and (pair? form)\n (variable? (car form",
"ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c", "))\n (variable=? (the 'syntax-unquote) (make-identifier (car form) ",
"ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ", "env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? f",
"(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis", "orm)\n (pair? (car form))\n (variable? (caar form))\n ",
"t)\n (list (the 'quote) (the 'syntax-unquote))\n ", " (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar f",
" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic", "orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; synt",
"ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ", "ax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ",
" (list (the 'append)\n (car (cdr (car expr)))\n ", " (car (cdr expr))\n (list (the 'list)\n ",
" (qq depth (cdr expr)))\n (list (the 'cons)\n ", " (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth ",
" (list (the 'list)\n (list (the 'quot", "1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synta",
"e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (", "x-unquote-splicing? expr)\n (if (= depth 1)\n (list (the",
"car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", " 'append)\n (car (cdr (car expr)))\n (qq",
" ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (", " depth (cdr expr)))\n (list (the 'cons)\n (lis",
"the 'list)\n (list (the 'quote) (the 'quasiquote))\n ", "t (the 'list)\n (list (the 'quote) (the 'syntax-unquot",
" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e", "e-splicing))\n (qq (- depth 1) (car (cdr (car expr))))",
"xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ", ")\n (qq depth (cdr expr)))))\n ;; syntax-quasiquote",
" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", "\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", " (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (",
" ;; variable\n ((variable? expr)\n (rename expr))\n ", "car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list",
" ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n", " (the 'cons)\n (qq depth (car expr))\n (qq depth",
" (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m", " (cdr expr))))\n ;; vector\n ((vector? expr)\n (list",
"ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form", " (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ",
" env)\n (let ((register1 (make-register))\n (register2 (make-register)", " ((variable? expr)\n (rename expr))\n ;; simple datum\n",
"))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ", " (else\n (list (the 'quote) expr))))\n\n (let ((body (q",
"(register1 var1)))\n (if var2\n (cdr v", "q 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ",
"ar2)\n (let ((var2 (make-identifier var1 env)))\n ", " ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regis",
" (register1 var1 var2)\n (register2 va", "ter1 (make-register))\n (register2 (make-register)))\n (letrec\n ",
"r2 var1)\n var2)))))\n (unwrap (lambda (var2)\n", " ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ",
" (let ((var1 (register2 var2)))\n (if v", " (if var2\n (cdr var2)\n ",
"ar1\n (cdr var1)\n var2))))\n ", " (let ((var2 (make-identifier var1 env)))\n (reg",
" (walk (lambda (f form)\n (cond\n ((v", "ister1 var1 var2)\n (register2 var2 var1)\n ",
"ariable? form)\n (f form))\n ((pair? form)\n", " var2)))))\n (unwrap (lambda (var2)\n (",
" (cons (walk f (car form)) (walk f (cdr form))))\n ", "let ((var1 (register2 var2)))\n (if var1\n ",
" ((vector? form)\n (list->vector (walk f (vector->lis", " (cdr var1)\n var2))))\n (walk (lambda",
"t form))))\n (else\n form)))))\n (let", " (f form)\n (cond\n ((variable? form)\n ",
" ((form (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(d", " (f form))\n ((pair? form)\n (",
"efine-macro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)", "cons (walk f (car form)) (walk f (cdr form))))\n ((vector? for",
"))\n (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(t", "m)\n (list->vector (walk f (vector->list form))))\n ",
"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `", " (else\n form)))))\n (let ((form (cdr form)))\n ",
"(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi", " (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syn",
"ne-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n", "tax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (",
" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n", "cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(c",
" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n f", "ar formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,fo",
"ormal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(", "rmal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax",
",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de", "\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr",
"fine-library\n (lambda (form _)\n (let ((name (cadr form))\n (body (cd", " (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(",
"dr form)))\n (let ((old-library (current-library))\n (new-library ", "the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body",
"(or (find-library name) (make-library name))))\n (let ((env (library-envir", "))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ",
"onment new-library)))\n (current-library new-library)\n (for-eac", ",@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda",
"h (lambda (expr) (eval expr env)) body)\n (current-library old-library))", " (form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ",
"))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (l", "((old-library (current-library))\n (new-library (or (find-library name",
"ambda (form)\n (or\n (eq? form 'else)\n ", ") (make-library name))))\n (let ((env (library-environment new-library)))\n",
" (and (symbol? form)\n (memq form (features)))\n ", " (current-library new-library)\n (for-each (lambda (expr) (eval",
" (and (pair? form)\n (case (car form)\n ", " expr env)) body)\n (current-library old-library))))))\n\n(define-macro co",
" ((library) (find-library (cadr form)))\n (", "nd-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ",
"(not) (not (test (cadr form))))\n ((and) (let loop ((form", " (or\n (eq? form 'else)\n (and (symbol? f",
" (cdr form)))\n (or (null? form)\n ", "orm)\n (memq form (features)))\n (and (pair",
" (and (test (car form)) (loop (cdr form))))))\n ", "? form)\n (case (car form)\n ((libra",
" ((or) (let loop ((form (cdr form)))\n ", "ry) (find-library (cadr form)))\n ((not) (not (test (cadr",
" (and (pair? form)\n (or (test (car form)) ", " form))))\n ((and) (let loop ((form (cdr form)))\n ",
"(loop (cdr form))))))\n (else #f)))))))\n (let loop (", " (or (null? form)\n ",
"(clauses (cdr form)))\n (if (null? clauses)\n #undefined\n ", " (and (test (car form)) (loop (cdr form))))))\n ((or) (le",
" (if (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", "t loop ((form (cdr form)))\n (and (pair? form)\n ",
" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _", " (or (test (car form)) (loop (cdr form))))))\n",
")\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefi", " (else #f)))))))\n (let loop ((clauses (cdr form)))\n",
"x\n (lambda (prefix symbol)\n (string->symbol\n ", " (if (null? clauses)\n #undefined\n (if (test (caar c",
"(string-append\n (symbol->string prefix)\n (symbol->st", "lauses))\n `(,the-begin ,@(cdar clauses))\n (loop (c",
"ring symbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", "dr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ",
" (case (car spec)\n ((only rename prefix except)\n ", " (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (",
" (extract (cadr spec)))\n (else\n (or (f", "prefix symbol)\n (string->symbol\n (string-append\n ",
"ind-library spec) (error \"library not found\" spec))))))\n (collect\n ", " (symbol->string prefix)\n (symbol->string symbol))))))\n ",
" (lambda (spec)\n (case (car spec)\n ((only)\n ", " (letrec\n ((extract\n (lambda (spec)\n (case (ca",
" (let ((alist (collect (cadr spec))))\n (map (lam", "r spec)\n ((only rename prefix except)\n (extract (",
"bda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ", "cadr spec)))\n (else\n (or (find-library spec) (err",
" (let ((alist (collect (cadr spec)))\n (renames (map (", "or \"library not found\" spec))))))\n (collect\n (lambda (spec)",
"lambda (x) `((car x) . (cadr x))) (cddr spec))))\n (map (lambda", "\n (case (car spec)\n ((only)\n (let ((",
" (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ", "alist (collect (cadr spec))))\n (map (lambda (var) (assq var al",
" (let ((alist (collect (cadr spec))))\n (map (lambda (s)", "ist)) (cddr spec))))\n ((rename)\n (let ((alist (co",
" (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((except", "llect (cadr spec)))\n (renames (map (lambda (x) `((car x) .",
")\n (let ((alist (collect (cadr spec))))\n (let ", " (cadr x))) (cddr spec))))\n (map (lambda (s) (or (assq (car s)",
"loop ((alist alist))\n (if (null? alist)\n ", " renames) s)) alist)))\n ((prefix)\n (let ((alist (",
" '()\n (if (memq (caar alist) (cddr spec))\n ", "collect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr ",
" (loop (cdr alist))\n (cons (car al", "spec) (car s)) (cdr s))) alist)))\n ((except)\n (le",
"ist) (loop (cdr alist))))))))\n (else\n (let ((lib ", "t ((alist (collect (cadr spec))))\n (let loop ((alist alist))\n ",
"(or (find-library spec) (error \"library not found\" spec))))\n (", " (if (null? alist)\n '()\n ",
"map (lambda (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ", " (if (memq (caar alist) (cddr spec))\n (lo",
" ((import\n (lambda (spec)\n (let ((lib (extract", "op (cdr alist))\n (cons (car alist) (loop (cdr alist)",
" spec))\n (alist (collect spec)))\n (for-e", ")))))))\n (else\n (let ((lib (or (find-library spec",
"ach\n (lambda (slot)\n (library-import lib", ") (error \"library not found\" spec))))\n (map (lambda (x) (cons ",
" (cdr slot) (car slot)))\n alist)))))\n (for-each impo", "x x)) (library-exports lib))))))))\n (letrec\n ((import\n ",
"rt (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ", " (lambda (spec)\n (let ((lib (extract spec))\n ",
" ((collect\n (lambda (spec)\n (cond\n ((symbol? spe", " (alist (collect spec)))\n (for-each\n ",
"c)\n `(,spec . ,spec))\n ((and (list? spec) (= (length sp", " (lambda (slot)\n (library-import lib (cdr slot) (car slot)",
"ec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref", "))\n alist)))))\n (for-each import (cdr form)))))))\n\n(",
" spec 2)))\n (else\n (error \"malformed export\")))))\n ", "define-macro export\n (lambda (form _)\n (letrec\n ((collect\n (",
" (export\n (lambda (spec)\n (let ((slot (collect spec)))\n", "lambda (spec)\n (cond\n ((symbol? spec)\n `(,sp",
" (library-export (car slot) (cdr slot))))))\n (for-each export", "ec . ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec)",
" (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n ", " 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n ",
"let let* letrec letrec*\n let-values let*-values define-values\n qua", " (else\n (error \"malformed export\")))))\n (export\n ",
"siquote unquote unquote-splicing\n and or\n cond case else =>\n ", " (lambda (spec)\n (let ((slot (collect spec)))\n (librar",
" do when unless\n parameterize\n define-syntax\n syntax-quote", "y-export (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(expo",
" syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-sy", "rt define lambda quote set! if begin define-macro\n let let* letrec letrec",
"ntax letrec-syntax\n syntax-error)\n\n\n", "*\n let-values let*-values define-values\n quasiquote unquote unquot",
"e-splicing\n and or\n cond case else =>\n do when unless\n ",
" parameterize\n define-syntax\n syntax-quote syntax-unquote\n ",
" syntax-quasiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n ",
" syntax-error)\n\n\n",
"", "",
"" ""
}; };