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
parent
7019f81aaf
commit
0f3ef76fcb
|
|
@ -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