refine error messages

This commit is contained in:
Yuichi Nishiwaki 2015-06-27 17:44:06 +09:00
parent bcf53b9883
commit 4d18610a79
4 changed files with 257 additions and 251 deletions

View File

@ -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",
"",
""
};

View File

@ -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

View File

@ -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);

View File

@ -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;