refine error messages
This commit is contained in:
		
							parent
							
								
									bcf53b9883
								
							
						
					
					
						commit
						4d18610a79
					
				| 
						 | 
				
			
			@ -109,7 +109,7 @@ my $src = <<'EOL';
 | 
			
		|||
                   (list the-define
 | 
			
		||||
                         (car (cadr form))
 | 
			
		||||
                         (cons the-lambda (cons (cdr (cadr form)) (cddr form))))
 | 
			
		||||
                   (error "illegal define form" form)))))
 | 
			
		||||
                   (error "define: binding to non-varaible object" form)))))
 | 
			
		||||
     (length form))))
 | 
			
		||||
 | 
			
		||||
(builtin:define-macro define-macro
 | 
			
		||||
| 
						 | 
				
			
			@ -117,7 +117,7 @@ my $src = <<'EOL';
 | 
			
		|||
    (if (= (length form) 3)
 | 
			
		||||
        (if (variable? (cadr form))
 | 
			
		||||
            (cons the-builtin-define-macro (cdr form))
 | 
			
		||||
            (error "illegal define-macro form" form))
 | 
			
		||||
            (error "define-macro: binding to non-variable object" form))
 | 
			
		||||
        (error "illegal define-macro form" form))))
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -760,250 +760,250 @@ const char pic_boot[][80] = {
 | 
			
		|||
"n-define (cdr form))\n                   (error \"illegal define form\" form))\n    ",
 | 
			
		||||
"           (if (pair? (cadr form))\n                   (list the-define\n         ",
 | 
			
		||||
"                (car (cadr form))\n                         (cons the-lambda (con",
 | 
			
		||||
"s (cdr (cadr form)) (cddr form))))\n                   (error \"illegal define for",
 | 
			
		||||
"m\" form)))))\n     (length form))))\n\n(builtin:define-macro define-macro\n  (lambda",
 | 
			
		||||
" (form env)\n    (if (= (length form) 3)\n        (if (variable? (cadr form))\n    ",
 | 
			
		||||
"        (cons the-builtin-define-macro (cdr form))\n            (error \"illegal d",
 | 
			
		||||
"efine-macro form\" form))\n        (error \"illegal define-macro form\" form))))\n\n\n(",
 | 
			
		||||
"define-macro syntax-error\n  (lambda (form _)\n    (apply error (cdr form))))\n\n(de",
 | 
			
		||||
"fine-macro define-auxiliary-syntax\n  (lambda (form _)\n    (define message\n      ",
 | 
			
		||||
"(string-append\n       \"invalid use of auxiliary syntax: '\" (symbol->string (cadr",
 | 
			
		||||
" form)) \"'\"))\n    (list\n     the-define-macro\n     (cadr form)\n     (list the-la",
 | 
			
		||||
"mbda '_\n           (list (the 'error) message)))))\n\n(define-auxiliary-syntax els",
 | 
			
		||||
"e)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syntax unquote)\n(define-auxili",
 | 
			
		||||
"ary-syntax unquote-splicing)\n(define-auxiliary-syntax syntax-unquote)\n(define-au",
 | 
			
		||||
"xiliary-syntax syntax-unquote-splicing)\n\n(define-macro let\n  (lambda (form env)\n",
 | 
			
		||||
"    (if (variable? (cadr form))\n        (list\n         (list the-lambda '()\n    ",
 | 
			
		||||
"           (list the-define (cadr form)\n                     (cons the-lambda\n  ",
 | 
			
		||||
"                         (cons (map car (car (cddr form)))\n                     ",
 | 
			
		||||
"            (cdr (cddr form)))))\n               (cons (cadr form) (map cadr (car",
 | 
			
		||||
" (cddr form))))))\n        (cons\n         (cons\n          the-lambda\n          (c",
 | 
			
		||||
"ons (map car (cadr form))\n                (cddr form)))\n         (map cadr (cadr",
 | 
			
		||||
" form))))))\n\n(define-macro and\n  (lambda (form env)\n    (if (null? (cdr form))\n ",
 | 
			
		||||
"       #t\n        (if (null? (cddr form))\n            (cadr form)\n            (l",
 | 
			
		||||
"ist the-if\n                  (cadr form)\n                  (cons (the 'and) (cdd",
 | 
			
		||||
"r form))\n                  #f)))))\n\n(define-macro or\n  (lambda (form env)\n    (i",
 | 
			
		||||
"f (null? (cdr form))\n        #f\n        (let ((tmp (make-identifier 'it env)))\n ",
 | 
			
		||||
"         (list (the 'let)\n                (list (list tmp (cadr form)))\n        ",
 | 
			
		||||
"        (list the-if\n                      tmp\n                      tmp\n       ",
 | 
			
		||||
"               (cons (the 'or) (cddr form))))))))\n\n(define-macro cond\n  (lambda ",
 | 
			
		||||
"(form env)\n    (let ((clauses (cdr form)))\n      (if (null? clauses)\n          #",
 | 
			
		||||
"undefined\n          (let ((clause (car clauses)))\n            (if (and (variable",
 | 
			
		||||
"? (car clause))\n                     (variable=? (the 'else) (make-identifier (c",
 | 
			
		||||
"ar clause) env)))\n                (cons the-begin (cdr clause))\n                ",
 | 
			
		||||
"(if (and (variable? (cadr clause))\n                         (variable=? (the '=>",
 | 
			
		||||
") (make-identifier (cadr clause) env)))\n                    (let ((tmp (make-ide",
 | 
			
		||||
"ntifier 'tmp here)))\n                      (list (the 'let) (list (list tmp (car",
 | 
			
		||||
" clause)))\n                            (list 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 (cdr clause))\n                          (",
 | 
			
		||||
"cons (the 'cond) (cdr clauses))))))))))\n\n(define-macro quasiquote\n  (lambda (for",
 | 
			
		||||
"m env)\n\n    (define (quasiquote? form)\n      (and (pair? form)\n           (varia",
 | 
			
		||||
"ble? (car form))\n           (variable=? (the 'quasiquote) (make-identifier (car ",
 | 
			
		||||
"form) env))))\n\n    (define (unquote? form)\n      (and (pair? form)\n           (v",
 | 
			
		||||
"ariable? (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           (variab",
 | 
			
		||||
"le=? (the 'unquote-splicing) (make-identifier (caar form) env))))\n\n    (define (",
 | 
			
		||||
"qq depth expr)\n      (cond\n       ;; unquote\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-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 (- depth 1) (car (cd",
 | 
			
		||||
"r (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 (cdr expr)))))\n    ",
 | 
			
		||||
"   ;; list\n       ((pair? expr)\n        (list (the 'cons)\n              (qq dept",
 | 
			
		||||
"h (car expr))\n              (qq depth (cdr expr))))\n       ;; vector\n       ((ve",
 | 
			
		||||
"ctor? expr)\n        (list (the 'list->vector) (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(define-macro let*\n  (lambda (form env)\n  ",
 | 
			
		||||
"  (let ((bindings (car (cdr form)))\n          (body     (cdr (cdr 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 e",
 | 
			
		||||
"nv)\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        `(,(t",
 | 
			
		||||
"he 'let) (,@variables)\n          ,@initials\n          ,@body)))))\n\n(define-macro",
 | 
			
		||||
" let-values\n  (lambda (form env)\n    `(,(the 'let*-values) ,@(cdr form))))\n\n(def",
 | 
			
		||||
"ine-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-with-values) (,the-lambda () ,@(cdr (car",
 | 
			
		||||
" formal)))\n            (,(the 'lambda) (,@(car (car formal)))\n             (,(th",
 | 
			
		||||
"e 'let*-values) (,@(cdr formal))\n              ,@body)))))))\n\n(define-macro defi",
 | 
			
		||||
"ne-values\n  (lambda (form env)\n    (let ((formal (car (cdr form)))\n          (bo",
 | 
			
		||||
"dy   (cdr (cdr form))))\n      (let ((arguments (make-identifier 'arguments here)",
 | 
			
		||||
"))\n        `(,the-begin\n          ,@(let loop ((formal formal))\n              (i",
 | 
			
		||||
"f (pair? formal)\n                  `((,the-define ,(car formal) #undefined) ,@(l",
 | 
			
		||||
"oop (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 arguments))\n       ",
 | 
			
		||||
"         (if (pair? formal)\n                    `((,the-set! ,(car formal) (,(th",
 | 
			
		||||
"e 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))\n                    ",
 | 
			
		||||
"(if (variable? formal)\n                        `((,the-set! ,formal ,args))\n    ",
 | 
			
		||||
"                    '()))))))))))\n\n(define-macro do\n  (lambda (form env)\n    (le",
 | 
			
		||||
"t ((bindings (car (cdr form)))\n          (test     (car (car (cdr (cdr form)))))",
 | 
			
		||||
"\n          (cleanup  (cdr (car (cdr (cdr form)))))\n          (body     (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                    ,@cleanup)\n         ",
 | 
			
		||||
"          (,the-begin\n                    ,@body\n                    (,loop ,@(m",
 | 
			
		||||
"ap (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 ((test (car (cdr form",
 | 
			
		||||
")))\n          (body (cdr (cdr form))))\n      `(,the-if ,test\n                (,t",
 | 
			
		||||
"he-begin ,@body)\n                #undefined))))\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                #undefined\n                (,the-begin ,@b",
 | 
			
		||||
"ody)))))\n\n(define-macro case\n  (lambda (form env)\n    (let ((key     (car (cdr f",
 | 
			
		||||
"orm)))\n          (clauses (cdr (cdr form))))\n      (let ((the-key (make-identifi",
 | 
			
		||||
"er 'key here)))\n        `(,(the 'let) ((,the-key ,key))\n          ,(let loop ((c",
 | 
			
		||||
"lauses 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 (lambda (x) `(,(the ",
 | 
			
		||||
"'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n                             ,",
 | 
			
		||||
"(if (and (variable? (cadr clause))\n                                       (varia",
 | 
			
		||||
"ble=? (the '=>) (make-identifier (cadr clause) env)))\n                          ",
 | 
			
		||||
"        `(,(car (cdr (cdr clause))) ,the-key)\n                                  ",
 | 
			
		||||
"`(,the-begin ,@(cdr clause)))\n                             ,(loop (cdr clauses))",
 | 
			
		||||
")))))))))\n\n(define-macro parameterize\n  (lambda (form env)\n    (let ((formal (ca",
 | 
			
		||||
"r (cdr form)))\n          (body   (cdr (cdr form))))\n      `(,(the 'with-paramete",
 | 
			
		||||
"r)\n        (,(the 'lambda) ()\n         ,@formal\n         ,@body)))))\n\n(define-ma",
 | 
			
		||||
"cro 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-id",
 | 
			
		||||
"entifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n          ",
 | 
			
		||||
"                   (rename var))))))\n           (walk (lambda (f form)\n         ",
 | 
			
		||||
"          (cond\n                    ((variable? form)\n                     (f fo",
 | 
			
		||||
"rm))\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 ((fo",
 | 
			
		||||
"rm (walk rename (cadr form))))\n          `(,(the 'let)\n            ,(map cdr ren",
 | 
			
		||||
"ames)\n            ,form))))))\n\n(define-macro syntax-quasiquote\n  (lambda (form e",
 | 
			
		||||
"nv)\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-ide",
 | 
			
		||||
"ntifier) ',var ',env)) . ,renames))\n                             (rename var))))",
 | 
			
		||||
")))\n\n        (define (syntax-quasiquote? form)\n          (and (pair? form)\n     ",
 | 
			
		||||
"          (variable? (car form))\n               (variable=? (the 'syntax-quasiqu",
 | 
			
		||||
"ote) (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               (variable? (caar form))\n               (va",
 | 
			
		||||
"riable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))\n\n  ",
 | 
			
		||||
"      (define (qq depth expr)\n          (cond\n           ;; syntax-unquote\n     ",
 | 
			
		||||
"      ((syntax-unquote? expr)\n            (if (= depth 1)\n                (car (",
 | 
			
		||||
"cdr expr))\n                (list (the 'list)\n                      (list (the 'q",
 | 
			
		||||
"uote) (the 'syntax-unquote))\n                      (qq (- depth 1) (car (cdr exp",
 | 
			
		||||
"r))))))\n           ;; syntax-unquote-splicing\n           ((syntax-unquote-splici",
 | 
			
		||||
"ng? 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 'syntax-unquote-splicing))\n   ",
 | 
			
		||||
"                         (qq (- depth 1) (car (cdr (car expr)))))\n              ",
 | 
			
		||||
"        (qq depth (cdr expr)))))\n           ;; syntax-quasiquote\n           ((sy",
 | 
			
		||||
"ntax-quasiquote? expr)\n            (list (the 'list)\n                  (list (th",
 | 
			
		||||
"e '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->vec",
 | 
			
		||||
"tor) (qq depth (vector->list expr))))\n           ;; variable\n           ((variab",
 | 
			
		||||
"le? 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            ,(map cdr renames)\n            ,body)))))",
 | 
			
		||||
")\n\n(define (transformer f)\n  (lambda (form env)\n    (let ((register1 (make-regis",
 | 
			
		||||
"ter))\n          (register2 (make-register)))\n      (letrec\n          ((wrap (lam",
 | 
			
		||||
"bda (var1)\n                   (let ((var2 (register1 var1)))\n                   ",
 | 
			
		||||
"  (if (undefined? var2)\n                         (let ((var2 (make-identifier va",
 | 
			
		||||
"r1 env)))\n                           (register1 var1 var2)\n                     ",
 | 
			
		||||
"      (register2 var2 var1)\n                           var2)\n                   ",
 | 
			
		||||
"      var2))))\n           (unwrap (lambda (var2)\n                     (let ((var",
 | 
			
		||||
"1 (register2 var2)))\n                       (if (undefined? var1)\n              ",
 | 
			
		||||
"             var2\n                           var1))))\n           (walk (lambda (",
 | 
			
		||||
"f form)\n                   (cond\n                    ((variable? form)\n         ",
 | 
			
		||||
"            (f form))\n                    ((pair? form)\n                     (co",
 | 
			
		||||
"ns (walk f (car form)) (walk f (cdr form))))\n                    ((vector? form)",
 | 
			
		||||
"\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-synta",
 | 
			
		||||
"x\n  (lambda (form env)\n    (let ((formal (car (cdr form)))\n          (body   (cd",
 | 
			
		||||
"r (cdr form))))\n      (if (pair? formal)\n          `(,(the 'define-syntax) ,(car",
 | 
			
		||||
" formal) (,the-lambda ,(cdr formal) ,@body))\n          `(,the-define-macro ,form",
 | 
			
		||||
"al (,(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                  `(,(th",
 | 
			
		||||
"e '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 e",
 | 
			
		||||
"xpr env)) body)\n          (current-library old-library))))))\n\n(define-macro cond",
 | 
			
		||||
"-expand\n  (lambda (form _)\n    (letrec\n        ((test (lambda (form)\n           ",
 | 
			
		||||
"      (or\n                  (eq? form 'else)\n                  (and (symbol? for",
 | 
			
		||||
"m)\n                       (memq form (features)))\n                  (and (pair? ",
 | 
			
		||||
"form)\n                       (case (car form)\n                         ((library",
 | 
			
		||||
") (find-library (cadr form)))\n                         ((not) (not (test (cadr f",
 | 
			
		||||
"orm))))\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 cla",
 | 
			
		||||
"uses))\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          (prefix\n           (lambda (pr",
 | 
			
		||||
"efix symbol)\n             (string->symbol\n              (string-append\n         ",
 | 
			
		||||
"      (symbol->string prefix)\n               (symbol->string symbol))))))\n      ",
 | 
			
		||||
"(letrec\n          ((extract\n            (lambda (spec)\n              (case (car ",
 | 
			
		||||
"spec)\n                ((only rename prefix except)\n                 (extract (ca",
 | 
			
		||||
"dr spec)))\n                (else\n                 (or (find-library spec) (error",
 | 
			
		||||
" \"library not found\" spec))))))\n           (collect\n            (lambda (spec)\n ",
 | 
			
		||||
"             (case (car spec)\n                ((only)\n                 (let ((al",
 | 
			
		||||
"ist (collect (cadr spec))))\n                   (map (lambda (var) (assq var alis",
 | 
			
		||||
"t)) (cddr spec))))\n                ((rename)\n                 (let ((alist (coll",
 | 
			
		||||
"ect (cadr spec))))\n                   (map (lambda (s) (or (assq (car s) (cddr s",
 | 
			
		||||
"pec)) s)) alist)))\n                ((prefix)\n                 (let ((alist (coll",
 | 
			
		||||
"ect (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 alist) (loop (cdr alist)))))",
 | 
			
		||||
")))\n                (else\n                 (let ((lib (or (find-library spec) (e",
 | 
			
		||||
"rror \"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                    (l",
 | 
			
		||||
"ambda (slot)\n                      (library-import lib (cdr slot) (car slot)))\n ",
 | 
			
		||||
"                   alist)))))\n          (for-each import (cdr form)))))))\n\n(defi",
 | 
			
		||||
"ne-macro export\n  (lambda (form _)\n    (letrec\n        ((collect\n          (lamb",
 | 
			
		||||
"da (spec)\n            (cond\n             ((symbol? spec)\n              `(,spec .",
 | 
			
		||||
" ,spec))\n             ((and (list? spec) (= (length spec) 3) (eq? (car spec) 're",
 | 
			
		||||
"name))\n              `(,(list-ref spec 1) . ,(list-ref spec 2)))\n             (e",
 | 
			
		||||
"lse\n              (error \"malformed export\")))))\n         (export\n           (la",
 | 
			
		||||
"mbda (spec)\n             (let ((slot (collect spec)))\n               (library-ex",
 | 
			
		||||
"port (car slot) (cdr slot))))))\n      (for-each export (cdr form)))))\n\n(export d",
 | 
			
		||||
"efine-library\n        cond-expand\n        import\n        export)\n\n(export let le",
 | 
			
		||||
"t* letrec letrec*\n        let-values let*-values define-values\n        quasiquot",
 | 
			
		||||
"e unquote unquote-splicing\n        and or\n        cond case else =>\n        do w",
 | 
			
		||||
"hen unless\n        parameterize\n        define-syntax\n        syntax-quote synta",
 | 
			
		||||
"x-unquote\n        syntax-quasiquote syntax-unquote-splicing\n        let-syntax l",
 | 
			
		||||
"etrec-syntax\n        syntax-error)\n\n\n",
 | 
			
		||||
"s (cdr (cadr form)) (cddr form))))\n                   (error \"define: binding to",
 | 
			
		||||
" non-varaible object\" form)))))\n     (length form))))\n\n(builtin:define-macro def",
 | 
			
		||||
"ine-macro\n  (lambda (form env)\n    (if (= (length form) 3)\n        (if (variable",
 | 
			
		||||
"? (cadr form))\n            (cons the-builtin-define-macro (cdr form))\n          ",
 | 
			
		||||
"  (error \"define-macro: binding to non-variable object\" form))\n        (error \"i",
 | 
			
		||||
"llegal define-macro form\" form))))\n\n\n(define-macro syntax-error\n  (lambda (form ",
 | 
			
		||||
"_)\n    (apply error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n  (lamb",
 | 
			
		||||
"da (form _)\n    (define message\n      (string-append\n       \"invalid use of auxi",
 | 
			
		||||
"liary syntax: '\" (symbol->string (cadr form)) \"'\"))\n    (list\n     the-define-ma",
 | 
			
		||||
"cro\n     (cadr form)\n     (list the-lambda '_\n           (list (the 'error) mess",
 | 
			
		||||
"age)))))\n\n(define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-au",
 | 
			
		||||
"xiliary-syntax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxil",
 | 
			
		||||
"iary-syntax syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(",
 | 
			
		||||
"define-macro let\n  (lambda (form env)\n    (if (variable? (cadr form))\n        (l",
 | 
			
		||||
"ist\n         (list the-lambda '()\n               (list the-define (cadr form)\n  ",
 | 
			
		||||
"                   (cons the-lambda\n                           (cons (map car (c",
 | 
			
		||||
"ar (cddr form)))\n                                 (cdr (cddr form)))))\n         ",
 | 
			
		||||
"      (cons (cadr form) (map cadr (car (cddr form))))))\n        (cons\n         (",
 | 
			
		||||
"cons\n          the-lambda\n          (cons (map car (cadr form))\n                ",
 | 
			
		||||
"(cddr form)))\n         (map cadr (cadr form))))))\n\n(define-macro and\n  (lambda (",
 | 
			
		||||
"form env)\n    (if (null? (cdr form))\n        #t\n        (if (null? (cddr form))\n",
 | 
			
		||||
"            (cadr form)\n            (list the-if\n                  (cadr form)\n ",
 | 
			
		||||
"                 (cons (the 'and) (cddr form))\n                  #f)))))\n\n(defin",
 | 
			
		||||
"e-macro or\n  (lambda (form env)\n    (if (null? (cdr form))\n        #f\n        (l",
 | 
			
		||||
"et ((tmp (make-identifier 'it env)))\n          (list (the 'let)\n                ",
 | 
			
		||||
"(list (list tmp (cadr form)))\n                (list the-if\n                     ",
 | 
			
		||||
" tmp\n                      tmp\n                      (cons (the 'or) (cddr form)",
 | 
			
		||||
")))))))\n\n(define-macro cond\n  (lambda (form env)\n    (let ((clauses (cdr form)))",
 | 
			
		||||
"\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 (undefined? var2)\n                  ",
 | 
			
		||||
"       (let ((var2 (make-identifier var1 env)))\n                           (regi",
 | 
			
		||||
"ster1 var1 var2)\n                           (register2 var2 var1)\n              ",
 | 
			
		||||
"             var2)\n                         var2))))\n           (unwrap (lambda ",
 | 
			
		||||
"(var2)\n                     (let ((var1 (register2 var2)))\n                     ",
 | 
			
		||||
"  (if (undefined? var1)\n                           var2\n                        ",
 | 
			
		||||
"   var1))))\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? form)\n                     (list->vector (walk ",
 | 
			
		||||
"f (vector->list form))))\n                    (else\n                     form))))",
 | 
			
		||||
")\n        (let ((form (cdr form)))\n          (walk unwrap (apply f (walk wrap fo",
 | 
			
		||||
"rm))))))))\n\n(define-macro define-syntax\n  (lambda (form env)\n    (let ((formal (",
 | 
			
		||||
"car (cdr form)))\n          (body   (cdr (cdr form))))\n      (if (pair? formal)\n ",
 | 
			
		||||
"         `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body",
 | 
			
		||||
"))\n          `(,the-define-macro ,formal (,(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         ,@(ma",
 | 
			
		||||
"p (lambda (x)\n                  `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n   ",
 | 
			
		||||
"             formal)\n         ,@body))))\n\n(define-macro let-syntax\n  (lambda (fo",
 | 
			
		||||
"rm env)\n    `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d",
 | 
			
		||||
"efine-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 cond-expand\n  (lambda (form _)\n    (letrec\n   ",
 | 
			
		||||
"     ((test (lambda (form)\n                 (or\n                  (eq? form 'els",
 | 
			
		||||
"e)\n                  (and (symbol? form)\n                       (memq form (feat",
 | 
			
		||||
"ures)))\n                  (and (pair? form)\n                       (case (car fo",
 | 
			
		||||
"rm)\n                         ((library) (find-library (cadr form)))\n            ",
 | 
			
		||||
"             ((not) (not (test (cadr form))))\n                         ((and) (l",
 | 
			
		||||
"et 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 (tes",
 | 
			
		||||
"t (car form)) (loop (cdr form))))))\n                         (else #f)))))))\n   ",
 | 
			
		||||
"   (let loop ((clauses (cdr form)))\n        (if (null? clauses)\n            #und",
 | 
			
		||||
"efined\n            (if (test (caar clauses))\n                `(,the-begin ,@(cda",
 | 
			
		||||
"r clauses))\n                (loop (cdr 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            (l",
 | 
			
		||||
"ambda (spec)\n              (case (car spec)\n                ((only rename prefix",
 | 
			
		||||
" except)\n                 (extract (cadr spec)))\n                (else\n         ",
 | 
			
		||||
"        (or (find-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 (lambda (var) (assq var alist)) (cddr spec))))\n                ((renam",
 | 
			
		||||
"e)\n                 (let ((alist (collect (cadr spec))))\n                   (map",
 | 
			
		||||
" (lambda (s) (or (assq (car s) (cddr spec)) s)) alist)))\n                ((prefi",
 | 
			
		||||
"x)\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 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        (le",
 | 
			
		||||
"trec\n            ((import\n               (lambda (spec)\n                 (let ((",
 | 
			
		||||
"lib (extract spec))\n                       (alist (collect spec)))\n             ",
 | 
			
		||||
"      (for-each\n                    (lambda (slot)\n                      (librar",
 | 
			
		||||
"y-import lib (cdr slot) (car slot)))\n                    alist)))))\n          (f",
 | 
			
		||||
"or-each import (cdr form)))))))\n\n(define-macro export\n  (lambda (form _)\n    (le",
 | 
			
		||||
"trec\n        ((collect\n          (lambda (spec)\n            (cond\n             (",
 | 
			
		||||
"(symbol? spec)\n              `(,spec . ,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 (coll",
 | 
			
		||||
"ect spec)))\n               (library-export (car slot) (cdr slot))))))\n      (for",
 | 
			
		||||
"-each export (cdr form)))))\n\n(export define-library\n        cond-expand\n        ",
 | 
			
		||||
"import\n        export)\n\n(export let let* letrec letrec*\n        let-values let*-",
 | 
			
		||||
"values define-values\n        quasiquote unquote unquote-splicing\n        and or\n",
 | 
			
		||||
"        cond case else =>\n        do when unless\n        parameterize\n        de",
 | 
			
		||||
"fine-syntax\n        syntax-quote syntax-unquote\n        syntax-quasiquote syntax",
 | 
			
		||||
"-unquote-splicing\n        let-syntax letrec-syntax\n        syntax-error)\n\n\n",
 | 
			
		||||
"",
 | 
			
		||||
""
 | 
			
		||||
};
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -1547,7 +1547,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
 | 
			
		|||
  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 | 
			
		||||
 | 
			
		||||
  fprintf(stdout, "# input expression\n");
 | 
			
		||||
  pic_debug(pic, obj);
 | 
			
		||||
  pic_write(pic, obj);
 | 
			
		||||
  fprintf(stdout, "\n");
 | 
			
		||||
 | 
			
		||||
  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 | 
			
		||||
| 
						 | 
				
			
			@ -1557,7 +1557,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
 | 
			
		|||
  obj = pic_expand(pic, obj, env);
 | 
			
		||||
#if DEBUG
 | 
			
		||||
  fprintf(stdout, "## expand completed\n");
 | 
			
		||||
  pic_debug(pic, obj);
 | 
			
		||||
  pic_write(pic, obj);
 | 
			
		||||
  fprintf(stdout, "\n");
 | 
			
		||||
  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 | 
			
		||||
#endif
 | 
			
		||||
| 
						 | 
				
			
			@ -1566,7 +1566,7 @@ pic_compile(pic_state *pic, pic_value obj, struct pic_env *env)
 | 
			
		|||
  obj = pic_analyze(pic, obj);
 | 
			
		||||
#if DEBUG
 | 
			
		||||
  fprintf(stdout, "## analyzer completed\n");
 | 
			
		||||
  pic_debug(pic, obj);
 | 
			
		||||
  pic_write(pic, obj);
 | 
			
		||||
  fprintf(stdout, "\n");
 | 
			
		||||
  fprintf(stdout, "ai = %zu\n", pic_gc_arena_preserve(pic));
 | 
			
		||||
#endif
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -156,7 +156,13 @@ pic_init_core(pic_state *pic)
 | 
			
		|||
    pic_init_attr(pic); DONE;
 | 
			
		||||
    pic_init_reg(pic); DONE;
 | 
			
		||||
 | 
			
		||||
    pic_load_cstr(pic, &pic_boot[0][0]);
 | 
			
		||||
    pic_try {
 | 
			
		||||
      pic_load_cstr(pic, &pic_boot[0][0]);
 | 
			
		||||
    }
 | 
			
		||||
    pic_catch {
 | 
			
		||||
      pic_print_backtrace(pic, xstdout);
 | 
			
		||||
      pic_raise(pic, pic->err);
 | 
			
		||||
    }
 | 
			
		||||
  }
 | 
			
		||||
 | 
			
		||||
  pic_import(pic, pic->PICRIN_BASE);
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -633,7 +633,7 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
 | 
			
		|||
 | 
			
		||||
      sym = irep->syms[c.u.i];
 | 
			
		||||
      if (! pic_dict_has(pic, pic->globals, sym)) {
 | 
			
		||||
        pic_errorf(pic, "logic flaw; reference to uninitialized global variable: %s", pic_symbol_name(pic, sym));
 | 
			
		||||
        pic_errorf(pic, "uninitialized global variable: %s", pic_symbol_name(pic, sym));
 | 
			
		||||
      }
 | 
			
		||||
      PUSH(pic_dict_ref(pic, pic->globals, sym));
 | 
			
		||||
      NEXT;
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue