From 0f3ef76fcb89f450ec4ca1c62110e19925c880eb Mon Sep 17 00:00:00 2001 From: Doug Currie Date: Sat, 23 Jan 2016 16:14:11 -0500 Subject: [PATCH] =?UTF-8?q?Fix=20cond=20to=20conform=20to=20R7RS=20'If=20t?= =?UTF-8?q?he=20selected=20=E2=9F=A8clause=E2=9F=A9=20contains=20only=20th?= =?UTF-8?q?e=20=E2=9F=A8test=E2=9F=A9=20and=20no=20=E2=9F=A8expression?= =?UTF-8?q?=E2=9F=A9s,=20then=20the=20value=20of=20the=20=E2=9F=A8test?= =?UTF-8?q?=E2=9F=A9=20is=20returned=20as=20the=20result.'?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extlib/benz/boot.c | 452 +++++++++++++++++++++++---------------------- 1 file changed, 230 insertions(+), 222 deletions(-) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 9802f811..72bb1d54 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -192,16 +192,20 @@ my $src = <<'EOL'; (if (and (variable? (car clause)) (variable=? (the 'else) (make-identifier (car clause) env))) (cons the-begin (cdr clause)) - (if (and (variable? (cadr clause)) - (variable=? (the '=>) (make-identifier (cadr clause) env))) + (if (null? (cdr clause)) (let ((tmp (make-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) - (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)))))))))) + (list the-if tmp tmp (cons (the 'cond) (cdr clauses))))) + (if (and (variable? (cadr clause)) + (variable=? (the '=>) (make-identifier (cadr clause) env))) + (let ((tmp (make-identifier 'tmp here))) + (list (the 'let) (list (list tmp (car clause))) + (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 (lambda (form env) @@ -788,220 +792,224 @@ const char pic_boot[][80] = { "\n (if (null? clauses)\n #undefined\n (let ((clause (car cla", "uses)))\n (if (and (variable? (car clause))\n (vari", "able=? (the 'else) (make-identifier (car clause) env)))\n (cons th", -"e-begin (cdr clause))\n (if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", -" (let ((tmp (make-identifier 'tmp here)))\n ", -" (list (the 'let) (list (list tmp (car clause)))\n (li", -"st the-if tmp\n (list (car (cddr clause)) tmp)\n ", -" (cons (the 'cond) (cdr clauses)))))\n ", -" (list the-if (car clause)\n (cons the-begin (cd", -"r clause))\n (cons (the 'cond) (cdr clauses))))))))))\n\n(", -"define-macro quasiquote\n (lambda (form env)\n\n (define (quasiquote? form)\n ", -" (and (pair? form)\n (variable? (car form))\n (variable=? (t", -"he 'quasiquote) (make-identifier (car form) env))))\n\n (define (unquote? form)", -"\n (and (pair? form)\n (variable? (car form))\n (variable=", -"? (the 'unquote) (make-identifier (car form) env))))\n\n (define (unquote-splic", -"ing? form)\n (and (pair? form)\n (pair? (car form))\n (var", -"iable? (caar form))\n (variable=? (the 'unquote-splicing) (make-identif", -"ier (caar form) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquo", -"te\n ((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n", -" (list (the 'list)\n (list (the 'quote) (the 'unquote", -"))\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-spli", -"cing\n ((unquote-splicing? expr)\n (if (= depth 1)\n (list ", -"(the 'append)\n (car (cdr (car expr)))\n (qq dep", -"th (cdr expr)))\n (list (the 'cons)\n (list (the 'list", -")\n (list (the 'quote) (the 'unquote-splicing))\n ", -" (qq (- depth 1) (car (cdr (car expr)))))\n (qq dep", -"th (cdr expr)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list ", -"(the 'list)\n (list (the 'quote) (the 'quasiquote))\n (q", -"q (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (l", -"ist (the 'cons)\n (qq depth (car expr))\n (qq depth (cdr", -" expr))))\n ;; vector\n ((vector? expr)\n (list (the 'list->vect", -"or) (qq depth (vector->list expr))))\n ;; simple datum\n (else\n ", -" (list (the 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(def", -"ine-macro let*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ", -" (body (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'l", -"et) () ,@body)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindi", -"ngs))))\n (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n", -"(define-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n", -"\n(define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form))", -")\n (body (cdr (cdr form))))\n (let ((variables (map (lambda (v)", -" `(,v #f)) (map car bindings)))\n (initials (map (lambda (v) `(,(the ", -"'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ,@initial", -"s\n ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(t", -"he 'let*-values) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)", -"\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ", -"(if (null? formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-wi", -"th-values) (,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@", -"(car (car formal)))\n (,(the 'let*-values) (,@(cdr formal))\n ", -" ,@body)))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((", -"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (let ((argum", -"ents (make-identifier 'arguments here)))\n `(,the-begin\n ,@(let l", -"oop ((formal formal))\n (if (pair? formal)\n `((,the", -"-define ,(car formal) #undefined) ,@(loop (cdr formal)))\n (if (", -"variable? formal)\n `((,the-define ,formal #undefined))\n ", -" '())))\n (,(the 'call-with-values) (,the-lambda () ,@b", -"ody)\n (,the-lambda\n ,arguments\n ,@(let loop ((fo", -"rmal formal) (args arguments))\n (if (pair? formal)\n ", -" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(t", -"he 'cdr) ,args)))\n (if (variable? formal)\n ", -" `((,the-set! ,formal ,args))\n '()))))))))))\n\n(define", -"-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (", -"test (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr f", -"orm)))))\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-id", -"entifier 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ", -",(cadr x))) bindings)\n (,the-if ,test\n (,the-begin\n ", -" ,@cleanup)\n (,the-begin\n ", -",@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (", -"car x) (car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (fo", -"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n ", -" `(,the-if ,test\n (,the-begin ,@body)\n #undefine", -"d))))\n\n(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)", -"))\n (body (cdr (cdr form))))\n `(,the-if ,test\n #und", -"efined\n (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (fo", -"rm env)\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))", -"))\n (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,t", -"he-key ,key))\n ,(let loop ((clauses clauses))\n (if (null? c", -"lauses)\n #undefined\n (let ((clause (car clauses)", -"))\n `(,the-if ,(if (and (variable? (car clause))\n ", -" (variable=? (the 'else) (make-identifier (car clause) ", -"env)))\n #t\n `(", -",(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car cla", -"use))))\n ,(if (and (variable? (cadr clause))\n ", -" (variable=? (the '=>) (make-identifier (cadr cla", -"use) env)))\n `(,(car (cdr (cdr clause))) ,the-k", -"ey)\n `(,the-begin ,@(cdr clause)))\n ", -" ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (l", -"ambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr", -" form))))\n `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@f", -"ormal\n ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n ", -"(let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ", -" (let ((x (assq var renames)))\n (if x\n ", -" (cadr x)\n (begin\n ", -" (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier)", -" ',var ',env)) . ,renames))\n (rename var))))))\n ", -" (walk (lambda (f form)\n (cond\n ((vari", -"able? form)\n (f form))\n ((pair? form)\n ", -" `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ", -" ((vector? form)\n `(,(the 'list->vector) (walk", -" f (vector->list form))))\n (else\n `(,(the", -" 'quote) ,form))))))\n (let ((form (walk rename (cadr form))))\n `", -"(,(the 'let)\n ,(map cdr renames)\n ,form))))))\n\n(define-mac", -"ro syntax-quasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec", -"\n ((rename (lambda (var)\n (let ((x (assq var rename", -"s)))\n (if x\n (cadr x)\n ", -" (begin\n (set! renames `((,var ,(mak", -"e-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ", -" (rename var)))))))\n\n (define (syntax-quasiquote? f", -"orm)\n (and (pair? form)\n (variable? (car form))\n ", -" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n", -" (define (syntax-unquote? form)\n (and (pair? form)\n ", -" (variable? (car form))\n (variable=? (the 'syntax-unquote) (make-", -"identifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ", -" (and (pair? form)\n (pair? (car form))\n (var", -"iable? (caar form))\n (variable=? (the 'syntax-unquote-splicing) (m", -"ake-identifier (caar form) env))))\n\n (define (qq depth expr)\n (c", -"ond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ", -"(if (= depth 1)\n (car (cdr expr))\n (list (the 'lis", -"t)\n (list (the 'quote) (the 'syntax-unquote))\n ", -" (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-splic", -"ing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ", -" (list (the 'append)\n (car (cdr (car expr)))\n ", -" (qq depth (cdr expr)))\n (list (the 'cons)\n ", -" (list (the 'list)\n (list (the 'quot", -"e) (the 'syntax-unquote-splicing))\n (qq (- depth 1) (", -"car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", -" ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list (", -"the 'list)\n (list (the 'quote) (the 'quasiquote))\n ", -" (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? e", -"xpr)\n (list (the 'cons)\n (qq depth (car expr))\n ", -" (qq depth (cdr expr))))\n ;; vector\n ((vector? e", -"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ", -" ;; variable\n ((variable? expr)\n (rename expr))\n ", -" ;; simple datum\n (else\n (list (the 'quote) expr))))\n\n", -" (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ,(m", -"ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form", -" env)\n (let ((register1 (make-register))\n (register2 (make-register)", -"))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ", -"(register1 var1)))\n (if var2\n (cdr v", -"ar2)\n (let ((var2 (make-identifier var1 env)))\n ", -" (register1 var1 var2)\n (register2 va", -"r2 var1)\n var2)))))\n (unwrap (lambda (var2)\n", -" (let ((var1 (register2 var2)))\n (if v", -"ar1\n (cdr var1)\n var2))))\n ", -" (walk (lambda (f form)\n (cond\n ((v", -"ariable? form)\n (f form))\n ((pair? form)\n", -" (cons (walk f (car form)) (walk f (cdr form))))\n ", -" ((vector? form)\n (list->vector (walk f (vector->lis", -"t form))))\n (else\n form)))))\n (let", -" ((form (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(d", -"efine-macro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)", -"))\n (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(t", -"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `", -"(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi", -"ne-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n", -" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n", -" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n f", -"ormal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(", -",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de", -"fine-library\n (lambda (form _)\n (let ((name (cadr form))\n (body (cd", -"dr form)))\n (let ((old-library (current-library))\n (new-library ", -"(or (find-library name) (make-library name))))\n (let ((env (library-envir", -"onment new-library)))\n (current-library new-library)\n (for-eac", -"h (lambda (expr) (eval expr env)) body)\n (current-library old-library))", -"))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (l", -"ambda (form)\n (or\n (eq? form 'else)\n ", -" (and (symbol? form)\n (memq form (features)))\n ", -" (and (pair? form)\n (case (car form)\n ", -" ((library) (find-library (cadr form)))\n (", -"(not) (not (test (cadr form))))\n ((and) (let loop ((form", -" (cdr form)))\n (or (null? form)\n ", -" (and (test (car form)) (loop (cdr form))))))\n ", -" ((or) (let loop ((form (cdr form)))\n ", -" (and (pair? form)\n (or (test (car form)) ", -"(loop (cdr form))))))\n (else #f)))))))\n (let loop (", -"(clauses (cdr form)))\n (if (null? clauses)\n #undefined\n ", -" (if (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", -" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _", -")\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefi", -"x\n (lambda (prefix symbol)\n (string->symbol\n ", -"(string-append\n (symbol->string prefix)\n (symbol->st", -"ring symbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", -" (case (car spec)\n ((only rename prefix except)\n ", -" (extract (cadr spec)))\n (else\n (or (f", -"ind-library spec) (error \"library not found\" spec))))))\n (collect\n ", -" (lambda (spec)\n (case (car spec)\n ((only)\n ", -" (let ((alist (collect (cadr spec))))\n (map (lam", -"bda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ", -" (let ((alist (collect (cadr spec)))\n (renames (map (", -"lambda (x) `((car x) . (cadr x))) (cddr spec))))\n (map (lambda", -" (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ", -" (let ((alist (collect (cadr spec))))\n (map (lambda (s)", -" (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((except", -")\n (let ((alist (collect (cadr spec))))\n (let ", -"loop ((alist alist))\n (if (null? alist)\n ", -" '()\n (if (memq (caar alist) (cddr spec))\n ", -" (loop (cdr alist))\n (cons (car al", -"ist) (loop (cdr alist))))))))\n (else\n (let ((lib ", -"(or (find-library spec) (error \"library not found\" spec))))\n (", -"map (lambda (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ", -" ((import\n (lambda (spec)\n (let ((lib (extract", -" spec))\n (alist (collect spec)))\n (for-e", -"ach\n (lambda (slot)\n (library-import lib", -" (cdr slot) (car slot)))\n alist)))))\n (for-each impo", -"rt (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ", -" ((collect\n (lambda (spec)\n (cond\n ((symbol? spe", -"c)\n `(,spec . ,spec))\n ((and (list? spec) (= (length sp", -"ec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref", -" spec 2)))\n (else\n (error \"malformed export\")))))\n ", -" (export\n (lambda (spec)\n (let ((slot (collect spec)))\n", -" (library-export (car slot) (cdr slot))))))\n (for-each export", -" (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n ", -"let let* letrec letrec*\n let-values let*-values define-values\n qua", -"siquote unquote unquote-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-sy", -"ntax letrec-syntax\n syntax-error)\n\n\n", +"e-begin (cdr clause))\n (if (null? (cdr clause))\n ", +" (let ((tmp (make-identifier 'tmp here)))\n (list (the 'le", +"t) (list (list tmp (car clause)))\n (list the-if tmp t", +"mp (cons (the 'cond) (cdr clauses)))))\n (if (and (variable? (", +"cadr clause))\n (variable=? (the '=>) (make-identifie", +"r (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp ", +"here)))\n (list (the 'let) (list (list tmp (car clause))", +")\n (list the-if tmp\n ", +" (list (car (cddr clause)) tmp)\n (c", +"ons (the 'cond) (cdr clauses)))))\n (list the-if (car clau", +"se)\n (cons the-begin (cdr clause))\n ", +" (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquot", +"e\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ", +" (variable? (car form))\n (variable=? (the 'quasiquote) (make-", +"identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? for", +"m)\n (variable? (car form))\n (variable=? (the 'unquote) (make", +"-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and ", +"(pair? form)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'unquote-splicing) (make-identifier (caar form) env)))", +")\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ((unquote? e", +"xpr)\n (if (= depth 1)\n (car (cdr expr))\n (list (the", +" 'list)\n (list (the 'quote) (the 'unquote))\n (", +"qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ((unquote-", +"splicing? expr)\n (if (= depth 1)\n (list (the 'append)\n ", +" (car (cdr (car expr)))\n (qq depth (cdr expr)))\n ", +" (list (the 'cons)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'unquote-splicing))\n (qq (- d", +"epth 1) (car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ", +" ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (car (cd", +"r expr)))))\n ;; list\n ((pair? expr)\n (list (the 'cons)\n ", +" (qq depth (car expr))\n (qq depth (cdr expr))))\n ;; ve", +"ctor\n ((vector? expr)\n (list (the 'list->vector) (qq depth (vector-", +">list expr))))\n ;; simple datum\n (else\n (list (the 'quote) ex", +"pr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro let*\n (lamb", +"da (form env)\n (let ((bindings (car (cdr form)))\n (body (cdr (cd", +"r form))))\n (if (null? bindings)\n `(,(the 'let) () ,@body)\n ", +" `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n (,", +"(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-macro letrec\n ", +" (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-macro letrec*", +"\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ", +"(cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) (map car bi", +"ndings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)", +"))\n `(,(the 'let) (,@variables)\n ,@initials\n ,@body))))", +")\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-values) ,@(cd", +"r form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let ((formal (ca", +"r (cdr form)))\n (body (cdr (cdr form))))\n (if (null? formal)\n ", +" `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) (,the-lambd", +"a () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car formal)))\n ", +" (,(the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n(d", +"efine-macro define-values\n (lambda (form env)\n (let ((formal (car (cdr form)", +"))\n (body (cdr (cdr form))))\n (let ((arguments (make-identifier ", +"'arguments here)))\n `(,the-begin\n ,@(let loop ((formal formal))\n", +" (if (pair? formal)\n `((,the-define ,(car formal) ", +"#undefined) ,@(loop (cdr formal)))\n (if (variable? formal)\n ", +" `((,the-define ,formal #undefined))\n '())", +"))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n (,the-", +"lambda\n ,arguments\n ,@(let loop ((formal formal) (args arg", +"uments))\n (if (pair? formal)\n `((,the-set! ,(c", +"ar formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n ", +" (if (variable? formal)\n `((,the-set! ,for", +"mal ,args))\n '()))))))))))\n\n(define-macro do\n (lambda (f", +"orm env)\n (let ((bindings (car (cdr form)))\n (test (car (car (cd", +"r (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form)))))\n (bo", +"dy (cdr (cdr (cdr form)))))\n (let ((loop (make-identifier 'loop here)))", +"\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)\n", +" (,the-if ,test\n (,the-begin\n ,@cl", +"eanup)\n (,the-begin\n ,@body\n ", +" (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr ", +"x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)\n (let ((tes", +"t (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n ", +" (,the-begin ,@body)\n #undefined))))\n\n(define-macro u", +"nless\n (lambda (form env)\n (let ((test (car (cdr form)))\n (body (cd", +"r (cdr form))))\n `(,the-if ,test\n #undefined\n ", +" (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)\n (let ((key", +" (car (cdr form)))\n (clauses (cdr (cdr form))))\n (let ((the-ke", +"y (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ,key))\n ", +" ,(let loop ((clauses clauses))\n (if (null? clauses)\n ", +" #undefined\n (let ((clause (car clauses)))\n ", +"`(,the-if ,(if (and (variable? (car clause))\n ", +" (variable=? (the 'else) (make-identifier (car clause) env)))\n ", +" #t\n `(,(the 'or) ,@(map (lam", +"bda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ", +" ,(if (and (variable? (cadr clause))\n ", +" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ", +" `(,(car (cdr (cdr clause))) ,the-key)\n ", +" `(,the-begin ,@(cdr clause)))\n ,(loo", +"p (cdr clauses)))))))))))\n\n(define-macro parameterize\n (lambda (form env)\n (", +"let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(,(th", +"e 'with-parameter)\n (,(the 'lambda) ()\n ,@formal\n ,@body)", +"))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((renames '()))\n ", +" (letrec\n ((rename (lambda (var)\n (let ((x (ass", +"q var renames)))\n (if x\n (cadr x", +")\n (begin\n (set! renames `", +"((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,rena", +"mes))\n (rename var))))))\n (walk (lambda (f", +" form)\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n `(,(", +"the 'cons) (walk f (car form)) (walk f (cdr form))))\n ((vecto", +"r? form)\n `(,(the 'list->vector) (walk f (vector->list form)", +")))\n (else\n `(,(the 'quote) ,form))))))\n ", +" (let ((form (walk rename (cadr form))))\n `(,(the 'let)\n ", +" ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-quasiquote\n ", +" (lambda (form env)\n (let ((renames '()))\n (letrec\n ((rename (l", +"ambda (var)\n (let ((x (assq var renames)))\n ", +" (if x\n (cadr x)\n (begi", +"n\n (set! renames `((,var ,(make-identifier var env) ", +"(,(the 'make-identifier) ',var ',env)) . ,renames))\n ", +" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n (and (p", +"air? form)\n (variable? (car form))\n (variable=? (the", +" 'syntax-quasiquote) (make-identifier (car form) env))))\n\n (define (synta", +"x-unquote? form)\n (and (pair? form)\n (variable? (car form", +"))\n (variable=? (the 'syntax-unquote) (make-identifier (car form) ", +"env))))\n\n (define (syntax-unquote-splicing? form)\n (and (pair? f", +"orm)\n (pair? (car form))\n (variable? (caar form))\n ", +" (variable=? (the 'syntax-unquote-splicing) (make-identifier (caar f", +"orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; synt", +"ax-unquote\n ((syntax-unquote? expr)\n (if (= depth 1)\n ", +" (car (cdr expr))\n (list (the 'list)\n ", +" (list (the 'quote) (the 'syntax-unquote))\n (qq (- depth ", +"1) (car (cdr expr))))))\n ;; syntax-unquote-splicing\n ((synta", +"x-unquote-splicing? expr)\n (if (= depth 1)\n (list (the", +" 'append)\n (car (cdr (car expr)))\n (qq", +" depth (cdr expr)))\n (list (the 'cons)\n (lis", +"t (the 'list)\n (list (the 'quote) (the 'syntax-unquot", +"e-splicing))\n (qq (- depth 1) (car (cdr (car expr))))", +")\n (qq depth (cdr expr)))))\n ;; syntax-quasiquote", +"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ", +" (list (the 'quote) (the 'quasiquote))\n (qq (+ depth 1) (", +"car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list", +" (the 'cons)\n (qq depth (car expr))\n (qq depth", +" (cdr expr))))\n ;; vector\n ((vector? expr)\n (list", +" (the 'list->vector) (qq depth (vector->list expr))))\n ;; variable\n ", +" ((variable? expr)\n (rename expr))\n ;; simple datum\n", +" (else\n (list (the 'quote) expr))))\n\n (let ((body (q", +"q 1 (cadr form))))\n `(,(the 'let)\n ,(map cdr renames)\n ", +" ,body))))))\n\n(define (transformer f)\n (lambda (form env)\n (let ((regis", +"ter1 (make-register))\n (register2 (make-register)))\n (letrec\n ", +" ((wrap (lambda (var1)\n (let ((var2 (register1 var1)))\n ", +" (if var2\n (cdr var2)\n ", +" (let ((var2 (make-identifier var1 env)))\n (reg", +"ister1 var1 var2)\n (register2 var2 var1)\n ", +" var2)))))\n (unwrap (lambda (var2)\n (", +"let ((var1 (register2 var2)))\n (if var1\n ", +" (cdr var1)\n var2))))\n (walk (lambda", +" (f form)\n (cond\n ((variable? form)\n ", +" (f form))\n ((pair? form)\n (", +"cons (walk f (car form)) (walk f (cdr form))))\n ((vector? for", +"m)\n (list->vector (walk f (vector->list form))))\n ", +" (else\n form)))))\n (let ((form (cdr form)))\n ", +" (walk unwrap (apply f (walk wrap form))))))))\n\n(define-macro define-syn", +"tax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (", +"cdr (cdr form))))\n (if (pair? formal)\n `(,(the 'define-syntax) ,(c", +"ar formal) (,the-lambda ,(cdr formal) ,@body))\n `(,the-define-macro ,fo", +"rmal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(define-macro letrec-syntax", +"\n (lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr", +" (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n `(,(", +"the 'define-syntax) ,(car x) ,(cadr x)))\n formal)\n ,@body", +"))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ", +",@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro define-library\n (lambda", +" (form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (let ", +"((old-library (current-library))\n (new-library (or (find-library name", +") (make-library name))))\n (let ((env (library-environment new-library)))\n", +" (current-library new-library)\n (for-each (lambda (expr) (eval", +" expr env)) body)\n (current-library old-library))))))\n\n(define-macro co", +"nd-expand\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ", +" (or\n (eq? form 'else)\n (and (symbol? f", +"orm)\n (memq form (features)))\n (and (pair", +"? form)\n (case (car form)\n ((libra", +"ry) (find-library (cadr form)))\n ((not) (not (test (cadr", +" form))))\n ((and) (let loop ((form (cdr form)))\n ", +" (or (null? form)\n ", +" (and (test (car form)) (loop (cdr form))))))\n ((or) (le", +"t loop ((form (cdr form)))\n (and (pair? form)\n ", +" (or (test (car form)) (loop (cdr form))))))\n", +" (else #f)))))))\n (let loop ((clauses (cdr form)))\n", +" (if (null? clauses)\n #undefined\n (if (test (caar c", +"lauses))\n `(,the-begin ,@(cdar clauses))\n (loop (c", +"dr clauses))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ", +" (lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (", +"prefix symbol)\n (string->symbol\n (string-append\n ", +" (symbol->string prefix)\n (symbol->string symbol))))))\n ", +" (letrec\n ((extract\n (lambda (spec)\n (case (ca", +"r spec)\n ((only rename prefix except)\n (extract (", +"cadr spec)))\n (else\n (or (find-library spec) (err", +"or \"library not found\" spec))))))\n (collect\n (lambda (spec)", +"\n (case (car spec)\n ((only)\n (let ((", +"alist (collect (cadr spec))))\n (map (lambda (var) (assq var al", +"ist)) (cddr spec))))\n ((rename)\n (let ((alist (co", +"llect (cadr spec)))\n (renames (map (lambda (x) `((car x) .", +" (cadr x))) (cddr spec))))\n (map (lambda (s) (or (assq (car s)", +" renames) s)) alist)))\n ((prefix)\n (let ((alist (", +"collect (cadr spec))))\n (map (lambda (s) (cons (prefix (caddr ", +"spec) (car s)) (cdr s))) alist)))\n ((except)\n (le", +"t ((alist (collect (cadr spec))))\n (let loop ((alist alist))\n ", +" (if (null? alist)\n '()\n ", +" (if (memq (caar alist) (cddr spec))\n (lo", +"op (cdr alist))\n (cons (car alist) (loop (cdr alist)", +")))))))\n (else\n (let ((lib (or (find-library spec", +") (error \"library not found\" spec))))\n (map (lambda (x) (cons ", +"x x)) (library-exports lib))))))))\n (letrec\n ((import\n ", +" (lambda (spec)\n (let ((lib (extract spec))\n ", +" (alist (collect spec)))\n (for-each\n ", +" (lambda (slot)\n (library-import lib (cdr slot) (car slot)", +"))\n alist)))))\n (for-each import (cdr form)))))))\n\n(", +"define-macro export\n (lambda (form _)\n (letrec\n ((collect\n (", +"lambda (spec)\n (cond\n ((symbol? spec)\n `(,sp", +"ec . ,spec))\n ((and (list? spec) (= (length spec) 3) (eq? (car spec)", +" 'rename))\n `(,(list-ref spec 1) . ,(list-ref spec 2)))\n ", +" (else\n (error \"malformed export\")))))\n (export\n ", +" (lambda (spec)\n (let ((slot (collect spec)))\n (librar", +"y-export (car slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n(expo", +"rt define lambda quote set! if begin define-macro\n let let* letrec letrec", +"*\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", "", "" };