Merge pull request #327 from dcurrie/defect-cond
Fix cond to conform to R7RS 'If the selected ⟨clause⟩ contains only t…
This commit is contained in:
Yuichi Nishiwaki
commit
5a5b5ee25c
|
|
@ -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",
|
||||
"",
|
||||
""
|
||||
};
|
||||
|
|
|
|||
Loading…
Reference in New Issue